APPROVE COMMIT NOTE: This patch has been committed. # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net&gt; # 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&gt; * 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&gt; * 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&gt; * 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&gt; + + * 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&gt; * 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&gt; + + * 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&gt; * 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&gt; + + * 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&gt; * 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