xemacs-beta: src/eval.c comparison

comparison src/eval.c @ 5118:e0db3c197671 ben-lisp-object

merge up to latest default branch, doesn't compile yet

author	Ben Wing <ben@xemacs.org>
date	Sat, 26 Dec 2009 21:18:49 -0600
parents	3742ea8250b5 17f7e9191c0b
children	623d57b7fbe8

comparison

equal deleted inserted replaced

-:3742ea8250b5
+:e0db3c197671
 Lisp_Object Qsetq;
 Lisp_Object Qdisplay_warning;
 Lisp_Object Vpending_warnings, Vpending_warnings_tail;
 Lisp_Object Qif;
+Lisp_Object Qthrow;
+Lisp_Object Qobsolete_throw;
+Lisp_Object Qmultiple_value_list_internal;
+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;
 /* Buffers, frames, windows, devices, and consoles created since most
 recent active
 static const struct memory_description subr_description[] = {
 { XD_DOC_STRING, offsetof (Lisp_Subr, doc), 0, { 0 }, XD_FLAG_NO_KKCC },
 { XD_END }
 };
-DEFINE_BASIC_LISP_OBJECT ("subr", subr,
+DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("subr", subr,
-				     0, print_subr, 0, 0, 0,
+					0, print_subr, 0, 0, 0,
-				     subr_description,
+					subr_description,
-				     Lisp_Subr);
+					Lisp_Subr);
 /************************************************************************/
 /*			 Entering the debugger				*/
 /************************************************************************/
 }
 /* Return 1 if an error with condition-symbols CONDITIONS,
 and described by SIGNAL-DATA, should skip the debugger
-according to debugger-ignore-errors.  */
+according to debug-ignored-errors.  */
 static int
 skip_debugger (Lisp_Object conditions, Lisp_Object data)
 {
 /* This function can GC */
 /* Except for Fprogn(), the basic special forms below are only called
 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.
+Eval ARGS until one of them yields non-nil, then return that value.
-The remaining args are not evalled at all.
+The remaining ARGS are not evalled at all.
 If all args return nil, return nil.
+Any multiple values from the last form, and only from the last form, are
+passed back.  See `values' and `multiple-value-bind'.
+arguments: (&rest ARGS)
 */
 (args))
 {
 /* This function can GC */
-REGISTER Lisp_Object val;
+Lisp_Object val = Qnil;
-LIST_LOOP_2 (arg, args)
+LIST_LOOP_3 (arg, args, tail)
 {
-if (!NILP (val = Feval (arg)))
+if (!NILP (IGNORE_MULTIPLE_VALUES (val = Feval (arg))))
-	return val;
+	{
-}
+	  if (NILP (XCDR (tail)))
+	    {
-return Qnil;
+	      /* Pass back multiple values if this is the last one: */
+	      return val;
+	    }
+	  return IGNORE_MULTIPLE_VALUES (val);
+	}
+}
+return val;
 }
 DEFUN ("and", Fand, 0, UNEVALLED, 0, /*
-Eval args until one of them yields nil, then return nil.
+Eval ARGS until one of them yields nil, then return nil.
-The remaining args are not evalled at all.
+The remaining ARGS are not evalled at all.
 If no arg yields nil, return the last arg's value.
+Any multiple values from the last form, and only from the last form, are
+passed back.  See `values' and `multiple-value-bind'.
+arguments: (&rest ARGS)
 */
 (args))
 {
 /* This function can GC */
-REGISTER Lisp_Object val = Qt;
+Lisp_Object val = Qt;
-LIST_LOOP_2 (arg, args)
+LIST_LOOP_3 (arg, args, tail)
 {
-if (NILP (val = Feval (arg)))
+if (NILP (IGNORE_MULTIPLE_VALUES (val = Feval (arg))))
-	return val;
+	{
+	  if (NILP (XCDR (tail)))
+	    {
+	      /* Pass back any multiple values for the last form: */
+	      return val;
+	    }
+	  return Qnil;
+	}
 }
 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))
 {
 /* This function can GC */
 Lisp_Object condition  = XCAR (args);
 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);
 }
 /* Macros `when' and `unless' are trivially defined in Lisp,
 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))
 {
 Lisp_Object cond = args[0];
 Lisp_Object body;
 return list3 (Qif, cond, body);
 }
 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))
 {
 Lisp_Object cond = args[0];
 Lisp_Object body = Flist (nargs-1, args+1);
 return Fcons (Qif, Fcons (cond, Fcons (Qnil, body)));
 }
 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
 value is the value of the cond-form.
 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))
 {
 /* This function can GC */
 REGISTER Lisp_Object val;
 LIST_LOOP_2 (clause, args)
 {
 CHECK_CONS (clause);
-if (!NILP (val = Feval (XCAR (clause))))
+if (!NILP (val = IGNORE_MULTIPLE_VALUES (Feval (XCAR (clause)))))
 	{
 	  if (!NILP (clause = XCDR (clause)))
 	    {
 	      CHECK_TRUE_LIST (clause);
+	      /* Pass back any multiple values here: */
 	      val = Fprogn (clause);
 	    }
 	  return val;
 	}
 }
 return Qnil;
 }
 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))
 {
 /* This function can GC */
 /* Caller must provide a true list in ARGS */
 /* Fprog1() is the canonical example of a function that must GCPRO a
 Lisp_Object across calls to Feval(). */
 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,
+All the arguments are evaluated sequentially.  The value of FIRST is saved
-whose values are discarded.
+during evaluation of the remaining args, whose values are discarded.
+arguments: (FIRST &rest BODY)
 */
 (args))
 {
-/* This function can GC */
 Lisp_Object val;
 struct gcpro gcpro1;
-val = Feval (XCAR (args));
+val = IGNORE_MULTIPLE_VALUES (Feval (Fcar (args)));
 GCPRO1 (val);
 {
 LIST_LOOP_2 (form, XCDR (args))
 return val;
 }
 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,
+All the arguments are evaluated sequentially.  The value of SECOND is saved
-whose values are discarded.
+during evaluation of the remaining args, whose values are discarded.
+arguments: (FIRST SECOND &rest BODY)
 */
 (args))
 {
 /* This function can GC */
 Lisp_Object val;
 struct gcpro gcpro1;
 Feval (XCAR (args));
 args = XCDR (args);
-val = Feval (XCAR (args));
+val = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args)));
 args = XCDR (args);
 GCPRO1 (val);
 {
 UNGCPRO;
 return val;
 }
 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))
 {
 /* This function can GC */
 Lisp_Object varlist = XCAR (args);
 	  if (NILP (tem))
 	    value = Qnil;
 	  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);
 	    }
 	}
 }
 return unbind_to_1 (speccount, Fprogn (body));
 }
 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))
 {
 /* This function can GC */
 Lisp_Object varlist = XCAR (args);
 	    if (NILP (tem))
 	      *value = Qnil;
 	    else
 	      {
 		CHECK_CONS (tem);
-		*value = Feval (XCAR (tem));
+*value = IGNORE_MULTIPLE_VALUES (Feval (XCAR (tem)));
 		gcpro1.nvars = idx;
 		if (!NILP (XCDR (tem)))
 		  sferror
 		    ("`let' bindings can have only one value-form", var);
 return unbind_to_1 (speccount, Fprogn (body));
 }
 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))
 {
 /* This function can GC */
 Lisp_Object test = XCAR (args);
 Lisp_Object body = XCDR (args);
-while (!NILP (Feval (test)))
+while (!NILP (IGNORE_MULTIPLE_VALUES (Feval (test))))
 {
 QUIT;
 Fprogn (body);
 }
 Fsignal (Qwrong_number_of_arguments, list2 (Qsetq, make_int (nargs)));
 GC_PROPERTY_LIST_LOOP_3 (symbol, val, args)
 {
 val = Feval (val);
+val = IGNORE_MULTIPLE_VALUES (val);
 Fset (symbol, val);
 retval = val;
 }
 END_GC_PROPERTY_LIST_LOOP (symbol);
 return retval;
 }
 DEFUN ("quote", Fquote, 1, UNEVALLED, 0, /*
 Return the argument, without evaluating it.  `(quote x)' yields `x'.
+`quote' differs from `function' in that it is a hint that an expression is
+data, not a function.  In particular, under some circumstances the byte
+compiler will compile an expression quoted with `function', but it will
+never do so for an expression quoted with `quote'.  These issues are most
+important for lambda expressions (see `lambda').
+There is an alternative, more readable, reader syntax for `quote':  a Lisp
+object preceded by `''. Thus, `'x' is equivalent to `(quote x)', in all
+contexts.  A print function may use either.  Internally the expression is
+represented as `(quote x)').
 */
 (args))
 {
 return XCAR (args);
 }
+/* Originally, this was just a function -- but `custom' used a garden-
+variety version, so why not make it a subr?  */
+DEFUN ("quote-maybe", Fquote_maybe, 1, 1, 0, /*
+Quote EXPR if it is not self quoting.
+In contrast with `quote', this is a function, not a special form; its
+argument is evaluated before `quote-maybe' is called.  It returns either
+EXPR (if it is self-quoting) or a list `(quote EXPR)' if it is not
+self-quoting.  Lists starting with the symbol `lambda' are regarded as
+self-quoting.
+*/
+(expr))
+{
+if ((XTYPE (expr)) == Lisp_Type_Record)
+{
+switch (XRECORD_LHEADER (expr)->type)
+{
+case lrecord_type_symbol:
+if (NILP (expr) || (EQ (expr, Qt)) || SYMBOL_IS_KEYWORD (expr))
+{
+return expr;
+}
+break;
+case lrecord_type_cons:
+if (EQ (XCAR (expr), Qlambda))
+{
+return expr;
+}
+break;
+case lrecord_type_vector:
+case lrecord_type_string:
+case lrecord_type_compiled_function:
+case lrecord_type_bit_vector:
+case lrecord_type_float:
+case lrecord_type_hash_table:
+case lrecord_type_char_table:
+case lrecord_type_range_table:
+case lrecord_type_bignum:
+case lrecord_type_ratio:
+case lrecord_type_bigfloat:
+return expr;
+}
+return list2 (Qquote, expr);
+}
+/* Fixnums and characters are self-quoting: */
+return expr;
+}
 DEFUN ("function", Ffunction, 1, UNEVALLED, 0, /*
-Like `quote', but preferred for objects which are functions.
+Return the argument, without evaluating it.  `(function x)' yields `x'.
-In byte compilation, `function' causes its argument to be compiled.
-`quote' cannot do that.
+`function' differs from `quote' in that it is a hint that an expression is
+a function, not data.  In particular, under some circumstances the byte
+compiler will compile an expression quoted with `function', but it will
+never do so for an expression quoted with `quote'.  However, the byte
+compiler will not compile an expression buried in a data structure such as
+a vector or a list which is not syntactically a function.  These issues are
+most important for lambda expressions (see `lambda').
+There is an alternative, more readable, reader syntax for `function':  a Lisp
+object preceded by `#''. Thus, #'x is equivalent to (function x), in all
+contexts.  A print function may use either.  Internally the expression is
+represented as `(function x)').
 */
 (args))
 {
 return XCAR (args);
 }
 /************************************************************************/
 static Lisp_Object
 define_function (Lisp_Object name, Lisp_Object defn)
 {
 Ffset (name, defn);
-LOADHIST_ATTACH (name);
+LOADHIST_ATTACH (Fcons (Qdefun, name));
 return name;
 }
 DEFUN ("defun", Fdefun, 2, UNEVALLED, 0, /*
-\(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.
+Define NAME as a function.
 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
 See also the function `interactive'.
+arguments: (NAME ARGLIST &optional DOCSTRING &rest BODY)
 */
 (args))
 {
 /* This function can GC */
 return define_function (XCAR (args),
 			  Fcons (Qlambda, XCDR (args)));
 }
 DEFUN ("defmacro", Fdefmacro, 2, UNEVALLED, 0, /*
-\(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.
+Define NAME as a macro.
 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).
 When the macro is called, as in (NAME ARGS...),
 the function (lambda ARGLIST BODY...) is applied to
 the list ARGS... as it appears in the expression,
 and the result should be a form to be evaluated instead of the original.
+arguments: (NAME ARGLIST &optional DOCSTRING &rest BODY)
 */
 (args))
 {
 /* This function can GC */
 return define_function (XCAR (args),
 			  Fcons (Qmacro, Fcons (Qlambda, XCDR (args))));
 }
 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.
 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is
 If DOCSTRING starts with *, this variable is identified as a user option.
 This means that M-x set-variable recognizes it.
 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))
 {
 /* This function can GC */
 Lisp_Object sym = XCAR (args);
 if (NILP (Fdefault_boundp (sym)))
 	{
 	  struct gcpro gcpro1;
 	  GCPRO1 (val);
-	  val = Feval (val);
+	  val = IGNORE_MULTIPLE_VALUES (Feval (val));
 	  Fset_default (sym, val);
 	  UNGCPRO;
 	}
 if (!NILP (args = XCDR (args)))
 LOADHIST_ATTACH (sym);
 return sym;
 }
 DEFUN ("defconst", Fdefconst, 2, UNEVALLED, 0, /*
-\(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant
+Define SYMBOL as a constant variable.
-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;
 buffer-local values are not affected.
 DOCSTRING is optional.
 Note: do not use `defconst' for user options in libraries that are not
 normally loaded, since it is useful for users to be able to specify
 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))
 {
 /* This function can GC */
 Lisp_Object sym = XCAR (args);
 Lisp_Object val = Feval (XCAR (args = XCDR (args)));
 struct gcpro gcpro1;
 GCPRO1 (val);
+val = IGNORE_MULTIPLE_VALUES (val);
 Fset_default (sym, val);
 UNGCPRO;
 if (!NILP (args = XCDR (args)))
 LOADHIST_ATTACH (sym);
 return sym;
 }
-DEFUN ("user-variable-p", Fuser_variable_p, 1, 1, 0, /*
+/* XEmacs: user-variable-p is in symbols.c, since it needs to mess around
-Return t if VARIABLE is intended to be set and modified by users.
+with the symbol variable aliases. */
-\(The alternative is a variable used internally in a Lisp program.)
-Determined by whether the first character of the documentation
-for the variable is `*'.
-*/
-(variable))
-{
-Lisp_Object documentation = Fget (variable, Qvariable_documentation, Qnil);
-return
-((INTP (documentation) && XINT (documentation) < 0) ||
-(STRINGP (documentation) &&
-(string_byte (documentation, 0) == '*')) ||
-/* If (STRING . INTEGER), a negative integer means a user variable. */
-(CONSP (documentation)
-&& STRINGP (XCAR (documentation))
-&& INTP (XCDR (documentation))
-&& XINT (XCDR (documentation)) < 0)) ?
-Qt : Qnil;
-}
 DEFUN ("macroexpand-internal", Fmacroexpand_internal, 1, 2, 0, /*
 Return result of expanding macros at top level of FORM.
 If FORM is not a macro call, it is returned unchanged.
 Otherwise, the macro is expanded and the expansion is considered
 }
 #endif /* ERROR_CHECK_TRAPPING_PROBLEMS */
 DEFUN ("catch", Fcatch, 1, UNEVALLED, 0, /*
-\(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.
+Eval BODY allowing nonlocal exits using `throw'.
 TAG is evalled to get the tag to use.  Then the BODY is executed.
-Within BODY, (throw TAG) with same (`eq') tag exits BODY and this `catch'.
+Within BODY, (throw TAG VAL) with same (`eq') tag exits BODY and this `catch'.
 If no throw happens, `catch' returns the value of the last BODY form.
 If a throw happens, it specifies the value to return from `catch'.
+arguments: (TAG &rest BODY)
 */
 (args))
 {
 /* This function can GC */
 Lisp_Object tag  = Feval (XCAR (args));
 throw_level = 0;
 #endif
 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));
+					  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)
 {
 #ifdef DEFEND_AGAINST_THROW_RECURSION
 /* die if we recurse more than is reasonable */
 that is EQ() to TAG.  When it finds it, it will longjmp()
 back to the place that established the catch (in this case,
 condition_case_1).  See below for more info.
 */
-DEFUN_NORETURN ("throw", Fthrow, 2, 2, 0, /*
+DEFUN_NORETURN ("throw", Fthrow, 2, UNEVALLED, 0, /*
 Throw to the catch for TAG and return VALUE from it.
-Both TAG and VALUE are evalled.  Tags are the same iff they are `eq'.
+Both TAG and VALUE are evalled, and multiple values in VALUE will be passed
+back.  Tags are the same if and only if they are `eq'.
+arguments: (TAG VALUE)
 */
-(tag, value))
+(args))
 {
+int nargs;
+Lisp_Object tag, value;
+GET_LIST_LENGTH (args, nargs);
+if (nargs != 2)
+{
+Fsignal (Qwrong_number_of_arguments, list2 (Qthrow, make_int (nargs)));
+}
+tag = IGNORE_MULTIPLE_VALUES (Feval (XCAR(args)));
+value = Feval (XCAR (XCDR (args)));
 throw_or_bomb_out (tag, value, 0, Qnil, Qnil); /* Doesn't return */
 RETURN_NOT_REACHED (Qnil);
 }
 DEFUN ("unwind-protect", Funwind_protect, 1, UNEVALLED, 0, /*
 Do BODYFORM, protecting with UNWINDFORMS.
-Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).
 If BODYFORM completes normally, its value is returned
 after executing the UNWINDFORMS.
 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
+arguments: (BODYFORM &rest UNWINDFORMS)
 */
 (args))
 {
 /* This function can GC */
 int speccount = specpdl_depth();
 Lisp_Object handlers = XCDR (XCDR (args));
 return condition_case_3 (bodyform, var, handlers);
 }
 DEFUN ("call-with-condition-handler", Fcall_with_condition_handler, 2, MANY, 0, /*
-Regain control when an error is signalled, without popping the stack.
+Call FUNCTION with arguments ARGS, regaining control on error.
-Usage looks like (call-with-condition-handler HANDLER FUNCTION &rest ARGS).
-This function is similar to `condition-case', but the handler is invoked
+This function is similar to `condition-case', but HANDLER is invoked
 with the same environment (Lisp stack, bindings, catches, condition-cases)
 that was current when `signal' was called, rather than when the handler
 was established.
 HANDLER should be a function of one argument, which is a cons of the args
 `signal' is called (this differs from `condition-case', which allows
 you to specify which errors are trapped).  If the handler function
 returns, `signal' continues as if the handler were never invoked.
 \(It continues to look for handlers established earlier than this one,
 and invokes the standard error-handler if none is found.)
+arguments: (HANDLER FUNCTION &rest ARGS)
 */
 (int nargs, Lisp_Object *args)) /* Note!  Args side-effected! */
 {
 /* This function can GC */
 int speccount = specpdl_depth();
 just to bomb out immediately. */
 stderr_out ("Error before initialization is complete!\n");
 ABORT ();
 }
+#ifndef NEW_GC
 assert (!gc_in_progress);
+#endif /* not NEW_GC */
 /* We abort if in_display and we are not protected, as garbage
 collections and non-local exits will invariably be fatal, but in
 messy, difficult-to-debug ways.  See enter_redisplay_critical_section().
 */
 /* t is used by handlers for all conditions, set up by C code.
 *  debugger is not called even if debug_on_error */
 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.
 	 This is normally used for the outer command-loop error
 	 handler. */
 UNGCPRO;
 if (!UNBOUNDP (tem))
 return return_from_signal (tem);
 tem = Fcons (error_symbol, data);
-return Fthrow (handlers, tem);
+throw_or_bomb_out (handlers, tem, 0, Qnil, Qnil);
 }
 else
 	{
 /* handler established by real (Lisp) condition-case */
 Lisp_Object h;
 		  if (!UNBOUNDP (tem))
 return return_from_signal (tem);
 /* Doesn't return */
 tem = Fcons (Fcons (error_symbol, data), Fcdr (clause));
-return Fthrow (handlers, tem);
+throw_or_bomb_out (handlers, tem, 0, Qnil, Qnil);
 }
 	    }
 	}
 }
 (cmd, record_flag, keys))
 {
 /* This function can GC */
 Lisp_Object prefixarg;
 Lisp_Object final = cmd;
-struct backtrace backtrace;
+PROFILE_DECLARE();
 struct console *con = XCONSOLE (Vselected_console);
 prefixarg = con->prefix_arg;
 con->prefix_arg = Qnil;
 Vcurrent_prefix_arg = prefixarg;
 REGISTER int i = 0;
 int max_non_rest_args = f->args_in_array - 1;
 int bindargs = min (nargs, max_non_rest_args);
 for (i = 0; i < bindargs; i++)
+#ifdef NEW_GC
+SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i],
+			  args[i]);
+#else /* not NEW_GC */
 SPECBIND_FAST_UNSAFE (f->args[i], args[i]);
+#endif /* not NEW_GC */
 for (i = bindargs; i < max_non_rest_args; i++)
+#ifdef NEW_GC
+SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i],
+			  Qnil);
+#else /* not NEW_GC */
 SPECBIND_FAST_UNSAFE (f->args[i], Qnil);
+#endif /* not NEW_GC */
+#ifdef NEW_GC
+SPECBIND_FAST_UNSAFE
+(XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[max_non_rest_args],
+nargs > max_non_rest_args ?
+Flist (nargs - max_non_rest_args, &args[max_non_rest_args]) :
+Qnil);
+#else /* not NEW_GC */
 SPECBIND_FAST_UNSAFE
 (f->args[max_non_rest_args],
 nargs > max_non_rest_args ?
 Flist (nargs - max_non_rest_args, &args[max_non_rest_args]) :
 Qnil);
+#endif /* not NEW_GC */
 }
 /* Apply compiled-function object FUN to the NARGS evaluated arguments
 in ARGS, and return the result of evaluation. */
 inline static Lisp_Object
 if (nargs == f->max_args) /* Optimize for the common case -- no unspecified
 			       optional arguments. */
 {
 #if 1
 for (i = 0; i < nargs; i++)
+#ifdef NEW_GC
+	SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i],
+			      args[i]);
+#else /* not NEW_GC */
 	SPECBIND_FAST_UNSAFE (f->args[i], args[i]);
+#endif /* not NEW_GC */
 #else
 /* Here's an alternate way to write the loop that tries to further
 optimize funcalls for functions with few arguments by partially
 unrolling the loop.  It's not clear whether this is a win since it
 increases the size of the function and the possibility of L1 cache
 else if (nargs < f->min_args)
 goto wrong_number_of_arguments;
 else if (nargs < f->max_args)
 {
 for (i = 0; i < nargs; i++)
+#ifdef NEW_GC
+	SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i],
+			      args[i]);
+#else /* not NEW_GC */
 	SPECBIND_FAST_UNSAFE (f->args[i], args[i]);
+#endif /* not NEW_GC */
 for (i = nargs; i < f->max_args; i++)
+#ifdef NEW_GC
+	SPECBIND_FAST_UNSAFE (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i],
+			      Qnil);
+#else /* not NEW_GC */
 	SPECBIND_FAST_UNSAFE (f->args[i], Qnil);
+#endif /* not NEW_GC */
 }
 else if (f->max_args == MANY)
 handle_compiled_function_with_and_rest (f, nargs, args);
 else
 {
 (form))
 {
 /* This function can GC */
 Lisp_Object fun, val, original_fun, original_args;
 int nargs;
-struct backtrace backtrace;
+PROFILE_DECLARE();
 #ifdef ERROR_CHECK_TRAPPING_PROBLEMS
 check_proper_critical_section_lisp_protection ();
 #endif
+if (!CONSP (form))
+{
+if (SYMBOLP (form))
+{
+return Fsymbol_value (form);
+}
+return form;
+}
 /* I think this is a pretty safe place to call Lisp code, don't you? */
 while (!in_warnings && !NILP (Vpending_warnings)
 	 /* well, perhaps not so safe after all! */
 	 && !(inhibit_flags & INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY))
 call3 (Qdisplay_warning, class_, messij, level);
 UNGCPRO;
 unbind_to (speccount);
 }
-if (!CONSP (form))
-{
-if (SYMBOLP (form))
-	return Fsymbol_value (form);
-else
-	return form;
-}
 QUIT;
 if (need_to_garbage_collect)
 {
 struct gcpro gcpro1;
 GCPRO1 (form);
+#ifdef NEW_GC
+gc_incremental ();
+#else /* not NEW_GC */
 garbage_collect_1 ();
+#endif /* not NEW_GC */
 UNGCPRO;
 }
 if (++lisp_eval_depth > max_lisp_eval_depth)
 {
 do_debug_on_call (Qt);
 /* At this point, only original_fun and original_args
 have values that will be used below. */
 retry:
-fun = indirect_function (original_fun, 1);
+/* Optimise for no indirection.  */
+fun = original_fun;
+if (SYMBOLP (fun) && !EQ (fun, Qunbound)
+&& (fun = XSYMBOL (fun)->function, SYMBOLP (fun)))
+{
+fun = indirect_function(original_fun, 1);
+}
 if (SUBRP (fun))
 {
 Lisp_Subr *subr = XSUBR (fun);
 int max_args = subr->max_args;
 	  gcpro1.nvars = 0;
 	  {
 	    LIST_LOOP_2 (arg, original_args)
 	      {
-		*p++ = Feval (arg);
+*p++ = IGNORE_MULTIPLE_VALUES (Feval (arg));
 		gcpro1.nvars++;
 	      }
 	  }
 	  /* &optional args default to nil. */
 	  gcpro1.nvars = 0;
 	  {
 	    LIST_LOOP_2 (arg, original_args)
 	      {
-		*p++ = Feval (arg);
+*p++ = IGNORE_MULTIPLE_VALUES (Feval (arg));
 		gcpro1.nvars++;
 	      }
 	  }
 	  backtrace.args  = args;
 gcpro1.nvars = 0;
 {
 	LIST_LOOP_2 (arg, original_args)
 	  {
-	    *p++ = Feval (arg);
+*p++ = IGNORE_MULTIPLE_VALUES (Feval (arg));
 	    gcpro1.nvars++;
 	  }
 }
 backtrace.args     = args;
 	  gcpro1.nvars = 0;
 	  {
 	    LIST_LOOP_2 (arg, original_args)
 	      {
-		*p++ = Feval (arg);
+*p++ = IGNORE_MULTIPLE_VALUES (Feval (arg));
 		gcpro1.nvars++;
 	      }
 	  }
 	  UNGCPRO;
 else
 	{
 	  goto invalid_function;
 	}
 }
-else /* ! (SUBRP (fun) || COMPILED_FUNCTIONP (fun) || CONSP (fun)) */
+else if (UNBOUNDP (fun))
+{
+val = signal_void_function_error (original_fun);
+}
+else /* ! (SUBRP (fun) || COMPILED_FUNCTIONP (fun) || CONSP (fun)
+UNBOUNDP (fun)) */
 {
 invalid_function:
 val = signal_invalid_function_error (fun);
 }
 (Qgarbage_collecting, 2, args, RUN_HOOKS_TO_COMPLETION,
 INHIBIT_QUIT | NO_INHIBIT_ERRORS);
 }
 DEFUN ("funcall", Ffuncall, 1, MANY, 0, /*
-Call first argument as a function, passing the remaining arguments to it.
+Call FUNCTION as a function, passing the remaining arguments to it.
 Thus, (funcall 'cons 'x 'y) returns (x . y).
+arguments: (FUNCTION &rest ARGS)
 */
 (int nargs, Lisp_Object *args))
 {
 /* This function can GC */
 Lisp_Object fun;
 Lisp_Object val;
-struct backtrace backtrace;
+PROFILE_DECLARE();
 int fun_nargs = nargs - 1;
 Lisp_Object *fun_args = args + 1;
 /* QUIT will check for proper redisplay wrapping */
 if (funcall_allocation_flag)
 {
 if (need_to_garbage_collect)
 	/* Callers should gcpro lexpr args */
+#ifdef NEW_GC
+	gc_incremental ();
+#else /* not NEW_GC */
 	garbage_collect_1 ();
+#endif /* not NEW_GC */
 if (need_to_check_c_alloca)
 	{
 	  if (++funcall_alloca_count >= MAX_FUNCALLS_BETWEEN_ALLOCA_CLEANUP)
 	    {
 	      xemacs_c_alloca (0);
 	}
 if (need_to_signal_post_gc)
 	{
 	  need_to_signal_post_gc = 0;
 	  recompute_funcall_allocation_flag ();
+#ifdef NEW_GC
+	  run_finalizers ();
+#endif /* NEW_GC */
 	  run_post_gc_hook ();
 	}
 }
 if (++lisp_eval_depth > max_lisp_eval_depth)
 	  val = SUBR_FUNCTION (subr, MANY) (fun_nargs, fun_args);
 	  PROFILE_EXIT_FUNCTION ();
 	}
 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
 	{
 	wrong_number_of_arguments:
 DEFUN ("apply", Fapply, 2, MANY, 0, /*
 Call FUNCTION with the remaining args, using the last arg as a list of args.
 Thus, (apply '+ 1 2 '(3 4)) returns 10.
+arguments: (FUNCTION &rest ARGS)
 */
 (int nargs, Lisp_Object *args))
 {
 /* This function can GC */
 Lisp_Object fun = args[0];
 RETURN_UNGCPRO (Ffuncall (funcall_nargs, funcall_args));
 }
 }
 /* Apply lambda list FUN to the NARGS evaluated arguments in ARGS and
 return the result of evaluation. */
 static Lisp_Object
 funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object args[])
 invalid_function:
 return signal_invalid_function_error (fun);
 }
+/* Multiple values.
+A multiple value object is returned by #'values if:
+-- The number of arguments to #'values is not one, and:
+-- Some special form in the call stack is prepared to handle more than
+one multiple value.
+The return value of #'values-list is analogous to that of #'values.
+Henry Baker, in https://eprints.kfupm.edu.sa/31898/1/31898.pdf ("CONS
+Should not CONS its Arguments, or, a Lazy Alloc is a Smart Alloc", ACM
+Sigplan Notices 27,3 (March 1992),24-34.) says it should be possible to
+allocate Common Lisp multiple-value objects on the stack, but this
+assumes that variable-length records can be allocated on the stack,
+something not true for us. As far as I can tell, it also ignores the
+contexts where multiple-values need to be thrown, or maybe it thinks such
+objects should be converted to heap allocation at that point.
+The specific multiple values saved and returned depend on how many
+multiple-values special forms in the stack are interested in; for
+example, if #'multiple-value-call is somewhere in the call stack, all
+values passed to #'values will be saved and returned.  If an expansion of
+#'multiple-value-setq with 10 SYMS is the only part of the call stack
+interested in multiple values, then a maximum of ten multiple values will
+be saved and returned.
+(#'throw passes back multiple values in its VALUE argument; this is why
+we can't just take the details of the most immediate
+#'multiple-value-{whatever} call to work out which values to save, we
+need to look at the whole stack, or, equivalently, the dynamic variables
+we set to reflect the whole stack.)
+The first value passed to #'values will always be saved, since that is
+needed to convert a multiple value object into a single value object,
+something that is normally necessary independent of how many functions in
+the call stack are interested in multiple values.
+However many values (for values of "however many" that are not one) are
+saved and restored, the multiple value object knows how many arguments it
+would contain were none to have been discarded, and will indicate this
+on being printed from within GDB.
+In lisp-interaction-mode, no multiple values should be discarded (unless
+they need to be for the sake of the correctness of the program);
+#'eval-interactive-with-multiple-value-list in lisp-mode.el wraps its
+#'eval calls with #'multiple-value-list calls to avoid this. This means
+that there is a small performance and memory penalty for code evaluated
+in *scratch*; use M-: EXPRESSION RET if you really need to avoid
+this. Lisp code execution that is not ultimately from hitting C-j in
+*scratch*--that is, the vast vast majority of Lisp code execution--does
+not have this penalty.
+Probably the most important aspect of multiple values is stated with
+admirable clarity by CLTL2:
+"No matter how many values a form produces, if the form is an argument
+form in a function call, then exactly one value (the first one) is
+used."
+This means that most contexts, most of the time, will never see multiple
+values.  There are important exceptions; search the web for that text in
+quotation marks and read the related chapter. This code handles all of
+them, to my knowledge. Aidan Kehoe, Mon Mar 16 00:17:39 GMT 2009. */
+static Lisp_Object
+make_multiple_value (Lisp_Object first_value, Elemcount count,
+Elemcount first_desired, Elemcount upper_limit)
+{
+Bytecount sizem;
+struct multiple_value *mv;
+Elemcount i, allocated_count;
+Lisp_Object mvobj;
+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);
+mvobj = ALLOC_SIZED_LISP_OBJECT (sizem, multiple_value);
+mv = XMULTIPLE_VALUE (mvobj);
+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 mvobj;
+}
+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_DUMPABLE_SIZABLE_LISP_OBJECT ("multiple-value", multiple_value,
+					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, nargs;
+struct gcpro gcpro1;
+GET_LIST_LENGTH (args, nargs);
+if (nargs != 3)
+{
+Fsignal (Qwrong_number_of_arguments,
+list2 (Qmultiple_value_list_internal, make_int (nargs)));
+}
+argv[0] = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args)));
+CHECK_NATNUM (argv[0]);
+first = XINT (argv[0]);
+GCPRO1 (argv[0]);
+gcpro1.nvars = 1;
+args = XCDR (args);
+argv[1] = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args)));
+CHECK_NATNUM (argv[1]);
+upper = XINT (argv[1]);
+gcpro1.nvars = 2;
+/* The unintuitive order of things here is for the sake of the bytecode;
+the alternative would be to encode the number of arguments in the
+bytecode stream, which complicates things if we have more than 255
+arguments. */
+argv[2] = make_int (bind_multiple_value_limits (first, upper));
+gcpro1.nvars = 3;
+args = XCDR (args);
+/* GCPROing in this function is not strictly necessary, this Feval is the
+only point that may cons up data that is not immediately discarded, and
+within it is the only point (in Fmultiple_value_list_internal and
+multiple_value_list) that we can garbage collect. But I'm conservative,
+and this function is called so rarely (only from interpreted code) that
+it doesn't matter for performance. */
+argv[3] = Feval (XCAR (args));
+gcpro1.nvars = 4;
+RETURN_UNGCPRO (multiple_value_list_internal (countof (argv), argv));
+}
+DEFUN ("multiple-value-prog1", Fmultiple_value_prog1, 1, UNEVALLED, 0, /*
+Similar to `prog1', but return any multiple values from the first form.
+`prog1' itself will never return multiple values.
+arguments: (FIRST &rest BODY)
+*/
+(args))
+{
+/* This function can GC */
+Lisp_Object val;
+struct gcpro gcpro1;
+val = Feval (XCAR (args));
+GCPRO1 (val);
+{
+LIST_LOOP_2 (form, XCDR (args))
+Feval (form);
+}
+RETURN_UNGCPRO (val);
+}
+DEFUN ("values", Fvalues, 0, MANY, 0, /*
+Return all ARGS as multiple values.
+arguments: (&rest ARGS)
+*/
+(int nargs, Lisp_Object *args))
+{
+Lisp_Object result = Qnil;
+int counting = 1;
+/* Pathological cases, no need to cons up an object: */
+if (1 == nargs || 1 == multiple_value_current_limit)
+{
+return nargs ? args[0] : Qnil;
+}
+/* If nargs is zero, this code is correct and desirable.  With
+#'multiple-value-call, we want zero-length multiple values in the
+argument list to be discarded entirely, and we can't do this if we
+transform them to nil. */
+result = make_multiple_value (nargs ? args[0] : Qnil, nargs,
+first_desired_multiple_value,
+multiple_value_current_limit);
+for (; counting < nargs; ++counting)
+{
+if (counting >= first_desired_multiple_value &&
+counting < multiple_value_current_limit)
+{
+multiple_value_aset (result, counting, args[counting]);
+}
+}
+return result;
+}
+DEFUN ("values-list", Fvalues_list, 1, 1, 0, /*
+Return all the elements of LIST as multiple values.
+*/
+(list))
+{
+Lisp_Object result = Qnil;
+int counting = 1, listcount;
+GET_EXTERNAL_LIST_LENGTH (list, listcount);
+/* Pathological cases, no need to cons up an object: */
+if (1 == listcount || 1 == multiple_value_current_limit)
+{
+return Fcar_safe (list);
+}
+result = make_multiple_value (Fcar_safe (list), listcount,
+first_desired_multiple_value,
+multiple_value_current_limit);
+list = Fcdr_safe (list);
+{
+EXTERNAL_LIST_LOOP_2 (elt, list)
+{
+if (counting >= first_desired_multiple_value &&
+counting < multiple_value_current_limit)
+{
+multiple_value_aset (result, counting, elt);
+}
+++counting;
+}
+}
+return result;
+}
+Lisp_Object
+values2 (Lisp_Object first, Lisp_Object second)
+{
+Lisp_Object argv[2];
+argv[0] = first;
+argv[1] = second;
+return Fvalues (countof (argv), argv);
+}
 /************************************************************************/
 /*		     Run hook variables in various ways.		*/
 /************************************************************************/
 DEFUN ("run-hooks", Frun_hooks, 1, MANY, 0, /*
 If the value is a function, it is called with no arguments.
 If it is a list, the elements are called, in order, with no arguments.
 To make a hook variable buffer-local, use `make-local-hook',
 not `make-local-variable'.
+arguments: (FIRST &rest REST)
 */
 (int nargs, Lisp_Object *args))
 {
 REGISTER int i;
 It is best not to depend on the value returned by `run-hook-with-args',
 as that may change.
 To make a hook variable buffer-local, use `make-local-hook',
 not `make-local-variable'.
+arguments: (HOOK &rest ARGS)
 */
 (int nargs, Lisp_Object *args))
 {
 return run_hook_with_args (nargs, args, RUN_HOOKS_TO_COMPLETION);
 }
 returns a non-nil value.  Then we return that value.
 If all the functions return nil, we return nil.
 To make a hook variable buffer-local, use `make-local-hook',
 not `make-local-variable'.
+arguments: (HOOK &rest ARGS)
 */
 (int nargs, Lisp_Object *args))
 {
 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_SUCCESS);
 }
 returns nil.  Then we return nil.
 If all the functions return non-nil, we return non-nil.
 To make a hook variable buffer-local, use `make-local-hook',
 not `make-local-variable'.
+arguments: (HOOK &rest ARGS)
 */
 (int nargs, Lisp_Object *args))
 {
 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_FAILURE);
 }
 if (!initialized || preparing_for_armageddon)
 /* We need to bail out of here pronto. */
 return Qnil;
+#ifndef NEW_GC
 /* Whenever gc_in_progress is true, preparing_for_armageddon
 will also be true unless something is really hosed. */
 assert (!gc_in_progress);
+#endif /* not NEW_GC */
 sym = args[0];
 val = symbol_value_in_buffer (sym, wrap_buffer (buf));
 ret = (cond == RUN_HOOKS_UNTIL_FAILURE ? Qt : Qnil);
 else
 p->backtrace = Qnil;
 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);
 }
 static Lisp_Object
 call_trapping_problems_2 (Lisp_Object opaque)
 Lisp_Object opaque = XCAR (cons);
 Lisp_Object lval = XCDR (cons);
 int *addr = (int *) get_opaque_ptr (opaque);
 int val;
+/* In the event that a C integer will always fit in an Emacs int, we
+haven't ever stored a C integer as an opaque pointer. This #ifdef
+eliminates a warning on AMD 64, where EMACS_INT has 63 value bits and C
+integers have 32 value bits.  */
+#if INT_VALBITS < INTBITS
 if (INTP (lval))
-val = XINT (lval);
+{
+val = XINT (lval);
+}
 else
 {
 val = (int) get_opaque_ptr (lval);
 free_opaque_ptr (lval);
 }
+#else /* !(INT_VALBITS < INTBITS) */
+val = XINT(lval);
+#endif /* INT_VALBITS < INTBITS */
 *addr = val;
 free_opaque_ptr (opaque);
 free_cons (cons);
 return Qnil;
 record_unwind_protect_restoring_int (int *addr, int val)
 {
 Lisp_Object opaque = make_opaque_ptr (addr);
 Lisp_Object lval;
+/* In the event that a C integer will always fit in an Emacs int, we don't
+ever want to store a C integer as an opaque pointer. This #ifdef
+eliminates a warning on AMD 64, where EMACS_INT has 63 value bits and C
+integers have 32 value bits.  */
+#if INT_VALBITS <= INTBITS
 if (NUMBER_FITS_IN_AN_EMACS_INT (val))
 lval = make_int (val);
 else
 lval = make_opaque_ptr ((void *) val);
+#else /* !(INT_VALBITS < INTBITS) */
+lval = make_int (val);
+#endif /* INT_VALBITS <= INTBITS */
 return record_unwind_protect (restore_int, noseeum_cons (opaque, lval));
 }
 /* Similar to specbind() but for any C variable whose value is an int.
 Sets up an unwind-protect to restore the variable pointed to by
 void
 syms_of_eval (void)
 {
 INIT_LISP_OBJECT (subr);
+INIT_LISP_OBJECT (multiple_value);
 DEFSYMBOL (Qinhibit_quit);
 DEFSYMBOL (Qautoload);
 DEFSYMBOL (Qdebug_on_error);
 DEFSYMBOL (Qstack_trace_on_error);
 DEFSYMBOL (Qvalues);
 DEFSYMBOL (Qdisplay_warning);
 DEFSYMBOL (Qrun_hooks);
 DEFSYMBOL (Qfinalize_list);
 DEFSYMBOL (Qif);
+DEFSYMBOL (Qthrow);
+DEFSYMBOL (Qobsolete_throw);
+DEFSYMBOL (Qmultiple_value_list_internal);
 DEFSUBR (For);
 DEFSUBR (Fand);
 DEFSUBR (Fif);
 DEFSUBR_MACRO (Fwhen);
 DEFSUBR (Fprogn);
 DEFSUBR (Fprog1);
 DEFSUBR (Fprog2);
 DEFSUBR (Fsetq);
 DEFSUBR (Fquote);
+DEFSUBR (Fquote_maybe);
 DEFSUBR (Ffunction);
 DEFSUBR (Fdefun);
 DEFSUBR (Fdefmacro);
 DEFSUBR (Fdefvar);
 DEFSUBR (Fdefconst);
-DEFSUBR (Fuser_variable_p);
 DEFSUBR (Flet);
 DEFSUBR (FletX);
 DEFSUBR (Fwhile);
 DEFSUBR (Fmacroexpand_internal);
 DEFSUBR (Fcatch);
 DEFSUBR (Fcommandp);
 DEFSUBR (Fcommand_execute);
 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);
 DEFSUBR (Ffunction_max_args);
 DEFSUBR (Frun_hooks);
 backtrace_list = 0;
 Vquit_flag = Qnil;
 debug_on_next_call = 0;
 lisp_eval_depth = 0;
 entering_debugger = 0;
+first_desired_multiple_value = 0;
+multiple_value_current_limit = 1;
 }
 void
 reinit_vars_of_eval (void)
 {
 a `condition-case'.
 If the value is a list, an error only means to enter the debugger
 if one of its condition symbols appears in the list.
 This variable is overridden by `debug-ignored-errors'.
 See also variables `debug-on-quit' and `debug-on-signal'.
+Process filters are considered to be outside of condition-case forms
+(unless contained in the process filter itself).  To prevent the
+debugger from being called from a process filter, use a list value, or
+put the expected error\(s) in `debug-ignored-errors'.
 If this variable is set while XEmacs is running noninteractively (using
 `-batch'), and XEmacs was configured with `--debug' (#define XEMACS_DEBUG
 in the C code), instead of trying to invoke the Lisp debugger (which
 obviously won't work), XEmacs will break out to a C debugger using
 If due to `apply' or `funcall' entry, one arg, `lambda'.
 If due to `eval' entry, one arg, t.
 */ );
 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);
 staticpro (&Vpending_warnings);
 Vpending_warnings = Qnil;

Mercurial > hg > xemacs-beta

comparison src/eval.c @ 5118:e0db3c197671 ben-lisp-object