Re: [PATCH] Support full Common Lisp multiple values in C.
15 years, 3 months
Aidan Kehoe
Aidan Kehoe
Ar an t-ochtú lá de mí Méan Fómhair, scríobh Michael Sperber:
> Aidan Kehoe <kehoea(a)parhasard.net> writes:
>
> > Ar an dara lá déag de mí Lúnasa, scríobh Aidan Kehoe:
> >
> > > OK, I’ve just taken some time, and profile-expression with (hanoi 6)
> > > repeatedly gives me 10187 ticks (or thereabouts) in both builds. (No
> > > change if I add __builtin_expect in the appropriate place.) This
> > > isn’t a great test, though, it’s dominated by redisplay. Suggestions
> > > for a better one?
>
> I've done some tesrs on function-call performance, and they indicate
> they performance hit, if any, totally gets lost in the noise, so we're
> good.
Ah, that’s good to read. Do you mind me asking, what exactly were the tests?
--
¿Dónde estará ahora mi sobrino Yoghurtu Nghe, que tuvo que huir
precipitadamente de la aldea por culpa de la escasez de rinocerontes?
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
Random (minimal) performance improvements at startup.
15 years, 3 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1252277232 -3600
# Node ID 02b7c71890410472b1e3acab50f4b8341a02555e
# Parent cdabd56ce1b5c2ec3669a554c173c808f953afa3
Random (minimal) performance improvements at startup.
lisp/ChangeLog addition:
2009-09-06 Aidan Kehoe <kehoea(a)parhasard.net>
* simple.el (handle-pre-motion-command-current-command-is-motion):
If KEY is a character, ascertain that once, not every iteration of
the loop.
* mule/mule-cmds.el (finish-set-language-environment):
Don't call #'string-match on a one-character string, use functions
that have bytecodes instead, since this is called so often on
startup.
diff -r cdabd56ce1b5 -r 02b7c7189041 lisp/ChangeLog
--- a/lisp/ChangeLog Sun Sep 06 19:36:02 2009 +0100
+++ b/lisp/ChangeLog Sun Sep 06 23:47:12 2009 +0100
＠＠ -1,3 +1,13 ＠＠
+2009-09-06 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * simple.el (handle-pre-motion-command-current-command-is-motion):
+ If KEY is a character, ascertain that once, not every iteration of
+ the loop.
+ * mule/mule-cmds.el (finish-set-language-environment):
+ Don't call #'string-match on a one-character string, use functions
+ that have bytecodes instead, since this is called so often on
+ startup.
+
2009-08-31 Aidan Kehoe <kehoea(a)parhasard.net>
* byte-optimize.el (byte-optimize-form-code-walker):
diff -r cdabd56ce1b5 -r 02b7c7189041 lisp/mule/mule-cmds.el
--- a/lisp/mule/mule-cmds.el Sun Sep 06 19:36:02 2009 +0100
+++ b/lisp/mule/mule-cmds.el Sun Sep 06 23:47:12 2009 +0100
＠＠ -771,7 +771,7 ＠＠
(let ((invalid-sequence-coding-system
(get-language-info language-name 'invalid-sequence-coding-system))
(disp-table (specifier-instance current-display-table))
- glyph string unicode-error-lookup)
+ glyph string unicode-error-lookup first-char)
(when (consp invalid-sequence-coding-system)
(setq invalid-sequence-coding-system
(car invalid-sequence-coding-system)))
＠＠ -788,7 +788,9 ＠＠
(when unicode-error-lookup
(setq string (format "%c" unicode-error-lookup)))
;; Treat control characters specially:
- (when (string-match "^[\x00-\x1f\x80-\x9f]$" string)
+ (setq first-char (aref string 0))
+ (when (or (and (>= #x00 first-char) (<= first-char #x1f))
+ (and (>= #x80 first-char) (<= first-char #x9f)))
(setq string (format "^%c" (+ ?＠ (aref string 0))))))
(setq glyph (make-glyph (vector 'string :data string)))
(set-glyph-face glyph 'unicode-invalid-sequence-warning-face)
diff -r cdabd56ce1b5 -r 02b7c7189041 lisp/simple.el
--- a/lisp/simple.el Sun Sep 06 19:36:02 2009 +0100
+++ b/lisp/simple.el Sun Sep 06 23:47:12 2009 +0100
＠＠ -2091,11 +2091,12 ＠＠
;(princ (format "key: %s mods: %s\n" key mods) 'external-debugging-output)
(catch 'handle-pre-motion-command-current-command-is-motion
(flet ((keysyms-equal (a b)
- (if (characterp a)
- (setq a (intern (char-to-string (downcase a)))))
(if (characterp b)
(setq b (intern (char-to-string (downcase b)))))
(eq a b)))
+ (setq key (if (characterp key)
+ (intern (char-to-string (downcase key)))
+ key))
(dolist (keysym motion-keys-for-shifted-motion)
(when (if (listp keysym)
(and (equal mods (butlast keysym))
--
¿Dónde estará ahora mi sobrino Yoghurtu Nghe, que tuvo que huir
precipitadamente de la aldea por culpa de la escasez de rinocerontes?
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit: Random (minimal) performance improvements at startup.
15 years, 3 months
Aidan Kehoe
Aidan Kehoe
changeset: 4687:02b7c7189041
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sun Sep 06 23:47:12 2009 +0100
files: lisp/ChangeLog lisp/mule/mule-cmds.el lisp/simple.el
description:
Random (minimal) performance improvements at startup.
lisp/ChangeLog addition:
2009-09-06 Aidan Kehoe <kehoea(a)parhasard.net>
* simple.el (handle-pre-motion-command-current-command-is-motion):
If KEY is a character, ascertain that once, not every iteration of
the loop.
* mule/mule-cmds.el (finish-set-language-environment):
Don't call #'string-match on a one-character string, use functions
that have bytecodes instead, since this is called so often on
startup.
diff -r cdabd56ce1b5 -r 02b7c7189041 lisp/ChangeLog
--- a/lisp/ChangeLog Sun Sep 06 19:36:02 2009 +0100
+++ b/lisp/ChangeLog Sun Sep 06 23:47:12 2009 +0100
＠＠ -1,3 +1,13 ＠＠
+2009-09-06 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * simple.el (handle-pre-motion-command-current-command-is-motion):
+ If KEY is a character, ascertain that once, not every iteration of
+ the loop.
+ * mule/mule-cmds.el (finish-set-language-environment):
+ Don't call #'string-match on a one-character string, use functions
+ that have bytecodes instead, since this is called so often on
+ startup.
+
2009-08-31 Aidan Kehoe <kehoea(a)parhasard.net>
* byte-optimize.el (byte-optimize-form-code-walker):
diff -r cdabd56ce1b5 -r 02b7c7189041 lisp/mule/mule-cmds.el
--- a/lisp/mule/mule-cmds.el Sun Sep 06 19:36:02 2009 +0100
+++ b/lisp/mule/mule-cmds.el Sun Sep 06 23:47:12 2009 +0100
＠＠ -771,7 +771,7 ＠＠
(let ((invalid-sequence-coding-system
(get-language-info language-name 'invalid-sequence-coding-system))
(disp-table (specifier-instance current-display-table))
- glyph string unicode-error-lookup)
+ glyph string unicode-error-lookup first-char)
(when (consp invalid-sequence-coding-system)
(setq invalid-sequence-coding-system
(car invalid-sequence-coding-system)))
＠＠ -788,7 +788,9 ＠＠
(when unicode-error-lookup
(setq string (format "%c" unicode-error-lookup)))
;; Treat control characters specially:
- (when (string-match "^[\x00-\x1f\x80-\x9f]$" string)
+ (setq first-char (aref string 0))
+ (when (or (and (>= #x00 first-char) (<= first-char #x1f))
+ (and (>= #x80 first-char) (<= first-char #x9f)))
(setq string (format "^%c" (+ ?＠ (aref string 0))))))
(setq glyph (make-glyph (vector 'string :data string)))
(set-glyph-face glyph 'unicode-invalid-sequence-warning-face)
diff -r cdabd56ce1b5 -r 02b7c7189041 lisp/simple.el
--- a/lisp/simple.el Sun Sep 06 19:36:02 2009 +0100
+++ b/lisp/simple.el Sun Sep 06 23:47:12 2009 +0100
＠＠ -2091,11 +2091,12 ＠＠
;(princ (format "key: %s mods: %s\n" key mods) 'external-debugging-output)
(catch 'handle-pre-motion-command-current-command-is-motion
(flet ((keysyms-equal (a b)
- (if (characterp a)
- (setq a (intern (char-to-string (downcase a)))))
(if (characterp b)
(setq b (intern (char-to-string (downcase b)))))
(eq a b)))
+ (setq key (if (characterp key)
+ (intern (char-to-string (downcase key)))
+ key))
(dolist (keysym motion-keys-for-shifted-motion)
(when (if (listp keysym)
(and (equal mods (butlast keysym))
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Fix various small issues with the multiple-value implementation.
15 years, 3 months
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1251715172 -3600
# Node ID 4d30614a3649565f34d17e3fd9035f0e93db94a8
# Parent 15c42a3f4065c6b9c89832983ae591d03d159cde
Fix various small issues with the multiple-value implementation.
lisp/ChangeLog addition:
2009-08-31 Aidan Kehoe <kehoea(a)parhasard.net>
* byte-optimize.el (byte-optimize-form-code-walker):
Be careful about discarding multiple values when optimising
#'prog1 calls.
(byte-optimize-or):
Preserve any trailing nil, as this is a supported way to
explicitly discard multiple values.
(byte-optimize-cond-1):
Discard multiple values with a singleton followed by no more
clauses.
* bytecomp.el (progn):
(prog1):
(prog2):
Be careful about discarding multiple values in the byte-hunk
handler of these three forms.
* bytecomp.el (byte-compile-prog1, byte-compile-prog2):
Don't call #'values explicitly, use `(or ,(pop form) nil) instead,
since that compiles to bytecode, not a funcall.
* bytecomp.el (byte-compile-values):
With one non-const argument, byte-compile to `(or ,(second form)
nil), not an explicit #'values call.
* bytecomp.el (byte-compile-insert-header):
Be nicer in the error message to emacs versions that don't
understand our bytecode.
src/ChangeLog addition:
2009-08-31 Aidan Kehoe <kehoea(a)parhasard.net>
* eval.c (For, Fand):
Don't declare val as REGISTER in these functions, for some reason
it breaks the non-DEBUG union build. These functions are only
called from interpreted code, the performance implication doesn't
matter. Thank you Robert Delius Royar!
tests/ChangeLog addition:
2009-08-31 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el (Assert-rounding):
Remove an overly-verbose failure message here.
Correct a couple of tests which were buggy in themselves. Add
three new tests, checking the behaviour of #'or and #'and when
passed zero arguments, and a Known-Bug-Expect-Failure call
involving letf and values. (The bug predates the C-level
multiple-value implementation.)
diff -r 15c42a3f4065 -r 4d30614a3649 lisp/ChangeLog
--- a/lisp/ChangeLog Sat Aug 29 22:37:50 2009 +0800
+++ b/lisp/ChangeLog Mon Aug 31 11:39:32 2009 +0100
＠＠ -1,3 +1,29 ＠＠
+2009-08-31 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * byte-optimize.el (byte-optimize-form-code-walker):
+ Be careful about discarding multiple values when optimising
+ #'prog1 calls.
+ (byte-optimize-or):
+ Preserve any trailing nil, as this is a supported way to
+ explicitly discard multiple values.
+ (byte-optimize-cond-1):
+ Discard multiple values with a singleton followed by no more
+ clauses.
+ * bytecomp.el (progn):
+ (prog1):
+ (prog2):
+ Be careful about discarding multiple values in the byte-hunk
+ handler of these three forms.
+ * bytecomp.el (byte-compile-prog1, byte-compile-prog2):
+ Don't call #'values explicitly, use `(or ,(pop form) nil) instead,
+ since that compiles to bytecode, not a funcall.
+ * bytecomp.el (byte-compile-values):
+ With one non-const argument, byte-compile to `(or ,(second form)
+ nil), not an explicit #'values call.
+ * bytecomp.el (byte-compile-insert-header):
+ Be nicer in the error message to emacs versions that don't
+ understand our bytecode.
+
2009-08-27 Aidan Kehoe <kehoea(a)parhasard.net>
* cl.el (bytecomp-load-hook): New.
diff -r 15c42a3f4065 -r 4d30614a3649 lisp/byte-optimize.el
--- a/lisp/byte-optimize.el Sat Aug 29 22:37:50 2009 +0800
+++ b/lisp/byte-optimize.el Mon Aug 31 11:39:32 2009 +0100
＠＠ -436,7 +436,7 ＠＠
(cons 'prog1
(cons (byte-optimize-form (nth 1 form) for-effect)
(byte-optimize-body (cdr (cdr form)) t)))
- (byte-optimize-form (nth 1 form) for-effect)))
+ (byte-optimize-form `(or ,(nth 1 form) nil) for-effect)))
((eq fn 'prog2)
(cons 'prog2
(cons (byte-optimize-form (nth 1 form) t)
＠＠ -950,12 +950,22 ＠＠
((byte-optimize-predicate form))))
(defun byte-optimize-or (form)
- ;; Throw away nil's, and simplify if less than 2 args.
- ;; If there is a literal non-nil constant in the args to `or', throw away all
- ;; following forms.
- (if (memq nil form)
- (setq form (delq nil (copy-sequence form))))
- (let ((rest form))
+ ;; Throw away unneeded nils, and simplify if less than 2 args.
+ ;; XEmacs; change to be more careful about discarding multiple values.
+ (let* ((memqueued (memq nil form))
+ (trailing-nil (and (cdr memqueued)
+ (equal '(nil) (last form))))
+ rest)
+ ;; A trailing nil indicates to discard multiple values, and we need to
+ ;; respect that:
+ (when (and memqueued (cdr memqueued))
+ (setq form (delq nil (copy-sequence form)))
+ (when trailing-nil
+ (setcdr (last form) '(nil))))
+ (setq rest form)
+ ;; If there is a literal non-nil constant in the args to `or', throw
+ ;; away all following forms. We can do this because a literal non-nil
+ ;; constant cannot be multiple.
(while (cdr (setq rest (cdr rest)))
(if (byte-compile-trueconstp (car rest))
(setq form (copy-sequence form)
＠＠ -978,7 +988,10 ＠＠
((consp (car clauses))
(nconc
(case (length (car clauses))
- (1 `(or ,(nth 0 (car clauses))))
+ (1 (if (cdr clauses)
+ `(or ,(nth 0 (car clauses)))
+ ;; XEmacs: don't pass any multiple values back:
+ `(or ,(nth 0 (car clauses)) nil)))
(2 `(if ,(nth 0 (car clauses)) ,(nth 1 (car clauses))))
(t `(if ,(nth 0 (car clauses)) (progn ,＠(cdr (car clauses))))))
(when (cdr clauses) (list (byte-optimize-cond-1 (cdr clauses))))))
diff -r 15c42a3f4065 -r 4d30614a3649 lisp/bytecomp.el
--- a/lisp/bytecomp.el Sat Aug 29 22:37:50 2009 +0800
+++ b/lisp/bytecomp.el Mon Aug 31 11:39:32 2009 +0100
＠＠ -1816,7 +1816,7 ＠＠
(defun byte-compile-insert-header (filename byte-compile-inbuffer
byte-compile-outbuffer)
(set-buffer byte-compile-inbuffer)
- (let (checks-string comments)
+ (let (comments)
(set-buffer byte-compile-outbuffer)
(delete-region 1 (1+ byte-compile-checks-and-comments-space))
(goto-char 1)
＠＠ -1840,17 +1840,34 ＠＠
(insert (format ";;;###coding system: %s\n"
(coding-system-name buffer-file-coding-system))))
(insert (format
- "\n(or %s\n (error \"Loading this file requires: %s\"))\n"
- (setq checks-string
- (let ((print-readably t))
- (prin1-to-string (if (> (length
- byte-compile-checks-on-load)
- 1)
- (cons 'and
- (reverse
- byte-compile-checks-on-load))
- (car byte-compile-checks-on-load)))))
- checks-string))
+ "\n(or %s\n (error \"Loading this file requires %s\"))\n"
+ (let ((print-readably t))
+ (prin1-to-string (if (> (length
+ byte-compile-checks-on-load)
+ 1)
+ (cons 'and
+ (setq byte-compile-checks-on-load
+ (nreverse
+ byte-compile-checks-on-load)))
+ (car byte-compile-checks-on-load))))
+ (loop
+ for check in byte-compile-checks-on-load
+ with seen-first = nil
+ with res = ""
+ do
+ (if seen-first
+ (setq res (concat res ", "))
+ (setq seen-first t))
+ ;; Print featurep calls differently:
+ (if (and (eq (car check) 'featurep)
+ (eq (car (second check)) 'quote)
+ (symbolp (second (second check))))
+ (setq res (concat res
+ (symbol-name (second (second check)))))
+ (setq res (concat res
+ (let ((print-readably t))
+ (prin1-to-string check)))))
+ finally return res)))
(setq comments
(with-string-as-buffer-contents ""
(insert "\n;;; compiled by "
＠＠ -2176,13 +2193,29 ＠＠
(eval form)
(byte-compile-keep-pending form 'byte-compile-normal-call))
-(put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn)
-(put 'prog1 'byte-hunk-handler 'byte-compile-file-form-progn)
-(put 'prog2 'byte-hunk-handler 'byte-compile-file-form-progn)
-(defun byte-compile-file-form-progn (form)
- (mapcar 'byte-compile-file-form (cdr form))
- ;; Return nil so the forms are not output twice.
- nil)
+;; XEmacs change: be careful about multiple values with these three forms.
+(put 'progn 'byte-hunk-handler
+ #'(lambda (form)
+ (mapc 'byte-compile-file-form (cdr form))
+ ;; Return nil so the forms are not output twice.
+ nil))
+
+(put 'prog1 'byte-hunk-handler
+ #'(lambda (form)
+ (when (first form)
+ (byte-compile-file-form `(or ,(first form) nil))
+ (mapc 'byte-compile-file-form (cdr form))
+ nil)))
+
+(put 'prog2 'byte-hunk-handler
+ #'(lambda (form)
+ (when (first form)
+ (byte-compile-file-form (first form))
+ (when (second form)
+ (setq form (cdr form))
+ (byte-compile-file-form `(or ,(first form) nil))
+ (mapc 'byte-compile-file-form (cdr form))
+ nil))))
;; This handler is not necessary, but it makes the output from dont-compile
;; and similar macros cleaner.
＠＠ -3677,7 +3710,7 ＠＠
(defun byte-compile-prog1 (form)
(setq form (cdr form))
;; #'prog1 never returns multiple values:
- (byte-compile-form-do-effect (list 'values (pop form)))
+ (byte-compile-form-do-effect `(or ,(pop form) nil))
(byte-compile-body form t))
(defun byte-compile-multiple-value-prog1 (form)
＠＠ -3686,9 +3719,11 ＠＠
(byte-compile-body form t))
(defun byte-compile-values (form)
- (if (and (= 2 (length form))
- (byte-compile-constp (second form)))
- (byte-compile-form-do-effect (second form))
+ (if (= 2 (length form))
+ (if (byte-compile-constp (second form))
+ (byte-compile-form-do-effect (second form))
+ ;; #'or compiles to bytecode, #'values doesn't:
+ (byte-compile-form-do-effect `(or ,(second form) nil)))
(byte-compile-normal-call form)))
(defun byte-compile-values-list (form)
＠＠ -3705,7 +3740,7 ＠＠
(setq form (cdr form))
(byte-compile-form (pop form) t)
;; #'prog2 never returns multiple values:
- (byte-compile-form-do-effect (list 'values (pop form)))
+ (byte-compile-form-do-effect `(or ,(pop form) nil))
(byte-compile-body form t))
(defmacro byte-compile-goto-if (cond discard tag)
diff -r 15c42a3f4065 -r 4d30614a3649 src/ChangeLog
--- a/src/ChangeLog Sat Aug 29 22:37:50 2009 +0800
+++ b/src/ChangeLog Mon Aug 31 11:39:32 2009 +0100
＠＠ -1,3 +1,11 ＠＠
+2009-08-31 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * eval.c (For, Fand):
+ Don't declare val as REGISTER in these functions, for some reason
+ it breaks the non-DEBUG union build. These functions are only
+ called from interpreted code, the performance implication doesn't
+ matter. Thank you Robert Delius Royar!
+
2009-08-24 Jerry James <james(a)xemacs.org>
* lisp.h (INT_64_BIT): define as __int64 on WIN32.
diff -r 15c42a3f4065 -r 4d30614a3649 src/eval.c
--- a/src/eval.c Sat Aug 29 22:37:50 2009 +0800
+++ b/src/eval.c Mon Aug 31 11:39:32 2009 +0100
＠＠ -838,7 +838,7 ＠＠
(args))
{
/* This function can GC */
- REGISTER Lisp_Object val;
+ Lisp_Object val = Qnil;
LIST_LOOP_3 (arg, args, tail)
{
＠＠ -870,7 +870,7 ＠＠
(args))
{
/* This function can GC */
- REGISTER Lisp_Object val = Qt;
+ Lisp_Object val = Qt;
LIST_LOOP_3 (arg, args, tail)
{
diff -r 15c42a3f4065 -r 4d30614a3649 tests/ChangeLog
--- a/tests/ChangeLog Sat Aug 29 22:37:50 2009 +0800
+++ b/tests/ChangeLog Mon Aug 31 11:39:32 2009 +0100
＠＠ -1,3 +1,13 ＠＠
+2009-08-31 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * automated/lisp-tests.el (Assert-rounding):
+ Remove an overly-verbose failure message here.
+ Correct a couple of tests which were buggy in themselves. Add
+ three new tests, checking the behaviour of #'or and #'and when
+ passed zero arguments, and a Known-Bug-Expect-Failure call
+ involving letf and values. (The bug predates the C-level
+ multiple-value implementation.)
+
2009-08-16 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el (foo):
diff -r 15c42a3f4065 -r 4d30614a3649 tests/automated/lisp-tests.el
--- a/tests/automated/lisp-tests.el Sat Aug 29 22:37:50 2009 +0800
+++ b/tests/automated/lisp-tests.el Mon Aug 31 11:39:32 2009 +0100
＠＠ -1475,11 +1475,8 ＠＠
first one-round-result))
(Assert (equal one-round-result (multiple-value-list
(round first 1)))
- (format "checking (round %S 1) gives %S, types %S, actual %S, types %S"
- first one-round-result (mapcar #'type-of one-round-result)
- (multiple-value-list (round first 1))
- (mapcar #'type-of (multiple-value-list (round first 1)))))
-
+ (format "checking (round %S 1) gives %S"
+ first one-round-result))
(Check-Error arith-error (round first 0))
(Check-Error arith-error (round first 0.0))
(Assert (equal two-round-result (multiple-value-list
＠＠ -1949,7 +1946,7 ＠＠
(multiple-value-function-returning-t ()
(values t pi e degrees-to-radians radians-to-degrees))
(multiple-value-function-returning-nil ()
- (values t pi e radians-to-degrees degrees-to-radians))
+ (values nil pi e radians-to-degrees degrees-to-radians))
(function-throwing-multiple-values ()
(let* ((listing '(0 3 4 nil "string" symbol))
(tail listing)
＠＠ -2051,7 +2048,7 ＠＠
(cond ((multiple-value-function-returning-t))))))
"Checking cond doesn't pass back multiple values in tests.")
(Assert
- (equal (list t pi e degrees-to-radians radians-to-degrees)
+ (equal (list nil pi e radians-to-degrees degrees-to-radians)
(multiple-value-list
(cond (t (multiple-value-function-returning-nil)))))
"Checking cond passes back multiple values in clauses.")
＠＠ -2069,10 +2066,28 ＠＠
(multiple-value-list
(catch 'VoN61Lo4Y (function-throwing-multiple-values)))))
(Assert
- (equal (list t pi e radians-to-degrees degrees-to-radians)
+ (equal (list t pi e degrees-to-radians radians-to-degrees)
(multiple-value-list
(loop
for eye in `(a b c d ,e f g ,nil ,pi)
do (when (null eye)
(return (multiple-value-function-returning-t))))))
- "Checking #'loop passes back multiple values correctly."))
+ "Checking #'loop passes back multiple values correctly.")
+ (Assert
+ (null (or))
+ "Checking #'or behaves correctly with zero arguments.")
+ (Assert
+ (eq t (and))
+ "Checking #'and behaves correctly with zero arguments.")
+ ;; This bug was here before the full multiple-value functionality
+ ;; was introduced (check it with (floor* pi) if you're
+ ;; curious). #'setf works, though, which is what most people are
+ ;; interested in. If you know the setf-method code better than I do,
+ ;; please post a patch; otherwise this is going to the back of the
+ ;; queue of things to do. I didn't break it :-) Aidan Kehoe, Mon Aug
+ ;; 31 10:45:50 GMTDT 2009.
+ (Known-Bug-Expect-Error
+ void-variable
+ (letf (((values three one-four-one-five-nine) (floor pi)))
+ (* three one-four-one-five-nine))))
+
--
¿Dónde estará ahora mi sobrino Yoghurtu Nghe, que tuvo que huir
precipitadamente de la aldea por culpa de la escasez de rinocerontes?
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 1 comments
commit: Fix various small issues with the multiple-value implementation.
15 years, 3 months
Aidan Kehoe
Aidan Kehoe
changeset: 4686:cdabd56ce1b5
tag: tip
user: Aidan Kehoe <kehoea(a)parhasard.net>
date: Sun Sep 06 19:36:02 2009 +0100
files: lisp/ChangeLog lisp/byte-optimize.el lisp/bytecomp.el src/ChangeLog src/eval.c tests/ChangeLog tests/automated/lisp-tests.el
description:
Fix various small issues with the multiple-value implementation.
lisp/ChangeLog addition:
2009-08-31 Aidan Kehoe <kehoea(a)parhasard.net>
* byte-optimize.el (byte-optimize-form-code-walker):
Be careful about discarding multiple values when optimising
#'prog1 calls.
(byte-optimize-or):
Preserve any trailing nil, as this is a supported way to
explicitly discard multiple values.
(byte-optimize-cond-1):
Discard multiple values with a singleton followed by no more
clauses.
* bytecomp.el (progn):
(prog1):
(prog2):
Be careful about discarding multiple values in the byte-hunk
handler of these three forms.
* bytecomp.el (byte-compile-prog1, byte-compile-prog2):
Don't call #'values explicitly, use `(or ,(pop form) nil) instead,
since that compiles to bytecode, not a funcall.
* bytecomp.el (byte-compile-values):
With one non-const argument, byte-compile to `(or ,(second form)
nil), not an explicit #'values call.
* bytecomp.el (byte-compile-insert-header):
Be nicer in the error message to emacs versions that don't
understand our bytecode.
src/ChangeLog addition:
2009-08-31 Aidan Kehoe <kehoea(a)parhasard.net>
* eval.c (For, Fand):
Don't declare val as REGISTER in these functions, for some reason
it breaks the non-DEBUG union build. These functions are only
called from interpreted code, the performance implication doesn't
matter. Thank you Robert Delius Royar!
* eval.c (Fmultiple_value_list_internal):
Error on too many arguments.
tests/ChangeLog addition:
2009-08-31 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el (Assert-rounding):
Remove an overly-verbose failure message here.
Correct a couple of tests which were buggy in themselves. Add
three new tests, checking the behaviour of #'or and #'and when
passed zero arguments, and a Known-Bug-Expect-Failure call
involving letf and values. (The bug predates the C-level
multiple-value implementation.)
diff -r 945247a8112f -r cdabd56ce1b5 lisp/ChangeLog
--- a/lisp/ChangeLog Wed Sep 02 20:38:14 2009 -0600
+++ b/lisp/ChangeLog Sun Sep 06 19:36:02 2009 +0100
＠＠ -1,3 +1,29 ＠＠
+2009-08-31 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * byte-optimize.el (byte-optimize-form-code-walker):
+ Be careful about discarding multiple values when optimising
+ #'prog1 calls.
+ (byte-optimize-or):
+ Preserve any trailing nil, as this is a supported way to
+ explicitly discard multiple values.
+ (byte-optimize-cond-1):
+ Discard multiple values with a singleton followed by no more
+ clauses.
+ * bytecomp.el (progn):
+ (prog1):
+ (prog2):
+ Be careful about discarding multiple values in the byte-hunk
+ handler of these three forms.
+ * bytecomp.el (byte-compile-prog1, byte-compile-prog2):
+ Don't call #'values explicitly, use `(or ,(pop form) nil) instead,
+ since that compiles to bytecode, not a funcall.
+ * bytecomp.el (byte-compile-values):
+ With one non-const argument, byte-compile to `(or ,(second form)
+ nil), not an explicit #'values call.
+ * bytecomp.el (byte-compile-insert-header):
+ Be nicer in the error message to emacs versions that don't
+ understand our bytecode.
+
2009-08-27 Aidan Kehoe <kehoea(a)parhasard.net>
* cl.el (bytecomp-load-hook): New.
diff -r 945247a8112f -r cdabd56ce1b5 lisp/byte-optimize.el
--- a/lisp/byte-optimize.el Wed Sep 02 20:38:14 2009 -0600
+++ b/lisp/byte-optimize.el Sun Sep 06 19:36:02 2009 +0100
＠＠ -436,7 +436,7 ＠＠
(cons 'prog1
(cons (byte-optimize-form (nth 1 form) for-effect)
(byte-optimize-body (cdr (cdr form)) t)))
- (byte-optimize-form (nth 1 form) for-effect)))
+ (byte-optimize-form `(or ,(nth 1 form) nil) for-effect)))
((eq fn 'prog2)
(cons 'prog2
(cons (byte-optimize-form (nth 1 form) t)
＠＠ -950,12 +950,22 ＠＠
((byte-optimize-predicate form))))
(defun byte-optimize-or (form)
- ;; Throw away nil's, and simplify if less than 2 args.
- ;; If there is a literal non-nil constant in the args to `or', throw away all
- ;; following forms.
- (if (memq nil form)
- (setq form (delq nil (copy-sequence form))))
- (let ((rest form))
+ ;; Throw away unneeded nils, and simplify if less than 2 args.
+ ;; XEmacs; change to be more careful about discarding multiple values.
+ (let* ((memqueued (memq nil form))
+ (trailing-nil (and (cdr memqueued)
+ (equal '(nil) (last form))))
+ rest)
+ ;; A trailing nil indicates to discard multiple values, and we need to
+ ;; respect that:
+ (when (and memqueued (cdr memqueued))
+ (setq form (delq nil (copy-sequence form)))
+ (when trailing-nil
+ (setcdr (last form) '(nil))))
+ (setq rest form)
+ ;; If there is a literal non-nil constant in the args to `or', throw
+ ;; away all following forms. We can do this because a literal non-nil
+ ;; constant cannot be multiple.
(while (cdr (setq rest (cdr rest)))
(if (byte-compile-trueconstp (car rest))
(setq form (copy-sequence form)
＠＠ -978,7 +988,10 ＠＠
((consp (car clauses))
(nconc
(case (length (car clauses))
- (1 `(or ,(nth 0 (car clauses))))
+ (1 (if (cdr clauses)
+ `(or ,(nth 0 (car clauses)))
+ ;; XEmacs: don't pass any multiple values back:
+ `(or ,(nth 0 (car clauses)) nil)))
(2 `(if ,(nth 0 (car clauses)) ,(nth 1 (car clauses))))
(t `(if ,(nth 0 (car clauses)) (progn ,＠(cdr (car clauses))))))
(when (cdr clauses) (list (byte-optimize-cond-1 (cdr clauses))))))
diff -r 945247a8112f -r cdabd56ce1b5 lisp/bytecomp.el
--- a/lisp/bytecomp.el Wed Sep 02 20:38:14 2009 -0600
+++ b/lisp/bytecomp.el Sun Sep 06 19:36:02 2009 +0100
＠＠ -1816,7 +1816,7 ＠＠
(defun byte-compile-insert-header (filename byte-compile-inbuffer
byte-compile-outbuffer)
(set-buffer byte-compile-inbuffer)
- (let (checks-string comments)
+ (let (comments)
(set-buffer byte-compile-outbuffer)
(delete-region 1 (1+ byte-compile-checks-and-comments-space))
(goto-char 1)
＠＠ -1840,17 +1840,34 ＠＠
(insert (format ";;;###coding system: %s\n"
(coding-system-name buffer-file-coding-system))))
(insert (format
- "\n(or %s\n (error \"Loading this file requires: %s\"))\n"
- (setq checks-string
- (let ((print-readably t))
- (prin1-to-string (if (> (length
- byte-compile-checks-on-load)
- 1)
- (cons 'and
- (reverse
- byte-compile-checks-on-load))
- (car byte-compile-checks-on-load)))))
- checks-string))
+ "\n(or %s\n (error \"Loading this file requires %s\"))\n"
+ (let ((print-readably t))
+ (prin1-to-string (if (> (length
+ byte-compile-checks-on-load)
+ 1)
+ (cons 'and
+ (setq byte-compile-checks-on-load
+ (reverse
+ byte-compile-checks-on-load)))
+ (car byte-compile-checks-on-load))))
+ (loop
+ for check in byte-compile-checks-on-load
+ with seen-first = nil
+ with res = ""
+ do
+ (if seen-first
+ (setq res (concat res ", "))
+ (setq seen-first t))
+ ;; Print featurep calls differently:
+ (if (and (eq (car check) 'featurep)
+ (eq (car (second check)) 'quote)
+ (symbolp (second (second check))))
+ (setq res (concat res
+ (symbol-name (second (second check)))))
+ (setq res (concat res
+ (let ((print-readably t))
+ (prin1-to-string check)))))
+ finally return res)))
(setq comments
(with-string-as-buffer-contents ""
(insert "\n;;; compiled by "
＠＠ -2176,13 +2193,29 ＠＠
(eval form)
(byte-compile-keep-pending form 'byte-compile-normal-call))
-(put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn)
-(put 'prog1 'byte-hunk-handler 'byte-compile-file-form-progn)
-(put 'prog2 'byte-hunk-handler 'byte-compile-file-form-progn)
-(defun byte-compile-file-form-progn (form)
- (mapcar 'byte-compile-file-form (cdr form))
- ;; Return nil so the forms are not output twice.
- nil)
+;; XEmacs change: be careful about multiple values with these three forms.
+(put 'progn 'byte-hunk-handler
+ #'(lambda (form)
+ (mapc 'byte-compile-file-form (cdr form))
+ ;; Return nil so the forms are not output twice.
+ nil))
+
+(put 'prog1 'byte-hunk-handler
+ #'(lambda (form)
+ (when (first form)
+ (byte-compile-file-form `(or ,(first form) nil))
+ (mapc 'byte-compile-file-form (cdr form))
+ nil)))
+
+(put 'prog2 'byte-hunk-handler
+ #'(lambda (form)
+ (when (first form)
+ (byte-compile-file-form (first form))
+ (when (second form)
+ (setq form (cdr form))
+ (byte-compile-file-form `(or ,(first form) nil))
+ (mapc 'byte-compile-file-form (cdr form))
+ nil))))
;; This handler is not necessary, but it makes the output from dont-compile
;; and similar macros cleaner.
＠＠ -3677,7 +3710,7 ＠＠
(defun byte-compile-prog1 (form)
(setq form (cdr form))
;; #'prog1 never returns multiple values:
- (byte-compile-form-do-effect (list 'values (pop form)))
+ (byte-compile-form-do-effect `(or ,(pop form) nil))
(byte-compile-body form t))
(defun byte-compile-multiple-value-prog1 (form)
＠＠ -3686,9 +3719,11 ＠＠
(byte-compile-body form t))
(defun byte-compile-values (form)
- (if (and (= 2 (length form))
- (byte-compile-constp (second form)))
- (byte-compile-form-do-effect (second form))
+ (if (= 2 (length form))
+ (if (byte-compile-constp (second form))
+ (byte-compile-form-do-effect (second form))
+ ;; #'or compiles to bytecode, #'values doesn't:
+ (byte-compile-form-do-effect `(or ,(second form) nil)))
(byte-compile-normal-call form)))
(defun byte-compile-values-list (form)
＠＠ -3705,7 +3740,7 ＠＠
(setq form (cdr form))
(byte-compile-form (pop form) t)
;; #'prog2 never returns multiple values:
- (byte-compile-form-do-effect (list 'values (pop form)))
+ (byte-compile-form-do-effect `(or ,(pop form) nil))
(byte-compile-body form t))
(defmacro byte-compile-goto-if (cond discard tag)
diff -r 945247a8112f -r cdabd56ce1b5 src/ChangeLog
--- a/src/ChangeLog Wed Sep 02 20:38:14 2009 -0600
+++ b/src/ChangeLog Sun Sep 06 19:36:02 2009 +0100
＠＠ -1,3 +1,13 ＠＠
+2009-08-31 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * eval.c (For, Fand):
+ Don't declare val as REGISTER in these functions, for some reason
+ it breaks the non-DEBUG union build. These functions are only
+ called from interpreted code, the performance implication doesn't
+ matter. Thank you Robert Delius Royar!
+ * eval.c (Fmultiple_value_list_internal):
+ Error on too many arguments.
+
2009-08-24 Jerry James <james(a)xemacs.org>
* lisp.h (INT_64_BIT): define as __int64 on WIN32.
diff -r 945247a8112f -r cdabd56ce1b5 src/eval.c
--- a/src/eval.c Wed Sep 02 20:38:14 2009 -0600
+++ b/src/eval.c Sun Sep 06 19:36:02 2009 +0100
＠＠ -243,6 +243,7 ＠＠
Lisp_Object Qthrow;
Lisp_Object Qobsolete_throw;
+Lisp_Object Qmultiple_value_list_internal;
static int first_desired_multiple_value;
/* Used outside this file, somewhat uncleanly, in the IGNORE_MULTIPLE_VALUES
＠＠ -838,7 +839,7 ＠＠
(args))
{
/* This function can GC */
- REGISTER Lisp_Object val;
+ Lisp_Object val = Qnil;
LIST_LOOP_3 (arg, args, tail)
{
＠＠ -870,7 +871,7 ＠＠
(args))
{
/* This function can GC */
- REGISTER Lisp_Object val = Qt;
+ Lisp_Object val = Qt;
LIST_LOOP_3 (arg, args, tail)
{
＠＠ -4795,8 +4796,15 ＠＠
(args))
{
Lisp_Object argv[4];
- int first, upper;
- struct gcpro gcpro1;
+ int first, upper, nargs;
+ struct gcpro gcpro1;
+
+ GET_LIST_LENGTH (args, nargs);
+ if (nargs != 3)
+ {
+ Fsignal (Qwrong_number_of_arguments,
+ list2 (Qmultiple_value_list_internal, make_int (nargs)));
+ }
argv[0] = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args)));
CHECK_NATNUM (argv[0]);
＠＠ -7226,6 +7234,7 ＠＠
DEFSYMBOL (Qif);
DEFSYMBOL (Qthrow);
DEFSYMBOL (Qobsolete_throw);
+ DEFSYMBOL (Qmultiple_value_list_internal);
DEFSUBR (For);
DEFSUBR (Fand);
diff -r 945247a8112f -r cdabd56ce1b5 tests/ChangeLog
--- a/tests/ChangeLog Wed Sep 02 20:38:14 2009 -0600
+++ b/tests/ChangeLog Sun Sep 06 19:36:02 2009 +0100
＠＠ -1,6 +1,16 ＠＠
2009-09-02 Jerry James <james(a)xemacs.org>
* reproduce-crashes.el (12): New bug.
+
+2009-08-31 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * automated/lisp-tests.el (Assert-rounding):
+ Remove an overly-verbose failure message here.
+ Correct a couple of tests which were buggy in themselves. Add
+ three new tests, checking the behaviour of #'or and #'and when
+ passed zero arguments, and a Known-Bug-Expect-Failure call
+ involving letf and values. (The bug predates the C-level
+ multiple-value implementation.)
2009-08-16 Aidan Kehoe <kehoea(a)parhasard.net>
diff -r 945247a8112f -r cdabd56ce1b5 tests/automated/lisp-tests.el
--- a/tests/automated/lisp-tests.el Wed Sep 02 20:38:14 2009 -0600
+++ b/tests/automated/lisp-tests.el Sun Sep 06 19:36:02 2009 +0100
＠＠ -1475,11 +1475,8 ＠＠
first one-round-result))
(Assert (equal one-round-result (multiple-value-list
(round first 1)))
- (format "checking (round %S 1) gives %S, types %S, actual %S, types %S"
- first one-round-result (mapcar #'type-of one-round-result)
- (multiple-value-list (round first 1))
- (mapcar #'type-of (multiple-value-list (round first 1)))))
-
+ (format "checking (round %S 1) gives %S"
+ first one-round-result))
(Check-Error arith-error (round first 0))
(Check-Error arith-error (round first 0.0))
(Assert (equal two-round-result (multiple-value-list
＠＠ -1949,7 +1946,7 ＠＠
(multiple-value-function-returning-t ()
(values t pi e degrees-to-radians radians-to-degrees))
(multiple-value-function-returning-nil ()
- (values t pi e radians-to-degrees degrees-to-radians))
+ (values nil pi e radians-to-degrees degrees-to-radians))
(function-throwing-multiple-values ()
(let* ((listing '(0 3 4 nil "string" symbol))
(tail listing)
＠＠ -2051,7 +2048,7 ＠＠
(cond ((multiple-value-function-returning-t))))))
"Checking cond doesn't pass back multiple values in tests.")
(Assert
- (equal (list t pi e degrees-to-radians radians-to-degrees)
+ (equal (list nil pi e radians-to-degrees degrees-to-radians)
(multiple-value-list
(cond (t (multiple-value-function-returning-nil)))))
"Checking cond passes back multiple values in clauses.")
＠＠ -2069,10 +2066,28 ＠＠
(multiple-value-list
(catch 'VoN61Lo4Y (function-throwing-multiple-values)))))
(Assert
- (equal (list t pi e radians-to-degrees degrees-to-radians)
+ (equal (list t pi e degrees-to-radians radians-to-degrees)
(multiple-value-list
(loop
for eye in `(a b c d ,e f g ,nil ,pi)
do (when (null eye)
(return (multiple-value-function-returning-t))))))
- "Checking #'loop passes back multiple values correctly."))
+ "Checking #'loop passes back multiple values correctly.")
+ (Assert
+ (null (or))
+ "Checking #'or behaves correctly with zero arguments.")
+ (Assert
+ (eq t (and))
+ "Checking #'and behaves correctly with zero arguments.")
+ ;; This bug was here before the full multiple-value functionality
+ ;; was introduced (check it with (floor* pi) if you're
+ ;; curious). #'setf works, though, which is what most people are
+ ;; interested in. If you know the setf-method code better than I do,
+ ;; please post a patch; otherwise this is going to the back of the
+ ;; queue of things to do. I didn't break it :-) Aidan Kehoe, Mon Aug
+ ;; 31 10:45:50 GMTDT 2009.
+ (Known-Bug-Expect-Error
+ void-variable
+ (letf (((values three one-four-one-five-nine) (floor pi)))
+ (* three one-four-one-five-nine))))
+
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
commit: Reproducer for menubar-x.c crash.
15 years, 3 months
Jerry James
Jerry James
changeset: 4685:945247a8112f
tag: tip
user: Jerry James <james(a)xemacs.org>
date: Wed Sep 02 20:38:14 2009 -0600
files: tests/ChangeLog tests/reproduce-crashes.el
description:
Reproducer for menubar-x.c crash.
diff -r 15c42a3f4065 -r 945247a8112f tests/ChangeLog
--- a/tests/ChangeLog Sat Aug 29 22:37:50 2009 +0800
+++ b/tests/ChangeLog Wed Sep 02 20:38:14 2009 -0600
＠＠ -1,3 +1,7 ＠＠
+2009-09-02 Jerry James <james(a)xemacs.org>
+
+ * reproduce-crashes.el (12): New bug.
+
2009-08-16 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el (foo):
diff -r 15c42a3f4065 -r 945247a8112f tests/reproduce-crashes.el
--- a/tests/reproduce-crashes.el Sat Aug 29 22:37:50 2009 +0800
+++ b/tests/reproduce-crashes.el Wed Sep 02 20:38:14 2009 -0600
＠＠ -133,6 +133,16 ＠＠
;;; ------------------------------------------------------------------
;;;; Bugs follow:
+(defbug 12 current
+ "Crash when clicking on the menubar, triggered by a Lisp error due to a
+version of truncate-string-to-width that does not take 5 parameters.
+Fatal error: assertion failed, file menubar-x.c, line 579, ABORT()
+Reported: https://bugzilla.redhat.com/show_bug.cgi?id=480845
+ <1251569781.4318.2.camel＠mslap>"
+ (fset 'truncate-string-to-width
+ #'(lambda (str end-column &optional start-column padding) str))
+ (accelerate-menu))
+
(defbug 11 fixed
"Crash in search due to backward movement.
Need Mule build with error checking in 21.5.28.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[AC 21.5] menubar-x.c crash reproducer
15 years, 3 months
Jerry James
Jerry James
APPROVE COMMIT 21.5
This is a reproducer for the crash in menubar-x.c that we discussed on
xemacs-beta recently.
diff -r 15c42a3f4065 tests/ChangeLog
--- a/tests/ChangeLog Sat Aug 29 22:37:50 2009 +0800
+++ b/tests/ChangeLog Wed Sep 02 20:29:16 2009 -0600
＠＠ -1,3 +1,7 ＠＠
+2009-09-02 Jerry James <james(a)xemacs.org>
+
+ * reproduce-crashes.el (12): New bug.
+
2009-08-16 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el (foo):
diff -r 15c42a3f4065 tests/reproduce-crashes.el
--- a/tests/reproduce-crashes.el Sat Aug 29 22:37:50 2009 +0800
+++ b/tests/reproduce-crashes.el Wed Sep 02 20:29:16 2009 -0600
＠＠ -133,6 +133,16 ＠＠
;;; ------------------------------------------------------------------
;;;; Bugs follow:
+(defbug 12 current
+ "Crash when clicking on the menubar, triggered by a Lisp error due to a
+version of truncate-string-to-width that does not take 5 parameters.
+Fatal error: assertion failed, file menubar-x.c, line 579, ABORT()
+Reported: https://bugzilla.redhat.com/show_bug.cgi?id=480845
+ <1251569781.4318.2.camel＠mslap>"
+ (fset 'truncate-string-to-width
+ #'(lambda (str end-column &optional start-column padding) str))
+ (accelerate-menu))
+
(defbug 11 fixed
"Crash in search due to backward movement.
Need Mule build with error checking in 21.5.28.
--
Jerry James
http://www.jamezone.org/
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[AC (mule-base)] Remove store-substring & truncate-string*
15 years, 3 months
Jerry James
Jerry James
APPROVE COMMIT mule-base
As per the conversation on xemacs-beta about crashes when clicking on
the menubar, this patch removes the functions that lead to a Lisp
error that leads to the reported crash. These functions have been
defined in subr.el for several years, but we overlooked the fact that
these bitrotted versions were still in mule-util.el.
NOTE: This patch masks the fact that something in menubar-x.c is
causing a crash when there is a Lisp error in the menubar. There is a
report that a Lisp error is reported correctly on Windows, so
menubar-msw.c apparently gets this right. We need to fix menubar-x.c.
Index: mule-packages/mule-base/ChangeLog
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/mule-packages/mule-base/ChangeLog,v
retrieving revision 1.66
diff -d -u -r1.66 ChangeLog
--- mule-packages/mule-base/ChangeLog 9 Aug 2008 12:41:17 -0000 1.66
+++ mule-packages/mule-base/ChangeLog 1 Sep 2009 18:56:15 -0000
＠＠ -1,3 +1,10 ＠＠
+2009-09-01 Jerry James <james(a)xemacs.org>
+
+ * mule-util.el (store-substring): Remove older version of a
+ function that is now defined in subr.el.
+ (truncate-string-to-width): Ditto.
+ (truncate-string): Ditto.
+
2008-08-09 Norbert Koch <viteno(a)xemacs.org>
* Makefile (VERSION): XEmacs package 1.53 released.
Index: mule-packages/mule-base/mule-util.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/mule-packages/mule-base/mule-util.el,v
retrieving revision 1.3
diff -d -u -r1.3 mule-util.el
--- mule-packages/mule-base/mule-util.el 20 May 2007 19:32:53 -0000 1.3
+++ mule-packages/mule-base/mule-util.el 1 Sep 2009 18:56:15 -0000
＠＠ -68,75 +68,6 ＠＠
;; "Return a vector of characters in STRING."
;; (string-to-sequence string 'vector))
-;;;###autoload
-(defun store-substring (string idx obj)
- "Embed OBJ (string or character) at index IDX of STRING."
- (if (characterp obj)
- (aset string idx obj)
- (let ((len1 (length obj))
- (len2 (length string))
- (i 0))
- (while (< i len1)
- (aset string (+ idx i) (aref obj i))
- (setq i (1+ i)))))
- string)
-
-;;;###autoload
-(defun truncate-string-to-width (str end-column &optional start-column padding)
- "Truncate string STR to end at column END-COLUMN.
-The optional 2nd arg START-COLUMN, if non-nil, specifies
-the starting column; that means to return the characters occupying
-columns START-COLUMN ... END-COLUMN of STR.
-
-The optional 3rd arg PADDING, if non-nil, specifies a padding character
-to add at the end of the result if STR doesn't reach column END-COLUMN,
-or if END-COLUMN comes in the middle of a character in STR.
-PADDING is also added at the beginning of the result
-if column START-COLUMN appears in the middle of a character in STR.
-
-If PADDING is nil, no padding is added in these cases, so
-the resulting string may be narrower than END-COLUMN."
- (or start-column
- (setq start-column 0))
- (let ((len (length str))
- (idx 0)
- (column 0)
- (head-padding "") (tail-padding "")
- ch last-column last-idx from-idx)
- (condition-case nil
- (while (< column start-column)
- (setq ch (aref str idx)
- column (+ column (char-width ch))
- idx (1+ idx)))
- (args-out-of-range (setq idx len)))
- (if (< column start-column)
- (if padding (make-string end-column padding) "")
- (if (and padding (> column start-column))
- (setq head-padding (make-string (- column start-column) padding)))
- (setq from-idx idx)
- (if (< end-column column)
- (setq idx from-idx)
- (condition-case nil
- (while (< column end-column)
- (setq last-column column
- last-idx idx
- ch (aref str idx)
- column (+ column (char-width ch))
- idx (1+ idx)))
- (args-out-of-range (setq idx len)))
- (if (> column end-column)
- (setq column last-column idx last-idx))
- (if (and padding (< column end-column))
- (setq tail-padding (make-string (- end-column column) padding))))
- (setq str (substring str from-idx idx))
- (if padding
- (concat head-padding str tail-padding)
- str))))
-
-;;; For backward compatibility ...
-;;;###autoload
-(defalias 'truncate-string 'truncate-string-to-width)
-(make-obsolete 'truncate-string 'truncate-string-to-width)
;;; Nested alist handler. Nested alist is alist whose elements are
;;; also nested alist.
--
Jerry James
http://www.jamezone.org/
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments