[PATCH] C support for full Common Lisp multiple values.

This code runs but is not production-ready; see http://mid.gmane.org/18912.40510.593475.645687＠parhasard.net for my motivation in posting it now. In particular, it needs tests, and it also needs to add some code at the start of any byte-compiled files that use the multiple value functionality to bomb out if the current XEmacs does not support them. My thinking for the tests was to change #'floor and #'ceiling to actually return the multiple values as specified by CL, and to look at CLTL and the hyperspec for examples of what should be checked. diff -r a1dd514df5c6 etc/gdbinit.in --- a/etc/gdbinit.in Sun Mar 08 22:52:13 2009 +0200 +++ b/etc/gdbinit.in Sat Apr 11 14:34:47 2009 +0100 ＠＠ -71,6 +71,8 ＠＠ #endif set $Lisp_Type_Int = -2 +set $Lisp_Type_Record = 0 +set $Lisp_Type_Char = 2 define decode_object set $obj = (unsigned long) $arg0 ＠＠ -80,7 +82,7 ＠＠ set $type = $Lisp_Type_Int else set $type = $obj & dbg_typemask - if $type == Lisp_Type_Char + if $type == $Lisp_Type_Char set $val = ($obj & dbg_valmask) >> dbg_gctypebits else ## It's a record pointer ＠＠ -88,7 +90,7 ＠＠ end end - if $type == Lisp_Type_Record + if $type == $Lisp_Type_Record set $lheader = ((struct lrecord_header *) $val) set $lrecord_type = ($lheader->type) set $imp = ((struct lrecord_implementation *) lrecord_implementations_table[(int) $lrecord_type]) ＠＠ -115,7 +117,7 ＠＠ if $type == $Lisp_Type_Int echo int\n else - if $type == Lisp_Type_Char + if $type == $Lisp_Type_Char echo char\n else printf "record type: %s\n", $imp->name ＠＠ -264,7 +266,7 ＠＠ if $type == $Lisp_Type_Int printf "Integer: %d\n", $val else - if $type == Lisp_Type_Char + if $type == $Lisp_Type_Char if $val > 32 && $val < 128 printf "Char: %c\n", $val else ＠＠ -393,6 +395,8 ＠＠ else if $lrecord_type == lrecord_type_subr pptype Lisp_Subr + if $lrecord_type == lrecord_type_multiple_value + pptype multiple_value else if $lrecord_type == lrecord_type_symbol_value_buffer_local pstructtype symbol_value_buffer_local ＠＠ -493,6 +497,7 ＠＠ end end end + end end document pobj diff -r a1dd514df5c6 lisp/byte-optimize.el --- a/lisp/byte-optimize.el Sun Mar 08 22:52:13 2009 +0200 +++ b/lisp/byte-optimize.el Sat Apr 11 14:34:47 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 a1dd514df5c6 lisp/bytecomp.el --- a/lisp/bytecomp.el Sun Mar 08 22:52:13 2009 +0200 +++ b/lisp/bytecomp.el Sat Apr 11 14:34:47 2009 +0100 ＠＠ -733,7 +733,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) ＠＠ -1718,9 +1721,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 ＠＠ -3081,6 +3082,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) ＠＠ -3099,11 +3105,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)) ＠＠ -3638,6 +3647,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) ＠＠ -3657,13 +3669,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) ＠＠ -3949,6 +3984,56 ＠＠ (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))))) + +(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))) + +(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)))  ;;; top-level forms elsewhere ＠＠ -4112,6 +4197,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 a1dd514df5c6 lisp/cl-compat.el --- a/lisp/cl-compat.el Sun Mar 08 22:52:13 2009 +0200 +++ b/lisp/cl-compat.el Sat Apr 11 14:34:47 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)))) ＠＠ -127,22 +85,22 ＠＠ ;;; 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 +109,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 a1dd514df5c6 lisp/cl-macs.el --- a/lisp/cl-macs.el Sun Mar 08 22:52:13 2009 +0200 +++ b/lisp/cl-macs.el Sat Apr 11 14:34:47 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. diff -r a1dd514df5c6 lisp/cl.el --- a/lisp/cl.el Sun Mar 08 22:52:13 2009 +0200 +++ b/lisp/cl.el Sat Apr 11 14:34:47 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 a1dd514df5c6 lisp/help.el --- a/lisp/help.el Sun Mar 08 22:52:13 2009 +0200 +++ b/lisp/help.el Sat Apr 11 14:34:47 2009 +0100 ＠＠ -1402,7 +1402,7 ＠＠ (cond ((eq 'neither macro-p) "") - (macrop " macro") + (macro-p " macro") (t " function")))) string))))) (cond ((or (stringp def) (vectorp def)) diff -r a1dd514df5c6 lisp/lisp-mode.el --- a/lisp/lisp-mode.el Sun Mar 08 22:52:13 2009 +0200 +++ b/lisp/lisp-mode.el Sat Apr 11 14:34:47 2009 +0100 ＠＠ -424,36 +424,54 ＠＠ 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> ;")))) ;; XEmacs change, based on Bob Weiner suggestion (defun eval-last-sexp (eval-last-sexp-arg-internal) ;dynamic scoping wonderment ＠＠ -463,31 +481,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 +514,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 a1dd514df5c6 lisp/mouse.el --- a/lisp/mouse.el Sun Mar 08 22:52:13 2009 +0200 +++ b/lisp/mouse.el Sat Apr 11 14:34:47 2009 +0100 ＠＠ -278,18 +278,25 ＠＠ (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 + (message "does the result string have newline? %S" + (string-match "\n" result-str)) (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 a1dd514df5c6 lisp/obsolete.el --- a/lisp/obsolete.el Sun Mar 08 22:52:13 2009 +0200 +++ b/lisp/obsolete.el Sat Apr 11 14:34:47 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 a1dd514df5c6 man/cl.texi --- a/man/cl.texi Sun Mar 08 22:52:13 2009 +0200 +++ b/man/cl.texi Sat Apr 11 14:34:47 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 a1dd514df5c6 src/bytecode.c --- a/src/bytecode.c Sun Mar 08 22:52:13 2009 +0200 +++ b/src/bytecode.c Sat Apr 11 14:34:47 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: ＠＠ -960,7 +996,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 +1004,7 ＠＠ case Bdup: { - Lisp_Object arg = TOP; + Lisp_Object arg = TOP_WITH_MULTIPLE_VALUES; PUSH (arg); break; } ＠＠ -978,17 +1014,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 +1042,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 +1120,7 ＠＠ DISCARD (1); goto list_loop; } - TOP = list; + TOP_LVALUE = list; break; } ＠＠ -1097,101 +1138,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 +1246,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 +1260,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 +1275,7 ＠＠ case Bmin: { Lisp_Object arg = POP; - TOP = bytecode_arithop (TOP, arg, opcode); + TOP_LVALUE = bytecode_arithop (TOP, arg, opcode); break; } ＠＠ -1239,7 +1286,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 +1295,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 +1318,7 ＠＠ Lisp_Object arg = POP; /* Fset may call magic handlers */ /* GCPRO_STACK; */ - TOP = Fset (TOP, arg); + TOP_LVALUE = Fset (TOP, arg); break; } ＠＠ -1278,21 +1327,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 +1350,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 +1370,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 +1386,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 +1439,8 ＠＠ const Opbyte *UNUSED (program_ptr), Opcode opcode) { + REGISTER int n; + switch (opcode) { ＠＠ -1403,7 +1454,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 +1467,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 +1486,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 +1494,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 +1546,7 ＠＠ { Lisp_Object arg2 = POP; Lisp_Object arg1 = POP; - TOP = Fsubstring (TOP, arg1, arg2); + TOP_LVALUE = Fsubstring (TOP, arg1, arg2); break; } ＠＠ -1504,11 +1555,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 +1600,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 +1659,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 a1dd514df5c6 src/callint.c --- a/src/callint.c Sun Mar 08 22:52:13 2009 +0200 +++ b/src/callint.c Sat Apr 11 14:34:47 2009 +0100 ＠＠ -398,7 +398,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; ＠＠ -914,7 +914,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 a1dd514df5c6 src/device-x.c --- a/src/device-x.c Sun Mar 08 22:52:13 2009 +0200 +++ b/src/device-x.c Sat Apr 11 14:34:47 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 a1dd514df5c6 src/eval.c --- a/src/eval.c Sun Mar 08 22:52:13 2009 +0200 +++ b/src/eval.c Sat Apr 11 14:34:47 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; ＠＠ -816,9 +826,11 ＠＠ from interpreted code. The byte compiler turns them into bytecodes. */ DEFUN ("or", For, 0, UNEVALLED, 0, /* -Eval args until one of them yields non-nil, then return that value. -The remaining args are not evalled at all. +Eval ARGS until one of them yields non-nil, then return that value. +The remaining ARGS are not evalled at all. If all args return nil, return nil. + +arguments: (&rest ARGS) */ (args)) { ＠＠ -827,7 +839,7 ＠＠ LIST_LOOP_2 (arg, args) { - if (!NILP (val = Feval (arg))) + if (!NILP (IGNORE_MULTIPLE_VALUES (val = Feval (arg)))) return val; } ＠＠ -835,9 +847,11 ＠＠ } DEFUN ("and", Fand, 0, UNEVALLED, 0, /* -Eval args until one of them yields nil, then return nil. -The remaining args are not evalled at all. +Eval ARGS until one of them yields nil, then return nil. +The remaining ARGS are not evalled at all. If no arg yields nil, return the last arg's value. + +arguments: (&rest ARGS) */ (args)) { ＠＠ -846,18 +860,20 ＠＠ LIST_LOOP_2 (arg, args) { - if (NILP (val = Feval (arg))) - return val; + if (NILP (IGNORE_MULTIPLE_VALUES (val = Feval (arg)))) + return val; } return val; } DEFUN ("if", Fif, 2, UNEVALLED, 0, /* -\(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE... +If COND yields non-nil, do THEN, else do ELSE. Returns the value of THEN or the value of the last of the ELSE's. THEN must be one expression, but ELSE... can be zero or more expressions. If COND yields nil, and there are no ELSE's, the value is nil. + +arguments: (COND THEN &rest ELSE) */ (args)) { ＠＠ -866,7 +882,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); ＠＠ -876,8 +892,10 ＠＠ but it helps for bootstrapping to have them ALWAYS defined. */ DEFUN ("when", Fwhen, 1, MANY, 0, /* -\(when COND BODY...): if COND yields non-nil, do BODY, else return nil. +If COND yields non-nil, do BODY, else return nil. BODY can be zero or more expressions. If BODY is nil, return nil. + +arguments: (COND &rest BODY) */ (int nargs, Lisp_Object *args)) { ＠＠ -895,8 +913,10 ＠＠ } DEFUN ("unless", Funless, 1, MANY, 0, /* -\(unless COND BODY...): if COND yields nil, do BODY, else return nil. +If COND yields nil, do BODY, else return nil. BODY can be zero or more expressions. If BODY is nil, return nil. + +arguments: (COND &rest BODY) */ (int nargs, Lisp_Object *args)) { ＠＠ -906,7 +926,7 ＠＠ } DEFUN ("cond", Fcond, 0, UNEVALLED, 0, /* -\(cond CLAUSES...): try each clause until one succeeds. +Try each clause until one succeeds. Each clause looks like (CONDITION BODY...). CONDITION is evaluated and, if the value is non-nil, this clause succeeds: then the expressions in BODY are evaluated and the last one's ＠＠ -914,6 +934,8 ＠＠ If no clause succeeds, cond returns nil. If a clause has one element, as in (CONDITION), CONDITION's value if non-nil is returned from the cond-form. + +arguments: (&rest CLAUSES) */ (args)) { ＠＠ -923,7 +945,7 ＠＠ LIST_LOOP_2 (clause, args) { CHECK_CONS (clause); - if (!NILP (val = Feval (XCAR (clause)))) + if (!NILP (IGNORE_MULTIPLE_VALUES (val = Feval (XCAR (clause))))) { if (!NILP (clause = XCDR (clause))) { ＠＠ -938,7 +960,9 ＠＠ } DEFUN ("progn", Fprogn, 0, UNEVALLED, 0, /* -\(progn BODY...): eval BODY forms sequentially and return value of last one. +Eval BODY forms sequentially and return value of last one. + +arguments: (&rest BODY) */ (args)) { ＠＠ -963,17 +987,18 ＠＠ DEFUN ("prog1", Fprog1, 1, UNEVALLED, 0, /* Similar to `progn', but the value of the first form is returned. -\(prog1 FIRST BODY...): All the arguments are evaluated sequentially. -The value of FIRST is saved during evaluation of the remaining args, -whose values are discarded. -*/ - (args)) -{ - /* This function can GC */ + +All the arguments are evaluated sequentially. The value of FIRST is saved +during evaluation of the remaining args, whose values are discarded. + +arguments: (FIRST &rest BODY) +*/ + (args)) +{ Lisp_Object val; - struct gcpro gcpro1; - - val = Feval (XCAR (args)); + struct gcpro gcpro1; + + val = IGNORE_MULTIPLE_VALUES (Feval (Fcar (args))); GCPRO1 (val); ＠＠ -988,9 +1013,11 ＠＠ DEFUN ("prog2", Fprog2, 2, UNEVALLED, 0, /* Similar to `progn', but the value of the second form is returned. -\(prog2 FIRST SECOND BODY...): All the arguments are evaluated sequentially. -The value of SECOND is saved during evaluation of the remaining args, -whose values are discarded. + +All the arguments are evaluated sequentially. The value of SECOND is saved +during evaluation of the remaining args, whose values are discarded. + +arguments: (FIRST SECOND &rest BODY) */ (args)) { ＠＠ -1000,7 +1027,9 ＠＠ Feval (XCAR (args)); args = XCDR (args); - val = Feval (XCAR (args)); + + val = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args))); + args = XCDR (args); GCPRO1 (val); ＠＠ -1015,11 +1044,13 ＠＠ } DEFUN ("let*", FletX, 1, UNEVALLED, 0, /* -\(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY. +Bind variables according to VARLIST then eval BODY. The value of the last form in BODY is returned. Each element of VARLIST is a symbol (which is bound to nil) or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM). Each VALUEFORM can refer to the symbols already bound by this VARLIST. + +arguments: (VARLIST &rest BODY) */ (args)) { ＠＠ -1043,7 +1074,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); ＠＠ -1055,11 +1086,13 ＠＠ } DEFUN ("let", Flet, 1, UNEVALLED, 0, /* -\(let VARLIST BODY...): bind variables according to VARLIST then eval BODY. +Bind variables according to VARLIST then eval BODY. The value of the last form in BODY is returned. Each element of VARLIST is a symbol (which is bound to nil) or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM). All the VALUEFORMs are evalled before any symbols are bound. + +arguments: (VARLIST &rest BODY) */ (args)) { ＠＠ -1099,7 +1132,7 ＠＠ else { CHECK_CONS (tem); - *value = Feval (XCAR (tem)); + *value = IGNORE_MULTIPLE_VALUES (Feval (XCAR (tem))); gcpro1.nvars = idx; if (!NILP (XCDR (tem))) ＠＠ -1124,9 +1157,11 ＠＠ } DEFUN ("while", Fwhile, 1, UNEVALLED, 0, /* -\(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat. +If TEST yields non-nil, eval BODY... and repeat. The order of execution is thus TEST, BODY, TEST, BODY and so on until TEST returns nil. + +arguments: (TEST &rest BODY) */ (args)) { ＠＠ -1134,7 +1169,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); ＠＠ -1166,6 +1201,7 ＠＠ GC_PROPERTY_LIST_LOOP_3 (symbol, val, args) { val = Feval (val); + val = IGNORE_MULTIPLE_VALUES (val); Fset (symbol, val); retval = val; } ＠＠ -1255,7 +1291,7 ＠＠ } DEFUN ("defvar", Fdefvar, 1, UNEVALLED, 0, /* -\(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable. +Define SYMBOL as a variable. You are not required to define a variable in order to use it, but the definition can supply documentation and an initial value in a way that tags can recognize. ＠＠ -1272,6 +1308,8 ＠＠ If INITVALUE is missing, SYMBOL's value is not set. In lisp-interaction-mode defvar is treated as defconst. + +arguments: (SYMBOL &optional INITVALUE DOCSTRING) */ (args)) { ＠＠ -1286,7 +1324,7 ＠＠ { struct gcpro gcpro1; GCPRO1 (val); - val = Feval (val); + val = IGNORE_MULTIPLE_VALUES (Feval (val)); Fset_default (sym, val); UNGCPRO; } ＠＠ -1310,8 +1348,7 ＠＠ } DEFUN ("defconst", Fdefconst, 2, UNEVALLED, 0, /* -\(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant -variable. +Define SYMBOL as a constant variable. The intent is that programs do not change this value, but users may. Always sets the value of SYMBOL to the result of evalling INITVALUE. If SYMBOL is buffer-local, its default value is what is set; ＠＠ -1325,6 +1362,8 ＠＠ their own values for such variables before loading the library. Since `defconst' unconditionally assigns the variable, it would override the user's choice. + +arguments: (SYMBOL &optional INITVALUE DOCSTRING) */ (args)) { ＠＠ -1334,6 +1373,8 ＠＠ struct gcpro gcpro1; GCPRO1 (val); + + val = IGNORE_MULTIPLE_VALUES (val); Fset_default (sym, val); ＠＠ -1637,10 +1678,10 ＠＠ LONGJMP (c->jmp, 1); } -static DECLARE_DOESNT_RETURN (throw_or_bomb_out (Lisp_Object, Lisp_Object, int, +DECLARE_DOESNT_RETURN (throw_or_bomb_out (Lisp_Object, Lisp_Object, int, Lisp_Object, Lisp_Object)); -static DOESNT_RETURN +DOESNT_RETURN throw_or_bomb_out (Lisp_Object tag, Lisp_Object val, int bomb_out_p, Lisp_Object sig, Lisp_Object data) { ＠＠ -1713,12 +1754,21 ＠＠ 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)) +{ + Lisp_Object tag, value; + 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); } ＠＠ -2334,7 +2384,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. ＠＠ -2353,7 +2404,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 { ＠＠ -2377,7 +2428,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); } } } ＠＠ -3639,7 +3690,7 ＠＠ { LIST_LOOP_2 (arg, original_args) { - *p++ = Feval (arg); + *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); gcpro1.nvars++; } } ＠＠ -3670,7 +3721,7 ＠＠ { LIST_LOOP_2 (arg, original_args) { - *p++ = Feval (arg); + *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); gcpro1.nvars++; } } ＠＠ -3703,7 +3754,7 ＠＠ { LIST_LOOP_2 (arg, original_args) { - *p++ = Feval (arg); + *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); gcpro1.nvars++; } } ＠＠ -3752,7 +3803,7 ＠＠ { LIST_LOOP_2 (arg, original_args) { - *p++ = Feval (arg); + *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg)); gcpro1.nvars++; } } ＠＠ -3932,6 +3983,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 ＠＠ -4212,7 +4269,6 ＠＠ } } - /* Apply lambda list FUN to the NARGS evaluated arguments in ARGS and return the result of evaluation. */ ＠＠ -4267,6 +4323,580 ＠＠ 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. + + 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); +} + +static 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; + or perhaps for the sake of not requiring me to understand the byte + compiler any more than I do now. */ + 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); }  ＠＠ -4285,6 +4915,8 ＠＠ To make a hook variable buffer-local, use `make-local-hook', not `make-local-variable'. + +arguments: (&rest HOOKS) */ (int nargs, Lisp_Object *args)) { ＠＠ -4309,6 +4941,8 ＠＠ To make a hook variable buffer-local, use `make-local-hook', not `make-local-variable'. + +arguments: (HOOK &rest ARGS) */ (int nargs, Lisp_Object *args)) { ＠＠ -4325,6 +4959,8 ＠＠ To make a hook variable buffer-local, use `make-local-hook', not `make-local-variable'. + +arguments: (HOOK &rest ARGS) */ (int nargs, Lisp_Object *args)) { ＠＠ -4341,6 +4977,8 ＠＠ To make a hook variable buffer-local, use `make-local-hook', not `make-local-variable'. + +arguments: (HOOK &rest ARGS) */ (int nargs, Lisp_Object *args)) { ＠＠ -4934,7 +5572,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); } ＠＠ -6521,6 +7159,7 ＠＠ syms_of_eval (void) { INIT_LRECORD_IMPLEMENTATION (subr); + INIT_LRECORD_IMPLEMENTATION (multiple_value); DEFSYMBOL (Qinhibit_quit); DEFSYMBOL (Qautoload); ＠＠ -6544,6 +7183,8 ＠＠ DEFSYMBOL (Qrun_hooks); DEFSYMBOL (Qfinalize_list); DEFSYMBOL (Qif); + DEFSYMBOL (Qthrow); + DEFSYMBOL (Qobsolete_throw); DEFSUBR (For); DEFSUBR (Fand); ＠＠ -6577,6 +7218,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); ＠＠ -6602,6 +7248,9 ＠＠ debug_on_next_call = 0; lisp_eval_depth = 0; entering_debugger = 0; + + first_desired_multiple_value = 0; + multiple_value_current_limit = 1; } void ＠＠ -6766,6 +7415,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 a1dd514df5c6 src/event-msw.c --- a/src/event-msw.c Sun Mar 08 22:52:13 2009 +0200 +++ b/src/event-msw.c Sat Apr 11 14:34:47 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 a1dd514df5c6 src/event-stream.c --- a/src/event-stream.c Sun Mar 08 22:52:13 2009 +0200 +++ b/src/event-stream.c Sat Apr 11 14:34:47 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 a1dd514df5c6 src/floatfns.c --- a/src/floatfns.c Sun Mar 08 22:52:13 2009 +0200 +++ b/src/floatfns.c Sat Apr 11 14:34:47 2009 +0100 ＠＠ -848,16 +848,45 ＠＠ #endif /* ! HAVE_LOGB */ } -DEFUN ("ceiling", Fceiling, 1, 1, 0, /* -Return the smallest integer no less than NUMBER. (Round toward +inf.) +DEFUN ("ceiling", Fceiling, 1, 2, 0, /* +Return the smallest integer no less than NUMBER. + +With optional argument DIVISOR, return the smallest integer no less than +NUMBER divided by DIVISOR. + +This function returns multiple values; see `multiple-value-call' and +`multiple-value-bind'. The returned value is the remainder in the +calculation. */ - (number)) + (number, divisor)) { + Lisp_Object res0, original_number = number; + + if (!NILP (divisor)) + { + Lisp_Object quoargs[2]; + + if (!FLOATP (number)) + { + CHECK_NUMBER (divisor); + + promote_args (&number, &divisor); + quoargs[0] = divisor; + quoargs[1] = number; + number = Fquo (2, quoargs); + } + else + { + + } + } + if (FLOATP (number)) { double d; IN_FLOAT ((d = ceil (XFLOAT_DATA (number))), "ceiling", number); - return (float_to_int (d, "ceiling", number, Qunbound)); + return values2 (float_to_int (d, "ceiling", number, Qunbound), + make_float (XFLOAT_DATA (number) - d)); } #ifdef HAVE_BIGNUM ＠＠ -865,14 +894,23 ＠＠ #else if (INTP (number)) #endif - return number; + return values2 (number, Qzero); #ifdef HAVE_RATIO if (RATIOP (number)) { + enum number_type nt; bignum_ceil (scratch_bignum, XRATIO_NUMERATOR (number), XRATIO_DENOMINATOR (number)); - return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + res0 = make_bignum_bg (scratch_bignum); + + nt = promote_args (&res0, &number); + assert (RATIO_T == nt); + + ratio_sub (scratch_ratio, XRATIO_DATA (number), XRATIO_DATA (res0)); + + return values2 (Fcanonicalize_number (res0), + Fcanonicalize_number (make_ratio_rt (scratch_ratio))); } #endif ＠＠ -881,16 +919,24 ＠＠ { bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number)); bigfloat_ceil (scratch_bigfloat, XBIGFLOAT_DATA (number)); + #ifdef HAVE_BIGNUM bignum_set_bigfloat (scratch_bignum, scratch_bigfloat); - return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); + res0 = make_bignum_bg (scratch_bignum); #else - return make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat)); + res0 = make_int ((EMACS_INT) bigfloat_to_long (scratch_bigfloat)); #endif /* HAVE_BIGNUM */ + bigfloat_sub (scratch_bigfloat, + XBIGFLOAT_DATA (number), + scratch_bigfloat); + + return + values2 (Fcanonicalize_number (res0), + Fcanonicalize_number (make_bigfloat_bf (scratch_bigfloat))); } #endif /* HAVE_BIGFLOAT */ - return Fceiling (wrong_type_argument (Qnumberp, number)); + return Fceiling (wrong_type_argument (Qnumberp, original_number), divisor); } diff -r a1dd514df5c6 src/glade.c --- a/src/glade.c Sun Mar 08 22:52:13 2009 +0200 +++ b/src/glade.c Sat Apr 11 14:34:47 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 a1dd514df5c6 src/glyphs-widget.c --- a/src/glyphs-widget.c Sun Mar 08 22:52:13 2009 +0200 +++ b/src/glyphs-widget.c Sat Apr 11 14:34:47 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 a1dd514df5c6 src/glyphs.c --- a/src/glyphs.c Sun Mar 08 22:52:13 2009 +0200 +++ b/src/glyphs.c Sat Apr 11 14:34:47 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 a1dd514df5c6 src/gui-x.c --- a/src/gui-x.c Sun Mar 08 22:52:13 2009 +0200 +++ b/src/gui-x.c Sat Apr 11 14:34:47 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 a1dd514df5c6 src/gui.c --- a/src/gui.c Sun Mar 08 22:52:13 2009 +0200 +++ b/src/gui.c Sat Apr 11 14:34:47 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 a1dd514df5c6 src/inline.c --- a/src/inline.c Sun Mar 08 22:52:13 2009 +0200 +++ b/src/inline.c Sat Apr 11 14:34:47 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 a1dd514df5c6 src/lisp.h --- a/src/lisp.h Sun Mar 08 22:52:13 2009 +0200 +++ b/src/lisp.h Sat Apr 11 14:34:47 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 a1dd514df5c6 src/lread.c --- a/src/lread.c Sun Mar 08 22:52:13 2009 +0200 +++ b/src/lread.c Sat Apr 11 14:34:47 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 a1dd514df5c6 src/lrecord.h --- a/src/lrecord.h Sun Mar 08 22:52:13 2009 +0200 +++ b/src/lrecord.h Sat Apr 11 14:34:47 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 a1dd514df5c6 src/macros.c --- a/src/macros.c Sun Mar 08 22:52:13 2009 +0200 +++ b/src/macros.c Sat Apr 11 14:34:47 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 a1dd514df5c6 src/menubar-gtk.c --- a/src/menubar-gtk.c Sun Mar 08 22:52:13 2009 +0200 +++ b/src/menubar-gtk.c Sat Apr 11 14:34:47 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 a1dd514df5c6 src/menubar-msw.c --- a/src/menubar-msw.c Sun Mar 08 22:52:13 2009 +0200 +++ b/src/menubar-msw.c Sat Apr 11 14:34:47 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 a1dd514df5c6 src/print.c --- a/src/print.c Sun Mar 08 22:52:13 2009 +0200 +++ b/src/print.c Sat Apr 11 14:34:48 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 a1dd514df5c6 src/symbols.c --- a/src/symbols.c Sun Mar 08 22:52:13 2009 +0200 +++ b/src/symbols.c Sat Apr 11 14:34:48 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 a1dd514df5c6 src/symeval.h --- a/src/symeval.h Sun Mar 08 22:52:13 2009 +0200 +++ b/src/symeval.h Sat Apr 11 14:34:48 2009 +0100 ＠＠ -488,6 +488,82 ＠＠ 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); + +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_ */ -- ¿Dónde estará ahora mi sobrino Yoghurtu Nghe, que tuvo que huir precipitadamente de la aldea por culpa de la escasez de rinocerontes? _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://calypso.tux.org/cgi-bin/mailman/listinfo/xemacs-patches