xemacs-beta: src/bytecode.c comparison

comparison src/bytecode.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	d674024a8674
children	b5e1d4f6b66f

comparison

equal deleted inserted replaced

-:e3feb329bda9
+:8f1ee2d15784
 BRgotoifnonnilelsepop = 0256,
 BlistN 		= 0257,
 BconcatN 		= 0260,
 BinsertN 		= 0261,
+Bbind_multiple_value_limits   = 0262,         /* New in 21.5. */
+Bmultiple_value_list_internal = 0263,         /* New in 21.5. */
+Bmultiple_value_call          = 0264,         /* New in 21.5. */
+Bthrow                        = 0265,         /* New in 21.5. */
 Bmember 		= 0266, /* new in v20 */
 Bassq 		= 0267, /* new in v20 */
 Bconstant 		= 0300
 };
 #define JUMPR_NEXT ((void) (program_ptr += 1))
 /* Push x onto the execution stack. */
 #define PUSH(x) (*++stack_ptr = (x))
-/* Pop a value off the execution stack. */
+/* Pop a value, which may be multiple, off the execution stack. */
-#define POP (*stack_ptr--)
+#define POP_WITH_MULTIPLE_VALUES (*stack_ptr--)
+/* Pop a value off the execution stack, treating multiple values as single. */
+#define POP (IGNORE_MULTIPLE_VALUES (POP_WITH_MULTIPLE_VALUES))
+#define DISCARD_PRESERVING_MULTIPLE_VALUES(n) (stack_ptr -= (n))
 /* Discard n values from the execution stack.  */
-#define DISCARD(n) (stack_ptr -= (n))
+#define DISCARD(n) do {                                         \
+if (1 != multiple_value_current_limit)                      \
+{                                                         \
+int i, en = n;                                          \
+for (i = 0; i < en; i++)                                \
+{                                                     \
+*stack_ptr = ignore_multiple_values (*stack_ptr);   \
+stack_ptr--;                                        \
+}                                                     \
+}                                                         \
+else                                                        \
+{                                                         \
+stack_ptr -= (n);                                       \
+}                                                         \
+} while (0)
+/* Get the value, which may be multiple, at the top of the execution stack;
+and leave it there. */
+#define TOP_WITH_MULTIPLE_VALUES (*stack_ptr)
+#define TOP_ADDRESS (stack_ptr)
 /* Get the value which is at the top of the execution stack,
 but don't pop it. */
-#define TOP (*stack_ptr)
+#define TOP (IGNORE_MULTIPLE_VALUES (TOP_WITH_MULTIPLE_VALUES))
+#define TOP_LVALUE (*stack_ptr)
 /* See comment before the big switch in execute_optimized_program(). */
 #define GCPRO_STACK  (gcpro1.nvars = stack_ptr - stack_beg)
 /* The actual interpreter for byte code.
 	      Lisp_Object val = Fget (TOP, Qbyte_code_meter, Qnil);
 	      if (INTP (val))
 		Fput (TOP, Qbyte_code_meter, make_int (XINT (val) + 1));
 	    }
 #endif
-	  TOP = Ffuncall (n + 1, &TOP);
+TOP_LVALUE = TOP; /* Ignore multiple values. */
+	  TOP_LVALUE = Ffuncall (n + 1, TOP_ADDRESS);
 	  break;
 	case Bunbind:
 	case Bunbind+1:
 	case Bunbind+2:
 	  else
 	    JUMP_NEXT;
 	  break;
 	case Bgotoifnilelsepop:
-	  if (NILP (TOP))
+	  /* Discard any multiple value: */
+	  if (NILP (TOP_LVALUE = TOP))
 	    JUMP;
 	  else
 	    {
 	      DISCARD (1);
 	      JUMP_NEXT;
 	    }
 	  break;
 	case Bgotoifnonnilelsepop:
-	  if (!NILP (TOP))
+	  /* Discard any multiple value: */
+	  if (!NILP (TOP_LVALUE = TOP))
 	    JUMP;
 	  else
 	    {
 	      DISCARD (1);
 	      JUMP_NEXT;
 	  else
 	    JUMPR_NEXT;
 	  break;
 	case BRgotoifnilelsepop:
-	  if (NILP (TOP))
+	  if (NILP (TOP_LVALUE = TOP))
 	    JUMPR;
 	  else
 	    {
 	      DISCARD (1);
 	      JUMPR_NEXT;
 	    }
 	  break;
 	case BRgotoifnonnilelsepop:
-	  if (!NILP (TOP))
+	  if (!NILP (TOP_LVALUE = TOP))
 	    JUMPR;
 	  else
 	    {
 	      DISCARD (1);
 	      JUMPR_NEXT;
 #ifdef ERROR_CHECK_BYTE_CODE
 	  /* Binds and unbinds are supposed to be compiled balanced.  */
 	  if (specpdl_depth() != speccount)
 	    invalid_byte_code ("unbalanced specbinding stack", Qunbound);
 #endif
-	  return TOP;
+	  return TOP_WITH_MULTIPLE_VALUES;
 	case Bdiscard:
 	  DISCARD (1);
 	  break;
 	case Bdup:
 	  {
-	    Lisp_Object arg = TOP;
+	    Lisp_Object arg = TOP_WITH_MULTIPLE_VALUES;
 	    PUSH (arg);
 	    break;
 	  }
 	case Bconstant2:
 	  PUSH (constants_data[READ_UINT_2]);
 	  break;
 	case Bcar:
-	  /* Fcar can GC via wrong_type_argument. */
+{
-	  /* GCPRO_STACK; */
+/* Fcar can GC via wrong_type_argument. */
-	  TOP = CONSP (TOP) ? XCAR (TOP) : Fcar (TOP);
+/* GCPRO_STACK; */
-	  break;
+Lisp_Object arg = TOP;
+TOP_LVALUE = CONSP (arg) ? XCAR (arg) : Fcar (arg);
+break;
+}
 	case Bcdr:
-	  /* Fcdr can GC via wrong_type_argument. */
+{
-	  /* GCPRO_STACK; */
+/* Fcdr can GC via wrong_type_argument. */
-	  TOP = CONSP (TOP) ? XCDR (TOP) : Fcdr (TOP);
+/* GCPRO_STACK; */
-	  break;
+Lisp_Object arg = TOP;
+TOP_LVALUE = CONSP (arg) ? XCDR (arg) : Fcdr (arg);
+break;
+}
 	case Bunbind_all:
 	  /* To unbind back to the beginning of this frame.  Not used yet,
 	     but will be needed for tail-recursion elimination. */
 	  unbind_to (speccount);
 	case Bnth:
 	  {
 	    Lisp_Object arg = POP;
 	    /* Fcar and Fnthcdr can GC via wrong_type_argument. */
 	    /* GCPRO_STACK; */
-	    TOP = Fcar (Fnthcdr (TOP, arg));
+	    TOP_LVALUE = Fcar (Fnthcdr (TOP, arg));
 	    break;
 	  }
 	case Bsymbolp:
-	  TOP = SYMBOLP (TOP) ? Qt : Qnil;
+	  TOP_LVALUE = SYMBOLP (TOP) ? Qt : Qnil;
 	  break;
 	case Bconsp:
-	  TOP = CONSP (TOP) ? Qt : Qnil;
+	  TOP_LVALUE = CONSP (TOP) ? Qt : Qnil;
 	  break;
 	case Bstringp:
-	  TOP = STRINGP (TOP) ? Qt : Qnil;
+	  TOP_LVALUE = STRINGP (TOP) ? Qt : Qnil;
 	  break;
 	case Blistp:
-	  TOP = LISTP (TOP) ? Qt : Qnil;
+	  TOP_LVALUE = LISTP (TOP) ? Qt : Qnil;
 	  break;
 	case Bnumberp:
 #ifdef WITH_NUMBER_TYPES
-	  TOP = NUMBERP (TOP) ? Qt : Qnil;
+	  TOP_LVALUE = NUMBERP (TOP) ? Qt : Qnil;
 #else
-	  TOP = INT_OR_FLOATP (TOP) ? Qt : Qnil;
+	  TOP_LVALUE = INT_OR_FLOATP (TOP) ? Qt : Qnil;
 #endif
 	  break;
 	case Bintegerp:
 #ifdef HAVE_BIGNUM
-	  TOP = INTEGERP (TOP) ? Qt : Qnil;
+	  TOP_LVALUE = INTEGERP (TOP) ? Qt : Qnil;
 #else
-	  TOP = INTP (TOP) ? Qt : Qnil;
+	  TOP_LVALUE = INTP (TOP) ? Qt : Qnil;
 #endif
 	  break;
 	case Beq:
 	  {
 	    Lisp_Object arg = POP;
-	    TOP = EQ_WITH_EBOLA_NOTICE (TOP, arg) ? Qt : Qnil;
+	    TOP_LVALUE = EQ_WITH_EBOLA_NOTICE (TOP, arg) ? Qt : Qnil;
 	    break;
 	  }
 	case Bnot:
-	  TOP = NILP (TOP) ? Qt : Qnil;
+	  TOP_LVALUE = NILP (TOP) ? Qt : Qnil;
 	  break;
 	case Bcons:
 	  {
 	    Lisp_Object arg = POP;
-	    TOP = Fcons (TOP, arg);
+	    TOP_LVALUE = Fcons (TOP, arg);
 	    break;
 	  }
 	case Blist1:
-	  TOP = Fcons (TOP, Qnil);
+	  TOP_LVALUE = Fcons (TOP, Qnil);
 	  break;
 	case BlistN:
 	  n = READ_UINT_1;
 	    if (--n)
 	      {
 		DISCARD (1);
 		goto list_loop;
 	      }
-	    TOP = list;
+	    TOP_LVALUE = list;
 	    break;
 	  }
 	case Bconcat2:
 	  n = READ_UINT_1;
 	do_concat:
 	  DISCARD (n - 1);
 	  /* Apparently `concat' can GC; Fconcat GCPROs its arguments. */
 	  /* GCPRO_STACK; */
-	  TOP = Fconcat (n, &TOP);
+TOP_LVALUE = TOP; /* Ignore multiple values. */
+	  TOP_LVALUE = Fconcat (n, TOP_ADDRESS);
 	  break;
 	case Blength:
-	  TOP = Flength (TOP);
+	  TOP_LVALUE = Flength (TOP);
 	  break;
 	case Baset:
 	  {
 	    Lisp_Object arg2 = POP;
 	    Lisp_Object arg1 = POP;
-	    TOP = Faset (TOP, arg1, arg2);
+	    TOP_LVALUE = Faset (TOP, arg1, arg2);
 	    break;
 	  }
 	case Bsymbol_value:
 	  /* Why does this need GCPRO_STACK?  If not, remove others, too. */
 	  /* GCPRO_STACK; */
-	  TOP = Fsymbol_value (TOP);
+	  TOP_LVALUE = Fsymbol_value (TOP);
 	  break;
 	case Bsymbol_function:
-	  TOP = Fsymbol_function (TOP);
+	  TOP_LVALUE = Fsymbol_function (TOP);
 	  break;
 	case Bget:
 	  {
 	    Lisp_Object arg = POP;
-	    TOP = Fget (TOP, arg, Qnil);
+	    TOP_LVALUE = Fget (TOP, arg, Qnil);
 	    break;
 	  }
 	case Bsub1:
+{
 #ifdef HAVE_BIGNUM
-	  TOP = Fsub1 (TOP);
+TOP_LVALUE = Fsub1 (TOP);
 #else
-	  TOP = INTP (TOP) ? INT_MINUS1 (TOP) : Fsub1 (TOP);
+Lisp_Object arg = TOP;
-#endif
+TOP_LVALUE = INTP (arg) ? INT_MINUS1 (arg) : Fsub1 (arg);
-	  break;
+#endif
+	  break;
+}
 	case Badd1:
+{
 #ifdef HAVE_BIGNUM
-	  TOP = Fadd1 (TOP);
+TOP_LVALUE = Fadd1 (TOP);
 #else
-	  TOP = INTP (TOP) ? INT_PLUS1 (TOP) : Fadd1 (TOP);
+Lisp_Object arg = TOP;
-#endif
+TOP_LVALUE = INTP (arg) ? INT_PLUS1 (arg) : Fadd1 (arg);
-	  break;
+#endif
+	  break;
+}
 	case Beqlsign:
 	  {
 	    Lisp_Object arg = POP;
-	    TOP = bytecode_arithcompare (TOP, arg) == 0 ? Qt : Qnil;
+	    TOP_LVALUE = bytecode_arithcompare (TOP, arg) == 0 ? Qt : Qnil;
 	    break;
 	  }
 	case Bgtr:
 	  {
 	    Lisp_Object arg = POP;
-	    TOP = bytecode_arithcompare (TOP, arg) > 0 ? Qt : Qnil;
+	    TOP_LVALUE = bytecode_arithcompare (TOP, arg) > 0 ? Qt : Qnil;
 	    break;
 	  }
 	case Blss:
 	  {
 	    Lisp_Object arg = POP;
-	    TOP = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil;
+	    TOP_LVALUE = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil;
 	    break;
 	  }
 	case Bleq:
 	  {
 	    Lisp_Object arg = POP;
-	    TOP = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil;
+	    TOP_LVALUE = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil;
 	    break;
 	  }
 	case Bgeq:
 	  {
 	    Lisp_Object arg = POP;
-	    TOP = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil;
+	    TOP_LVALUE = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil;
 	    break;
 	  }
 	case Bnegate:
-	  TOP = bytecode_negate (TOP);
+	  TOP_LVALUE = bytecode_negate (TOP);
 	  break;
 	case Bnconc:
 	  DISCARD (1);
 	  /* nconc2 GCPROs before calling this. */
 	  /* GCPRO_STACK; */
-	  TOP = bytecode_nconc2 (&TOP);
+TOP_LVALUE = TOP; /* Ignore multiple values. */
+	  TOP_LVALUE = bytecode_nconc2 (TOP_ADDRESS);
 	  break;
 	case Bplus:
 	  {
 	    Lisp_Object arg2 = POP;
 	    Lisp_Object arg1 = TOP;
 #ifdef HAVE_BIGNUM
-	    TOP = bytecode_arithop (arg1, arg2, opcode);
+	    TOP_LVALUE = bytecode_arithop (arg1, arg2, opcode);
 #else
-	    TOP = INTP (arg1) && INTP (arg2) ?
+	    TOP_LVALUE = INTP (arg1) && INTP (arg2) ?
 	      INT_PLUS (arg1, arg2) :
 	      bytecode_arithop (arg1, arg2, opcode);
 #endif
 	    break;
 	  }
 	case Bdiff:
 	  {
 	    Lisp_Object arg2 = POP;
 	    Lisp_Object arg1 = TOP;
 #ifdef HAVE_BIGNUM
-	    TOP = bytecode_arithop (arg1, arg2, opcode);
+	    TOP_LVALUE = bytecode_arithop (arg1, arg2, opcode);
 #else
-	    TOP = INTP (arg1) && INTP (arg2) ?
+	    TOP_LVALUE = INTP (arg1) && INTP (arg2) ?
 	      INT_MINUS (arg1, arg2) :
 	      bytecode_arithop (arg1, arg2, opcode);
 #endif
 	    break;
 	  }
 	case Bquo:
 	case Bmax:
 	case Bmin:
 	  {
 	    Lisp_Object arg = POP;
-	    TOP = bytecode_arithop (TOP, arg, opcode);
+	    TOP_LVALUE = bytecode_arithop (TOP, arg, opcode);
 	    break;
 	  }
 	case Bpoint:
 	  PUSH (make_int (BUF_PT (current_buffer)));
 	  break;
 	case Binsert:
 	  /* Says it can GC. */
 	  /* GCPRO_STACK; */
-	  TOP = Finsert (1, &TOP);
+TOP_LVALUE = TOP; /* Ignore multiple values. */
+	  TOP_LVALUE = Finsert (1, TOP_ADDRESS);
 	  break;
 	case BinsertN:
 	  n = READ_UINT_1;
 	  DISCARD (n - 1);
 	  /* See Binsert. */
 	  /* GCPRO_STACK; */
-	  TOP = Finsert (n, &TOP);
+TOP_LVALUE = TOP; /* Ignore multiple values. */
+	  TOP_LVALUE = Finsert (n, TOP_ADDRESS);
 	  break;
 	case Baref:
 	  {
 	    Lisp_Object arg = POP;
-	    TOP = Faref (TOP, arg);
+	    TOP_LVALUE = Faref (TOP, arg);
 	    break;
 	  }
 	case Bmemq:
 	  {
 	    Lisp_Object arg = POP;
-	    TOP = Fmemq (TOP, arg);
+	    TOP_LVALUE = Fmemq (TOP, arg);
 	    break;
 	  }
 	case Bset:
 	  {
 	    Lisp_Object arg = POP;
 	    /* Fset may call magic handlers */
 	    /* GCPRO_STACK; */
-	    TOP = Fset (TOP, arg);
+	    TOP_LVALUE = Fset (TOP, arg);
 	    break;
 	  }
 	case Bequal:
 	  {
 	    Lisp_Object arg = POP;
 	    /* Can QUIT, so can GC, right? */
 	    /* GCPRO_STACK; */
-	    TOP = Fequal (TOP, arg);
+	    TOP_LVALUE = Fequal (TOP, arg);
 	    break;
 	  }
 	case Bnthcdr:
 	  {
 	    Lisp_Object arg = POP;
-	    TOP = Fnthcdr (TOP, arg);
+	    TOP_LVALUE = Fnthcdr (TOP, arg);
 	    break;
 	  }
 	case Belt:
 	  {
 	    Lisp_Object arg = POP;
-	    TOP = Felt (TOP, arg);
+	    TOP_LVALUE = Felt (TOP, arg);
 	    break;
 	  }
 	case Bmember:
 	  {
 	    Lisp_Object arg = POP;
 	    /* Can QUIT, so can GC, right? */
 	    /* GCPRO_STACK; */
-	    TOP = Fmember (TOP, arg);
+	    TOP_LVALUE = Fmember (TOP, arg);
 	    break;
 	  }
 	case Bgoto_char:
-	  TOP = Fgoto_char (TOP, Qnil);
+	  TOP_LVALUE = Fgoto_char (TOP, Qnil);
 	  break;
 	case Bcurrent_buffer:
 	  {
 	    Lisp_Object buffer = wrap_buffer (current_buffer);
 	case Bset_buffer:
 	  /* #### WAG: set-buffer may cause Fset's of buffer locals
 	     Didn't prevent crash. :-( */
 	  /* GCPRO_STACK; */
-	  TOP = Fset_buffer (TOP);
+	  TOP_LVALUE = Fset_buffer (TOP);
 	  break;
 	case Bpoint_max:
 	  PUSH (make_int (BUF_ZV (current_buffer)));
 	  break;
 	case Bskip_chars_forward:
 	  {
 	    Lisp_Object arg = POP;
 	    /* Can QUIT, so can GC, right? */
 	    /* GCPRO_STACK; */
-	    TOP = Fskip_chars_forward (TOP, arg, Qnil);
+	    TOP_LVALUE = Fskip_chars_forward (TOP, arg, Qnil);
 	    break;
 	  }
 	case Bassq:
 	  {
 	    Lisp_Object arg = POP;
-	    TOP = Fassq (TOP, arg);
+	    TOP_LVALUE = Fassq (TOP, arg);
 	    break;
 	  }
 	case Bsetcar:
 	  {
 	    Lisp_Object arg = POP;
-	    TOP = Fsetcar (TOP, arg);
+	    TOP_LVALUE = Fsetcar (TOP, arg);
 	    break;
 	  }
 	case Bsetcdr:
 	  {
 	    Lisp_Object arg = POP;
-	    TOP = Fsetcdr (TOP, arg);
+	    TOP_LVALUE = Fsetcdr (TOP, arg);
 	    break;
 	  }
 	case Bnreverse:
-	  TOP = bytecode_nreverse (TOP);
+	  TOP_LVALUE = bytecode_nreverse (TOP);
 	  break;
 	case Bcar_safe:
-	  TOP = CONSP (TOP) ? XCAR (TOP) : Qnil;
+	  TOP_LVALUE = CONSP (TOP) ? XCAR (TOP) : Qnil;
 	  break;
 	case Bcdr_safe:
-	  TOP = CONSP (TOP) ? XCDR (TOP) : Qnil;
+	  TOP_LVALUE = CONSP (TOP) ? XCDR (TOP) : Qnil;
 	  break;
 	}
 }
 }
 Lisp_Object *
 execute_rare_opcode (Lisp_Object *stack_ptr,
 		     const Opbyte *UNUSED (program_ptr),
 		     Opcode opcode)
 {
+REGISTER int n;
 switch (opcode)
 {
 case Bsave_excursion:
 record_unwind_protect (save_excursion_restore,
 case Bsave_window_excursion:
 {
 	int count = specpdl_depth ();
 	record_unwind_protect (save_window_excursion_unwind,
 			       call1 (Qcurrent_window_configuration, Qnil));
-	TOP = Fprogn (TOP);
+	TOP_LVALUE = Fprogn (TOP);
 	unbind_to (count);
 	break;
 }
 case Bsave_restriction:
 break;
 case Bcatch:
 {
 	Lisp_Object arg = POP;
-	TOP = internal_catch (TOP, Feval, arg, 0, 0, 0);
+	TOP_LVALUE = internal_catch (TOP, Feval, arg, 0, 0, 0);
 	break;
 }
 case Bskip_chars_backward:
 {
 	Lisp_Object arg = POP;
-	TOP = Fskip_chars_backward (TOP, arg, Qnil);
+	TOP_LVALUE = Fskip_chars_backward (TOP, arg, Qnil);
 	break;
 }
 case Bunwind_protect:
 record_unwind_protect (Fprogn, POP);
 case Bcondition_case:
 {
 	Lisp_Object arg2 = POP; /* handlers */
 	Lisp_Object arg1 = POP; /* bodyform */
-	TOP = condition_case_3 (arg1, TOP, arg2);
+	TOP_LVALUE = condition_case_3 (arg1, TOP, arg2);
 	break;
 }
 case Bset_marker:
 {
 	Lisp_Object arg2 = POP;
 	Lisp_Object arg1 = POP;
-	TOP = Fset_marker (TOP, arg1, arg2);
+	TOP_LVALUE = Fset_marker (TOP, arg1, arg2);
 	break;
 }
 case Brem:
 {
 	Lisp_Object arg = POP;
-	TOP = Frem (TOP, arg);
+	TOP_LVALUE = Frem (TOP, arg);
 	break;
 }
 case Bmatch_beginning:
-TOP = Fmatch_beginning (TOP);
+TOP_LVALUE = Fmatch_beginning (TOP);
 break;
 case Bmatch_end:
-TOP = Fmatch_end (TOP);
+TOP_LVALUE = Fmatch_end (TOP);
 break;
 case Bupcase:
-TOP = Fupcase (TOP, Qnil);
+TOP_LVALUE = Fupcase (TOP, Qnil);
 break;
 case Bdowncase:
-TOP = Fdowncase (TOP, Qnil);
+TOP_LVALUE = Fdowncase (TOP, Qnil);
 break;
 case Bfset:
 {
 	Lisp_Object arg = POP;
-	TOP = Ffset (TOP, arg);
+	TOP_LVALUE = Ffset (TOP, arg);
 	break;
 }
 case Bstring_equal:
 {
 	Lisp_Object arg = POP;
-	TOP = Fstring_equal (TOP, arg);
+	TOP_LVALUE = Fstring_equal (TOP, arg);
 	break;
 }
 case Bstring_lessp:
 {
 	Lisp_Object arg = POP;
-	TOP = Fstring_lessp (TOP, arg);
+	TOP_LVALUE = Fstring_lessp (TOP, arg);
 	break;
 }
 case Bsubstring:
 {
 	Lisp_Object arg2 = POP;
 	Lisp_Object arg1 = POP;
-	TOP = Fsubstring (TOP, arg1, arg2);
+	TOP_LVALUE = Fsubstring (TOP, arg1, arg2);
 	break;
 }
 case Bcurrent_column:
 PUSH (make_int (current_column (current_buffer)));
 break;
 case Bchar_after:
-TOP = Fchar_after (TOP, Qnil);
+TOP_LVALUE = Fchar_after (TOP, Qnil);
 break;
 case Bindent_to:
-TOP = Findent_to (TOP, Qnil, Qnil);
+TOP_LVALUE = Findent_to (TOP, Qnil, Qnil);
 break;
 case Bwiden:
 PUSH (Fwiden (Qnil));
 break;
 case Binteractive_p:
 PUSH (Finteractive_p ());
 break;
 case Bforward_char:
-TOP = Fforward_char (TOP, Qnil);
+TOP_LVALUE = Fforward_char (TOP, Qnil);
 break;
 case Bforward_word:
-TOP = Fforward_word (TOP, Qnil);
+TOP_LVALUE = Fforward_word (TOP, Qnil);
 break;
 case Bforward_line:
-TOP = Fforward_line (TOP, Qnil);
+TOP_LVALUE = Fforward_line (TOP, Qnil);
 break;
 case Bchar_syntax:
-TOP = Fchar_syntax (TOP, Qnil);
+TOP_LVALUE = Fchar_syntax (TOP, Qnil);
 break;
 case Bbuffer_substring:
 {
 	Lisp_Object arg = POP;
-	TOP = Fbuffer_substring (TOP, arg, Qnil);
+	TOP_LVALUE = Fbuffer_substring (TOP, arg, Qnil);
 	break;
 }
 case Bdelete_region:
 {
 	Lisp_Object arg = POP;
-	TOP = Fdelete_region (TOP, arg, Qnil);
+	TOP_LVALUE = Fdelete_region (TOP, arg, Qnil);
 	break;
 }
 case Bnarrow_to_region:
 {
 	Lisp_Object arg = POP;
-	TOP = Fnarrow_to_region (TOP, arg, Qnil);
+	TOP_LVALUE = Fnarrow_to_region (TOP, arg, Qnil);
 	break;
 }
 case Bend_of_line:
-TOP = Fend_of_line (TOP, Qnil);
+TOP_LVALUE = Fend_of_line (TOP, Qnil);
 break;
 case Btemp_output_buffer_setup:
 temp_output_buffer_setup (TOP);
-TOP = Vstandard_output;
+TOP_LVALUE = Vstandard_output;
 break;
 case Btemp_output_buffer_show:
 {
 	Lisp_Object arg = POP;
 	temp_output_buffer_show (TOP, Qnil);
-	TOP = arg;
+	TOP_LVALUE = arg;
 	/* GAG ME!! */
 	/* pop binding of standard-output */
 	unbind_to (specpdl_depth() - 1);
 	break;
 }
 case Bold_eq:
 {
 	Lisp_Object arg = POP;
-	TOP = HACKEQ_UNSAFE (TOP, arg) ? Qt : Qnil;
+	TOP_LVALUE = HACKEQ_UNSAFE (TOP, arg) ? Qt : Qnil;
 	break;
 }
 case Bold_memq:
 {
 	Lisp_Object arg = POP;
-	TOP = Fold_memq (TOP, arg);
+	TOP_LVALUE = Fold_memq (TOP, arg);
 	break;
 }
 case Bold_equal:
 {
 	Lisp_Object arg = POP;
-	TOP = Fold_equal (TOP, arg);
+	TOP_LVALUE = Fold_equal (TOP, arg);
 	break;
 }
 case Bold_member:
 {
 	Lisp_Object arg = POP;
-	TOP = Fold_member (TOP, arg);
+	TOP_LVALUE = Fold_member (TOP, arg);
 	break;
 }
 case Bold_assq:
 {
 	Lisp_Object arg = POP;
-	TOP = Fold_assq (TOP, arg);
+	TOP_LVALUE = Fold_assq (TOP, arg);
 	break;
+}
+case Bbind_multiple_value_limits:
+{
+Lisp_Object upper = POP, first = TOP, speccount;
+CHECK_NATNUM (upper);
+CHECK_NATNUM (first);
+speccount = make_int (bind_multiple_value_limits (XINT (first),
+XINT (upper)));
+PUSH (upper);
+PUSH (speccount);
+break;
+}
+case Bmultiple_value_call:
+{
+n = XINT (POP);
+DISCARD_PRESERVING_MULTIPLE_VALUES (n - 1);
+/* Discard multiple values for the first (function) argument: */
+TOP_LVALUE = TOP;
+TOP_LVALUE = multiple_value_call (n, TOP_ADDRESS);
+break;
+}
+case Bmultiple_value_list_internal:
+{
+DISCARD_PRESERVING_MULTIPLE_VALUES (3);
+TOP_LVALUE = multiple_value_list_internal (4, TOP_ADDRESS);
+break;
+}
+case Bthrow:
+{
+Lisp_Object arg = POP_WITH_MULTIPLE_VALUES;
+/* We never throw to a catch tag that is a multiple value: */
+throw_or_bomb_out (TOP, arg, 0, Qnil, Qnil);
+break;
 }
 default:
 ABORT();
 break;

Mercurial > hg > xemacs-beta

comparison src/bytecode.c @ 4677:8f1ee2d15784