Merge from mainline.

1 files changed, 143 insertions, 20 deletions

diff --git a/src/bytecode.c b/src/bytecode.c
index 5a62c913a40..5879d312b07 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -80,9 +80,11 @@ Lisp_Object Qbyte_code_meter;
 
 
 Lisp_Object Qbytecode;
+extern Lisp_Object Qand_optional, Qand_rest;
 
 /*  Byte codes: */
 
+#define Bstack_ref 0 /* Actually, Bstack_ref+0 is not implemented: use dup.  */
 #define Bvarref 010
 #define Bvarset 020
 #define Bvarbind 030
@@ -132,7 +134,7 @@ Lisp_Object Qbytecode;
 
 #define Bpoint 0140
 /* Was Bmark in v17.  */
-#define Bsave_current_buffer 0141
+#define Bsave_current_buffer 0141 /* Obsolete.  */
 #define Bgoto_char 0142
 #define Binsert 0143
 #define Bpoint_max 0144
@@ -158,7 +160,7 @@ Lisp_Object Qbytecode;
 #ifdef BYTE_CODE_SAFE
 #define Bset_mark 0163 /* this loser is no longer generated as of v18 */
 #endif
-#define Binteractive_p 0164 /* Needed since interactive-p takes unevalled args */
+#define Binteractive_p 0164 /* Obsolete since Emacs-24.1.  */
 
 #define Bforward_char 0165
 #define Bforward_word 0166
@@ -183,16 +185,16 @@ Lisp_Object Qbytecode;
 #define Bdup 0211
 
 #define Bsave_excursion 0212
-#define Bsave_window_excursion 0213
+#define Bsave_window_excursion 0213 /* Obsolete since Emacs-24.1.  */
 #define Bsave_restriction 0214
 #define Bcatch 0215
 
 #define Bunwind_protect 0216
 #define Bcondition_case 0217
-#define Btemp_output_buffer_setup 0220
-#define Btemp_output_buffer_show 0221
+#define Btemp_output_buffer_setup 0220 /* Obsolete since Emacs-24.1.  */
+#define Btemp_output_buffer_show 0221  /* Obsolete since Emacs-24.1.  */
 
-#define Bunbind_all 0222
+#define Bunbind_all 0222	/* Obsolete.  Never used.  */
 
 #define Bset_marker 0223
 #define Bmatch_beginning 0224
@@ -228,6 +230,11 @@ Lisp_Object Qbytecode;
 #define BconcatN 0260
 #define BinsertN 0261
 
+/* Bstack_ref is code 0.  */
+#define Bstack_set  0262
+#define Bstack_set2 0263
+#define BdiscardN   0266
+
 #define Bconstant 0300
 
 /* Whether to maintain a `top' and `bottom' field in the stack frame.  */
@@ -414,6 +421,21 @@ the third, MAXDEPTH, the maximum stack depth used in this function.
 If the third argument is incorrect, Emacs may crash.  */)
   (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth)
 {
+  return exec_byte_code (bytestr, vector, maxdepth, Qnil, 0, NULL);
+}
+
+/* Execute the byte-code in BYTESTR.  VECTOR is the constant vector, and
+   MAXDEPTH is the maximum stack depth used (if MAXDEPTH is incorrect,
+   emacs may crash!).  If ARGS_TEMPLATE is non-nil, it should be a lisp
+   argument list (including &rest, &optional, etc.), and ARGS, of size
+   NARGS, should be a vector of the actual arguments.  The arguments in
+   ARGS are pushed on the stack according to ARGS_TEMPLATE before
+   executing BYTESTR.  */
+
+Lisp_Object
+exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
+		Lisp_Object args_template, int nargs, Lisp_Object *args)
+{
   int count = SPECPDL_INDEX ();
 #ifdef BYTE_CODE_METER
   int this_op = 0;
@@ -475,6 +497,52 @@ If the third argument is incorrect, Emacs may crash.  */)
   stacke = stack.bottom - 1 + XFASTINT (maxdepth);
 #endif
 
+  if (INTEGERP (args_template))
+    {
+      int at = XINT (args_template);
+      int rest = at & 128;
+      int mandatory = at & 127;
+      int nonrest = at >> 8;
+      eassert (mandatory <= nonrest);
+      if (nargs <= nonrest)
+	{
+	  int i;
+	  for (i = 0 ; i < nargs; i++, args++)
+	    PUSH (*args);
+	  if (nargs < mandatory)
+	    /* Too few arguments.  */
+	    Fsignal (Qwrong_number_of_arguments,
+		     Fcons (Fcons (make_number (mandatory),
+				   rest ? Qand_rest : make_number (nonrest)),
+			    Fcons (make_number (nargs), Qnil)));
+	  else
+	    {
+	      for (; i < nonrest; i++)
+		PUSH (Qnil);
+	      if (rest)
+		PUSH (Qnil);
+	    }
+	}
+      else if (rest)
+	{
+	  int i;
+	  for (i = 0 ; i < nonrest; i++, args++)
+	    PUSH (*args);
+	  PUSH (Flist (nargs - nonrest, args));
+	}
+      else
+	/* Too many arguments.  */
+	Fsignal (Qwrong_number_of_arguments,
+		 Fcons (Fcons (make_number (mandatory),
+			       make_number (nonrest)),
+			Fcons (make_number (nargs), Qnil)));
+    }
+  else if (! NILP (args_template))
+    /* We should push some arguments on the stack.  */
+    {
+      error ("Unknown args template!");
+    }
+
   while (1)
     {
 #ifdef BYTE_CODE_SAFE
@@ -735,7 +803,7 @@ If the third argument is incorrect, Emacs may crash.  */)
 	  AFTER_POTENTIAL_GC ();
 	  break;
 
-	case Bunbind_all:
+	case Bunbind_all:	/* Obsolete.  Never used.  */
 	  /* To unbind back to the beginning of this frame.  Not used yet,
 	     but will be needed for tail-recursion elimination.  */
 	  BEFORE_POTENTIAL_GC ();
@@ -863,37 +931,43 @@ If the third argument is incorrect, Emacs may crash.  */)
 				 save_excursion_save ());
 	  break;
 
-	case Bsave_current_buffer:
+	case Bsave_current_buffer: /* Obsolete since ??.  */
 	case Bsave_current_buffer_1:
 	  record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ());
 	  break;
 
-	case Bsave_window_excursion:
-	  BEFORE_POTENTIAL_GC ();
-	  TOP = Fsave_window_excursion (TOP);
-	  AFTER_POTENTIAL_GC ();
-	  break;
+	case Bsave_window_excursion: /* Obsolete since 24.1.  */
+	  {
+	    register int count = SPECPDL_INDEX ();
+	    record_unwind_protect (Fset_window_configuration,
+				   Fcurrent_window_configuration (Qnil));
+	    BEFORE_POTENTIAL_GC ();
+	    TOP = Fprogn (TOP);
+	    unbind_to (count, TOP);
+	    AFTER_POTENTIAL_GC ();
+	    break;
+	  }
 
 	case Bsave_restriction:
 	  record_unwind_protect (save_restriction_restore,
 				 save_restriction_save ());
 	  break;
 
-	case Bcatch:
+	case Bcatch:		/* FIXME: ill-suited for lexbind */
 	  {
 	    Lisp_Object v1;
 	    BEFORE_POTENTIAL_GC ();
 	    v1 = POP;
-	    TOP = internal_catch (TOP, Feval, v1);
+	    TOP = internal_catch (TOP, eval_sub, v1);
 	    AFTER_POTENTIAL_GC ();
 	    break;
 	  }
 
-	case Bunwind_protect:
+	case Bunwind_protect:	/* FIXME: avoid closure for lexbind */
 	  record_unwind_protect (Fprogn, POP);
 	  break;
 
-	case Bcondition_case:
+	case Bcondition_case:	/* FIXME: ill-suited for lexbind */
 	  {
 	    Lisp_Object handlers, body;
 	    handlers = POP;
@@ -904,7 +978,7 @@ If the third argument is incorrect, Emacs may crash.  */)
 	    break;
 	  }
 
-	case Btemp_output_buffer_setup:
+	case Btemp_output_buffer_setup: /* Obsolete since 24.1.  */
 	  BEFORE_POTENTIAL_GC ();
 	  CHECK_STRING (TOP);
 	  temp_output_buffer_setup (SSDATA (TOP));
@@ -912,7 +986,7 @@ If the third argument is incorrect, Emacs may crash.  */)
 	  TOP = Vstandard_output;
 	  break;
 
-	case Btemp_output_buffer_show:
+	case Btemp_output_buffer_show: /* Obsolete since 24.1.  */
 	  {
 	    Lisp_Object v1;
 	    BEFORE_POTENTIAL_GC ();
@@ -1384,7 +1458,7 @@ If the third argument is incorrect, Emacs may crash.  */)
 	  AFTER_POTENTIAL_GC ();
 	  break;
 
-	case Binteractive_p:
+	case Binteractive_p:	/* Obsolete since 24.1.  */
 	  PUSH (Finteractive_p ());
 	  break;
 
@@ -1674,8 +1748,57 @@ If the third argument is incorrect, Emacs may crash.  */)
 #endif
 
 	case 0:
+	  /* Actually this is Bstack_ref with offset 0, but we use Bdup
+	     for that instead.  */
+	  /* case Bstack_ref: */
 	  abort ();
 
+	  /* Handy byte-codes for lexical binding.  */
+	case Bstack_ref+1:
+	case Bstack_ref+2:
+	case Bstack_ref+3:
+	case Bstack_ref+4:
+	case Bstack_ref+5:
+	  {
+	    Lisp_Object *ptr = top - (op - Bstack_ref);
+	    PUSH (*ptr);
+	    break;
+	  }
+	case Bstack_ref+6:
+	  {
+	    Lisp_Object *ptr = top - (FETCH);
+	    PUSH (*ptr);
+	    break;
+	  }
+	case Bstack_ref+7:
+	  {
+	    Lisp_Object *ptr = top - (FETCH2);
+	    PUSH (*ptr);
+	    break;
+	  }
+	  /* stack-set-0 = discard; stack-set-1 = discard-1-preserve-tos.  */
+	case Bstack_set:
+	  {
+	    Lisp_Object *ptr = top - (FETCH);
+	    *ptr = POP;
+	    break;
+	  }
+	case Bstack_set2:
+	  {
+	    Lisp_Object *ptr = top - (FETCH2);
+	    *ptr = POP;
+	    break;
+	  }
+	case BdiscardN:
+	  op = FETCH;
+	  if (op & 0x80)
+	    {
+	      op &= 0x7F;
+	      top[-op] = TOP;
+	    }
+	  DISCARD (op);
+	  break;
+
 	case 255:
 	default:
 #ifdef BYTE_CODE_SAFE