xemacs-beta: lisp/bytecomp.el comparison

comparison lisp/bytecomp.el @ 4677:8f1ee2d15784

Support full Common Lisp multiple values in C. lisp/ChangeLog 2009-08-11 Aidan Kehoe <kehoea@parhasard.net> * bytecomp.el : Update this file to support full C-level multiple values. This involves: -- Four new bytecodes, and special compiler functions to compile multiple-value-call, multiple-value-list-internal, values, values-list, and, since it now needs to pass back multiple values and is a special form, throw. -- There's a new compiler variable, byte-compile-checks-on-load, which is a list of forms that are evaluated at the very start of a file, with an error thrown if any of them give nil. -- The header is now inserted *after* compilation, giving a chance for the compilation process to influence what those checks are. There is still a check done before compilation for non-ASCII characters, to try to turn off dynamic docstrings if appopriate, in `byte-compile-maybe-reset-coding'. Space is reserved for checks; comments describing the version of the byte compiler generating the file are inserted if space remains for them. * bytecomp.el (byte-compile-version): Update this, we're a newer version of the byte compiler. * byte-optimize.el (byte-optimize-funcall): Correct a comment. * bytecomp.el (byte-compile-lapcode): Discard the arg with byte-multiple-value-call. * bytecomp.el (byte-compile-checks-and-comments-space): New variable, describe how many octets to reserve for checks at the start of byte-compiled files. * cl-compat.el: Remove the fake multiple-value implementation. Have the functions that use it use the real multiple-value implementation instead. * cl-macs.el (cl-block-wrapper, cl-block-throw): Revise the byte-compile properties of these symbols to work now we've made throw into a special form; keep the byte-compile properties as anonymous lambdas, since we don't have docstrings for them. * cl-macs.el (multiple-value-bind, multiple-value-setq) (multiple-value-list, nth-value): Update these functions to work with the C support for multiple values. * cl-macs.el (values): Modify the setf handler for this to call #'multiple-value-list-internal appropriately. * cl-macs.el (cl-setf-do-store): If the store form is a cons, treat it specially as wrapping the store value. * cl.el (cl-block-wrapper): Make this an alias of #'and, not #'identity, since it needs to pass back multiple values. * cl.el (multiple-value-apply): We no longer support this, mark it obsolete. * lisp-mode.el (eval-interactive-verbose): Remove a useless space in the docstring. * lisp-mode.el (eval-interactive): Update this function and its docstring. It now passes back a list, basically wrapping any eval calls with multiple-value-list. This allows multiple values to be printed by default in *scratch*. * lisp-mode.el (prin1-list-as-multiple-values): New function, printing a list as multiple values in the manner of Bruno Haible's clisp, separating each entry with " ;\n". * lisp-mode.el (eval-last-sexp): Call #'prin1-list-as-multiple-values on the return value of #'eval-interactive. * lisp-mode.el (eval-defun): Call #'prin1-list-as-multiple-values on the return value of #'eval-interactive. * mouse.el (mouse-eval-sexp): Deal with lists corresponding to multiple values from #'eval-interactive. Call #'cl-prettyprint, which is always available, instead of sometimes calling #'pprint and sometimes falling back to prin1. * obsolete.el (obsolete-throw): New function, called from eval.c when #'funcall encounters an attempt to call #'throw (now a special form) as a function. Only needed for compatibility with 21.4 byte-code. man/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea@parhasard.net> * cl.texi (Organization): Remove references to the obsolete multiple-value emulating code. src/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea@parhasard.net> * bytecode.c (enum Opcode /* Byte codes */): Add four new bytecodes, to deal with multiple values. (POP_WITH_MULTIPLE_VALUES): New macro. (POP): Modify this macro to ignore multiple values. (DISCARD_PRESERVING_MULTIPLE_VALUES): New macro. (DISCARD): Modify this macro to ignore multiple values. (TOP_WITH_MULTIPLE_VALUES): New macro. (TOP_ADDRESS): New macro. (TOP): Modify this macro to ignore multiple values. (TOP_LVALUE): New macro. (Bcall): Ignore multiple values where appropriate. (Breturn): Pass back multiple values. (Bdup): Preserve multiple values. Use TOP_LVALUE with most bytecodes that assign anything to anything. (Bbind_multiple_value_limits, Bmultiple_value_call, Bmultiple_value_list_internal, Bthrow): Implement the new bytecodes. (Bgotoifnilelsepop, Bgotoifnonnilelsepop, BRgotoifnilelsepop, BRgotoifnonnilelsepop): Discard any multiple values. * callint.c (Fcall_interactively): Ignore multiple values when calling #'eval, in two places. * device-x.c (x_IO_error_handler): * macros.c (pop_kbd_macro_event): * eval.c (Fsignal): * eval.c (flagged_a_squirmer): Call throw_or_bomb_out, not Fthrow, now that the latter is a special form. * eval.c: Make Qthrow, Qobsolete_throw available as symbols. Provide multiple_value_current_limit, multiple-values-limit (the latter as specified by Common Lisp. * eval.c (For): Ignore multiple values when comparing with Qnil, but pass any multiple values back for the last arg. * eval.c (Fand): Ditto. * eval.c (Fif): Ignore multiple values when examining the result of the condition. * eval.c (Fcond): Ignore multiple values when comparing what the clauses give, but pass them back if a clause gave non-nil. * eval.c (Fprog2): Never pass back multiple values. * eval.c (FletX, Flet): Ignore multiple when evaluating what exactly symbols should be bound to. * eval.c (Fwhile): Ignore multiple values when evaluating the test. * eval.c (Fsetq, Fdefvar, Fdefconst): Ignore multiple values. * eval.c (Fthrow): Declare this as a special form; ignore multiple values for TAG, preserve them for VALUE. * eval.c (throw_or_bomb_out): Make this available to other files, now Fthrow is a special form. * eval.c (Feval): Ignore multiple values when calling a compiled function, a non-special-form subr, or a lambda expression. * eval.c (Ffuncall): If we attempt to call #'throw (now a special form) as a function, don't error, call #'obsolete-throw instead. * eval.c (make_multiple_value, multiple_value_aset) (multiple_value_aref, print_multiple_value, mark_multiple_value) (size_multiple_value): Implement the multiple_value type. Add a long comment describing our implementation. * eval.c (bind_multiple_value_limits): New function, used by the bytecode and by #'multiple-value-call, #'multiple-value-list-internal. * eval.c (multiple_value_call): New function, used by the bytecode and #'multiple-value-call. * eval.c (Fmultiple_value_call): New special form. * eval.c (multiple_value_list_internal): New function, used by the byte code and #'multiple-value-list-internal. * eval.c (Fmultiple_value_list_internal, Fmultiple_value_prog1): New special forms. * eval.c (Fvalues, Fvalues_list): New Lisp functions. * eval.c (values2): New function, for C code returning multiple values. * eval.c (syms_of_eval): Make our new Lisp functions and symbols available. * eval.c (multiple-values-limit): Make this available to Lisp. * event-msw.c (dde_eval_string): * event-stream.c (execute_help_form): * glade.c (connector): * glyphs-widget.c (glyph_instantiator_to_glyph): * glyphs.c (evaluate_xpm_color_symbols): * gui-x.c (wv_set_evalable_slot, button_item_to_widget_value): * gui.c (gui_item_value, gui_item_display_flush_left): * lread.c (check_if_suppressed): * menubar-gtk.c (menu_convert, menu_descriptor_to_widget_1): * menubar-msw.c (populate_menu_add_item): * print.c (Fwith_output_to_temp_buffer): * symbols.c (Fsetq_default): Ignore multiple values when calling Feval. * symeval.h: Add the header declarations necessary for the multiple-values implementation. * inline.c: #include symeval.h, now that it has some inline functions. * lisp.h: Update Fthrow's declaration. Make throw_or_bomb_out available to all files. * lrecord.h (enum lrecord_type): Add the multiple_value type here.

author	Aidan Kehoe <kehoea@parhasard.net>
date	Sun, 16 Aug 2009 20:55:49 +0100
parents	7757334005ae
children	0cc9d22c3732

comparison

equal deleted inserted replaced

-:e3feb329bda9
+:8f1ee2d15784
 ;;	Ben Wing <ben@xemacs.org>
 ;;	Martin Buchholz <martin@xemacs.org>
 ;;	Richard Stallman <rms@gnu.org>
 ;; Keywords: internal lisp
-(defconst byte-compile-version "2.27 XEmacs; 2000-09-12.")
+(defconst byte-compile-version "2.28 XEmacs; 2009-08-09.")
 ;; This file is part of XEmacs.
 ;; XEmacs is free software; you can redistribute it and/or modify it
 ;; under the terms of the GNU General Public License as published by
 (or (fboundp 'defsubst)
 ;; This really ought to be loaded already!
 (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.")
 (cond
 ;; XEmacs addition
 (defvar byte-compile-new-bytecodes nil
 "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
 ;; for the fact that if you enable either of these, you get incompatible
 ;; byte code that can't be read by XEmacs 19.13 or before or FSF 19.28 or
 "Alist of variables bound in the context of the current form,
 that is, the current lexical environment.  This list lives partly
 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
 easily determined from the input file.")
 (byte-defop 175 nil byte-listN)
 (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)
 (byte-defop 183 -1 byte-assq)
 					     (cons byte-constant2 bytes))))))
 			 ((and (<= byte-listN (symbol-value op))
 			       (<= (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))
 			 ((< off 256)
 			  (setq pc (+ 2 pc))
 	;;
 	(byte-compile-verbose byte-compile-verbose)
 	(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)
 	(byte-compile-warnings (if (eq byte-compile-warnings t)
 				   byte-compile-default-warnings
 	;;	  #### This is bound in b-c-close-variables.
 	;;	  (byte-compile-warnings (if (eq byte-compile-warnings t)
 	;;				     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-dynamic nil))
-(byte-compile-using-escape-quoted nil)
-	)
 (byte-compile-close-variables
 (save-excursion
 (setq byte-compile-outbuffer
 	     (set-buffer (get-buffer-create " *Compiler Output*")))
 (erase-buffer)
 ;;	 (emacs-lisp-mode)
 (setq case-fold-search nil)
 (and filename
 	    (not eval)
-	    (byte-compile-insert-header filename
+	    (byte-compile-maybe-reset-coding byte-compile-inbuffer
-					byte-compile-inbuffer
+					     byte-compile-outbuffer))
-					byte-compile-outbuffer))
 (setq byte-compile-using-dynamic
 (or (symbol-value-in-buffer 'byte-compile-dynamic
 byte-compile-inbuffer)
 (symbol-value-in-buffer 'byte-compile-dynamic-docstrings
 byte-compile-inbuffer)))
 		 (not (eobp)))
 	  (byte-compile-file-form (read byte-compile-inbuffer)))
 	;; 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
 	;; been compiled.
 	(setq byte-compile-unresolved-functions nil)))
 		 (end-of-file nil))
 	  (eval form)))
 (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
 ;; the file-format version number (19 or 20) as a byte, followed by some
 ;; nulls.  The primary motivation for doing this is to get some binary
 ;; >4	byte		x		version %d
 ;;
 (insert
 ";ELC"
 (if (byte-compile-version-cond byte-compile-emacs19-compatibility) 19 20)
-"\000\000\000\n"
+"\000\000\000\n")
-)
+(when (not (eq (find-coding-system 'raw-text-unix)
-(insert ";;; compiled by "
+		   (find-coding-system buffer-file-coding-system)))
-	    (or (and (boundp 'user-mail-address) user-mail-address)
+(insert (format ";;;###coding system: %s\n"
-		(concat (user-login-name) "@" (system-name)))
+		      (coding-system-name buffer-file-coding-system))))
-	    " on "
+(insert (format
-	    (current-time-string) "\n;;; from file " filename "\n")
+	     "\n(or %s\n    (error \"Loading this file requires: %s\"))\n"
-(insert ";;; emacs version " emacs-version ".\n")
+	     (setq checks-string
-(insert ";;; bytecomp version " byte-compile-version "\n;;; "
+		   (let ((print-readably t))
-(cond
+		     (prin1-to-string (if (> (length
-((eq byte-optimize 'source) "source-level optimization only")
+					      byte-compile-checks-on-load)
-((eq byte-optimize 'byte) "byte-level optimization only")
+					     1)
-(byte-optimize "optimization is on")
+					  (cons 'and
-(t "optimization is off"))
+						(reverse
-(if (byte-compile-version-cond byte-compile-emacs19-compatibility)
+						 byte-compile-checks-on-load))
-	 "; compiled with Emacs 19 compatibility.\n"
+					(car byte-compile-checks-on-load)))))
-".\n"))
+	     checks-string))
-(if (not (byte-compile-version-cond byte-compile-emacs19-compatibility))
+(setq comments
-(insert ";;; this file uses opcodes which do not exist in Emacs 19.\n"
+	  (with-string-as-buffer-contents ""
-	       ;; Have to check if emacs-version is bound so that this works
+	    (insert "\n;;; compiled by "
-	       ;; in files loaded early in loadup.el.
+		    (or (and (boundp 'user-mail-address) user-mail-address)
-	       "\n(if (and (boundp 'emacs-version)\n"
+			(concat (user-login-name) "@" (system-name)))
-	       "\t (or (and (boundp 'epoch::version) epoch::version)\n"
+		    " on "
-	       "\t     (string-lessp emacs-version \"20\")))\n"
+		    (current-time-string) "\n;;; from file " filename "\n")
-	       "    (error \"`"
+	    (insert ";;; emacs version " emacs-version ".\n")
-	       ;; prin1-to-string is used to quote backslashes.
+	    (insert ";;; bytecomp version " byte-compile-version "\n;;; "
-	       (substring (prin1-to-string (file-name-nondirectory filename))
+		    (cond
-			  1 -1)
+		     ((eq byte-optimize 'source)
-	       "' was compiled for Emacs 20\"))\n\n"))
+		      "source-level optimization only")
-(insert "(or (boundp 'current-load-list) (setq current-load-list nil))\n"
+		     ((eq byte-optimize 'byte) "byte-level optimization only")
-	   "\n")
+		     (byte-optimize "optimization is on")
-(if (and (byte-compile-version-cond byte-compile-emacs19-compatibility)
+		     (t "optimization is off"))
-	    dynamic-docstrings)
+		    "\n")))
-(insert ";;; this file uses opcodes which do not exist prior to\n"
-	       ";;; XEmacs 19.14/GNU Emacs 19.29 or later."
+;; We won't trip this unless the byte-compiler changes, in which case
-	       ;; Have to check if emacs-version is bound so that this works
+;; it's just a matter of upping the space.
-	       ;; in files loaded early in loadup.el.
+(assert (natnump (- (1+ byte-compile-checks-and-comments-space) (point)))
-	       "\n(if (and (boundp 'emacs-version)\n"
+	    t "Not enough space for the feature checks!")
-	       "\t (or (and (boundp 'epoch::version) epoch::version)\n"
-	       "\t     (and (not (string-match \"XEmacs\" emacs-version))\n"
+(if (natnump (- (1+ byte-compile-checks-and-comments-space)
-	       "\t          (string-lessp emacs-version \"19.29\"))\n"
+		    (+ (point) (length comments))))
-	       "\t     (string-lessp emacs-version \"19.14\")))\n"
+	(insert comments))
-	       "    (error \"`"
+(insert-char ?\  (- (1+ byte-compile-checks-and-comments-space)
-	       ;; prin1-to-string is used to quote backslashes.
+			(point)))))
-	       (substring (prin1-to-string (file-name-nondirectory filename))
-			  1 -1)
+(defun byte-compile-maybe-reset-coding (byte-compile-inbuffer
-	       "' was compiled for XEmacs 19.14/Emacs 19.29 or later\"))\n\n"
+					byte-compile-outbuffer)
-	       )
+;; We also reserve some space for the feature checks:
-))
+(goto-char 1)
+(insert-char ?\  byte-compile-checks-and-comments-space)
-;; 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.
 (if (or (featurep '(not mule)) ;; Don't scan buffer if we are not muleized
 (and
 	   (not byte-compile-force-escape-quoted)
 	   (save-excursion
 	     (set-buffer byte-compile-inbuffer)
 	     ;; escapes. Any such occurrences in a @#COUNT comment will lead
 	     ;; to an escape-quoted coding cookie being inserted, but this is
 	     ;; 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)
 		   (skip-chars-backward "^;" (point-at-bol))
 		   (if (bolp) (throw 'need-to-escape-quote nil))
 		   (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
+(pushnew '(featurep 'mule) byte-compile-checks-on-load)
-;; mrb - Fix this someday.
 (save-excursion
 (set-buffer byte-compile-inbuffer)
 (setq byte-compile-dynamic nil
-	    byte-compile-dynamic-docstrings nil))
+	    byte-compile-dynamic-docstrings nil))))
-;;(external-debugging-output (prin1-to-string (buffer-local-variables))))
-)
-)
 (defun byte-compile-output-file-form (form)
 ;; writes the given form to the output buffer, being careful of docstrings
 ;; in defun, defmacro, defvar, defconst and autoload because make-docfile is
 ;; so amazingly stupid.
 (byte-defop-compiler delete-region	2+1)
 (byte-defop-compiler narrow-to-region	2+1)
 (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)
 ;;####(byte-defop-compiler move-to-column	1)
 (byte-defop-compiler-1 interactive byte-compile-noop)
 ;; compiler.  Note also that `%' is more efficient than `mod' because the
 ;; former is byte-coded and the latter is not.
 ;;(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))
 (defun byte-compile-no-args (form)
 (case (length (cdr form))
 (setq for-effect nil))
 (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)
 (byte-defop-compiler-1 and)
 (byte-defop-compiler-1 or)
 (defun byte-compile-progn (form)
 (byte-compile-body-do-effect (cdr form)))
 (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)
 `(byte-compile-goto
 (if ,cond
 (byte-compile-form (car (cdr form)))
 (byte-compile-out 'byte-temp-output-buffer-setup 0)
 (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
 (byte-defop-compiler-1 defun)
 (byte-defop-compiler-1 defmacro)
 (setq byte-compile-depth (- byte-compile-depth offset)))
 (byte-return
 ;; 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
 					   (symbol-value opcode))
 				     (- (1- offset))))

Mercurial > hg > xemacs-beta

comparison lisp/bytecomp.el @ 4677:8f1ee2d15784