summaryrefslogtreecommitdiff
path: root/src/bytecode.c
diff options
context:
space:
mode:
Diffstat (limited to 'src/bytecode.c')
-rw-r--r--src/bytecode.c178
1 files changed, 155 insertions, 23 deletions
diff --git a/src/bytecode.c b/src/bytecode.c
index bb4e87c019..b19f9687cd 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -51,7 +51,7 @@ by Hallvard:
*
* define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
*/
-/* #define BYTE_CODE_SAFE */
+#define BYTE_CODE_SAFE 1
/* #define BYTE_CODE_METER */
@@ -84,9 +84,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
@@ -136,7 +138,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
@@ -156,7 +158,7 @@ Lisp_Object Qbytecode;
#define Bsave_current_buffer_1 0162 /* Replacing Bsave_current_buffer. */
#define Bread_char 0162 /* No longer generated as of v19 */
#define Bset_mark 0163 /* this loser is no longer generated as of v18 */
-#define Binteractive_p 0164 /* Needed since interactive-p takes unevalled args */
+#define Binteractive_p 0164 /* Obsolete. */
#define Bforward_char 0165
#define Bforward_word 0166
@@ -181,16 +183,16 @@ Lisp_Object Qbytecode;
#define Bdup 0211
#define Bsave_excursion 0212
-#define Bsave_window_excursion 0213
+#define Bsave_window_excursion 0213 /* Obsolete. */
#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. */
+#define Btemp_output_buffer_show 0221 /* Obsolete. */
-#define Bunbind_all 0222
+#define Bunbind_all 0222 /* Obsolete. */
#define Bset_marker 0223
#define Bmatch_beginning 0224
@@ -226,6 +228,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
#define CONSTANTLIM 0100
@@ -404,13 +411,37 @@ unmark_byte_stack (void)
} while (0)
-DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0,
+DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, MANY, 0,
doc: /* Function used internally in byte-compiled code.
The first argument, BYTESTR, is a string of byte code;
the second, VECTOR, a vector of constants;
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)
+If the third argument is incorrect, Emacs may crash.
+
+If ARGS-TEMPLATE is specified, it is an argument list specification,
+according to which any remaining arguments are pushed on the stack
+before executing BYTESTR.
+
+usage: (byte-code BYTESTR VECTOR MAXDEP &optional ARGS-TEMPLATE &rest ARGS) */)
+ (int nargs, Lisp_Object *args)
+{
+ Lisp_Object args_tmpl = nargs >= 4 ? args[3] : Qnil;
+ int pnargs = nargs >= 4 ? nargs - 4 : 0;
+ Lisp_Object *pargs = nargs >= 4 ? args + 4 : 0;
+ return exec_byte_code (args[0], args[1], args[2], args_tmpl, pnargs, pargs);
+}
+
+/* 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
@@ -471,6 +502,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
@@ -712,7 +789,7 @@ If the third argument is incorrect, Emacs may crash. */)
AFTER_POTENTIAL_GC ();
break;
- case Bunbind_all:
+ case Bunbind_all: /* Obsolete. */
/* To unbind back to the beginning of this frame. Not used yet,
but will be needed for tail-recursion elimination. */
BEFORE_POTENTIAL_GC ();
@@ -840,16 +917,22 @@ If the third argument is incorrect, Emacs may crash. */)
save_excursion_save ());
break;
- case Bsave_current_buffer:
+ case Bsave_current_buffer: /* Obsolete. */
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. */
+ {
+ 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,
@@ -861,13 +944,13 @@ If the third argument is incorrect, Emacs may crash. */)
Lisp_Object v1;
BEFORE_POTENTIAL_GC ();
v1 = POP;
- TOP = internal_catch (TOP, Feval, v1);
+ TOP = internal_catch (TOP, eval_sub, v1); /* FIXME: lexbind */
AFTER_POTENTIAL_GC ();
break;
}
case Bunwind_protect:
- record_unwind_protect (Fprogn, POP);
+ record_unwind_protect (Fprogn, POP); /* FIXME: lexbind */
break;
case Bcondition_case:
@@ -876,12 +959,12 @@ If the third argument is incorrect, Emacs may crash. */)
handlers = POP;
body = POP;
BEFORE_POTENTIAL_GC ();
- TOP = internal_lisp_condition_case (TOP, body, handlers);
+ TOP = internal_lisp_condition_case (TOP, body, handlers); /* FIXME: lexbind */
AFTER_POTENTIAL_GC ();
break;
}
- case Btemp_output_buffer_setup:
+ case Btemp_output_buffer_setup: /* Obsolete. */
BEFORE_POTENTIAL_GC ();
CHECK_STRING (TOP);
temp_output_buffer_setup (SSDATA (TOP));
@@ -889,7 +972,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. */
{
Lisp_Object v1;
BEFORE_POTENTIAL_GC ();
@@ -1361,7 +1444,7 @@ If the third argument is incorrect, Emacs may crash. */)
AFTER_POTENTIAL_GC ();
break;
- case Binteractive_p:
+ case Binteractive_p: /* Obsolete. */
PUSH (Finteractive_p ());
break;
@@ -1651,8 +1734,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
generated by cgit v1.2.3 (git 2.46.0) at 2024-09-21 14:15:14 +0000