xemacs-beta: src/eval.c comparison

comparison src/eval.c @ 4677:8f1ee2d15784

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

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

comparison

equal deleted inserted replaced

-:e3feb329bda9
+:8f1ee2d15784
 Lisp_Object Qsetq;
 Lisp_Object Qdisplay_warning;
 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;
 /* Buffers, frames, windows, devices, and consoles created since most
 recent active
 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.
 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;
-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.
 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;
-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;
 }
 /* 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);
 }
 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;
 	}
 }
 (args))
 {
 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))
 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);
 {
 	  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);
 	    }
 	}
 	    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);
 {
 /* 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);
 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)))
 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;
 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, /*
 /* 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);
 }
 	    }
 	}
 }
 	  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;
 	  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:
 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[])
 wrong_number_of_arguments:
 return signal_wrong_number_of_arguments_error (fun, nargs);
 invalid_function:
 return signal_invalid_function_error (fun);
+}
+/* Multiple values.
+A multiple value object is returned by #'values if:
+-- The number of arguments to #'values is not one, and:
+-- Some special form in the call stack is prepared to handle more than
+one multiple value.
+The return value of #'values-list is analogous to that of #'values.
+Henry Baker, in https://eprints.kfupm.edu.sa/31898/1/31898.pdf ("CONS
+Should not CONS its Arguments, or, a Lazy Alloc is a Smart Alloc", ACM
+Sigplan Notices 27,3 (March 1992),24-34.) says it should be possible to
+allocate Common Lisp multiple-value objects on the stack, but this
+assumes that variable-length records can be allocated on the stack,
+something not true for us. As far as I can tell, it also ignores the
+contexts where multiple-values need to be thrown, or maybe it thinks such
+objects should be converted to heap allocation at that point.
+The specific multiple values saved and returned depend on how many
+multiple-values special forms in the stack are interested in; for
+example, if #'multiple-value-call is somewhere in the call stack, all
+values passed to #'values will be saved and returned.  If an expansion of
+#'multiple-value-setq with 10 SYMS is the only part of the call stack
+interested in multiple values, then a maximum of ten multiple values will
+be saved and returned.
+(#'throw passes back multiple values in its VALUE argument; this is why
+we can't just take the details of the most immediate
+#'multiple-value-{whatever} call to work out which values to save, we
+need to look at the whole stack, or, equivalently, the dynamic variables
+we set to reflect the whole stack.)
+The first value passed to #'values will always be saved, since that is
+needed to convert a multiple value object into a single value object,
+something that is normally necessary independent of how many functions in
+the call stack are interested in multiple values.
+However many values (for values of "however many" that are not one) are
+saved and restored, the multiple value object knows how many arguments it
+would contain were none to have been discarded, and will indicate this
+on being printed from within GDB.
+In lisp-interaction-mode, no multiple values should be discarded (unless
+they need to be for the sake of the correctness of the program);
+#'eval-interactive-with-multiple-value-list in lisp-mode.el wraps its
+#'eval calls with #'multiple-value-list calls to avoid this. This means
+that there is a small performance and memory penalty for code evaluated
+in *scratch*; use M-: EXPRESSION RET if you really need to avoid
+this. Lisp code execution that is not ultimately from hitting C-j in
+*scratch*--that is, the vast vast majority of Lisp code execution--does
+not have this penalty.
+Probably the most important aspect of multiple values is stated with
+admirable clarity by CLTL2:
+"No matter how many values a form produces, if the form is an argument
+form in a function call, then exactly one value (the first one) is
+used."
+This means that most contexts, most of the time, will never see multiple
+values.  There are important exceptions; search the web for that text in
+quotation marks and read the related chapter. This code handles all of
+them, to my knowledge. Aidan Kehoe, Mon Mar 16 00:17:39 GMT 2009. */
+static Lisp_Object
+make_multiple_value (Lisp_Object first_value, Elemcount count,
+Elemcount first_desired, Elemcount upper_limit)
+{
+Bytecount sizem;
+struct multiple_value *mv;
+Elemcount i, allocated_count;
+assert (count != 1);
+if (1 != upper_limit && (0 == first_desired))
+{
+/* We always allocate element zero, and that's taken into account when
+working out allocated_count: */
+first_desired = 1;
+}
+if (first_desired >= count)
+{
+/* We can't pass anything back that our caller is interested in. Only
+allocate for the first argument. */
+allocated_count = 1;
+}
+else
+{
+allocated_count = 1 + ((upper_limit > count ? count : upper_limit)
+- first_desired);
+}
+sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (multiple_value,
+Lisp_Object,
+contents, allocated_count);
+mv = (multiple_value *) BASIC_ALLOC_LCRECORD (sizem,
+&lrecord_multiple_value);
+mv->count = count;
+mv->first_desired = first_desired;
+mv->allocated_count = allocated_count;
+mv->contents[0] = first_value;
+for (i = first_desired; i < upper_limit && i < count; ++i)
+{
+mv->contents[1 + (i - first_desired)] = Qunbound;
+}
+return wrap_multiple_value (mv);
+}
+void
+multiple_value_aset (Lisp_Object obj, Elemcount index, Lisp_Object value)
+{
+struct multiple_value *mv = XMULTIPLE_VALUE (obj);
+Elemcount first_desired = mv->first_desired;
+Elemcount allocated_count = mv->allocated_count;
+if (index != 0 &&
+(index < first_desired || index >= (first_desired + allocated_count)))
+{
+args_out_of_range (make_int (first_desired),
+make_int (first_desired + allocated_count));
+}
+mv->contents[index == 0 ? 0 : 1 + (index - first_desired)] = value;
+}
+Lisp_Object
+multiple_value_aref (Lisp_Object obj, Elemcount index)
+{
+struct multiple_value *mv = XMULTIPLE_VALUE (obj);
+Elemcount first_desired = mv->first_desired;
+Elemcount allocated_count = mv->allocated_count;
+if (index != 0 &&
+(index < first_desired || index >= (first_desired + allocated_count)))
+{
+args_out_of_range (make_int (first_desired),
+make_int (first_desired + allocated_count));
+}
+return mv->contents[index == 0 ? 0 : 1 + (index - first_desired)];
+}
+static void
+print_multiple_value (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
+{
+struct multiple_value *mv = XMULTIPLE_VALUE (obj);
+Elemcount first_desired = mv->first_desired;
+Elemcount allocated_count = mv->allocated_count;
+Elemcount count = mv->count, index;
+if (print_readably)
+{
+printing_unreadable_object ("multiple values");
+}
+if (0 == count)
+{
+write_c_string (printcharfun, "#<zero-length multiple value>");
+}
+for (index = 0; index < count;)
+{
+if (index != 0 &&
+(index < first_desired ||
+index >= (first_desired + (allocated_count - 1))))
+{
+write_fmt_string (printcharfun, "#<discarded-multiple-value %d>",
+index);
+}
+else
+{
+print_internal (multiple_value_aref (obj, index),
+printcharfun, escapeflag);
+}
+++index;
+if (count > 1 && index < count)
+{
+write_c_string (printcharfun, " ;\n");
+}
+}
+}
+static Lisp_Object
+mark_multiple_value (Lisp_Object obj)
+{
+struct multiple_value *mv = XMULTIPLE_VALUE (obj);
+Elemcount index, allocated_count = mv->allocated_count;
+for (index = 0; index < allocated_count; ++index)
+{
+mark_object (mv->contents[index]);
+}
+return Qnil;
+}
+static Bytecount
+size_multiple_value (const void *lheader)
+{
+return FLEXIBLE_ARRAY_STRUCT_SIZEOF (struct multiple_value,
+Lisp_Object, contents,
+((struct multiple_value *) lheader)->
+allocated_count);
+}
+static const struct memory_description multiple_value_description[] = {
+{ XD_LONG, offsetof (struct multiple_value, count) },
+{ XD_ELEMCOUNT, offsetof (struct multiple_value, allocated_count) },
+{ XD_LONG, offsetof (struct multiple_value, first_desired) },
+{ XD_LISP_OBJECT_ARRAY, offsetof (struct multiple_value, contents),
+XD_INDIRECT (1, 0) },
+{ XD_END }
+};
+DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("multiple-value", multiple_value,
+					1, /*dumpable-flag*/
+					mark_multiple_value,
+print_multiple_value, 0,
+					0, /* No equal method. */
+					0, /* No hash method. */
+					multiple_value_description,
+					size_multiple_value,
+struct multiple_value);
+/* Given that FIRST and UPPER are the inclusive lower and exclusive upper
+bounds for the multiple values we're interested in, modify (or don't) the
+special variables used to indicate this to #'values and #'values-list.
+Returns the specpdl_depth() value before any modification. */
+int
+bind_multiple_value_limits (int first, int upper)
+{
+int result = specpdl_depth();
+if (!(upper > first))
+{
+invalid_argument ("MULTIPLE-VALUE-UPPER-LIMIT must be greater than "
+" FIRST-DESIRED-MULTIPLE-VALUE", Qunbound);
+}
+if (upper > Vmultiple_values_limit)
+{
+args_out_of_range (make_int (upper), make_int (Vmultiple_values_limit));
+}
+/* In the event that something back up the stack wants more multiple
+values than we do, we need to keep its figures for
+first_desired_multiple_value or multiple_value_current_limit both. It
+may be that the form will throw past us.
+If first_desired_multiple_value is zero, this means it hasn't ever been
+bound, and any value we have for first is appropriate to use.
+Zeroth element is always saved, no need to note that: */
+if (0 == first)
+{
+first = 1;
+}
+if (0 == first_desired_multiple_value
+|| first < first_desired_multiple_value)
+{
+internal_bind_int (&first_desired_multiple_value, first);
+}
+if (upper > multiple_value_current_limit)
+{
+internal_bind_int (&multiple_value_current_limit, upper);
+}
+return result;
+}
+Lisp_Object
+multiple_value_call (int nargs, Lisp_Object *args)
+{
+/* The argument order here is horrible: */
+int i, speccount = XINT (args[3]);
+Lisp_Object result = Qnil, head = Fcons (args[0], Qnil), list_offset;
+struct gcpro gcpro1, gcpro2;
+Lisp_Object apply_args[2];
+GCPRO2 (head, result);
+list_offset = head;
+assert (!(MULTIPLE_VALUEP (args[0])));
+CHECK_FUNCTION (args[0]);
+/* Start at 4, to ignore the function, the speccount, and the arguments to
+multiple-values-limit (which we don't discard because
+#'multiple-value-list-internal needs them): */
+for (i = 4; i < nargs; ++i)
+{
+result = args[i];
+if (MULTIPLE_VALUEP (result))
+{
+Lisp_Object val;
+Elemcount i, count = XMULTIPLE_VALUE_COUNT (result);
+for (i = 0; i < count; i++)
+{
+val = multiple_value_aref (result, i);
+assert (!UNBOUNDP (val));
+XSETCDR (list_offset, Fcons (val, Qnil));
+list_offset = XCDR (list_offset);
+}
+}
+else
+{
+XSETCDR (list_offset, Fcons (result, Qnil));
+list_offset = XCDR (list_offset);
+}
+}
+apply_args [0] = XCAR (head);
+apply_args [1] = XCDR (head);
+unbind_to (speccount);
+RETURN_UNGCPRO (Fapply (countof(apply_args), apply_args));
+}
+DEFUN ("multiple-value-call", Fmultiple_value_call, 1, UNEVALLED, 0, /*
+Call FUNCTION with arguments FORMS, using multiple values when returned.
+All of the (possibly multiple) values returned by each form in FORMS are
+gathered together, and given as arguments to FUNCTION; conceptually, this
+function is a version of `apply' that by-passes the multiple values
+infrastructure, treating multiple values as intercalated lists.
+arguments: (FUNCTION &rest FORMS)
+*/
+(args))
+{
+int listcount, i = 0, speccount;
+Lisp_Object *constructed_args;
+struct gcpro gcpro1;
+GET_EXTERNAL_LIST_LENGTH (args, listcount);
+constructed_args = alloca_array (Lisp_Object, listcount + 3);
+/* Fcar so we error on non-cons: */
+constructed_args[i] = IGNORE_MULTIPLE_VALUES (Feval (Fcar (args)));
+GCPRO1 (*constructed_args);
+gcpro1.nvars = ++i;
+/* The argument order is horrible here. */
+constructed_args[i] = make_int (0);
+gcpro1.nvars = ++i;
+constructed_args[i] = make_int (Vmultiple_values_limit);
+gcpro1.nvars = ++i;
+speccount = bind_multiple_value_limits (0, Vmultiple_values_limit);
+constructed_args[i] = make_int (speccount);
+gcpro1.nvars = ++i;
+{
+LIST_LOOP_2 (elt, XCDR (args))
+{
+constructed_args[i] = Feval (elt);
+gcpro1.nvars = ++i;
+}
+}
+RETURN_UNGCPRO (multiple_value_call (listcount + 3, constructed_args));
+}
+Lisp_Object
+multiple_value_list_internal (int nargs, Lisp_Object *args)
+{
+int first = XINT (args[0]), upper = XINT (args[1]),
+speccount = XINT(args[2]);
+Lisp_Object result = Qnil;
+assert (nargs == 4);
+result = args[3];
+unbind_to (speccount);
+if (MULTIPLE_VALUEP (result))
+{
+Lisp_Object head = Fcons (Qnil, Qnil);
+Lisp_Object list_offset = head, val;
+Elemcount count = XMULTIPLE_VALUE_COUNT(result);
+for (; first < upper && first < count; ++first)
+{
+val = multiple_value_aref (result, first);
+assert (!UNBOUNDP (val));
+XSETCDR (list_offset, Fcons (val, Qnil));
+list_offset = XCDR (list_offset);
+}
+return XCDR (head);
+}
+else
+{
+if (first == 0)
+	{
+return Fcons (result, Qnil);
+}
+else
+{
+return Qnil;
+}
+}
+}
+DEFUN ("multiple-value-list-internal", Fmultiple_value_list_internal, 3,
+UNEVALLED, 0, /*
+Evaluate FORM. Return a list of multiple vals reflecting the other two args.
+Don't use this.  Use `multiple-value-list', the macro specified by Common
+Lisp, instead.
+FIRST-DESIRED-MULTIPLE-VALUE is the first element in list of multiple values
+to pass back.  MULTIPLE-VALUE-UPPER-LIMIT is the exclusive upper limit on
+the indexes within the values that may be passed back; this function will
+never return a list longer than MULTIPLE-VALUE-UPPER-LIMIT -
+FIRST-DESIRED-MULTIPLE-VALUE.  It may return a list shorter than that, if
+`values' or `values-list' do not supply enough elements.
+arguments: (FIRST-DESIRED-MULTIPLE-VALUE MULTIPLE-VALUE-UPPER-LIMIT FORM)
+*/
+(args))
+{
+Lisp_Object argv[4];
+int first, upper;
+struct gcpro gcpro1;
+argv[0] = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args)));
+CHECK_NATNUM (argv[0]);
+first = XINT (argv[0]);
+GCPRO1 (argv[0]);
+gcpro1.nvars = 1;
+args = XCDR (args);
+argv[1] = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args)));
+CHECK_NATNUM (argv[1]);
+upper = XINT (argv[1]);
+gcpro1.nvars = 2;
+/* The unintuitive order of things here is for the sake of the bytecode;
+the alternative would be to encode the number of arguments in the
+bytecode stream, which complicates things if we have more than 255
+arguments. */
+argv[2] = make_int (bind_multiple_value_limits (first, upper));
+gcpro1.nvars = 3;
+args = XCDR (args);
+/* GCPROing in this function is not strictly necessary, this Feval is the
+only point that may cons up data that is not immediately discarded, and
+within it is the only point (in Fmultiple_value_list_internal and
+multiple_value_list) that we can garbage collect. But I'm conservative,
+and this function is called so rarely (only from interpreted code) that
+it doesn't matter for performance. */
+argv[3] = Feval (XCAR (args));
+gcpro1.nvars = 4;
+RETURN_UNGCPRO (multiple_value_list_internal (countof (argv), argv));
+}
+DEFUN ("multiple-value-prog1", Fmultiple_value_prog1, 1, UNEVALLED, 0, /*
+Similar to `prog1', but return any multiple values from the first form.
+`prog1' itself will never return multiple values.
+arguments: (FIRST &rest BODY)
+*/
+(args))
+{
+/* This function can GC */
+Lisp_Object val;
+struct gcpro gcpro1;
+val = Feval (XCAR (args));
+GCPRO1 (val);
+{
+LIST_LOOP_2 (form, XCDR (args))
+Feval (form);
+}
+RETURN_UNGCPRO (val);
+}
+DEFUN ("values", Fvalues, 0, MANY, 0, /*
+Return all ARGS as multiple values.
+arguments: (&rest ARGS)
+*/
+(int nargs, Lisp_Object *args))
+{
+Lisp_Object result = Qnil;
+int counting = 1;
+/* Pathological cases, no need to cons up an object: */
+if (1 == nargs || 1 == multiple_value_current_limit)
+{
+return nargs ? args[0] : Qnil;
+}
+/* If nargs is zero, this code is correct and desirable.  With
+#'multiple-value-call, we want zero-length multiple values in the
+argument list to be discarded entirely, and we can't do this if we
+transform them to nil. */
+result = make_multiple_value (nargs ? args[0] : Qnil, nargs,
+first_desired_multiple_value,
+multiple_value_current_limit);
+for (; counting < nargs; ++counting)
+{
+if (counting >= first_desired_multiple_value &&
+counting < multiple_value_current_limit)
+{
+multiple_value_aset (result, counting, args[counting]);
+}
+}
+return result;
+}
+DEFUN ("values-list", Fvalues_list, 1, 1, 0, /*
+Return all the elements of LIST as multiple values.
+*/
+(list))
+{
+Lisp_Object result = Qnil;
+int counting = 1, listcount;
+GET_EXTERNAL_LIST_LENGTH (list, listcount);
+/* Pathological cases, no need to cons up an object: */
+if (1 == listcount || 1 == multiple_value_current_limit)
+{
+return Fcar_safe (list);
+}
+result = make_multiple_value (Fcar_safe (list), listcount,
+first_desired_multiple_value,
+multiple_value_current_limit);
+list = Fcdr_safe (list);
+{
+EXTERNAL_LIST_LOOP_2 (elt, list)
+{
+if (counting >= first_desired_multiple_value &&
+counting < multiple_value_current_limit)
+{
+multiple_value_aset (result, counting, elt);
+}
+++counting;
+}
+}
+return result;
+}
+Lisp_Object
+values2 (Lisp_Object first, Lisp_Object second)
+{
+Lisp_Object argv[2];
+argv[0] = first;
+argv[1] = second;
+return Fvalues (countof (argv), argv);
 }
 /************************************************************************/
 /*		     Run hook variables in various ways.		*/
 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)
 void
 syms_of_eval (void)
 {
 INIT_LRECORD_IMPLEMENTATION (subr);
+INIT_LRECORD_IMPLEMENTATION (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);
 DEFSUBR (For);
 DEFSUBR (Fand);
 DEFSUBR (Fif);
 DEFSUBR_MACRO (Fwhen);
 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)
 {
 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 @ 4677:8f1ee2d15784