commit: Support full Common Lisp multiple values in C.

Sunday, 16 August 2009

        changeset:   4677:8f1ee2d15784
user:        Aidan Kehoe <kehoea(a)parhasard.net&gt;
date:        Sun Aug 16 20:55:49 2009 +0100
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
description:
Support full Common Lisp multiple values in C.

lisp/ChangeLog

2009-08-11  Aidan Kehoe  <kehoea(a)parhasard.net&gt;

	* 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(a)parhasard.net&gt;

	* cl.texi (Organization):
	Remove references to the obsolete multiple-value emulating code.

src/ChangeLog addition:

2009-08-11  Aidan Kehoe  <kehoea(a)parhasard.net&gt;

	* 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.

diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/ChangeLog
--- a/lisp/ChangeLog	Sun Aug 16 14:58:57 2009 +0100
+++ b/lisp/ChangeLog	Sun Aug 16 20:55:49 2009 +0100
＠＠ -9,6 +9,83 ＠＠
 	* minibuf.el (read-from-minibuffer): 
 	Use buffer (format " *Minibuf-%d*" (minibuffer-depth)), regardless
 	of depth. 
+
+2009-08-11  Aidan Kehoe  <kehoea(a)parhasard.net&gt;
+
+	* 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(a)parhasard.net&gt;

diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/byte-optimize.el
--- 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))
diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/bytecomp.el
--- 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(a)gnu.org&gt;
 ;; 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
diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/cl-compat.el
--- 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))
diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/cl-macs.el
--- 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-wrapper 'byte-compile
+     #'(lambda (cl-form)
+         (if (/= (length cl-form) 2)
+             (byte-compile-warn-wrong-args cl-form 1))

-(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))))
+         (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)
diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/cl.el
--- 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)

+;;; XEmacs; multiple values are in eval.c and cl-macs.el. 

-;;; 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.
+;;; 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 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)
-
-(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)
-
-(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.

diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/lisp-mode.el
--- 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(a)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(a)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<")
diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/mouse.el
--- 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."
diff -r e3feb329bda9 -r 8f1ee2d15784 lisp/obsolete.el
--- 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
diff -r e3feb329bda9 -r 8f1ee2d15784 man/ChangeLog
--- 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(a)parhasard.net&gt;
+
+	* cl.texi (Organization): 
+	Remove references to the obsolete multiple-value emulating code.
+
 2009-07-28  Stephen Turnbull  <stephen(a)xemacs.org&gt;

 	* internals/internals.texi (Redisplay Piece by Piece):
diff -r e3feb329bda9 -r 8f1ee2d15784 man/cl.texi
--- 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
＠＠ -5376,14 +5367,6 ＠＠
 ＠noindent
 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.
＠＠ -5448,19 +5431,6 ＠＠
 macro is not, however, and in any case it's best to change to
 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
diff -r e3feb329bda9 -r 8f1ee2d15784 src/ChangeLog
--- 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(a)parhasard.net&gt;
+
+	* 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(a)xemacs.org&gt;

 	* faces.c (ensure_face_cachel_contains_charset):
diff -r e3feb329bda9 -r 8f1ee2d15784 src/bytecode.c
--- 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,36 +1661,76 ＠＠
     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:
diff -r e3feb329bda9 -r 8f1ee2d15784 src/callint.c
--- 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;
 	    }
diff -r e3feb329bda9 -r 8f1ee2d15784 src/device-x.c
--- 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);
 }
diff -r e3feb329bda9 -r 8f1ee2d15784 src/eval.c
--- 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)
-    {
-      if (!NILP (val = Feval (arg)))
-	return val;
-    }
-
-  return Qnil;
+  LIST_LOOP_3 (arg, args, tail)
+    {
+      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 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)
-    {
-      if (NILP (val = Feval (arg)))
-	return val;
+  LIST_LOOP_3 (arg, args, tail)
+    {
+      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;
 	}
＠＠ -1360,6 +1396,8 ＠＠
   struct gcpro gcpro1;

   GCPRO1 (val);
+
+  val = IGNORE_MULTIPLE_VALUES (val);

   Fset_default (sym, val);

＠＠ -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'.
-*/
-       (tag, value))
-{
+
+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)
+*/
+       (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. */

＠＠ -4293,6 +4354,590 ＠＠

  invalid_function:
   return signal_invalid_function_error (fun);
+}
+
+
+/* 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);
 }

＠＠ -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);

diff -r e3feb329bda9 -r 8f1ee2d15784 src/event-msw.c
--- 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);
 }
diff -r e3feb329bda9 -r 8f1ee2d15784 src/event-stream.c
--- 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);
diff -r e3feb329bda9 -r 8f1ee2d15784 src/glade.c
--- 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 */
diff -r e3feb329bda9 -r 8f1ee2d15784 src/glyphs-widget.c
--- 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))
diff -r e3feb329bda9 -r 8f1ee2d15784 src/glyphs.c
--- 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))
diff -r e3feb329bda9 -r 8f1ee2d15784 src/gui-x.c
--- 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);
 	}

diff -r e3feb329bda9 -r 8f1ee2d15784 src/gui.c
--- 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);
 	}

diff -r e3feb329bda9 -r 8f1ee2d15784 src/inline.c
--- 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"

diff -r e3feb329bda9 -r 8f1ee2d15784 src/lisp.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,10 +4269,14 ＠＠
 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,
diff -r e3feb329bda9 -r 8f1ee2d15784 src/lread.c
--- 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))
diff -r e3feb329bda9 -r 8f1ee2d15784 src/lrecord.h
--- 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,
diff -r e3feb329bda9 -r 8f1ee2d15784 src/macros.c
--- 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);
 }

diff -r e3feb329bda9 -r 8f1ee2d15784 src/menubar-gtk.c
--- 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 || 
diff -r e3feb329bda9 -r 8f1ee2d15784 src/menubar-msw.c
--- 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;
diff -r e3feb329bda9 -r 8f1ee2d15784 src/print.c
--- 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);

diff -r e3feb329bda9 -r 8f1ee2d15784 src/symbols.c
--- 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;
     }
diff -r e3feb329bda9 -r 8f1ee2d15784 src/symeval.h
--- 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_ */

_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

2003

commit: Support full Common Lisp multiple values in C.