diff 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
line wrap: on
line diff
--- a/src/eval.c	Sun Aug 16 14:58:57 2009 +0100
+++ b/src/eval.c	Sun Aug 16 20:55:49 2009 +0100
@@ -241,6 +241,16 @@
 Lisp_Object Vpending_warnings, Vpending_warnings_tail;
 Lisp_Object Qif;
 
+Lisp_Object Qthrow;
+Lisp_Object Qobsolete_throw;
+
+static int first_desired_multiple_value;
+/* Used outside this file, somewhat uncleanly, in the IGNORE_MULTIPLE_VALUES
+   macro: */
+int multiple_value_current_limit;
+
+Fixnum Vmultiple_values_limit;
+
 /* Flags specifying which operations are currently inhibited. */
 int inhibit_flags;
 
@@ -820,6 +830,9 @@
 The remaining ARGS are not evalled at all.
 If all args return nil, return nil.
 
+Any multiple values from the last form, and only from the last form, are
+passed back.  See `values' and `multiple-value-bind'. 
+
 arguments: (&rest ARGS)
 */
        (args))
@@ -827,13 +840,21 @@
   /* This function can GC */
   REGISTER Lisp_Object val;
 
-  LIST_LOOP_2 (arg, args)
+  LIST_LOOP_3 (arg, args, tail)
     {
-      if (!NILP (val = Feval (arg)))
-	return val;
+      if (!NILP (IGNORE_MULTIPLE_VALUES (val = Feval (arg))))
+	{
+	  if (NILP (XCDR (tail)))
+	    {
+	      /* Pass back multiple values if this is the last one: */
+	      return val;
+	    }
+
+	  return IGNORE_MULTIPLE_VALUES (val);
+	}
     }
 
-  return Qnil;
+  return val;
 }
 
 DEFUN ("and", Fand, 0, UNEVALLED, 0, /*
@@ -841,6 +862,9 @@
 The remaining ARGS are not evalled at all.
 If no arg yields nil, return the last arg's value.
 
+Any multiple values from the last form, and only from the last form, are
+passed back.  See `values' and `multiple-value-bind'. 
+
 arguments: (&rest ARGS)
 */
        (args))
@@ -848,10 +872,18 @@
   /* This function can GC */
   REGISTER Lisp_Object val = Qt;
 
-  LIST_LOOP_2 (arg, args)
+  LIST_LOOP_3 (arg, args, tail)
     {
-      if (NILP (val = Feval (arg)))
-	return val;
+      if (NILP (IGNORE_MULTIPLE_VALUES (val = Feval (arg))))
+	{
+	  if (NILP (XCDR (tail)))
+	    {
+	      /* Pass back any multiple values for the last form: */
+	      return val;
+	    }
+
+	  return Qnil;
+	}
     }
 
   return val;
@@ -872,7 +904,7 @@
   Lisp_Object then_form  = XCAR (XCDR (args));
   Lisp_Object else_forms = XCDR (XCDR (args));
 
-  if (!NILP (Feval (condition)))
+  if (!NILP (IGNORE_MULTIPLE_VALUES (Feval (condition))))
     return Feval (then_form);
   else
     return Fprogn (else_forms);
@@ -935,11 +967,12 @@
   LIST_LOOP_2 (clause, args)
     {
       CHECK_CONS (clause);
-      if (!NILP (val = Feval (XCAR (clause))))
+      if (!NILP (val = IGNORE_MULTIPLE_VALUES (Feval (XCAR (clause)))))
 	{
 	  if (!NILP (clause = XCDR (clause)))
 	    {
 	      CHECK_TRUE_LIST (clause);
+	      /* Pass back any multiple values here: */
 	      val = Fprogn (clause);
 	    }
 	  return val;
@@ -988,7 +1021,7 @@
   Lisp_Object val;
   struct gcpro gcpro1;
 
-  val = Feval (XCAR (args));
+  val = IGNORE_MULTIPLE_VALUES (Feval (Fcar (args)));
 
   GCPRO1 (val);
 
@@ -1017,7 +1050,9 @@
 
   Feval (XCAR (args));
   args = XCDR (args);
-  val = Feval (XCAR (args));
+
+  val = IGNORE_MULTIPLE_VALUES (Feval (XCAR (args)));
+
   args = XCDR (args);
 
   GCPRO1 (val);
@@ -1062,7 +1097,7 @@
 	  else
 	    {
 	      CHECK_CONS (tem);
-	      value = Feval (XCAR (tem));
+              value = IGNORE_MULTIPLE_VALUES (Feval (XCAR (tem)));
 	      if (!NILP (XCDR (tem)))
 		sferror
 		  ("`let' bindings can have only one value-form", var);
@@ -1120,7 +1155,7 @@
 	    else
 	      {
 		CHECK_CONS (tem);
-		*value = Feval (XCAR (tem));
+                *value = IGNORE_MULTIPLE_VALUES (Feval (XCAR (tem)));
 		gcpro1.nvars = idx;
 
 		if (!NILP (XCDR (tem)))
@@ -1157,7 +1192,7 @@
   Lisp_Object test = XCAR (args);
   Lisp_Object body = XCDR (args);
 
-  while (!NILP (Feval (test)))
+  while (!NILP (IGNORE_MULTIPLE_VALUES (Feval (test))))
     {
       QUIT;
       Fprogn (body);
@@ -1189,6 +1224,7 @@
   GC_PROPERTY_LIST_LOOP_3 (symbol, val, args)
     {
       val = Feval (val);
+      val = IGNORE_MULTIPLE_VALUES (val);
       Fset (symbol, val);
       retval = val;
     }
@@ -1311,7 +1347,7 @@
 	{
 	  struct gcpro gcpro1;
 	  GCPRO1 (val);
-	  val = Feval (val);
+	  val = IGNORE_MULTIPLE_VALUES (Feval (val));
 	  Fset_default (sym, val);
 	  UNGCPRO;
 	}
@@ -1361,6 +1397,8 @@
 
   GCPRO1 (val);
 
+  val = IGNORE_MULTIPLE_VALUES (val);
+
   Fset_default (sym, val);
 
   UNGCPRO;
@@ -1663,10 +1701,10 @@
   LONGJMP (c->jmp, 1);
 }
 
-static DECLARE_DOESNT_RETURN (throw_or_bomb_out (Lisp_Object, Lisp_Object, int,
-						 Lisp_Object, Lisp_Object));
-
-static DOESNT_RETURN
+DECLARE_DOESNT_RETURN (throw_or_bomb_out (Lisp_Object, Lisp_Object, int,
+					  Lisp_Object, Lisp_Object));
+
+DOESNT_RETURN
 throw_or_bomb_out (Lisp_Object tag, Lisp_Object val, int bomb_out_p,
 		   Lisp_Object sig, Lisp_Object data)
 {
@@ -1739,12 +1777,29 @@
    condition_case_1).  See below for more info.
 */
 
-DEFUN_NORETURN ("throw", Fthrow, 2, 2, 0, /*
+DEFUN_NORETURN ("throw", Fthrow, 2, UNEVALLED, 0, /*
 Throw to the catch for TAG and return VALUE from it.
-Both TAG and VALUE are evalled.  Tags are the same iff they are `eq'.
+
+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);
 }
@@ -2360,7 +2415,8 @@
       else if (EQ (handler_data, Qt))
 	{
           UNGCPRO;
-          return Fthrow (handlers, Fcons (error_symbol, data));
+          throw_or_bomb_out (handlers, Fcons (error_symbol, data),
+                             0, Qnil, Qnil);
 	}
       /* `error' is used similarly to the way `t' is used, but in
          addition it invokes the debugger if debug_on_error.
@@ -2379,7 +2435,7 @@
             return return_from_signal (tem);
 
           tem = Fcons (error_symbol, data);
-          return Fthrow (handlers, tem);
+          throw_or_bomb_out (handlers, tem, 0, Qnil, Qnil);
         }
       else
 	{
@@ -2403,7 +2459,7 @@
 
                   /* Doesn't return */
                   tem = Fcons (Fcons (error_symbol, data), Fcdr (clause));
-                  return Fthrow (handlers, tem);
+                  throw_or_bomb_out (handlers, tem, 0, Qnil, Qnil);
                 }
 	    }
 	}
@@ -3665,7 +3721,7 @@
 	  {
 	    LIST_LOOP_2 (arg, original_args)
 	      {
-		*p++ = Feval (arg);
+                *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg));
 		gcpro1.nvars++;
 	      }
 	  }
@@ -3696,7 +3752,7 @@
 	  {
 	    LIST_LOOP_2 (arg, original_args)
 	      {
-		*p++ = Feval (arg);
+                *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg));
 		gcpro1.nvars++;
 	      }
 	  }
@@ -3729,7 +3785,7 @@
       {
 	LIST_LOOP_2 (arg, original_args)
 	  {
-	    *p++ = Feval (arg);
+            *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg));
 	    gcpro1.nvars++;
 	  }
       }
@@ -3778,7 +3834,7 @@
 	  {
 	    LIST_LOOP_2 (arg, original_args)
 	      {
-		*p++ = Feval (arg);
+                *p++ = IGNORE_MULTIPLE_VALUES (Feval (arg));
 		gcpro1.nvars++;
 	      }
 	  }
@@ -3958,6 +4014,12 @@
 	}
       else if (max_args == UNEVALLED) /* Can't funcall a special form */
 	{
+          /* Ugh, ugh, ugh. */
+          if (EQ (fun, XSYMBOL_FUNCTION (Qthrow)))
+            {
+              args[0] = Qobsolete_throw;
+              goto retry;
+            }
 	  goto invalid_function;
 	}
       else
@@ -4238,7 +4300,6 @@
   }
 }
 
-
 /* Apply lambda list FUN to the NARGS evaluated arguments in ARGS and
    return the result of evaluation. */
 
@@ -4296,6 +4357,590 @@
 }
 
 
+/* 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.		*/
 /************************************************************************/
@@ -4968,7 +5613,7 @@
   p->error_conditions = error_conditions;
   p->data = data;
 
-  Fthrow (p->catchtag, Qnil);
+  throw_or_bomb_out (p->catchtag, Qnil, 0, Qnil, Qnil);
   RETURN_NOT_REACHED (Qnil);
 }
 
@@ -6555,6 +7200,7 @@
 syms_of_eval (void)
 {
   INIT_LRECORD_IMPLEMENTATION (subr);
+  INIT_LRECORD_IMPLEMENTATION (multiple_value);
 
   DEFSYMBOL (Qinhibit_quit);
   DEFSYMBOL (Qautoload);
@@ -6578,6 +7224,8 @@
   DEFSYMBOL (Qrun_hooks);
   DEFSYMBOL (Qfinalize_list);
   DEFSYMBOL (Qif);
+  DEFSYMBOL (Qthrow);
+  DEFSYMBOL (Qobsolete_throw);  
 
   DEFSUBR (For);
   DEFSUBR (Fand);
@@ -6611,6 +7259,11 @@
   DEFSUBR (Fautoload);
   DEFSUBR (Feval);
   DEFSUBR (Fapply);
+  DEFSUBR (Fmultiple_value_call);
+  DEFSUBR (Fmultiple_value_list_internal);
+  DEFSUBR (Fmultiple_value_prog1);
+  DEFSUBR (Fvalues);
+  DEFSUBR (Fvalues_list);
   DEFSUBR (Ffuncall);
   DEFSUBR (Ffunctionp);
   DEFSUBR (Ffunction_min_args);
@@ -6636,6 +7289,9 @@
   debug_on_next_call = 0;
   lisp_eval_depth = 0;
   entering_debugger = 0;
+
+  first_desired_multiple_value = 0;
+  multiple_value_current_limit = 1;
 }
 
 void
@@ -6805,6 +7461,14 @@
 */ );
   Vdebugger = Qnil;
 
+  DEFVAR_CONST_INT ("multiple-values-limit", &Vmultiple_values_limit /*
+The exclusive upper bound on the number of multiple values. 
+
+This applies to `values', `values-list', `multiple-value-bind' and related
+macros and special forms.
+*/);
+  Vmultiple_values_limit = EMACS_INT_MAX > INT_MAX ? INT_MAX : EMACS_INT_MAX;
+
   staticpro (&Vcatch_everything_tag);
   Vcatch_everything_tag = make_opaque (OPAQUE_CLEAR, 0);