Mercurial > hg > xemacs-beta
changeset 4677:8f1ee2d15784
Support full Common Lisp multiple values in C.
lisp/ChangeLog
2009-08-11 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el :
Update this file to support full C-level multiple values. This
involves:
-- Four new bytecodes, and special compiler functions to compile
multiple-value-call, multiple-value-list-internal, values,
values-list, and, since it now needs to pass back multiple values
and is a special form, throw.
-- There's a new compiler variable, byte-compile-checks-on-load,
which is a list of forms that are evaluated at the very start of a
file, with an error thrown if any of them give nil.
-- The header is now inserted *after* compilation, giving a chance
for the compilation process to influence what those checks
are. There is still a check done before compilation for non-ASCII
characters, to try to turn off dynamic docstrings if appopriate,
in `byte-compile-maybe-reset-coding'.
Space is reserved for checks; comments describing the version of
the byte compiler generating the file are inserted if space
remains for them.
* bytecomp.el (byte-compile-version):
Update this, we're a newer version of the byte compiler.
* byte-optimize.el (byte-optimize-funcall):
Correct a comment.
* bytecomp.el (byte-compile-lapcode):
Discard the arg with byte-multiple-value-call.
* bytecomp.el (byte-compile-checks-and-comments-space):
New variable, describe how many octets to reserve for checks at
the start of byte-compiled files.
* cl-compat.el:
Remove the fake multiple-value implementation. Have the functions
that use it use the real multiple-value implementation instead.
* cl-macs.el (cl-block-wrapper, cl-block-throw):
Revise the byte-compile properties of these symbols to work now
we've made throw into a special form; keep the byte-compile
properties as anonymous lambdas, since we don't have docstrings
for them.
* cl-macs.el (multiple-value-bind, multiple-value-setq)
(multiple-value-list, nth-value):
Update these functions to work with the C support for multiple
values.
* cl-macs.el (values):
Modify the setf handler for this to call
#'multiple-value-list-internal appropriately.
* cl-macs.el (cl-setf-do-store):
If the store form is a cons, treat it specially as wrapping the
store value.
* cl.el (cl-block-wrapper):
Make this an alias of #'and, not #'identity, since it needs to
pass back multiple values.
* cl.el (multiple-value-apply):
We no longer support this, mark it obsolete.
* lisp-mode.el (eval-interactive-verbose):
Remove a useless space in the docstring.
* lisp-mode.el (eval-interactive):
Update this function and its docstring. It now passes back a list,
basically wrapping any eval calls with multiple-value-list. This
allows multiple values to be printed by default in *scratch*.
* lisp-mode.el (prin1-list-as-multiple-values):
New function, printing a list as multiple values in the manner of
Bruno Haible's clisp, separating each entry with " ;\n".
* lisp-mode.el (eval-last-sexp):
Call #'prin1-list-as-multiple-values on the return value of
#'eval-interactive.
* lisp-mode.el (eval-defun):
Call #'prin1-list-as-multiple-values on the return value of
#'eval-interactive.
* mouse.el (mouse-eval-sexp):
Deal with lists corresponding to multiple values from
#'eval-interactive. Call #'cl-prettyprint, which is always
available, instead of sometimes calling #'pprint and sometimes
falling back to prin1.
* obsolete.el (obsolete-throw):
New function, called from eval.c when #'funcall encounters an
attempt to call #'throw (now a special form) as a function. Only
needed for compatibility with 21.4 byte-code.
man/ChangeLog addition:
2009-08-11 Aidan Kehoe <kehoea@parhasard.net>
* cl.texi (Organization):
Remove references to the obsolete multiple-value emulating code.
src/ChangeLog addition:
2009-08-11 Aidan Kehoe <kehoea@parhasard.net>
* bytecode.c (enum Opcode /* Byte codes */):
Add four new bytecodes, to deal with multiple values.
(POP_WITH_MULTIPLE_VALUES): New macro.
(POP): Modify this macro to ignore multiple values.
(DISCARD_PRESERVING_MULTIPLE_VALUES): New macro.
(DISCARD): Modify this macro to ignore multiple values.
(TOP_WITH_MULTIPLE_VALUES): New macro.
(TOP_ADDRESS): New macro.
(TOP): Modify this macro to ignore multiple values.
(TOP_LVALUE): New macro.
(Bcall): Ignore multiple values where appropriate.
(Breturn): Pass back multiple values.
(Bdup): Preserve multiple values.
Use TOP_LVALUE with most bytecodes that assign anything to
anything.
(Bbind_multiple_value_limits, Bmultiple_value_call,
Bmultiple_value_list_internal, Bthrow): Implement the new
bytecodes.
(Bgotoifnilelsepop, Bgotoifnonnilelsepop, BRgotoifnilelsepop,
BRgotoifnonnilelsepop):
Discard any multiple values.
* callint.c (Fcall_interactively):
Ignore multiple values when calling #'eval, in two places.
* device-x.c (x_IO_error_handler):
* macros.c (pop_kbd_macro_event):
* eval.c (Fsignal):
* eval.c (flagged_a_squirmer):
Call throw_or_bomb_out, not Fthrow, now that the latter is a
special form.
* eval.c:
Make Qthrow, Qobsolete_throw available as symbols.
Provide multiple_value_current_limit, multiple-values-limit (the
latter as specified by Common Lisp.
* eval.c (For):
Ignore multiple values when comparing with Qnil, but pass any
multiple values back for the last arg.
* eval.c (Fand):
Ditto.
* eval.c (Fif):
Ignore multiple values when examining the result of the
condition.
* eval.c (Fcond):
Ignore multiple values when comparing what the clauses give, but
pass them back if a clause gave non-nil.
* eval.c (Fprog2):
Never pass back multiple values.
* eval.c (FletX, Flet):
Ignore multiple when evaluating what exactly symbols should be
bound to.
* eval.c (Fwhile):
Ignore multiple values when evaluating the test.
* eval.c (Fsetq, Fdefvar, Fdefconst):
Ignore multiple values.
* eval.c (Fthrow):
Declare this as a special form; ignore multiple values for TAG,
preserve them for VALUE.
* eval.c (throw_or_bomb_out):
Make this available to other files, now Fthrow is a special form.
* eval.c (Feval):
Ignore multiple values when calling a compiled function, a
non-special-form subr, or a lambda expression.
* eval.c (Ffuncall):
If we attempt to call #'throw (now a special form) as a function,
don't error, call #'obsolete-throw instead.
* eval.c (make_multiple_value, multiple_value_aset)
(multiple_value_aref, print_multiple_value, mark_multiple_value)
(size_multiple_value):
Implement the multiple_value type. Add a long comment describing
our implementation.
* eval.c (bind_multiple_value_limits):
New function, used by the bytecode and by #'multiple-value-call,
#'multiple-value-list-internal.
* eval.c (multiple_value_call):
New function, used by the bytecode and #'multiple-value-call.
* eval.c (Fmultiple_value_call):
New special form.
* eval.c (multiple_value_list_internal):
New function, used by the byte code and
#'multiple-value-list-internal.
* eval.c (Fmultiple_value_list_internal, Fmultiple_value_prog1):
New special forms.
* eval.c (Fvalues, Fvalues_list):
New Lisp functions.
* eval.c (values2):
New function, for C code returning multiple values.
* eval.c (syms_of_eval):
Make our new Lisp functions and symbols available.
* eval.c (multiple-values-limit):
Make this available to Lisp.
* event-msw.c (dde_eval_string):
* event-stream.c (execute_help_form):
* glade.c (connector):
* glyphs-widget.c (glyph_instantiator_to_glyph):
* glyphs.c (evaluate_xpm_color_symbols):
* gui-x.c (wv_set_evalable_slot, button_item_to_widget_value):
* gui.c (gui_item_value, gui_item_display_flush_left):
* lread.c (check_if_suppressed):
* menubar-gtk.c (menu_convert, menu_descriptor_to_widget_1):
* menubar-msw.c (populate_menu_add_item):
* print.c (Fwith_output_to_temp_buffer):
* symbols.c (Fsetq_default):
Ignore multiple values when calling Feval.
* symeval.h:
Add the header declarations necessary for the multiple-values
implementation.
* inline.c:
#include symeval.h, now that it has some inline functions.
* lisp.h:
Update Fthrow's declaration. Make throw_or_bomb_out available to
all files.
* lrecord.h (enum lrecord_type):
Add the multiple_value type here.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sun, 16 Aug 2009 20:55:49 +0100 |
| parents | e3feb329bda9 |
| children | b5e1d4f6b66f |
| files | lisp/ChangeLog lisp/byte-optimize.el lisp/bytecomp.el lisp/cl-compat.el lisp/cl-macs.el lisp/cl.el lisp/lisp-mode.el lisp/mouse.el lisp/obsolete.el man/ChangeLog man/cl.texi src/ChangeLog src/bytecode.c src/callint.c src/device-x.c src/eval.c src/event-msw.c src/event-stream.c src/glade.c src/glyphs-widget.c src/glyphs.c src/gui-x.c src/gui.c src/inline.c src/lisp.h src/lread.c src/lrecord.h src/macros.c src/menubar-gtk.c src/menubar-msw.c src/print.c src/symbols.c src/symeval.h |
| diffstat | 33 files changed, 1609 insertions(+), 479 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Sun Aug 16 14:58:57 2009 +0100 +++ b/lisp/ChangeLog Sun Aug 16 20:55:49 2009 +0100 @@ -10,6 +10,83 @@ Use buffer (format " *Minibuf-%d*" (minibuffer-depth)), regardless of depth. +2009-08-11 Aidan Kehoe <kehoea@parhasard.net> + + * bytecomp.el : + Update this file to support full C-level multiple values. This + involves: + -- Four new bytecodes, and special compiler functions to compile + multiple-value-call, multiple-value-list-internal, values, + values-list, and, since it now needs to pass back multiple values + and is a special form, throw. + -- There's a new compiler variable, byte-compile-checks-on-load, + which is a list of forms that are evaluated at the very start of a + file, with an error thrown if any of them give nil. + -- The header is now inserted *after* compilation, giving a chance + for the compilation process to influence what those checks + are. There is still a check done before compilation for non-ASCII + characters, to try to turn off dynamic docstrings if appopriate, + in `byte-compile-maybe-reset-coding'. + Space is reserved for checks; comments describing the version of + the byte compiler generating the file are inserted if space + remains for them. + * bytecomp.el (byte-compile-version): + Update this, we're a newer version of the byte compiler. + * byte-optimize.el (byte-optimize-funcall): + Correct a comment. + * bytecomp.el (byte-compile-lapcode): + Discard the arg with byte-multiple-value-call. + * bytecomp.el (byte-compile-checks-and-comments-space): + New variable, describe how many octets to reserve for checks at + the start of byte-compiled files. + * cl-compat.el: + Remove the fake multiple-value implementation. Have the functions + that use it use the real multiple-value implementation instead. + * cl-macs.el (cl-block-wrapper, cl-block-throw): + Revise the byte-compile properties of these symbols to work now + we've made throw into a special form; keep the byte-compile + properties as anonymous lambdas, since we don't have docstrings + for them. + * cl-macs.el (multiple-value-bind, multiple-value-setq) + (multiple-value-list, nth-value): + Update these functions to work with the C support for multiple + values. + * cl-macs.el (values): + Modify the setf handler for this to call + #'multiple-value-list-internal appropriately. + * cl-macs.el (cl-setf-do-store): + If the store form is a cons, treat it specially as wrapping the + store value. + * cl.el (cl-block-wrapper): + Make this an alias of #'and, not #'identity, since it needs to + pass back multiple values. + * cl.el (multiple-value-apply): + We no longer support this, mark it obsolete. + * lisp-mode.el (eval-interactive-verbose): + Remove a useless space in the docstring. + * lisp-mode.el (eval-interactive): + Update this function and its docstring. It now passes back a list, + basically wrapping any eval calls with multiple-value-list. This + allows multiple values to be printed by default in *scratch*. + * lisp-mode.el (prin1-list-as-multiple-values): + New function, printing a list as multiple values in the manner of + Bruno Haible's clisp, separating each entry with " ;\n". + * lisp-mode.el (eval-last-sexp): + Call #'prin1-list-as-multiple-values on the return value of + #'eval-interactive. + * lisp-mode.el (eval-defun): + Call #'prin1-list-as-multiple-values on the return value of + #'eval-interactive. + * mouse.el (mouse-eval-sexp): + Deal with lists corresponding to multiple values from + #'eval-interactive. Call #'cl-prettyprint, which is always + available, instead of sometimes calling #'pprint and sometimes + falling back to prin1. + * obsolete.el (obsolete-throw): + New function, called from eval.c when #'funcall encounters an + attempt to call #'throw (now a special form) as a function. Only + needed for compatibility with 21.4 byte-code. + 2009-08-10 Aidan Kehoe <kehoea@parhasard.net> * help.el (function-arglist, function-documentation):
--- a/lisp/byte-optimize.el Sun Aug 16 14:58:57 2009 +0100 +++ b/lisp/byte-optimize.el Sun Aug 16 20:55:49 2009 +0100 @@ -1093,7 +1093,7 @@ (put 'nlistp 'byte-optimizer 'byte-compile-negation-optimizer) (defun byte-optimize-funcall (form) - ;; (funcall '(lambda ...) ...) ==> ((lambda ...) ...) + ;; (funcall #'(lambda ...) ...) ==> ((lambda ...) ...) ;; (funcall 'foo ...) ==> (foo ...) (let ((fn (nth 1 form))) (if (memq (car-safe fn) '(quote function))
--- a/lisp/bytecomp.el Sun Aug 16 14:58:57 2009 +0100 +++ b/lisp/bytecomp.el Sun Aug 16 20:55:49 2009 +0100 @@ -10,7 +10,7 @@ ;; Richard Stallman <rms@gnu.org> ;; Keywords: internal lisp -(defconst byte-compile-version "2.27 XEmacs; 2000-09-12.") +(defconst byte-compile-version "2.28 XEmacs; 2009-08-09.") ;; This file is part of XEmacs. @@ -215,7 +215,7 @@ (load-library "bytecomp-runtime")) (eval-when-compile - (defvar byte-compile-single-version nil + (defvar byte-compile-single-version t "If this is true, the choice of emacs version (v19 or v20) byte-codes will be hard-coded into bytecomp when it compiles itself. If the compiler itself is compiled with optimization, this causes a speedup.") @@ -304,6 +304,10 @@ "This is completely ignored. It is only around for backwards compatibility.") +(defvar byte-compile-checks-on-load '((featurep 'xemacs)) + "A list of expressions to check when first loading a file. +Emacs will throw an error if any of them fail; checks will be made in +reverse order.") ;; FSF enables byte-compile-dynamic-docstrings but not byte-compile-dynamic ;; by default. This would be a reasonable conservative approach except @@ -440,7 +444,7 @@ on the specbind stack. The cdr of each cell is an integer bitmask.") (defvar byte-compile-force-escape-quoted nil - "If non-nil, `byte-compile-insert-header' always adds a coding cookie. + "If t, `byte-compile-maybe-reset-coding' always chooses `escape-quoted' This is for situations where the byte compiler output file needs to be able to encode character values above ?\\xFF, but this cannot be @@ -733,7 +737,10 @@ (byte-defop 176 nil byte-concatN) (byte-defop 177 nil byte-insertN) -;; unused: 178-181 +(byte-defop 178 1 byte-bind-multiple-value-limits) +(byte-defop 179 -3 byte-multiple-value-list-internal) +(byte-defop 180 0 byte-multiple-value-call) +(byte-defop 181 -1 byte-throw) ;; these ops are new to v20 (byte-defop 182 -1 byte-member) @@ -833,6 +840,10 @@ (<= (symbol-value op) byte-insertN)) (setq pc (+ 2 pc)) (cons off (cons (symbol-value op) bytes))) + ((= byte-multiple-value-call (symbol-value op)) + (setq pc (1+ pc)) + ;; Ignore off. + (cons (symbol-value op) bytes)) ((< off 6) (setq pc (1+ pc)) (cons (+ (symbol-value op) off) bytes)) @@ -1386,6 +1397,8 @@ (byte-optimize byte-optimize) (byte-compile-emacs19-compatibility byte-compile-emacs19-compatibility) + (byte-compile-checks-on-load + byte-compile-checks-on-load) (byte-compile-dynamic byte-compile-dynamic) (byte-compile-dynamic-docstrings byte-compile-dynamic-docstrings) @@ -1718,9 +1731,7 @@ ;; byte-compile-warning-types ;; byte-compile-warnings)) (byte-compile-force-escape-quoted byte-compile-force-escape-quoted) - (byte-compile-using-dynamic nil) - (byte-compile-using-escape-quoted nil) - ) + (byte-compile-using-dynamic nil)) (byte-compile-close-variables (save-excursion (setq byte-compile-outbuffer @@ -1730,9 +1741,8 @@ (setq case-fold-search nil) (and filename (not eval) - (byte-compile-insert-header filename - byte-compile-inbuffer - byte-compile-outbuffer)) + (byte-compile-maybe-reset-coding byte-compile-inbuffer + byte-compile-outbuffer)) (setq byte-compile-using-dynamic (or (symbol-value-in-buffer 'byte-compile-dynamic byte-compile-inbuffer) @@ -1763,6 +1773,8 @@ ;; Compile pending forms at end of file. (byte-compile-flush-pending) + (byte-compile-insert-header filename byte-compile-inbuffer + byte-compile-outbuffer) (byte-compile-warn-about-unresolved-functions) ;; Should we always do this? When calling multiple files, it ;; would be useful to delay this warning until all have @@ -1797,11 +1809,16 @@ (kill-buffer byte-compile-outbuffer) nil))) +(defvar byte-compile-checks-and-comments-space 475 + "Number of octets of space for checks and comments; used by the dynamic +docstrings code.") + (defun byte-compile-insert-header (filename byte-compile-inbuffer - byte-compile-outbuffer) + byte-compile-outbuffer) (set-buffer byte-compile-inbuffer) - (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) + (let (checks-string comments) (set-buffer byte-compile-outbuffer) + (delete-region 1 (1+ byte-compile-checks-and-comments-space)) (goto-char 1) ;; ;; The magic number of .elc files is ";ELC", or 0x3B454C43. After that is @@ -1817,62 +1834,56 @@ (insert ";ELC" (if (byte-compile-version-cond byte-compile-emacs19-compatibility) 19 20) - "\000\000\000\n" - ) - (insert ";;; compiled by " - (or (and (boundp 'user-mail-address) user-mail-address) - (concat (user-login-name) "@" (system-name))) - " on " - (current-time-string) "\n;;; from file " filename "\n") - (insert ";;; emacs version " emacs-version ".\n") - (insert ";;; bytecomp version " byte-compile-version "\n;;; " - (cond - ((eq byte-optimize 'source) "source-level optimization only") - ((eq byte-optimize 'byte) "byte-level optimization only") - (byte-optimize "optimization is on") - (t "optimization is off")) - (if (byte-compile-version-cond byte-compile-emacs19-compatibility) - "; compiled with Emacs 19 compatibility.\n" - ".\n")) - (if (not (byte-compile-version-cond byte-compile-emacs19-compatibility)) - (insert ";;; this file uses opcodes which do not exist in Emacs 19.\n" - ;; Have to check if emacs-version is bound so that this works - ;; in files loaded early in loadup.el. - "\n(if (and (boundp 'emacs-version)\n" - "\t (or (and (boundp 'epoch::version) epoch::version)\n" - "\t (string-lessp emacs-version \"20\")))\n" - " (error \"`" - ;; prin1-to-string is used to quote backslashes. - (substring (prin1-to-string (file-name-nondirectory filename)) - 1 -1) - "' was compiled for Emacs 20\"))\n\n")) - (insert "(or (boundp 'current-load-list) (setq current-load-list nil))\n" - "\n") - (if (and (byte-compile-version-cond byte-compile-emacs19-compatibility) - dynamic-docstrings) - (insert ";;; this file uses opcodes which do not exist prior to\n" - ";;; XEmacs 19.14/GNU Emacs 19.29 or later." - ;; Have to check if emacs-version is bound so that this works - ;; in files loaded early in loadup.el. - "\n(if (and (boundp 'emacs-version)\n" - "\t (or (and (boundp 'epoch::version) epoch::version)\n" - "\t (and (not (string-match \"XEmacs\" emacs-version))\n" - "\t (string-lessp emacs-version \"19.29\"))\n" - "\t (string-lessp emacs-version \"19.14\")))\n" - " (error \"`" - ;; prin1-to-string is used to quote backslashes. - (substring (prin1-to-string (file-name-nondirectory filename)) - 1 -1) - "' was compiled for XEmacs 19.14/Emacs 19.29 or later\"))\n\n" - ) - )) - - ;; back in the inbuffer; determine and set the coding system for the .elc - ;; file if under Mule. If there are any extended characters in the - ;; input file, use `escape-quoted' to make sure that both binary and - ;; extended characters are output properly and distinguished properly. - ;; Otherwise, use `raw-text' for maximum portability with non-Mule - ;; Emacsen. + "\000\000\000\n") + (when (not (eq (find-coding-system 'raw-text-unix) + (find-coding-system buffer-file-coding-system))) + (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)) + (setq comments + (with-string-as-buffer-contents "" + (insert "\n;;; compiled by " + (or (and (boundp 'user-mail-address) user-mail-address) + (concat (user-login-name) "@" (system-name))) + " on " + (current-time-string) "\n;;; from file " filename "\n") + (insert ";;; emacs version " emacs-version ".\n") + (insert ";;; bytecomp version " byte-compile-version "\n;;; " + (cond + ((eq byte-optimize 'source) + "source-level optimization only") + ((eq byte-optimize 'byte) "byte-level optimization only") + (byte-optimize "optimization is on") + (t "optimization is off")) + "\n"))) + + ;; We won't trip this unless the byte-compiler changes, in which case + ;; it's just a matter of upping the space. + (assert (natnump (- (1+ byte-compile-checks-and-comments-space) (point))) + t "Not enough space for the feature checks!") + + (if (natnump (- (1+ byte-compile-checks-and-comments-space) + (+ (point) (length comments)))) + (insert comments)) + (insert-char ?\ (- (1+ byte-compile-checks-and-comments-space) + (point))))) + +(defun byte-compile-maybe-reset-coding (byte-compile-inbuffer + byte-compile-outbuffer) + ;; We also reserve some space for the feature checks: + (goto-char 1) + (insert-char ?\ byte-compile-checks-and-comments-space) (if (or (featurep '(not mule)) ;; Don't scan buffer if we are not muleized (and (not byte-compile-force-escape-quoted) @@ -1885,7 +1896,8 @@ ;; not true of ordinary comments. (let ((non-latin-1-re (concat "[^\000-\377]" - #r"\|\\u[0-9a-fA-F]\{4,4\}\|\\U[0-9a-fA-F]\{8,8\}")) + #r"\|\\u[0-9a-fA-F]\{4,4\}\|\\U[0-9a-fA-F]" + "\\{8,8\\}")) (case-fold-search nil)) (catch 'need-to-escape-quote (while (re-search-forward non-latin-1-re nil t) @@ -1894,19 +1906,12 @@ (forward-line 1)) t))))) (setq buffer-file-coding-system 'raw-text-unix) - (insert "(or (featurep 'mule) (error \"Loading this file requires Mule support\")) -;;;###coding system: escape-quoted\n") (setq buffer-file-coding-system 'escape-quoted) - ;; #### Lazy loading not yet implemented for MULE files - ;; mrb - Fix this someday. + (pushnew '(featurep 'mule) byte-compile-checks-on-load) (save-excursion (set-buffer byte-compile-inbuffer) (setq byte-compile-dynamic nil - byte-compile-dynamic-docstrings nil)) - ;;(external-debugging-output (prin1-to-string (buffer-local-variables)))) - ) - ) - + byte-compile-dynamic-docstrings nil)))) (defun byte-compile-output-file-form (form) ;; writes the given form to the output buffer, being careful of docstrings @@ -3084,6 +3089,11 @@ (byte-defop-compiler (% byte-rem) 2) (byte-defop-compiler aset 3) +(byte-defop-compiler-1 bind-multiple-value-limits) +(byte-defop-compiler multiple-value-list-internal) +(byte-defop-compiler-1 multiple-value-call) +(byte-defop-compiler throw) + (byte-defop-compiler-rmsfun member 2) (byte-defop-compiler-rmsfun assq 2) @@ -3102,11 +3112,14 @@ ;;(byte-defop-compiler (mod byte-rem) 2) -(defun byte-compile-subr-wrong-args (form n) +(defun byte-compile-warn-wrong-args (form n) (when (memq 'subr-callargs byte-compile-warnings) (byte-compile-warn "%s called with %d arg%s, but requires %s" (car form) (length (cdr form)) - (if (= 1 (length (cdr form))) "" "s") n)) + (if (= 1 (length (cdr form))) "" "s") n))) + +(defun byte-compile-subr-wrong-args (form n) + (byte-compile-warn-wrong-args form n) ;; get run-time wrong-number-of-args error. (byte-compile-normal-call form)) @@ -3641,6 +3654,9 @@ (byte-defop-compiler-1 inline byte-compile-progn) (byte-defop-compiler-1 progn) (byte-defop-compiler-1 prog1) +(byte-defop-compiler-1 multiple-value-prog1) +(byte-defop-compiler-1 values) +(byte-defop-compiler-1 values-list) (byte-defop-compiler-1 prog2) (byte-defop-compiler-1 if) (byte-defop-compiler-1 cond) @@ -3660,13 +3676,36 @@ (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-body form t)) + +(defun byte-compile-multiple-value-prog1 (form) + (setq form (cdr form)) (byte-compile-form-do-effect (pop form)) (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)) + (byte-compile-normal-call form))) + +(defun byte-compile-values-list (form) + (if (and (= 2 (length form)) + (or (null (second form)) + (and (consp (second form)) + (eq (car (second form)) + 'quote) + (not (symbolp (car-safe (cdr (second form)))))))) + (byte-compile-form-do-effect (car-safe (cdr (second form)))) + (byte-compile-normal-call form))) + (defun byte-compile-prog2 (form) (setq form (cdr form)) (byte-compile-form (pop form) t) - (byte-compile-form-do-effect (pop form)) + ;; #'prog2 never returns multiple values: + (byte-compile-form-do-effect (list 'values (pop form))) (byte-compile-body form t)) (defmacro byte-compile-goto-if (cond discard tag) @@ -3952,6 +3991,65 @@ (byte-compile-body (cdr (cdr form))) (byte-compile-out 'byte-temp-output-buffer-show 0)) +(defun byte-compile-multiple-value-call (form) + (if (< (length form) 2) + (progn + (byte-compile-warn-wrong-args form 1) + (byte-compile-normal-call + `(signal 'wrong-number-of-arguments '(,(car form) + ,(length (cdr form)))))) + (setq form (cdr form)) + (byte-compile-form (car form)) + (byte-compile-push-constant 0) + (byte-compile-variable-ref 'byte-varref 'multiple-values-limit) + ;; bind-multiple-value-limits leaves two existing values on the stack, + ;; and pushes a new value, the specpdl_depth() at the time it was + ;; called. + (byte-compile-out 'byte-bind-multiple-value-limits 0) + (mapcar 'byte-compile-form (cdr form)) + ;; Most of the other code puts this sort of value in the program stream, + ;; not pushing it on the stack. + (byte-compile-push-constant (+ 3 (length form))) + (byte-compile-out 'byte-multiple-value-call (+ 3 (length form))) + (pushnew '(subrp (symbol-function 'multiple-value-call)) + byte-compile-checks-on-load + :test #'equal))) + +(defun byte-compile-multiple-value-list-internal (form) + (if (/= 4 (length form)) + (progn + (byte-compile-warn-wrong-args form 3) + (byte-compile-normal-call + `(signal 'wrong-number-of-arguments '(,(car form) + ,(length (cdr form)))))) + (byte-compile-form (nth 1 form)) + (byte-compile-form (nth 2 form)) + (byte-compile-out 'byte-bind-multiple-value-limits 0) + (byte-compile-form (nth 3 form)) + (byte-compile-out (get (car form) 'byte-opcode) 0) + (pushnew '(subrp (symbol-function 'multiple-value-call)) + byte-compile-checks-on-load + :test #'equal))) + +(defun byte-compile-throw (form) + ;; We can't use byte-compile-two-args for throw because in the event that + ;; the form does not have two args, it tries to #'funcall it expecting a + ;; runtime wrong-number-of-arguments error. Now that #'throw is a special + ;; form, it provokes an invalid-function error instead (or at least it + ;; should; there's a kludge around for the moment in eval.c that avoids + ;; that, but this file should not assume that that will always be there). + (if (/= 2 (length (cdr form))) + (progn + (byte-compile-warn-wrong-args form 2) + (byte-compile-normal-call + `(signal 'wrong-number-of-arguments '(,(car form) + ,(length (cdr form)))))) + (byte-compile-form (nth 1 form)) ;; Push the arguments + (byte-compile-form (nth 2 form)) + (byte-compile-out (get (car form) 'byte-opcode) 0) + (pushnew '(null (function-max-args 'throw)) + byte-compile-checks-on-load + :test #'equal))) ;;; top-level forms elsewhere @@ -4115,6 +4213,8 @@ ;; This is actually an unnecessary case, because there should be ;; no more opcodes behind byte-return. (setq byte-compile-depth nil)) + (byte-multiple-value-call + (setq byte-compile-depth (- byte-compile-depth offset))) (t (setq byte-compile-depth (+ byte-compile-depth (or (aref byte-stack+-info
--- a/lisp/cl-compat.el Sun Aug 16 14:58:57 2009 +0100 +++ b/lisp/cl-compat.el Sun Aug 16 20:55:49 2009 +0100 @@ -59,52 +59,10 @@ (defun keyword-of (sym) (or (keywordp sym) (keywordp (intern (format ":%s" sym))))) - -;;; Multiple values. Note that the new package uses a different -;;; convention for multiple values. The following definitions -;;; emulate the old convention; all function names have been changed -;;; by capitalizing the first letter: Values, Multiple-value-*, -;;; to avoid conflict with the new-style definitions in cl-macs. - -(put 'Multiple-value-bind 'lisp-indent-function 2) -(put 'Multiple-value-setq 'lisp-indent-function 2) -(put 'Multiple-value-call 'lisp-indent-function 1) -(put 'Multiple-value-prog1 'lisp-indent-function 1) - -(defvar *mvalues-values* nil) - -(defun Values (&rest val-forms) - (setq *mvalues-values* val-forms) - (car val-forms)) - -(defun Values-list (val-forms) - (apply 'values val-forms)) - -(defmacro Multiple-value-list (form) - (list 'let* (list '(*mvalues-values* nil) (list '*mvalues-temp* form)) - '(or (and (eq *mvalues-temp* (car *mvalues-values*)) *mvalues-values*) - (list *mvalues-temp*)))) - -(defmacro Multiple-value-call (function &rest args) - (list 'apply function - (cons 'append - (mapcar (function (lambda (x) (list 'Multiple-value-list x))) - args)))) - -(defmacro Multiple-value-bind (vars form &rest body) - (list* 'multiple-value-bind vars (list 'Multiple-value-list form) body)) - -(defmacro Multiple-value-setq (vars form) - (list 'multiple-value-setq vars (list 'Multiple-value-list form))) - -(defmacro Multiple-value-prog1 (form &rest body) - (list 'prog1 form (list* 'let '((*mvalues-values* nil)) body))) - - ;;; Routines for parsing keyword arguments. (defun build-klist (arglist keys &optional allow-others) - (let ((res (Multiple-value-call 'mapcar* 'cons (unzip-lists arglist)))) + (let ((res (multiple-value-call 'mapcar* 'cons (unzip-lists arglist)))) (or allow-others (let ((bad (set-difference (mapcar 'car res) keys))) (if bad (error "Bad keywords: %s not in %s" bad keys)))) @@ -124,25 +82,23 @@ (if test-not (not (funcall test-not item elt)) (funcall (or test 'eql) item elt)))) - ;;; Rounding functions with old-style multiple value returns. -(defun cl-floor (a &optional b) (Values-list (floor* a b))) -(defun cl-ceiling (a &optional b) (Values-list (ceiling* a b))) -(defun cl-round (a &optional b) (Values-list (round* a b))) -(defun cl-truncate (a &optional b) (Values-list (truncate* a b))) +(defun cl-floor (a &optional b) (values-list (floor* a b))) +(defun cl-ceiling (a &optional b) (values-list (ceiling* a b))) +(defun cl-round (a &optional b) (values-list (round* a b))) +(defun cl-truncate (a &optional b) (values-list (truncate* a b))) (defun safe-idiv (a b) (let* ((q (/ (abs a) (abs b))) (s (* (signum a) (signum b)))) - (Values q (- a (* s q b)) s))) - + (values q (- a (* s q b)) s))) ;; Internal routines. (defun pair-with-newsyms (oldforms) (let ((newsyms (mapcar (function (lambda (x) (gensym))) oldforms))) - (Values (mapcar* 'list newsyms oldforms) newsyms))) + (values (mapcar* 'list newsyms oldforms) newsyms))) (defun zip-lists (evens odds) (mapcan 'list evens odds)) @@ -151,7 +107,7 @@ (let ((e nil) (o nil)) (while list (setq e (cons (car list) e) o (cons (cadr list) o) list (cddr list))) - (Values (nreverse e) (nreverse o)))) + (values (nreverse e) (nreverse o)))) (defun reassemble-argslists (list) (let ((n (apply 'min (mapcar 'length list))) (res nil))
--- a/lisp/cl-macs.el Sun Aug 16 14:58:57 2009 +0100 +++ b/lisp/cl-macs.el Sun Aug 16 20:55:49 2009 +0100 @@ -715,24 +715,30 @@ (defvar cl-active-block-names nil) -(put 'cl-block-wrapper 'byte-compile 'cl-byte-compile-block) -(defun cl-byte-compile-block (cl-form) - (if (fboundp 'byte-compile-form-do-effect) ; Check for optimizing compiler - (progn - (let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil)) - (cl-active-block-names (cons cl-entry cl-active-block-names)) - (cl-body (byte-compile-top-level - (cons 'progn (cddr (nth 1 cl-form)))))) - (if (cdr cl-entry) - (byte-compile-form (list 'catch (nth 1 (nth 1 cl-form)) cl-body)) - (byte-compile-form cl-body)))) - (byte-compile-form (nth 1 cl-form)))) - -(put 'cl-block-throw 'byte-compile 'cl-byte-compile-throw) -(defun cl-byte-compile-throw (cl-form) - (let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names))) - (if cl-found (setcdr cl-found t))) - (byte-compile-normal-call (cons 'throw (cdr cl-form)))) +(put 'cl-block-wrapper 'byte-compile + #'(lambda (cl-form) + (if (/= (length cl-form) 2) + (byte-compile-warn-wrong-args cl-form 1)) + + (if (fboundp 'byte-compile-form-do-effect) ; Check for optimizing + ; compiler + (progn + (let* ((cl-entry (cons (nth 1 (nth 1 (nth 1 cl-form))) nil)) + (cl-active-block-names (cons cl-entry + cl-active-block-names)) + (cl-body (byte-compile-top-level + (cons 'progn (cddr (nth 1 cl-form)))))) + (if (cdr cl-entry) + (byte-compile-form (list 'catch (nth 1 (nth 1 cl-form)) + cl-body)) + (byte-compile-form cl-body)))) + (byte-compile-form (nth 1 cl-form))))) + +(put 'cl-block-throw 'byte-compile + #'(lambda (cl-form) + (let ((cl-found (assq (nth 1 (nth 1 cl-form)) cl-active-block-names))) + (if cl-found (setcdr cl-found t))) + (byte-compile-throw (cons 'throw (cdr cl-form))))) ;;;###autoload (defmacro return (&optional result) @@ -1841,47 +1847,70 @@ (list 'function (cons 'lambda rest))) (list 'quote func))) - -;;; Multiple values. +;;; Multiple values. We support full Common Lisp conventions here. ;;;###autoload -(defmacro multiple-value-bind (vars form &rest body) - "(multiple-value-bind (SYM SYM...) FORM BODY): collect multiple return values. -FORM must return a list; the BODY is then executed with the first N elements -of this list bound (`let'-style) to each of the symbols SYM in turn. This -is analogous to the Common Lisp `multiple-value-bind' macro, using lists to -simulate true multiple return values. For compatibility, (values A B C) is -a synonym for (list A B C)." - (let ((temp (gensym)) (n -1)) - (list* 'let* (cons (list temp form) - (mapcar #'(lambda (v) - (list v (list 'nth (setq n (1+ n)) temp))) - vars)) - body))) +(defmacro multiple-value-bind (syms form &rest body) + "Collect and bind multiple return values. + +If FORM returns multiple values, each symbol in SYMS is bound to one of +them, in order, and BODY is executed. If FORM returns fewer multiple values +than there are SYMS, remaining SYMS are bound to nil. If FORM does +not return multiple values, it is treated as returning one multiple value. + +Returns the value given by the last element of BODY." + (if (null syms) + `(progn ,form ,@body) + (if (= 1 (length syms)) + ;; Code written to deal with other "implementations" of multiple + ;; values may have a one-element SYMS. + `(let ((,(car syms) ,form)) + ,@body) + (let ((temp (gensym))) + `(let* ((,temp (multiple-value-list-internal 0 ,(length syms) ,form)) + ,@(loop + for var in syms + collect `(,var (prog1 (car ,temp) + (setq ,temp (cdr ,temp)))))) + ,@body))))) ;;;###autoload -(defmacro multiple-value-setq (vars form) - "(multiple-value-setq (SYM SYM...) FORM): collect multiple return values. -FORM must return a list; the first N elements of this list are stored in -each of the symbols SYM in turn. This is analogous to the Common Lisp -`multiple-value-setq' macro, using lists to simulate true multiple return -values. For compatibility, (values A B C) is a synonym for (list A B C)." - (cond ((null vars) (list 'progn form nil)) - ((null (cdr vars)) (list 'setq (car vars) (list 'car form))) - (t - (let* ((temp (gensym)) (n 0)) - (list 'let (list (list temp form)) - (list 'prog1 (list 'setq (pop vars) (list 'car temp)) - (cons 'setq - (apply 'nconc - (mapcar - #'(lambda (v) - (list v (list - 'nth - (setq n (1+ n)) - temp))) - vars))))))))) - +(defmacro multiple-value-setq (syms form) + "Collect and set multiple values. + +FORM should normally return multiple values; the first N values are stored +in the symbols in SYMS in turn. If FORM returns fewer than N values, the +remaining symbols have their values set to nil. FORM not returning multiple +values is treated as FORM returning one multiple value, with other elements +of SYMS initialized to nil. + +Returns the first of the multiple values given by FORM." + (if (null syms) + ;; Never return multiple values from multiple-value-setq: + (and form `(values ,form)) + (if (= 1 (length syms)) + `(setq ,(car syms) ,form) + (let ((temp (gensym))) + `(let* ((,temp (multiple-value-list-internal 0 ,(length syms) ,form))) + (setq ,@(loop + for sym in syms + nconc `(,sym (car-safe ,temp) + ,temp (cdr-safe ,temp)))) + ,(car syms)))))) + +;;;###autoload +(defmacro multiple-value-list (form) + "Evaluate FORM and return a list of the multiple values it returned." + `(multiple-value-list-internal 0 multiple-values-limit ,form)) + +;;;###autoload +(defmacro nth-value (n form) + "Evaluate FORM and return the Nth multiple value it returned." + (if (integerp n) + `(car (multiple-value-list-internal ,n ,(1+ n) ,form)) + (let ((temp (gensym))) + `(let ((,temp ,n)) + (car (multiple-value-list-internal ,temp (1+ ,temp) ,form)))))) ;;; Declarations. @@ -2346,8 +2375,9 @@ (store-temp (gensym "--values-store--"))) (list (apply 'append (mapcar 'first methods)) (apply 'append (mapcar 'second methods)) - (list store-temp) - (cons 'list + `((,store-temp + (multiple-value-list-internal 0 ,(if args (length args) 1)))) + (cons 'values (mapcar #'(lambda (m) (cl-setf-do-store (cons (car (third m)) (fourth m)) (list 'pop store-temp))) @@ -2410,11 +2440,25 @@ (defun cl-setf-do-store (spec val) (let ((sym (car spec)) (form (cdr spec))) - (if (or (cl-const-expr-p val) - (and (cl-simple-expr-p val) (eq (cl-expr-contains form sym) 1)) - (cl-setf-simple-store-p sym form)) - (subst val sym form) - (list 'let (list (list sym val)) form)))) + (if (consp sym) + ;; XEmacs change, only used for implementing #'values at the moment. + (let* ((orig (copy-list sym)) + (intermediate (last orig)) + (circular-limit 32)) + (while (consp (car intermediate)) + (when (zerop circular-limit) + (error 'circular-list "Form seems to contain loops")) + (setq intermediate (last (car intermediate)) + circular-limit (1- circular-limit))) + (setcdr intermediate (list val)) + `(let (,orig) + ,form)) + (if (or (cl-const-expr-p val) + (and (cl-simple-expr-p val) + (eq (cl-expr-contains form sym) 1)) + (cl-setf-simple-store-p sym form)) + (subst val sym form) + (list 'let (list (list sym val)) form))))) (defun cl-setf-simple-store-p (sym form) (and (consp form) (eq (cl-expr-contains form sym) 1)
--- a/lisp/cl.el Sun Aug 16 14:58:57 2009 +0100 +++ b/lisp/cl.el Sun Aug 16 20:55:49 2009 +0100 @@ -209,48 +209,24 @@ ;;; Blocks and exits. -(defalias 'cl-block-wrapper 'identity) +;; This used to be #'identity, but that didn't preserve multiple values in +;; interpreted code. #'and isn't great either, there's no error on too many +;; arguments passed to it when interpreted. Fortunately most of the places +;; where cl-block-wrapper is called are generated from old, established +;; macros, so too many arguments resulting from human error is unlikely; and +;; the byte compile handler in cl-macs.el warns if more than one arg is +;; passed to it. +(defalias 'cl-block-wrapper 'and) + (defalias 'cl-block-throw 'throw) - -;;; Multiple values. True multiple values are not supported, or even -;;; simulated. Instead, multiple-value-bind and friends simply expect -;;; the target form to return the values as a list. - -(defsubst values (&rest values) - "Return multiple values, Common Lisp style. -The arguments of `values' are the values -that the containing function should return." - values) - -(defsubst values-list (list) - "Return multiple values, Common Lisp style, taken from a list. -LIST specifies the list of values -that the containing function should return." - list) +;;; XEmacs; multiple values are in eval.c and cl-macs.el. -(defsubst multiple-value-list (expression) - "Return a list of the multiple values produced by EXPRESSION. -This handles multiple values in Common Lisp style, but it does not -work right when EXPRESSION calls an ordinary Emacs Lisp function -that returns just one value." - expression) +;;; We no longer support `multiple-value-apply', which was ill-conceived to +;;; start with, is not specified by Common Lisp, and which nothing uses, +;;; according to Google Code Search, as of Sat Mar 14 23:31:35 GMT 2009. -(defsubst multiple-value-apply (function expression) - "Evaluate EXPRESSION to get multiple values and apply FUNCTION to them. -This handles multiple values in Common Lisp style, but it does not work -right when EXPRESSION calls an ordinary Emacs Lisp function that returns just -one value." - (apply function expression)) - -(defalias 'multiple-value-call 'apply) ; only works for one arg - -(defsubst nth-value (n expression) - "Evaluate EXPRESSION to get multiple values and return the Nth one. -This handles multiple values in Common Lisp style, but it does not work -right when EXPRESSION calls an ordinary Emacs Lisp function that returns just -one value." - (nth n expression)) +(make-obsolete 'multiple-value-apply 'multiple-value-call) ;;; Macros.
--- a/lisp/lisp-mode.el Sun Aug 16 14:58:57 2009 +0100 +++ b/lisp/lisp-mode.el Sun Aug 16 20:55:49 2009 +0100 @@ -424,36 +424,55 @@ been treated noninteractively. The printed messages are \"defvar treated as defconst\" and \"defcustom - evaluation forced\". See `eval-interactive' for more details." +evaluation forced\". See `eval-interactive' for more details." :type 'boolean :group 'lisp) (defun eval-interactive (expr) - "Like `eval' except that it transforms defvars to defconsts. -The evaluation of defcustom forms is forced." + "Evaluate EXPR; pass back multiple values, transform defvars to defconsts. + +Always returns a list. The length of this list will be something other than +one if the form returned multiple values. It will be zero if the form +returned a single zero-length multiple value." (cond ((and (eq (car-safe expr) 'defvar) (> (length expr) 2)) - (eval (cons 'defconst (cdr expr))) + (setq expr (multiple-value-list (eval (cons 'defconst (cdr expr))))) (when eval-interactive-verbose (message "defvar treated as defconst") (sit-for 1) (message "")) - (nth 1 expr)) + expr) ((and (eq (car-safe expr) 'defcustom) (> (length expr) 2) (default-boundp (nth 1 expr))) ;; Force variable to be bound - ;; #### defcustom might specify a different :set method. - (set-default (nth 1 expr) (eval (nth 2 expr))) + (funcall + (or (plist-get expr :set) #'custom-set-default) + (nth 1 expr) (eval (nth 2 expr))) ;; And evaluate the defcustom - (eval expr) + (setq expr (multiple-value-list (eval expr))) (when eval-interactive-verbose (message "defcustom evaluation forced") (sit-for 1) (message "")) - (nth 1 expr)) + expr) (t - (eval expr)))) + (multiple-value-list (eval expr))))) + +(defun prin1-list-as-multiple-values (multiple-value-list &optional stream) + "Call `prin1' on each element of MULTIPLE-VALUE-LIST, separated by \" ;\\n\" + +If MULTIPLE-VALUE-LIST is zero-length, print the text +\"#<zero length multiple value> ;\\n\". Always returns nil." + (loop for value in multiple-value-list + with seen-first = nil + do + (if seen-first + (princ " ;\n" stream) + (setq seen-first t)) + (prin1 value stream) + finally (unless seen-first + (princ "#<zero length multiple value> ;" stream)))) ;; XEmacs change, based on Bob Weiner suggestion (defun eval-last-sexp (eval-last-sexp-arg-internal) ;dynamic scoping wonderment @@ -463,31 +482,32 @@ (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t)) (opoint (point)) ignore-quotes) - (prin1 (eval-interactive - (letf (((syntax-table) emacs-lisp-mode-syntax-table)) - (save-excursion - ;; If this sexp appears to be enclosed in `...' then - ;; ignore the surrounding quotes. - (setq ignore-quotes (or (eq (char-after) ?\') - (eq (char-before) ?\'))) - (forward-sexp -1) - ;; vladimir@cs.ualberta.ca 30-Jul-1997: skip ` in - ;; `variable' so that the value is returned, not the - ;; name. - (if (and ignore-quotes - (eq (char-after) ?\`)) - (forward-char)) - (save-restriction - (narrow-to-region (point-min) opoint) - (let ((expr (read (current-buffer)))) - (if (eq (car-safe expr) 'interactive) - ;; If it's an (interactive ...) form, it's - ;; more useful to show how an interactive call - ;; would use it. - `(call-interactively - (lambda (&rest args) - ,expr args)) - expr))))))))) + (prin1-list-as-multiple-values + (eval-interactive + (letf (((syntax-table) emacs-lisp-mode-syntax-table)) + (save-excursion + ;; If this sexp appears to be enclosed in `...' then + ;; ignore the surrounding quotes. + (setq ignore-quotes (or (eq (char-after) ?\') + (eq (char-before) ?\'))) + (forward-sexp -1) + ;; vladimir@cs.ualberta.ca 30-Jul-1997: skip ` in + ;; `variable' so that the value is returned, not the + ;; name. + (if (and ignore-quotes + (eq (char-after) ?\`)) + (forward-char)) + (save-restriction + (narrow-to-region (point-min) opoint) + (let ((expr (read (current-buffer)))) + (if (eq (car-safe expr) 'interactive) + ;; If it's an (interactive ...) form, it's + ;; more useful to show how an interactive call + ;; would use it. + `(call-interactively + (lambda (&rest args) + ,expr args)) + expr))))))))) (defun eval-defun (eval-defun-arg-internal) "Evaluate defun that point is in or before. @@ -495,11 +515,12 @@ With argument, insert value in current buffer after the defun." (interactive "P") (let ((standard-output (if eval-defun-arg-internal (current-buffer) t))) - (prin1 (eval-interactive (save-excursion - (end-of-defun) - (beginning-of-defun) - (read (current-buffer))))))) - + (prin1-list-as-multiple-values + (eval-interactive + (save-excursion + (end-of-defun) + (beginning-of-defun) + (read (current-buffer))))))) (defun lisp-comment-indent () (if (looking-at "\\s<\\s<\\s<")
--- a/lisp/mouse.el Sun Aug 16 14:58:57 2009 +0100 +++ b/lisp/mouse.el Sun Aug 16 20:55:49 2009 +0100 @@ -278,18 +278,23 @@ (message "Regex \"%s\" not found" exp) (ding nil 'quiet))) (t (setq val (if (fboundp 'eval-interactive) - (eval-interactive exp) - (eval exp))))) - (setq result-str (prin1-to-string val)) + (eval-interactive exp) + (list (eval exp)))))) + (setq result-str (mapconcat #'prin1-to-string val " ;\n")) ;; #### -- need better test (if (and (not force-window) - (<= (length result-str) (window-width (selected-window)))) + (<= (length result-str) (window-width (selected-window))) + (not (string-match "\n" result-str))) (message "%s" result-str) (with-output-to-temp-buffer "*Mouse-Eval*" - (if-fboundp 'pprint - (pprint val) - (prin1 val))) - ))) + (loop + for value in val + with seen-first = nil + do + (if seen-first + (princ " ;\n") + (setq seen-first t)) + (cl-prettyprint value)))))) (defun mouse-line-length (event) "Print the length of the line indicated by the pointer."
--- a/lisp/obsolete.el Sun Aug 16 14:58:57 2009 +0100 +++ b/lisp/obsolete.el Sun Aug 16 20:55:49 2009 +0100 @@ -395,5 +395,18 @@ (make-obsolete 'function-called-at-point 'function-at-point) +;; As of 21.5, #'throw is a special form. This makes bytecode using it +;; compiled for 21.4 fail; making this function available works around that. +(defun obsolete-throw (tag value) + "Ugly compatibility hack. + +See the implementation of #'funcall in eval.c. This should be removed once +we no longer encounter bytecode from 21.4." + (throw tag value)) + +(make-obsolete + 'obsolete-throw + "it says `obsolete' in the name, you know you shouldn't be using this.") + (provide 'obsolete) ;;; obsolete.el ends here
--- a/man/ChangeLog Sun Aug 16 14:58:57 2009 +0100 +++ b/man/ChangeLog Sun Aug 16 20:55:49 2009 +0100 @@ -1,3 +1,8 @@ +2009-08-11 Aidan Kehoe <kehoea@parhasard.net> + + * cl.texi (Organization): + Remove references to the obsolete multiple-value emulating code. + 2009-07-28 Stephen Turnbull <stephen@xemacs.org> * internals/internals.texi (Redisplay Piece by Piece):
--- a/man/cl.texi Sun Aug 16 14:58:57 2009 +0100 +++ b/man/cl.texi Sun Aug 16 20:55:49 2009 +0100 @@ -249,9 +249,8 @@ There is another file, @file{cl-compat.el}, which defines some routines from the older @file{cl.el} package that are no longer present in the new package. This includes internal routines -like @code{setelt} and @code{zip-lists}, deprecated features -like @code{defkeyword}, and an emulation of the old-style -multiple-values feature. @xref{Old CL Compatibility}. +like @code{setelt} and @code{zip-lists}, and deprecated features +like @code{defkeyword}. @xref{Old CL Compatibility}. @node Installation, Naming Conventions, Organization, Overview @section Installation @@ -5345,14 +5344,6 @@ The @code{loop} macro is complete except that @code{loop-finish} and type specifiers are unimplemented. -The multiple-value return facility treats lists as multiple -values, since Emacs Lisp cannot support multiple return values -directly. The macros will be compatible with Common Lisp if -@code{values} or @code{values-list} is always used to return to -a @code{multiple-value-bind} or other multiple-value receiver; -if @code{values} is used without @code{multiple-value-@dots{}} -or vice-versa the effect will be different from Common Lisp. - Many Common Lisp declarations are ignored, and others match the Common Lisp standard in concept but not in detail. For example, local @code{special} declarations, which are purely @@ -5377,14 +5368,6 @@ Following is a list of all known incompatibilities between this package and the older Quiroz @file{cl.el} package. -This package's emulation of multiple return values in functions is -incompatible with that of the older package. That package attempted -to come as close as possible to true Common Lisp multiple return -values; unfortunately, it could not be 100% reliable and so was prone -to occasional surprises if used freely. This package uses a simpler -method, namely replacing multiple values with lists of values, which -is more predictable though more noticeably different from Common Lisp. - The @code{defkeyword} form and @code{keywordp} function are not implemented in this package. @@ -5449,19 +5432,6 @@ use the more natural keyword argument processing offered by @code{defun*}. -Multiple return values are treated differently by the two -Common Lisp packages. The old package's method was more -compatible with true Common Lisp, though it used heuristics -that caused it to report spurious multiple return values in -certain cases. The @code{cl-compat} package defines a set -of multiple-value macros that are compatible with the old -CL package; again, they are heuristic in nature, but they -are guaranteed to work in any case where the old package's -macros worked. To avoid name collision with the ``official'' -multiple-value facilities, the ones in @code{cl-compat} have -capitalized names: @code{Values}, @code{Values-list}, -@code{Multiple-value-bind}, etc. - The functions @code{cl-floor}, @code{cl-ceiling}, @code{cl-truncate}, and @code{cl-round} are defined by @code{cl-compat} to use the old-style multiple-value mechanism, just as they did in the old
--- a/src/ChangeLog Sun Aug 16 14:58:57 2009 +0100 +++ b/src/ChangeLog Sun Aug 16 20:55:49 2009 +0100 @@ -1,3 +1,118 @@ +2009-08-11 Aidan Kehoe <kehoea@parhasard.net> + + * bytecode.c (enum Opcode /* Byte codes */): + Add four new bytecodes, to deal with multiple values. + (POP_WITH_MULTIPLE_VALUES): New macro. + (POP): Modify this macro to ignore multiple values. + (DISCARD_PRESERVING_MULTIPLE_VALUES): New macro. + (DISCARD): Modify this macro to ignore multiple values. + (TOP_WITH_MULTIPLE_VALUES): New macro. + (TOP_ADDRESS): New macro. + (TOP): Modify this macro to ignore multiple values. + (TOP_LVALUE): New macro. + (Bcall): Ignore multiple values where appropriate. + (Breturn): Pass back multiple values. + (Bdup): Preserve multiple values. + Use TOP_LVALUE with most bytecodes that assign anything to + anything. + (Bbind_multiple_value_limits, Bmultiple_value_call, + Bmultiple_value_list_internal, Bthrow): Implement the new + bytecodes. + (Bgotoifnilelsepop, Bgotoifnonnilelsepop, BRgotoifnilelsepop, + BRgotoifnonnilelsepop): + Discard any multiple values. + * callint.c (Fcall_interactively): + Ignore multiple values when calling #'eval, in two places. + * device-x.c (x_IO_error_handler): + * macros.c (pop_kbd_macro_event): + * eval.c (Fsignal): + * eval.c (flagged_a_squirmer): + Call throw_or_bomb_out, not Fthrow, now that the latter is a + special form. + * eval.c: + Make Qthrow, Qobsolete_throw available as symbols. + Provide multiple_value_current_limit, multiple-values-limit (the + latter as specified by Common Lisp. + * eval.c (For): + Ignore multiple values when comparing with Qnil, but pass any + multiple values back for the last arg. + * eval.c (Fand): + Ditto. + * eval.c (Fif): + Ignore multiple values when examining the result of the + condition. + * eval.c (Fcond): + Ignore multiple values when comparing what the clauses give, but + pass them back if a clause gave non-nil. + * eval.c (Fprog2): + Never pass back multiple values. + * eval.c (FletX, Flet): + Ignore multiple when evaluating what exactly symbols should be + bound to. + * eval.c (Fwhile): + Ignore multiple values when evaluating the test. + * eval.c (Fsetq, Fdefvar, Fdefconst): + Ignore multiple values. + * eval.c (Fthrow): + Declare this as a special form; ignore multiple values for TAG, + preserve them for VALUE. + * eval.c (throw_or_bomb_out): + Make this available to other files, now Fthrow is a special form. + * eval.c (Feval): + Ignore multiple values when calling a compiled function, a + non-special-form subr, or a lambda expression. + * eval.c (Ffuncall): + If we attempt to call #'throw (now a special form) as a function, + don't error, call #'obsolete-throw instead. + * eval.c (make_multiple_value, multiple_value_aset) + (multiple_value_aref, print_multiple_value, mark_multiple_value) + (size_multiple_value): + Implement the multiple_value type. Add a long comment describing + our implementation. + * eval.c (bind_multiple_value_limits): + New function, used by the bytecode and by #'multiple-value-call, + #'multiple-value-list-internal. + * eval.c (multiple_value_call): + New function, used by the bytecode and #'multiple-value-call. + * eval.c (Fmultiple_value_call): + New special form. + * eval.c (multiple_value_list_internal): + New function, used by the byte code and + #'multiple-value-list-internal. + * eval.c (Fmultiple_value_list_internal, Fmultiple_value_prog1): + New special forms. + * eval.c (Fvalues, Fvalues_list): + New Lisp functions. + * eval.c (values2): + New function, for C code returning multiple values. + * eval.c (syms_of_eval): + Make our new Lisp functions and symbols available. + * eval.c (multiple-values-limit): + Make this available to Lisp. + * event-msw.c (dde_eval_string): + * event-stream.c (execute_help_form): + * glade.c (connector): + * glyphs-widget.c (glyph_instantiator_to_glyph): + * glyphs.c (evaluate_xpm_color_symbols): + * gui-x.c (wv_set_evalable_slot, button_item_to_widget_value): + * gui.c (gui_item_value, gui_item_display_flush_left): + * lread.c (check_if_suppressed): + * menubar-gtk.c (menu_convert, menu_descriptor_to_widget_1): + * menubar-msw.c (populate_menu_add_item): + * print.c (Fwith_output_to_temp_buffer): + * symbols.c (Fsetq_default): + Ignore multiple values when calling Feval. + * symeval.h: + Add the header declarations necessary for the multiple-values + implementation. + * inline.c: + #include symeval.h, now that it has some inline functions. + * lisp.h: + Update Fthrow's declaration. Make throw_or_bomb_out available to + all files. + * lrecord.h (enum lrecord_type): + Add the multiple_value type here. + 2009-07-28 Stephen Turnbull <stephen@xemacs.org> * faces.c (ensure_face_cachel_contains_charset):
--- a/src/bytecode.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/bytecode.c Sun Aug 16 20:55:49 2009 +0100 @@ -243,6 +243,12 @@ BlistN = 0257, BconcatN = 0260, BinsertN = 0261, + + Bbind_multiple_value_limits = 0262, /* New in 21.5. */ + Bmultiple_value_list_internal = 0263, /* New in 21.5. */ + Bmultiple_value_call = 0264, /* New in 21.5. */ + Bthrow = 0265, /* New in 21.5. */ + Bmember = 0266, /* new in v20 */ Bassq = 0267, /* new in v20 */ @@ -653,15 +659,44 @@ /* Push x onto the execution stack. */ #define PUSH(x) (*++stack_ptr = (x)) -/* Pop a value off the execution stack. */ -#define POP (*stack_ptr--) +/* Pop a value, which may be multiple, off the execution stack. */ +#define POP_WITH_MULTIPLE_VALUES (*stack_ptr--) + +/* Pop a value off the execution stack, treating multiple values as single. */ +#define POP (IGNORE_MULTIPLE_VALUES (POP_WITH_MULTIPLE_VALUES)) + +#define DISCARD_PRESERVING_MULTIPLE_VALUES(n) (stack_ptr -= (n)) /* Discard n values from the execution stack. */ -#define DISCARD(n) (stack_ptr -= (n)) +#define DISCARD(n) do { \ + if (1 != multiple_value_current_limit) \ + { \ + int i, en = n; \ + for (i = 0; i < en; i++) \ + { \ + *stack_ptr = ignore_multiple_values (*stack_ptr); \ + stack_ptr--; \ + } \ + } \ + else \ + { \ + stack_ptr -= (n); \ + } \ + } while (0) + +/* Get the value, which may be multiple, at the top of the execution stack; + and leave it there. */ +#define TOP_WITH_MULTIPLE_VALUES (*stack_ptr) + +#define TOP_ADDRESS (stack_ptr) /* Get the value which is at the top of the execution stack, but don't pop it. */ -#define TOP (*stack_ptr) +#define TOP (IGNORE_MULTIPLE_VALUES (TOP_WITH_MULTIPLE_VALUES)) + +#define TOP_LVALUE (*stack_ptr) + + /* See comment before the big switch in execute_optimized_program(). */ #define GCPRO_STACK (gcpro1.nvars = stack_ptr - stack_beg) @@ -859,7 +894,8 @@ Fput (TOP, Qbyte_code_meter, make_int (XINT (val) + 1)); } #endif - TOP = Ffuncall (n + 1, &TOP); + TOP_LVALUE = TOP; /* Ignore multiple values. */ + TOP_LVALUE = Ffuncall (n + 1, TOP_ADDRESS); break; case Bunbind: @@ -895,7 +931,8 @@ break; case Bgotoifnilelsepop: - if (NILP (TOP)) + /* Discard any multiple value: */ + if (NILP (TOP_LVALUE = TOP)) JUMP; else { @@ -905,7 +942,8 @@ break; case Bgotoifnonnilelsepop: - if (!NILP (TOP)) + /* Discard any multiple value: */ + if (!NILP (TOP_LVALUE = TOP)) JUMP; else { @@ -934,7 +972,7 @@ break; case BRgotoifnilelsepop: - if (NILP (TOP)) + if (NILP (TOP_LVALUE = TOP)) JUMPR; else { @@ -944,7 +982,7 @@ break; case BRgotoifnonnilelsepop: - if (!NILP (TOP)) + if (!NILP (TOP_LVALUE = TOP)) JUMPR; else { @@ -960,7 +998,7 @@ if (specpdl_depth() != speccount) invalid_byte_code ("unbalanced specbinding stack", Qunbound); #endif - return TOP; + return TOP_WITH_MULTIPLE_VALUES; case Bdiscard: DISCARD (1); @@ -968,7 +1006,7 @@ case Bdup: { - Lisp_Object arg = TOP; + Lisp_Object arg = TOP_WITH_MULTIPLE_VALUES; PUSH (arg); break; } @@ -978,17 +1016,22 @@ break; case Bcar: - /* Fcar can GC via wrong_type_argument. */ - /* GCPRO_STACK; */ - TOP = CONSP (TOP) ? XCAR (TOP) : Fcar (TOP); - break; + { + /* Fcar can GC via wrong_type_argument. */ + /* GCPRO_STACK; */ + Lisp_Object arg = TOP; + TOP_LVALUE = CONSP (arg) ? XCAR (arg) : Fcar (arg); + break; + } case Bcdr: - /* Fcdr can GC via wrong_type_argument. */ - /* GCPRO_STACK; */ - TOP = CONSP (TOP) ? XCDR (TOP) : Fcdr (TOP); - break; - + { + /* Fcdr can GC via wrong_type_argument. */ + /* GCPRO_STACK; */ + Lisp_Object arg = TOP; + TOP_LVALUE = CONSP (arg) ? XCDR (arg) : Fcdr (arg); + break; + } case Bunbind_all: /* To unbind back to the beginning of this frame. Not used yet, @@ -1001,62 +1044,62 @@ Lisp_Object arg = POP; /* Fcar and Fnthcdr can GC via wrong_type_argument. */ /* GCPRO_STACK; */ - TOP = Fcar (Fnthcdr (TOP, arg)); + TOP_LVALUE = Fcar (Fnthcdr (TOP, arg)); break; } case Bsymbolp: - TOP = SYMBOLP (TOP) ? Qt : Qnil; + TOP_LVALUE = SYMBOLP (TOP) ? Qt : Qnil; break; case Bconsp: - TOP = CONSP (TOP) ? Qt : Qnil; + TOP_LVALUE = CONSP (TOP) ? Qt : Qnil; break; case Bstringp: - TOP = STRINGP (TOP) ? Qt : Qnil; + TOP_LVALUE = STRINGP (TOP) ? Qt : Qnil; break; case Blistp: - TOP = LISTP (TOP) ? Qt : Qnil; + TOP_LVALUE = LISTP (TOP) ? Qt : Qnil; break; case Bnumberp: #ifdef WITH_NUMBER_TYPES - TOP = NUMBERP (TOP) ? Qt : Qnil; + TOP_LVALUE = NUMBERP (TOP) ? Qt : Qnil; #else - TOP = INT_OR_FLOATP (TOP) ? Qt : Qnil; + TOP_LVALUE = INT_OR_FLOATP (TOP) ? Qt : Qnil; #endif break; case Bintegerp: #ifdef HAVE_BIGNUM - TOP = INTEGERP (TOP) ? Qt : Qnil; + TOP_LVALUE = INTEGERP (TOP) ? Qt : Qnil; #else - TOP = INTP (TOP) ? Qt : Qnil; + TOP_LVALUE = INTP (TOP) ? Qt : Qnil; #endif break; case Beq: { Lisp_Object arg = POP; - TOP = EQ_WITH_EBOLA_NOTICE (TOP, arg) ? Qt : Qnil; + TOP_LVALUE = EQ_WITH_EBOLA_NOTICE (TOP, arg) ? Qt : Qnil; break; } case Bnot: - TOP = NILP (TOP) ? Qt : Qnil; + TOP_LVALUE = NILP (TOP) ? Qt : Qnil; break; case Bcons: { Lisp_Object arg = POP; - TOP = Fcons (TOP, arg); + TOP_LVALUE = Fcons (TOP, arg); break; } case Blist1: - TOP = Fcons (TOP, Qnil); + TOP_LVALUE = Fcons (TOP, Qnil); break; @@ -1079,7 +1122,7 @@ DISCARD (1); goto list_loop; } - TOP = list; + TOP_LVALUE = list; break; } @@ -1097,101 +1140,107 @@ DISCARD (n - 1); /* Apparently `concat' can GC; Fconcat GCPROs its arguments. */ /* GCPRO_STACK; */ - TOP = Fconcat (n, &TOP); + TOP_LVALUE = TOP; /* Ignore multiple values. */ + TOP_LVALUE = Fconcat (n, TOP_ADDRESS); break; case Blength: - TOP = Flength (TOP); + TOP_LVALUE = Flength (TOP); break; case Baset: { Lisp_Object arg2 = POP; Lisp_Object arg1 = POP; - TOP = Faset (TOP, arg1, arg2); + TOP_LVALUE = Faset (TOP, arg1, arg2); break; } case Bsymbol_value: /* Why does this need GCPRO_STACK? If not, remove others, too. */ /* GCPRO_STACK; */ - TOP = Fsymbol_value (TOP); + TOP_LVALUE = Fsymbol_value (TOP); break; case Bsymbol_function: - TOP = Fsymbol_function (TOP); + TOP_LVALUE = Fsymbol_function (TOP); break; case Bget: { Lisp_Object arg = POP; - TOP = Fget (TOP, arg, Qnil); + TOP_LVALUE = Fget (TOP, arg, Qnil); break; } case Bsub1: + { #ifdef HAVE_BIGNUM - TOP = Fsub1 (TOP); + TOP_LVALUE = Fsub1 (TOP); #else - TOP = INTP (TOP) ? INT_MINUS1 (TOP) : Fsub1 (TOP); + Lisp_Object arg = TOP; + TOP_LVALUE = INTP (arg) ? INT_MINUS1 (arg) : Fsub1 (arg); #endif break; - + } case Badd1: + { #ifdef HAVE_BIGNUM - TOP = Fadd1 (TOP); + TOP_LVALUE = Fadd1 (TOP); #else - TOP = INTP (TOP) ? INT_PLUS1 (TOP) : Fadd1 (TOP); + Lisp_Object arg = TOP; + TOP_LVALUE = INTP (arg) ? INT_PLUS1 (arg) : Fadd1 (arg); #endif break; - + } case Beqlsign: { Lisp_Object arg = POP; - TOP = bytecode_arithcompare (TOP, arg) == 0 ? Qt : Qnil; + TOP_LVALUE = bytecode_arithcompare (TOP, arg) == 0 ? Qt : Qnil; break; } case Bgtr: { Lisp_Object arg = POP; - TOP = bytecode_arithcompare (TOP, arg) > 0 ? Qt : Qnil; + TOP_LVALUE = bytecode_arithcompare (TOP, arg) > 0 ? Qt : Qnil; break; } case Blss: { Lisp_Object arg = POP; - TOP = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil; + TOP_LVALUE = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil; break; } case Bleq: { Lisp_Object arg = POP; - TOP = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil; + TOP_LVALUE = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil; break; } case Bgeq: { Lisp_Object arg = POP; - TOP = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil; + TOP_LVALUE = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil; break; } case Bnegate: - TOP = bytecode_negate (TOP); + TOP_LVALUE = bytecode_negate (TOP); break; case Bnconc: DISCARD (1); /* nconc2 GCPROs before calling this. */ /* GCPRO_STACK; */ - TOP = bytecode_nconc2 (&TOP); + TOP_LVALUE = TOP; /* Ignore multiple values. */ + TOP_LVALUE = bytecode_nconc2 (TOP_ADDRESS); break; case Bplus: @@ -1199,9 +1248,9 @@ Lisp_Object arg2 = POP; Lisp_Object arg1 = TOP; #ifdef HAVE_BIGNUM - TOP = bytecode_arithop (arg1, arg2, opcode); + TOP_LVALUE = bytecode_arithop (arg1, arg2, opcode); #else - TOP = INTP (arg1) && INTP (arg2) ? + TOP_LVALUE = INTP (arg1) && INTP (arg2) ? INT_PLUS (arg1, arg2) : bytecode_arithop (arg1, arg2, opcode); #endif @@ -1213,9 +1262,9 @@ Lisp_Object arg2 = POP; Lisp_Object arg1 = TOP; #ifdef HAVE_BIGNUM - TOP = bytecode_arithop (arg1, arg2, opcode); + TOP_LVALUE = bytecode_arithop (arg1, arg2, opcode); #else - TOP = INTP (arg1) && INTP (arg2) ? + TOP_LVALUE = INTP (arg1) && INTP (arg2) ? INT_MINUS (arg1, arg2) : bytecode_arithop (arg1, arg2, opcode); #endif @@ -1228,7 +1277,7 @@ case Bmin: { Lisp_Object arg = POP; - TOP = bytecode_arithop (TOP, arg, opcode); + TOP_LVALUE = bytecode_arithop (TOP, arg, opcode); break; } @@ -1239,7 +1288,8 @@ case Binsert: /* Says it can GC. */ /* GCPRO_STACK; */ - TOP = Finsert (1, &TOP); + TOP_LVALUE = TOP; /* Ignore multiple values. */ + TOP_LVALUE = Finsert (1, TOP_ADDRESS); break; case BinsertN: @@ -1247,20 +1297,21 @@ DISCARD (n - 1); /* See Binsert. */ /* GCPRO_STACK; */ - TOP = Finsert (n, &TOP); + TOP_LVALUE = TOP; /* Ignore multiple values. */ + TOP_LVALUE = Finsert (n, TOP_ADDRESS); break; case Baref: { Lisp_Object arg = POP; - TOP = Faref (TOP, arg); + TOP_LVALUE = Faref (TOP, arg); break; } case Bmemq: { Lisp_Object arg = POP; - TOP = Fmemq (TOP, arg); + TOP_LVALUE = Fmemq (TOP, arg); break; } @@ -1269,7 +1320,7 @@ Lisp_Object arg = POP; /* Fset may call magic handlers */ /* GCPRO_STACK; */ - TOP = Fset (TOP, arg); + TOP_LVALUE = Fset (TOP, arg); break; } @@ -1278,21 +1329,21 @@ Lisp_Object arg = POP; /* Can QUIT, so can GC, right? */ /* GCPRO_STACK; */ - TOP = Fequal (TOP, arg); + TOP_LVALUE = Fequal (TOP, arg); break; } case Bnthcdr: { Lisp_Object arg = POP; - TOP = Fnthcdr (TOP, arg); + TOP_LVALUE = Fnthcdr (TOP, arg); break; } case Belt: { Lisp_Object arg = POP; - TOP = Felt (TOP, arg); + TOP_LVALUE = Felt (TOP, arg); break; } @@ -1301,12 +1352,12 @@ Lisp_Object arg = POP; /* Can QUIT, so can GC, right? */ /* GCPRO_STACK; */ - TOP = Fmember (TOP, arg); + TOP_LVALUE = Fmember (TOP, arg); break; } case Bgoto_char: - TOP = Fgoto_char (TOP, Qnil); + TOP_LVALUE = Fgoto_char (TOP, Qnil); break; case Bcurrent_buffer: @@ -1321,7 +1372,7 @@ /* #### WAG: set-buffer may cause Fset's of buffer locals Didn't prevent crash. :-( */ /* GCPRO_STACK; */ - TOP = Fset_buffer (TOP); + TOP_LVALUE = Fset_buffer (TOP); break; case Bpoint_max: @@ -1337,41 +1388,41 @@ Lisp_Object arg = POP; /* Can QUIT, so can GC, right? */ /* GCPRO_STACK; */ - TOP = Fskip_chars_forward (TOP, arg, Qnil); + TOP_LVALUE = Fskip_chars_forward (TOP, arg, Qnil); break; } case Bassq: { Lisp_Object arg = POP; - TOP = Fassq (TOP, arg); + TOP_LVALUE = Fassq (TOP, arg); break; } case Bsetcar: { Lisp_Object arg = POP; - TOP = Fsetcar (TOP, arg); + TOP_LVALUE = Fsetcar (TOP, arg); break; } case Bsetcdr: { Lisp_Object arg = POP; - TOP = Fsetcdr (TOP, arg); + TOP_LVALUE = Fsetcdr (TOP, arg); break; } case Bnreverse: - TOP = bytecode_nreverse (TOP); + TOP_LVALUE = bytecode_nreverse (TOP); break; case Bcar_safe: - TOP = CONSP (TOP) ? XCAR (TOP) : Qnil; + TOP_LVALUE = CONSP (TOP) ? XCAR (TOP) : Qnil; break; case Bcdr_safe: - TOP = CONSP (TOP) ? XCDR (TOP) : Qnil; + TOP_LVALUE = CONSP (TOP) ? XCDR (TOP) : Qnil; break; } @@ -1390,6 +1441,8 @@ const Opbyte *UNUSED (program_ptr), Opcode opcode) { + REGISTER int n; + switch (opcode) { @@ -1403,7 +1456,7 @@ int count = specpdl_depth (); record_unwind_protect (save_window_excursion_unwind, call1 (Qcurrent_window_configuration, Qnil)); - TOP = Fprogn (TOP); + TOP_LVALUE = Fprogn (TOP); unbind_to (count); break; } @@ -1416,14 +1469,14 @@ case Bcatch: { Lisp_Object arg = POP; - TOP = internal_catch (TOP, Feval, arg, 0, 0, 0); + TOP_LVALUE = internal_catch (TOP, Feval, arg, 0, 0, 0); break; } case Bskip_chars_backward: { Lisp_Object arg = POP; - TOP = Fskip_chars_backward (TOP, arg, Qnil); + TOP_LVALUE = Fskip_chars_backward (TOP, arg, Qnil); break; } @@ -1435,7 +1488,7 @@ { Lisp_Object arg2 = POP; /* handlers */ Lisp_Object arg1 = POP; /* bodyform */ - TOP = condition_case_3 (arg1, TOP, arg2); + TOP_LVALUE = condition_case_3 (arg1, TOP, arg2); break; } @@ -1443,51 +1496,51 @@ { Lisp_Object arg2 = POP; Lisp_Object arg1 = POP; - TOP = Fset_marker (TOP, arg1, arg2); + TOP_LVALUE = Fset_marker (TOP, arg1, arg2); break; } case Brem: { Lisp_Object arg = POP; - TOP = Frem (TOP, arg); + TOP_LVALUE = Frem (TOP, arg); break; } case Bmatch_beginning: - TOP = Fmatch_beginning (TOP); + TOP_LVALUE = Fmatch_beginning (TOP); break; case Bmatch_end: - TOP = Fmatch_end (TOP); + TOP_LVALUE = Fmatch_end (TOP); break; case Bupcase: - TOP = Fupcase (TOP, Qnil); + TOP_LVALUE = Fupcase (TOP, Qnil); break; case Bdowncase: - TOP = Fdowncase (TOP, Qnil); + TOP_LVALUE = Fdowncase (TOP, Qnil); break; case Bfset: { Lisp_Object arg = POP; - TOP = Ffset (TOP, arg); + TOP_LVALUE = Ffset (TOP, arg); break; } case Bstring_equal: { Lisp_Object arg = POP; - TOP = Fstring_equal (TOP, arg); + TOP_LVALUE = Fstring_equal (TOP, arg); break; } case Bstring_lessp: { Lisp_Object arg = POP; - TOP = Fstring_lessp (TOP, arg); + TOP_LVALUE = Fstring_lessp (TOP, arg); break; } @@ -1495,7 +1548,7 @@ { Lisp_Object arg2 = POP; Lisp_Object arg1 = POP; - TOP = Fsubstring (TOP, arg1, arg2); + TOP_LVALUE = Fsubstring (TOP, arg1, arg2); break; } @@ -1504,11 +1557,11 @@ break; case Bchar_after: - TOP = Fchar_after (TOP, Qnil); + TOP_LVALUE = Fchar_after (TOP, Qnil); break; case Bindent_to: - TOP = Findent_to (TOP, Qnil, Qnil); + TOP_LVALUE = Findent_to (TOP, Qnil, Qnil); break; case Bwiden: @@ -1549,56 +1602,56 @@ break; case Bforward_char: - TOP = Fforward_char (TOP, Qnil); + TOP_LVALUE = Fforward_char (TOP, Qnil); break; case Bforward_word: - TOP = Fforward_word (TOP, Qnil); + TOP_LVALUE = Fforward_word (TOP, Qnil); break; case Bforward_line: - TOP = Fforward_line (TOP, Qnil); + TOP_LVALUE = Fforward_line (TOP, Qnil); break; case Bchar_syntax: - TOP = Fchar_syntax (TOP, Qnil); + TOP_LVALUE = Fchar_syntax (TOP, Qnil); break; case Bbuffer_substring: { Lisp_Object arg = POP; - TOP = Fbuffer_substring (TOP, arg, Qnil); + TOP_LVALUE = Fbuffer_substring (TOP, arg, Qnil); break; } case Bdelete_region: { Lisp_Object arg = POP; - TOP = Fdelete_region (TOP, arg, Qnil); + TOP_LVALUE = Fdelete_region (TOP, arg, Qnil); break; } case Bnarrow_to_region: { Lisp_Object arg = POP; - TOP = Fnarrow_to_region (TOP, arg, Qnil); + TOP_LVALUE = Fnarrow_to_region (TOP, arg, Qnil); break; } case Bend_of_line: - TOP = Fend_of_line (TOP, Qnil); + TOP_LVALUE = Fend_of_line (TOP, Qnil); break; case Btemp_output_buffer_setup: temp_output_buffer_setup (TOP); - TOP = Vstandard_output; + TOP_LVALUE = Vstandard_output; break; case Btemp_output_buffer_show: { Lisp_Object arg = POP; temp_output_buffer_show (TOP, Qnil); - TOP = arg; + TOP_LVALUE = arg; /* GAG ME!! */ /* pop binding of standard-output */ unbind_to (specpdl_depth() - 1); @@ -1608,38 +1661,78 @@ case Bold_eq: { Lisp_Object arg = POP; - TOP = HACKEQ_UNSAFE (TOP, arg) ? Qt : Qnil; + TOP_LVALUE = HACKEQ_UNSAFE (TOP, arg) ? Qt : Qnil; break; } case Bold_memq: { Lisp_Object arg = POP; - TOP = Fold_memq (TOP, arg); + TOP_LVALUE = Fold_memq (TOP, arg); break; } case Bold_equal: { Lisp_Object arg = POP; - TOP = Fold_equal (TOP, arg); + TOP_LVALUE = Fold_equal (TOP, arg); break; } case Bold_member: { Lisp_Object arg = POP; - TOP = Fold_member (TOP, arg); + TOP_LVALUE = Fold_member (TOP, arg); break; } case Bold_assq: { Lisp_Object arg = POP; - TOP = Fold_assq (TOP, arg); + TOP_LVALUE = Fold_assq (TOP, arg); break; } + case Bbind_multiple_value_limits: + { + Lisp_Object upper = POP, first = TOP, speccount; + + CHECK_NATNUM (upper); + CHECK_NATNUM (first); + + speccount = make_int (bind_multiple_value_limits (XINT (first), + XINT (upper))); + PUSH (upper); + PUSH (speccount); + break; + } + + case Bmultiple_value_call: + { + n = XINT (POP); + DISCARD_PRESERVING_MULTIPLE_VALUES (n - 1); + /* Discard multiple values for the first (function) argument: */ + TOP_LVALUE = TOP; + TOP_LVALUE = multiple_value_call (n, TOP_ADDRESS); + break; + } + + case Bmultiple_value_list_internal: + { + DISCARD_PRESERVING_MULTIPLE_VALUES (3); + TOP_LVALUE = multiple_value_list_internal (4, TOP_ADDRESS); + break; + } + + case Bthrow: + { + Lisp_Object arg = POP_WITH_MULTIPLE_VALUES; + + /* We never throw to a catch tag that is a multiple value: */ + throw_or_bomb_out (TOP, arg, 0, Qnil, Qnil); + break; + } + default: ABORT(); break;
--- a/src/callint.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/callint.c Sun Aug 16 20:55:49 2009 +0100 @@ -400,7 +400,7 @@ GCPRO3 (function, specs, input); /* Compute the arg values using the user's expression. */ - specs = Feval (specs); + specs = IGNORE_MULTIPLE_VALUES (Feval (specs)); if (EQ (record_flag, Qlambda)) /* XEmacs addition */ { UNGCPRO; @@ -916,7 +916,7 @@ { Lisp_Object tem = call1 (Qread_expression, PROMPT ()); /* visargs[argnum] = Fprin1_to_string (tem, Qnil); */ - args[argnum] = Feval (tem); + args[argnum] = IGNORE_MULTIPLE_VALUES (Feval (tem)); arg_from_tty = 1; break; }
--- a/src/device-x.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/device-x.c Sun Aug 16 20:55:49 2009 +0100 @@ -1280,7 +1280,8 @@ enqueue_magic_eval_event (io_error_delete_device, dev); DEVICE_X_BEING_DELETED (d) = 1; } - Fthrow (Qtop_level, Qnil); + + throw_or_bomb_out (Qtop_level, Qnil, 0, Qnil, Qnil); RETURN_NOT_REACHED (0); }
--- a/src/eval.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/eval.c Sun Aug 16 20:55:49 2009 +0100 @@ -241,6 +241,16 @@ Lisp_Object Vpending_warnings, Vpending_warnings_tail; Lisp_Object Qif; +Lisp_Object Qthrow; +Lisp_Object Qobsolete_throw; + +static int first_desired_multiple_value; +/* Used outside this file, somewhat uncleanly, in the IGNORE_MULTIPLE_VALUES + macro: */ +int multiple_value_current_limit; + +Fixnum Vmultiple_values_limit; + /* Flags specifying which operations are currently inhibited. */ int inhibit_flags; @@ -820,6 +830,9 @@ The remaining ARGS are not evalled at all. If all args return nil, return nil. +Any multiple values from the last form, and only from the last form, are +passed back. See `values' and `multiple-value-bind'. + arguments: (&rest ARGS) */ (args)) @@ -827,13 +840,21 @@ /* This function can GC */ REGISTER Lisp_Object val; - LIST_LOOP_2 (arg, args) + LIST_LOOP_3 (arg, args, tail) { - if (!NILP (val = Feval (arg))) - return val; + if (!NILP (IGNORE_MULTIPLE_VALUES (val = Feval (arg)))) + { + if (NILP (XCDR (tail))) + { + /* Pass back multiple values if this is the last one: */ + return val; + } + + return IGNORE_MULTIPLE_VALUES (val); + } } - return Qnil; + return val; } DEFUN ("and", Fand, 0, UNEVALLED, 0, /* @@ -841,6 +862,9 @@ The remaining ARGS are not evalled at all. If no arg yields nil, return the last arg's value. +Any multiple values from the last form, and only from the last form, are +passed back. See `values' and `multiple-value-bind'. + arguments: (&rest ARGS) */ (args)) @@ -848,10 +872,18 @@ /* This function can GC */ REGISTER Lisp_Object val = Qt; - LIST_LOOP_2 (arg, args) + LIST_LOOP_3 (arg, args, tail) { - if (NILP (val = Feval (arg))) - return val; + if (NILP (IGNORE_MULTIPLE_VALUES (val = Feval (arg)))) + { + if (NILP (XCDR (tail))) + { + /* Pass back any multiple values for the last form: */ + return val; + } + + return Qnil; + } } return val; @@ -872,7 +904,7 @@ Lisp_Object then_form = XCAR (XCDR (args)); Lisp_Object else_forms = XCDR (XCDR (args)); - if (!NILP (Feval (condition))) + if (!NILP (IGNORE_MULTIPLE_VALUES (Feval (condition)))) return Feval (then_form); else return Fprogn (else_forms); @@ -935,11 +967,12 @@ LIST_LOOP_2 (clause, args) { CHECK_CONS (clause); - if (!NILP (val = Feval (XCAR (clause)))) + if (!NILP (val = IGNORE_MULTIPLE_VALUES (Feval (XCAR (clause))))) { if (!NILP (clause = XCDR (clause))) { CHECK_TRUE_LIST (clause); + /* Pass back any multiple values here: */ val = Fprogn (clause); } return val; @@ -988,7 +1021,7 @@ Lisp_Object val; struct gcpro gcpro1; - val = Feval (XCAR (args)); + val = IGNORE_MULTIPLE_VALUES (Feval (Fcar (args))); GCPRO1 (val); @@ -1017,7 +1050,9 @@ Feval (XCAR (args)); args = XCDR (args); - val = Feval (XCAR (args)); + + val = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args))); + args = XCDR (args); GCPRO1 (val); @@ -1062,7 +1097,7 @@ else { CHECK_CONS (tem); - value = Feval (XCAR (tem)); + value = IGNORE_MULTIPLE_VALUES (Feval (XCAR (tem))); if (!NILP (XCDR (tem))) sferror ("`let' bindings can have only one value-form", var); @@ -1120,7 +1155,7 @@ else { CHECK_CONS (tem); - *value = Feval (XCAR (tem)); + *value = IGNORE_MULTIPLE_VALUES (Feval (XCAR (tem))); gcpro1.nvars = idx; if (!NILP (XCDR (tem))) @@ -1157,7 +1192,7 @@ Lisp_Object test = XCAR (args); Lisp_Object body = XCDR (args); - while (!NILP (Feval (test))) + while (!NILP (IGNORE_MULTIPLE_VALUES (Feval (test)))) { QUIT; Fprogn (body); @@ -1189,6 +1224,7 @@ GC_PROPERTY_LIST_LOOP_3 (symbol, val, args) { val = Feval (val); + val = IGNORE_MULTIPLE_VALUES (val); Fset (symbol, val); retval = val; } @@ -1311,7 +1347,7 @@ { struct gcpro gcpro1; GCPRO1 (val); - val = Feval (val); + val = IGNORE_MULTIPLE_VALUES (Feval (val)); Fset_default (sym, val); UNGCPRO; } @@ -1361,6 +1397,8 @@ GCPRO1 (val); + val = IGNORE_MULTIPLE_VALUES (val); + Fset_default (sym, val); UNGCPRO; @@ -1663,10 +1701,10 @@ LONGJMP (c->jmp, 1); } -static DECLARE_DOESNT_RETURN (throw_or_bomb_out (Lisp_Object, Lisp_Object, int, - Lisp_Object, Lisp_Object)); - -static DOESNT_RETURN +DECLARE_DOESNT_RETURN (throw_or_bomb_out (Lisp_Object, Lisp_Object, int, + Lisp_Object, Lisp_Object)); + +DOESNT_RETURN throw_or_bomb_out (Lisp_Object tag, Lisp_Object val, int bomb_out_p, Lisp_Object sig, Lisp_Object data) { @@ -1739,12 +1777,29 @@ condition_case_1). See below for more info. */ -DEFUN_NORETURN ("throw", Fthrow, 2, 2, 0, /* +DEFUN_NORETURN ("throw", Fthrow, 2, UNEVALLED, 0, /* Throw to the catch for TAG and return VALUE from it. -Both TAG and VALUE are evalled. Tags are the same iff they are `eq'. + +Both TAG and VALUE are evalled, and multiple values in VALUE will be passed +back. Tags are the same if and only if they are `eq'. + +arguments: (TAG VALUE) */ - (tag, value)) -{ + (args)) +{ + int nargs; + Lisp_Object tag, value; + + GET_LIST_LENGTH (args, nargs); + if (nargs != 2) + { + Fsignal (Qwrong_number_of_arguments, list2 (Qthrow, make_int (nargs))); + } + + tag = IGNORE_MULTIPLE_VALUES (Feval (XCAR(args))); + + value = Feval (XCAR (XCDR (args))); + throw_or_bomb_out (tag, value, 0, Qnil, Qnil); /* Doesn't return */ RETURN_NOT_REACHED (Qnil); } @@ -2360,7 +2415,8 @@ else if (EQ (handler_data, Qt)) { UNGCPRO; - return Fthrow (handlers, Fcons (error_symbol, data)); + throw_or_bomb_out (handlers, Fcons (error_symbol, data), + 0, Qnil, Qnil); } /* `error' is used similarly to the way `t' is used, but in addition it invokes the debugger if debug_on_error. @@ -2379,7 +2435,7 @@ return return_from_signal (tem); tem = Fcons (error_symbol, data); - return Fthrow (handlers, tem); + throw_or_bomb_out (handlers, tem, 0, Qnil, Qnil); } else { @@ -2403,7 +2459,7 @@ /* Doesn't return */ tem = Fcons (Fcons (error_symbol, data), Fcdr (clause)); - return Fthrow (handlers, tem); + throw_or_bomb_out (handlers, tem, 0, Qnil, Qnil); } } } @@ -3665,7 +3721,7 @@ { LIST_LOOP_2 (arg, original_args) { - *p++ = Feval (arg); + *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); gcpro1.nvars++; } } @@ -3696,7 +3752,7 @@ { LIST_LOOP_2 (arg, original_args) { - *p++ = Feval (arg); + *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); gcpro1.nvars++; } } @@ -3729,7 +3785,7 @@ { LIST_LOOP_2 (arg, original_args) { - *p++ = Feval (arg); + *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); gcpro1.nvars++; } } @@ -3778,7 +3834,7 @@ { LIST_LOOP_2 (arg, original_args) { - *p++ = Feval (arg); + *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); gcpro1.nvars++; } } @@ -3958,6 +4014,12 @@ } else if (max_args == UNEVALLED) /* Can't funcall a special form */ { + /* Ugh, ugh, ugh. */ + if (EQ (fun, XSYMBOL_FUNCTION (Qthrow))) + { + args[0] = Qobsolete_throw; + goto retry; + } goto invalid_function; } else @@ -4238,7 +4300,6 @@ } } - /* Apply lambda list FUN to the NARGS evaluated arguments in ARGS and return the result of evaluation. */ @@ -4296,6 +4357,590 @@ } +/* Multiple values. + + A multiple value object is returned by #'values if: + + -- The number of arguments to #'values is not one, and: + -- Some special form in the call stack is prepared to handle more than + one multiple value. + + The return value of #'values-list is analogous to that of #'values. + + Henry Baker, in https://eprints.kfupm.edu.sa/31898/1/31898.pdf ("CONS + Should not CONS its Arguments, or, a Lazy Alloc is a Smart Alloc", ACM + Sigplan Notices 27,3 (March 1992),24-34.) says it should be possible to + allocate Common Lisp multiple-value objects on the stack, but this + assumes that variable-length records can be allocated on the stack, + something not true for us. As far as I can tell, it also ignores the + contexts where multiple-values need to be thrown, or maybe it thinks such + objects should be converted to heap allocation at that point. + + The specific multiple values saved and returned depend on how many + multiple-values special forms in the stack are interested in; for + example, if #'multiple-value-call is somewhere in the call stack, all + values passed to #'values will be saved and returned. If an expansion of + #'multiple-value-setq with 10 SYMS is the only part of the call stack + interested in multiple values, then a maximum of ten multiple values will + be saved and returned. + + (#'throw passes back multiple values in its VALUE argument; this is why + we can't just take the details of the most immediate + #'multiple-value-{whatever} call to work out which values to save, we + need to look at the whole stack, or, equivalently, the dynamic variables + we set to reflect the whole stack.) + + The first value passed to #'values will always be saved, since that is + needed to convert a multiple value object into a single value object, + something that is normally necessary independent of how many functions in + the call stack are interested in multiple values. + + However many values (for values of "however many" that are not one) are + saved and restored, the multiple value object knows how many arguments it + would contain were none to have been discarded, and will indicate this + on being printed from within GDB. + + In lisp-interaction-mode, no multiple values should be discarded (unless + they need to be for the sake of the correctness of the program); + #'eval-interactive-with-multiple-value-list in lisp-mode.el wraps its + #'eval calls with #'multiple-value-list calls to avoid this. This means + that there is a small performance and memory penalty for code evaluated + in *scratch*; use M-: EXPRESSION RET if you really need to avoid + this. Lisp code execution that is not ultimately from hitting C-j in + *scratch*--that is, the vast vast majority of Lisp code execution--does + not have this penalty. + + Probably the most important aspect of multiple values is stated with + admirable clarity by CLTL2: + + "No matter how many values a form produces, if the form is an argument + form in a function call, then exactly one value (the first one) is + used." + + This means that most contexts, most of the time, will never see multiple + values. There are important exceptions; search the web for that text in + quotation marks and read the related chapter. This code handles all of + them, to my knowledge. Aidan Kehoe, Mon Mar 16 00:17:39 GMT 2009. */ + +static Lisp_Object +make_multiple_value (Lisp_Object first_value, Elemcount count, + Elemcount first_desired, Elemcount upper_limit) +{ + Bytecount sizem; + struct multiple_value *mv; + Elemcount i, allocated_count; + + assert (count != 1); + + if (1 != upper_limit && (0 == first_desired)) + { + /* We always allocate element zero, and that's taken into account when + working out allocated_count: */ + first_desired = 1; + } + + if (first_desired >= count) + { + /* We can't pass anything back that our caller is interested in. Only + allocate for the first argument. */ + allocated_count = 1; + } + else + { + allocated_count = 1 + ((upper_limit > count ? count : upper_limit) + - first_desired); + } + + sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (multiple_value, + Lisp_Object, + contents, allocated_count); + mv = (multiple_value *) BASIC_ALLOC_LCRECORD (sizem, + &lrecord_multiple_value); + + mv->count = count; + mv->first_desired = first_desired; + mv->allocated_count = allocated_count; + mv->contents[0] = first_value; + + for (i = first_desired; i < upper_limit && i < count; ++i) + { + mv->contents[1 + (i - first_desired)] = Qunbound; + } + + return wrap_multiple_value (mv); +} + +void +multiple_value_aset (Lisp_Object obj, Elemcount index, Lisp_Object value) +{ + struct multiple_value *mv = XMULTIPLE_VALUE (obj); + Elemcount first_desired = mv->first_desired; + Elemcount allocated_count = mv->allocated_count; + + if (index != 0 && + (index < first_desired || index >= (first_desired + allocated_count))) + { + args_out_of_range (make_int (first_desired), + make_int (first_desired + allocated_count)); + } + + mv->contents[index == 0 ? 0 : 1 + (index - first_desired)] = value; +} + +Lisp_Object +multiple_value_aref (Lisp_Object obj, Elemcount index) +{ + struct multiple_value *mv = XMULTIPLE_VALUE (obj); + Elemcount first_desired = mv->first_desired; + Elemcount allocated_count = mv->allocated_count; + + if (index != 0 && + (index < first_desired || index >= (first_desired + allocated_count))) + { + args_out_of_range (make_int (first_desired), + make_int (first_desired + allocated_count)); + } + + return mv->contents[index == 0 ? 0 : 1 + (index - first_desired)]; +} + +static void +print_multiple_value (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) +{ + struct multiple_value *mv = XMULTIPLE_VALUE (obj); + Elemcount first_desired = mv->first_desired; + Elemcount allocated_count = mv->allocated_count; + Elemcount count = mv->count, index; + + if (print_readably) + { + printing_unreadable_object ("multiple values"); + } + + if (0 == count) + { + write_c_string (printcharfun, "#<zero-length multiple value>"); + } + + for (index = 0; index < count;) + { + if (index != 0 && + (index < first_desired || + index >= (first_desired + (allocated_count - 1)))) + { + write_fmt_string (printcharfun, "#<discarded-multiple-value %d>", + index); + } + else + { + print_internal (multiple_value_aref (obj, index), + printcharfun, escapeflag); + } + + ++index; + + if (count > 1 && index < count) + { + write_c_string (printcharfun, " ;\n"); + } + } +} + +static Lisp_Object +mark_multiple_value (Lisp_Object obj) +{ + struct multiple_value *mv = XMULTIPLE_VALUE (obj); + Elemcount index, allocated_count = mv->allocated_count; + + for (index = 0; index < allocated_count; ++index) + { + mark_object (mv->contents[index]); + } + + return Qnil; +} + +static Bytecount +size_multiple_value (const void *lheader) +{ + return FLEXIBLE_ARRAY_STRUCT_SIZEOF (struct multiple_value, + Lisp_Object, contents, + ((struct multiple_value *) lheader)-> + allocated_count); +} + +static const struct memory_description multiple_value_description[] = { + { XD_LONG, offsetof (struct multiple_value, count) }, + { XD_ELEMCOUNT, offsetof (struct multiple_value, allocated_count) }, + { XD_LONG, offsetof (struct multiple_value, first_desired) }, + { XD_LISP_OBJECT_ARRAY, offsetof (struct multiple_value, contents), + XD_INDIRECT (1, 0) }, + { XD_END } +}; + +DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("multiple-value", multiple_value, + 1, /*dumpable-flag*/ + mark_multiple_value, + print_multiple_value, 0, + 0, /* No equal method. */ + 0, /* No hash method. */ + multiple_value_description, + size_multiple_value, + struct multiple_value); + +/* Given that FIRST and UPPER are the inclusive lower and exclusive upper + bounds for the multiple values we're interested in, modify (or don't) the + special variables used to indicate this to #'values and #'values-list. + Returns the specpdl_depth() value before any modification. */ +int +bind_multiple_value_limits (int first, int upper) +{ + int result = specpdl_depth(); + + if (!(upper > first)) + { + invalid_argument ("MULTIPLE-VALUE-UPPER-LIMIT must be greater than " + " FIRST-DESIRED-MULTIPLE-VALUE", Qunbound); + } + + if (upper > Vmultiple_values_limit) + { + args_out_of_range (make_int (upper), make_int (Vmultiple_values_limit)); + } + + /* In the event that something back up the stack wants more multiple + values than we do, we need to keep its figures for + first_desired_multiple_value or multiple_value_current_limit both. It + may be that the form will throw past us. + + If first_desired_multiple_value is zero, this means it hasn't ever been + bound, and any value we have for first is appropriate to use. + + Zeroth element is always saved, no need to note that: */ + if (0 == first) + { + first = 1; + } + + if (0 == first_desired_multiple_value + || first < first_desired_multiple_value) + { + internal_bind_int (&first_desired_multiple_value, first); + } + + if (upper > multiple_value_current_limit) + { + internal_bind_int (&multiple_value_current_limit, upper); + } + + return result; +} + +Lisp_Object +multiple_value_call (int nargs, Lisp_Object *args) +{ + /* The argument order here is horrible: */ + int i, speccount = XINT (args[3]); + Lisp_Object result = Qnil, head = Fcons (args[0], Qnil), list_offset; + struct gcpro gcpro1, gcpro2; + Lisp_Object apply_args[2]; + + GCPRO2 (head, result); + list_offset = head; + + assert (!(MULTIPLE_VALUEP (args[0]))); + CHECK_FUNCTION (args[0]); + + /* Start at 4, to ignore the function, the speccount, and the arguments to + multiple-values-limit (which we don't discard because + #'multiple-value-list-internal needs them): */ + for (i = 4; i < nargs; ++i) + { + result = args[i]; + if (MULTIPLE_VALUEP (result)) + { + Lisp_Object val; + Elemcount i, count = XMULTIPLE_VALUE_COUNT (result); + + for (i = 0; i < count; i++) + { + val = multiple_value_aref (result, i); + assert (!UNBOUNDP (val)); + + XSETCDR (list_offset, Fcons (val, Qnil)); + list_offset = XCDR (list_offset); + } + } + else + { + XSETCDR (list_offset, Fcons (result, Qnil)); + list_offset = XCDR (list_offset); + } + } + + apply_args [0] = XCAR (head); + apply_args [1] = XCDR (head); + + unbind_to (speccount); + + RETURN_UNGCPRO (Fapply (countof(apply_args), apply_args)); +} + +DEFUN ("multiple-value-call", Fmultiple_value_call, 1, UNEVALLED, 0, /* +Call FUNCTION with arguments FORMS, using multiple values when returned. + +All of the (possibly multiple) values returned by each form in FORMS are +gathered together, and given as arguments to FUNCTION; conceptually, this +function is a version of `apply' that by-passes the multiple values +infrastructure, treating multiple values as intercalated lists. + +arguments: (FUNCTION &rest FORMS) +*/ + (args)) +{ + int listcount, i = 0, speccount; + Lisp_Object *constructed_args; + struct gcpro gcpro1; + + GET_EXTERNAL_LIST_LENGTH (args, listcount); + + constructed_args = alloca_array (Lisp_Object, listcount + 3); + + /* Fcar so we error on non-cons: */ + constructed_args[i] = IGNORE_MULTIPLE_VALUES (Feval (Fcar (args))); + + GCPRO1 (*constructed_args); + gcpro1.nvars = ++i; + + /* The argument order is horrible here. */ + constructed_args[i] = make_int (0); + gcpro1.nvars = ++i; + constructed_args[i] = make_int (Vmultiple_values_limit); + gcpro1.nvars = ++i; + + speccount = bind_multiple_value_limits (0, Vmultiple_values_limit); + constructed_args[i] = make_int (speccount); + gcpro1.nvars = ++i; + + { + LIST_LOOP_2 (elt, XCDR (args)) + { + constructed_args[i] = Feval (elt); + gcpro1.nvars = ++i; + } + } + + RETURN_UNGCPRO (multiple_value_call (listcount + 3, constructed_args)); +} + +Lisp_Object +multiple_value_list_internal (int nargs, Lisp_Object *args) +{ + int first = XINT (args[0]), upper = XINT (args[1]), + speccount = XINT(args[2]); + Lisp_Object result = Qnil; + + assert (nargs == 4); + + result = args[3]; + + unbind_to (speccount); + + if (MULTIPLE_VALUEP (result)) + { + Lisp_Object head = Fcons (Qnil, Qnil); + Lisp_Object list_offset = head, val; + Elemcount count = XMULTIPLE_VALUE_COUNT(result); + + for (; first < upper && first < count; ++first) + { + val = multiple_value_aref (result, first); + assert (!UNBOUNDP (val)); + + XSETCDR (list_offset, Fcons (val, Qnil)); + list_offset = XCDR (list_offset); + } + + return XCDR (head); + } + else + { + if (first == 0) + { + return Fcons (result, Qnil); + } + else + { + return Qnil; + } + } +} + +DEFUN ("multiple-value-list-internal", Fmultiple_value_list_internal, 3, + UNEVALLED, 0, /* +Evaluate FORM. Return a list of multiple vals reflecting the other two args. + +Don't use this. Use `multiple-value-list', the macro specified by Common +Lisp, instead. + +FIRST-DESIRED-MULTIPLE-VALUE is the first element in list of multiple values +to pass back. MULTIPLE-VALUE-UPPER-LIMIT is the exclusive upper limit on +the indexes within the values that may be passed back; this function will +never return a list longer than MULTIPLE-VALUE-UPPER-LIMIT - +FIRST-DESIRED-MULTIPLE-VALUE. It may return a list shorter than that, if +`values' or `values-list' do not supply enough elements. + +arguments: (FIRST-DESIRED-MULTIPLE-VALUE MULTIPLE-VALUE-UPPER-LIMIT FORM) +*/ + (args)) +{ + Lisp_Object argv[4]; + int first, upper; + struct gcpro gcpro1; + + argv[0] = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args))); + CHECK_NATNUM (argv[0]); + first = XINT (argv[0]); + + GCPRO1 (argv[0]); + gcpro1.nvars = 1; + + args = XCDR (args); + + argv[1] = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args))); + CHECK_NATNUM (argv[1]); + upper = XINT (argv[1]); + gcpro1.nvars = 2; + + /* The unintuitive order of things here is for the sake of the bytecode; + the alternative would be to encode the number of arguments in the + bytecode stream, which complicates things if we have more than 255 + arguments. */ + argv[2] = make_int (bind_multiple_value_limits (first, upper)); + gcpro1.nvars = 3; + args = XCDR (args); + + /* GCPROing in this function is not strictly necessary, this Feval is the + only point that may cons up data that is not immediately discarded, and + within it is the only point (in Fmultiple_value_list_internal and + multiple_value_list) that we can garbage collect. But I'm conservative, + and this function is called so rarely (only from interpreted code) that + it doesn't matter for performance. */ + argv[3] = Feval (XCAR (args)); + gcpro1.nvars = 4; + + RETURN_UNGCPRO (multiple_value_list_internal (countof (argv), argv)); +} + +DEFUN ("multiple-value-prog1", Fmultiple_value_prog1, 1, UNEVALLED, 0, /* +Similar to `prog1', but return any multiple values from the first form. +`prog1' itself will never return multiple values. + +arguments: (FIRST &rest BODY) +*/ + (args)) +{ + /* This function can GC */ + Lisp_Object val; + struct gcpro gcpro1; + + val = Feval (XCAR (args)); + + GCPRO1 (val); + + { + LIST_LOOP_2 (form, XCDR (args)) + Feval (form); + } + + RETURN_UNGCPRO (val); +} + +DEFUN ("values", Fvalues, 0, MANY, 0, /* +Return all ARGS as multiple values. + +arguments: (&rest ARGS) +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object result = Qnil; + int counting = 1; + + /* Pathological cases, no need to cons up an object: */ + if (1 == nargs || 1 == multiple_value_current_limit) + { + return nargs ? args[0] : Qnil; + } + + /* If nargs is zero, this code is correct and desirable. With + #'multiple-value-call, we want zero-length multiple values in the + argument list to be discarded entirely, and we can't do this if we + transform them to nil. */ + result = make_multiple_value (nargs ? args[0] : Qnil, nargs, + first_desired_multiple_value, + multiple_value_current_limit); + + for (; counting < nargs; ++counting) + { + if (counting >= first_desired_multiple_value && + counting < multiple_value_current_limit) + { + multiple_value_aset (result, counting, args[counting]); + } + } + + return result; +} + +DEFUN ("values-list", Fvalues_list, 1, 1, 0, /* +Return all the elements of LIST as multiple values. +*/ + (list)) +{ + Lisp_Object result = Qnil; + int counting = 1, listcount; + + GET_EXTERNAL_LIST_LENGTH (list, listcount); + + /* Pathological cases, no need to cons up an object: */ + if (1 == listcount || 1 == multiple_value_current_limit) + { + return Fcar_safe (list); + } + + result = make_multiple_value (Fcar_safe (list), listcount, + first_desired_multiple_value, + multiple_value_current_limit); + + list = Fcdr_safe (list); + + { + EXTERNAL_LIST_LOOP_2 (elt, list) + { + if (counting >= first_desired_multiple_value && + counting < multiple_value_current_limit) + { + multiple_value_aset (result, counting, elt); + } + ++counting; + } + } + + return result; +} + +Lisp_Object +values2 (Lisp_Object first, Lisp_Object second) +{ + Lisp_Object argv[2]; + + argv[0] = first; + argv[1] = second; + + return Fvalues (countof (argv), argv); +} + + /************************************************************************/ /* Run hook variables in various ways. */ /************************************************************************/ @@ -4968,7 +5613,7 @@ p->error_conditions = error_conditions; p->data = data; - Fthrow (p->catchtag, Qnil); + throw_or_bomb_out (p->catchtag, Qnil, 0, Qnil, Qnil); RETURN_NOT_REACHED (Qnil); } @@ -6555,6 +7200,7 @@ syms_of_eval (void) { INIT_LRECORD_IMPLEMENTATION (subr); + INIT_LRECORD_IMPLEMENTATION (multiple_value); DEFSYMBOL (Qinhibit_quit); DEFSYMBOL (Qautoload); @@ -6578,6 +7224,8 @@ DEFSYMBOL (Qrun_hooks); DEFSYMBOL (Qfinalize_list); DEFSYMBOL (Qif); + DEFSYMBOL (Qthrow); + DEFSYMBOL (Qobsolete_throw); DEFSUBR (For); DEFSUBR (Fand); @@ -6611,6 +7259,11 @@ DEFSUBR (Fautoload); DEFSUBR (Feval); DEFSUBR (Fapply); + DEFSUBR (Fmultiple_value_call); + DEFSUBR (Fmultiple_value_list_internal); + DEFSUBR (Fmultiple_value_prog1); + DEFSUBR (Fvalues); + DEFSUBR (Fvalues_list); DEFSUBR (Ffuncall); DEFSUBR (Ffunctionp); DEFSUBR (Ffunction_min_args); @@ -6636,6 +7289,9 @@ debug_on_next_call = 0; lisp_eval_depth = 0; entering_debugger = 0; + + first_desired_multiple_value = 0; + multiple_value_current_limit = 1; } void @@ -6805,6 +7461,14 @@ */ ); Vdebugger = Qnil; + DEFVAR_CONST_INT ("multiple-values-limit", &Vmultiple_values_limit /* +The exclusive upper bound on the number of multiple values. + +This applies to `values', `values-list', `multiple-value-bind' and related +macros and special forms. +*/); + Vmultiple_values_limit = EMACS_INT_MAX > INT_MAX ? INT_MAX : EMACS_INT_MAX; + staticpro (&Vcatch_everything_tag); Vcatch_everything_tag = make_opaque (OPAQUE_CLEAR, 0);
--- a/src/event-msw.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/event-msw.c Sun Aug 16 20:55:49 2009 +0100 @@ -1769,7 +1769,7 @@ return Qnil; GCPRO1 (obj); - obj = Feval (XCAR (obj)); + obj = IGNORE_MULTIPLE_VALUES (Feval (XCAR (obj))); RETURN_UNGCPRO (obj); }
--- a/src/event-stream.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/event-stream.c Sun Aug 16 20:55:49 2009 +0100 @@ -843,7 +843,7 @@ call1 (Qcurrent_window_configuration, Qnil)); reset_key_echo (command_builder, 1); - help = Feval (Vhelp_form); + help = IGNORE_MULTIPLE_VALUES (Feval (Vhelp_form)); if (STRINGP (help)) internal_with_output_to_temp_buffer (build_string ("*Help*"), print_help, help, Qnil);
--- a/src/glade.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/glade.c Sun Aug 16 20:55:49 2009 +0100 @@ -42,7 +42,8 @@ if (signal_data && signal_data[0]) { - lisp_data = Feval (Fread (build_string (signal_data))); + lisp_data + = IGNORE_MULTIPLE_VALUES (Feval (Fread (build_string (signal_data)))); } /* obj, name, func, cb_data, object_signal, after_p */
--- a/src/glyphs-widget.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/glyphs-widget.c Sun Aug 16 20:55:49 2009 +0100 @@ -222,7 +222,7 @@ glyph = XSYMBOL (glyph)->value; if (CONSP (glyph)) - glyph = Feval (glyph); + glyph = IGNORE_MULTIPLE_VALUES (Feval (glyph)); /* Be really helpful to the user. */ if (VECTORP (glyph))
--- a/src/glyphs.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/glyphs.c Sun Aug 16 20:55:49 2009 +0100 @@ -3079,7 +3079,7 @@ value = XCDR (cons); CHECK_CONS (value); value = XCAR (value); - value = Feval (value); + value = IGNORE_MULTIPLE_VALUES (Feval (value)); if (NILP (value)) continue; if (!STRINGP (value) && !COLOR_SPECIFIERP (value))
--- a/src/gui-x.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/gui-x.c Sun Aug 16 20:55:49 2009 +0100 @@ -325,8 +325,9 @@ Lisp_Object wses_form = (form); \ (slot) = (NILP (wses_form) ? 0 : \ EQ (wses_form, Qt) ? 1 : \ - !NILP (in_display ? eval_within_redisplay (wses_form) \ - : Feval (wses_form))); \ + !NILP (in_display ? \ + IGNORE_MULTIPLE_VALUES (eval_within_redisplay (wses_form)) \ + : IGNORE_MULTIPLE_VALUES (Feval (wses_form)))); \ } while (0) #else /* Treat the activep slot of the menu item as a boolean */ @@ -436,7 +437,7 @@ #endif /* HAVE_MENUBARS */ if (!STRINGP (pgui->name)) - pgui->name = Feval (pgui->name); + pgui->name = IGNORE_MULTIPLE_VALUES (Feval (pgui->name)); CHECK_STRING (pgui->name); if (accel_p) @@ -459,7 +460,7 @@ suffix2 = pgui->suffix; else { - suffix2 = Feval (pgui->suffix); + suffix2 = IGNORE_MULTIPLE_VALUES (Feval (pgui->suffix)); CHECK_STRING (suffix2); }
--- a/src/gui.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/gui.c Sun Aug 16 20:55:49 2009 +0100 @@ -386,7 +386,6 @@ gui_item_value (Lisp_Object form) { /* This function can call Lisp. */ - #ifndef ERROR_CHECK_DISPLAY /* Shortcut to avoid evaluating Qt/Qnil each time; but don't do it when error-checking so we catch unprotected eval within redisplay quicker */ @@ -395,7 +394,9 @@ if (EQ (form, Qt)) return 1; #endif - return !NILP (in_display ? eval_within_redisplay (form) : Feval (form)); + return !NILP (in_display ? + IGNORE_MULTIPLE_VALUES (eval_within_redisplay (form)) + : IGNORE_MULTIPLE_VALUES (Feval (form))); } /* @@ -511,6 +512,7 @@ if (!STRINGP (suffix)) { suffix = Feval (suffix); + suffix = IGNORE_MULTIPLE_VALUES (suffix); CHECK_STRING (suffix); }
--- a/src/inline.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/inline.c Sun Aug 16 20:55:49 2009 +0100 @@ -64,6 +64,7 @@ #include "process.h" #include "rangetab.h" #include "specifier.h" +#include "symeval.h" #include "syntax.h" #include "window.h"
--- a/src/lisp.h Sun Aug 16 14:58:57 2009 +0100 +++ b/src/lisp.h Sun Aug 16 20:55:49 2009 +0100 @@ -4269,11 +4269,15 @@ EXFUN (Finteractive_p, 0); EXFUN (Fprogn, UNEVALLED); MODULE_API EXFUN (Fsignal, 2); -MODULE_API EXFUN_NORETURN (Fthrow, 2); +MODULE_API EXFUN_NORETURN (Fthrow, UNEVALLED); MODULE_API EXFUN (Fcall_with_condition_handler, MANY); EXFUN (Ffunction_max_args, 1); EXFUN (Ffunction_min_args, 1); +MODULE_API DECLARE_DOESNT_RETURN (throw_or_bomb_out (Lisp_Object, + Lisp_Object, int, + Lisp_Object, Lisp_Object)); + MODULE_API DECLARE_DOESNT_RETURN (signal_error_1 (Lisp_Object, Lisp_Object)); void maybe_signal_error_1 (Lisp_Object, Lisp_Object, Lisp_Object, Error_Behavior);
--- a/src/lread.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/lread.c Sun Aug 16 20:55:49 2009 +0100 @@ -372,7 +372,7 @@ Lisp_Object val; GCPRO1 (reloc); - val = Feval (XCDR (acons)); + val = IGNORE_MULTIPLE_VALUES (Feval (XCDR (acons))); UNGCPRO; if (!NILP (val))
--- a/src/lrecord.h Sun Aug 16 14:58:57 2009 +0100 +++ b/src/lrecord.h Sun Aug 16 20:55:49 2009 +0100 @@ -224,6 +224,7 @@ lrecord_type_max_symbol_value_magic = lrecord_type_symbol_value_buffer_local, lrecord_type_symbol, lrecord_type_subr, + lrecord_type_multiple_value, lrecord_type_cons, lrecord_type_vector, lrecord_type_string,
--- a/src/macros.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/macros.c Sun Aug 16 20:55:49 2009 +0100 @@ -197,7 +197,7 @@ with Qt to force an early exit. */ signal_error (Qinvalid_state, "junk in executing-macro", Qunbound); - Fthrow (Qexecute_kbd_macro, Qt); + throw_or_bomb_out (Qexecute_kbd_macro, Qt, 0, Qnil, Qnil); }
--- a/src/menubar-gtk.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/menubar-gtk.c Sun Aug 16 20:55:49 2009 +0100 @@ -666,13 +666,14 @@ if ((!NILP (config_tag) && NILP (Fmemq (config_tag, Vmenubar_configuration))) - || (included_spec && NILP (Feval (include_p)))) + || (included_spec && + NILP (IGNORE_MULTIPLE_VALUES (Feval (include_p))))) { return (NULL); } if (active_spec) - active_p = Feval (active_p); + active_p = IGNORE_MULTIPLE_VALUES (Feval (active_p)); gtk_widget_set_sensitive (GTK_WIDGET (menu_item), ! NILP (active_p)); } @@ -853,7 +854,8 @@ #ifdef HAVE_MENUBARS if ((!NILP (config_tag) && NILP (Fmemq (config_tag, Vmenubar_configuration))) - || (included_spec && NILP (Feval (include_p)))) + || (included_spec && NILP (IGNORE_MULTIPLE_VALUES (Feval (include_p))))) + { /* the include specification says to ignore this item. */ return 0; @@ -866,7 +868,8 @@ accel = menu_name_to_accelerator (XSTRING_DATA (name)); if (!NILP (suffix)) - suffix = Feval (suffix); + suffix = IGNORE_MULTIPLE_VALUES (Feval (suffix)); + if (!separator_string_p (XSTRING_DATA (name))) { @@ -901,7 +904,7 @@ } else { - selected_p = Feval (selected_p); + selected_p = IGNORE_MULTIPLE_VALUES (Feval (selected_p)); } } @@ -911,7 +914,7 @@ } else { - active_p = Feval (active_p); + active_p = IGNORE_MULTIPLE_VALUES (Feval (active_p)); } if (0 ||
--- a/src/menubar-msw.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/menubar-msw.c Sun Aug 16 20:55:49 2009 +0100 @@ -326,7 +326,7 @@ } if (!STRINGP (pgui_item->name)) - pgui_item->name = Feval (pgui_item->name); + pgui_item->name = IGNORE_MULTIPLE_VALUES (Feval (pgui_item->name)); if (!gui_item_active_p (gui_item)) item_info.fState = MFS_GRAYED;
--- a/src/print.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/print.c Sun Aug 16 20:55:49 2009 +0100 @@ -821,7 +821,7 @@ #endif GCPRO2 (name, val); - name = Feval (XCAR (args)); + name = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args))); CHECK_STRING (name);
--- a/src/symbols.c Sun Aug 16 14:58:57 2009 +0100 +++ b/src/symbols.c Sun Aug 16 20:55:49 2009 +0100 @@ -2146,7 +2146,7 @@ GC_PROPERTY_LIST_LOOP_3 (symbol, val, args) { - val = Feval (val); + val = IGNORE_MULTIPLE_VALUES (Feval (val)); Fset_default (symbol, val); retval = val; }
--- a/src/symeval.h Sun Aug 16 14:58:57 2009 +0100 +++ b/src/symeval.h Sun Aug 16 20:55:49 2009 +0100 @@ -488,6 +488,83 @@ void flush_all_buffer_local_cache (void); +struct multiple_value { + struct LCRECORD_HEADER header; + Elemcount count; + Elemcount allocated_count; + Elemcount first_desired; + Lisp_Object contents[1]; +}; +typedef struct multiple_value multiple_value; + +DECLARE_LRECORD (multiple_value, multiple_value); +#define MULTIPLE_VALUEP(x) RECORDP (x, multiple_value) + +#define XMULTIPLE_VALUE(x) XRECORD (x, multiple_value, multiple_value) +#define wrap_multiple_value(p) wrap_record (p, multiple_value) + +#define CHECK_MULTIPLE_VALUE(x) CHECK_RECORD (x, multiple_value) +#define CONCHECK_MULTIPLE_VALUE(x) CONCHECK_RECORD (x, multiple_value) + +#define multiple_value_count(x) ((x)->count) +#define multiple_value_allocated_count(x) ((x)->allocated_count) +#define multiple_value_first_desired(x) ((x)->first_desired) +#define multiple_value_contents(x) ((x)->contents) + +#define XMULTIPLE_VALUE_COUNT(x) multiple_value_count (XMULTIPLE_VALUE (x)) +#define XMULTIPLE_VALUE_ALLOCATED_COUNT(x) \ + multiple_value_allocated_count (XMULTIPLE_VALUE (x)) +#define XMULTIPLE_VALUE_FIRST_DESIRED(x) \ + multiple_value_first_desired (XMULTIPLE_VALUE(x)) +#define XMULTIPLE_VALUE_CONTENTS(x) multiple_value_contents (XMULTIPLE_VALUE(x)) + +Lisp_Object multiple_value_call (int nargs, Lisp_Object *args); +Lisp_Object multiple_value_list_internal (int nargs, Lisp_Object *args); + +/* It's slightly ugly to expose this here, but it does cut down the amount + of work the bytecode interpreter has to do substantially. */ +extern int multiple_value_current_limit; + +/* Bind the multiple value limits that #'values and #'values-list pay + attention to. Used by bytecode and interpreted code. */ +int bind_multiple_value_limits (int first, int upper); + +Lisp_Object multiple_value_aref (Lisp_Object, Elemcount); +void multiple_value_aset (Lisp_Object, Elemcount, Lisp_Object); + +Lisp_Object values2 (Lisp_Object first, Lisp_Object second); + +DECLARE_INLINE_HEADER ( +Lisp_Object +ignore_multiple_values (Lisp_Object obj) +) +{ + return MULTIPLE_VALUEP (obj) ? multiple_value_aref (obj, 0) : obj; +} + +#ifdef ERROR_CHECK_MULTIPLE_VALUES + +DECLARE_INLINE_HEADER ( +Lisp_Object +ignore_multiple_values_1 (Lisp_Object obj) +) +{ + if (1 == multiple_value_current_limit) + { + assert (!MULTIPLE_VALUEP (obj)); + return obj; + } + + return ignore_multiple_values (obj); +} + +#define IGNORE_MULTIPLE_VALUES(X) ignore_multiple_values_1 (X) + +#else +#define IGNORE_MULTIPLE_VALUES(X) (multiple_value_current_limit == 1 ? (X) \ + : ignore_multiple_values (X)) +#endif + END_C_DECLS #endif /* INCLUDED_symeval_h_ */