} \
}
-#else /* no BYTE_CODE_METER */
-
-#define METER_CODE(last_code, this_code)
-
-#endif /* no BYTE_CODE_METER */
+#endif /* BYTE_CODE_METER */
\f
Lisp_Object Qbytecode;
-extern Lisp_Object Qand_optional, Qand_rest;
/* Byte codes: */
-#define Bstack_ref 0
+#define Bstack_ref 0 /* Actually, Bstack_ref+0 is not implemented: use dup. */
#define Bvarref 010
#define Bvarset 020
#define Bvarbind 030
#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
#define Bpreceding_char 0150
#define Bcurrent_column 0151
#define Bindent_to 0152
-#define Bscan_buffer 0153 /* No longer generated as of v18 */
+#ifdef BYTE_CODE_SAFE
+#define Bscan_buffer 0153 /* No longer generated as of v18. */
+#endif
#define Beolp 0154
#define Beobp 0155
#define Bbolp 0156
#define Bcurrent_buffer 0160
#define Bset_buffer 0161
#define Bsave_current_buffer_1 0162 /* Replacing Bsave_current_buffer. */
+#if 0
#define Bread_char 0162 /* No longer generated as of v19 */
+#endif
+#ifdef BYTE_CODE_SAFE
#define Bset_mark 0163 /* this loser is no longer generated as of v18 */
-#define Binteractive_p 0164 /* Needed since interactive-p takes unevalled args */
+#endif
+#define Binteractive_p 0164 /* Obsolete since Emacs-24.1. */
#define Bforward_char 0165
#define Bforward_word 0166
#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
/* Bstack_ref is code 0. */
#define Bstack_set 0262
#define Bstack_set2 0263
-#define Bvec_ref 0264
-#define Bvec_set 0265
#define BdiscardN 0266
#define Bconstant 0300
-#define CONSTANTLIM 0100
+/* Whether to maintain a `top' and `bottom' field in the stack frame. */
+#define BYTE_MAINTAIN_TOP (BYTE_CODE_SAFE || BYTE_MARK_STACK)
\f
/* Structure describing a value stack used during byte-code execution
in Fbyte_code. */
/* Top and bottom of stack. The bottom points to an area of memory
allocated with alloca in Fbyte_code. */
+#if BYTE_MAINTAIN_TOP
Lisp_Object *top, *bottom;
+#endif
/* The string containing the byte-code, and its current address.
Storing this here protects it from GC because mark_byte_stack
\f
/* Mark objects on byte_stack_list. Called during GC. */
+#if BYTE_MARK_STACK
void
mark_byte_stack (void)
{
mark_object (stack->constants);
}
}
-
+#endif
/* Unmark objects in the stacks on byte_stack_list. Relocate program
counters. Called when GC has completed. */
/* Actions that must be performed before and after calling a function
that might GC. */
+#if !BYTE_MAINTAIN_TOP
+#define BEFORE_POTENTIAL_GC() ((void)0)
+#define AFTER_POTENTIAL_GC() ((void)0)
+#else
#define BEFORE_POTENTIAL_GC() stack.top = top
#define AFTER_POTENTIAL_GC() stack.top = NULL
+#endif
/* Garbage collect if we have consed enough since the last time.
We do this at every branch, to avoid loops that never GC. */
#define MAYBE_GC() \
+ do { \
if (consing_since_gc > gc_cons_threshold \
&& consing_since_gc > gc_relative_threshold) \
{ \
Fgarbage_collect (); \
AFTER_POTENTIAL_GC (); \
} \
- else
+ } while (0)
/* Check for jumping out of range. */
} while (0)
-DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, MANY, 0,
+DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 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.
-
-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)
+If the third argument is incorrect, Emacs may crash. */)
+ (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth)
{
- 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);
+ return exec_byte_code (bytestr, vector, maxdepth, Qnil, 0, NULL);
}
/* Execute the byte-code in BYTESTR. VECTOR is the constant vector, and
Lisp_Object
exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
- Lisp_Object args_template, int nargs, Lisp_Object *args)
+ Lisp_Object args_template, ptrdiff_t nargs, Lisp_Object *args)
{
- int count = SPECPDL_INDEX ();
+ ptrdiff_t count = SPECPDL_INDEX ();
#ifdef BYTE_CODE_METER
int this_op = 0;
int prev_op;
/* Lisp_Object v1, v2; */
Lisp_Object *vectorp;
#ifdef BYTE_CODE_SAFE
- int const_length = XVECTOR (vector)->size;
+ ptrdiff_t const_length;
Lisp_Object *stacke;
-#endif
int bytestr_length;
+#endif
struct byte_stack stack;
Lisp_Object *top;
Lisp_Object result;
CHECK_STRING (bytestr);
CHECK_VECTOR (vector);
- CHECK_NUMBER (maxdepth);
+ CHECK_NATNUM (maxdepth);
+
+#ifdef BYTE_CODE_SAFE
+ const_length = ASIZE (vector);
+#endif
if (STRING_MULTIBYTE (bytestr))
/* BYTESTR must have been produced by Emacs 20.2 or the earlier
convert them back to the originally intended unibyte form. */
bytestr = Fstring_as_unibyte (bytestr);
+#ifdef BYTE_CODE_SAFE
bytestr_length = SBYTES (bytestr);
+#endif
vectorp = XVECTOR (vector)->contents;
stack.byte_string = bytestr;
stack.pc = stack.byte_string_start = SDATA (bytestr);
stack.constants = vector;
- stack.bottom = (Lisp_Object *) alloca (XFASTINT (maxdepth)
+ top = (Lisp_Object *) alloca (XFASTINT (maxdepth)
* sizeof (Lisp_Object));
- top = stack.bottom - 1;
+#if BYTE_MAINTAIN_TOP
+ stack.bottom = top;
stack.top = NULL;
+#endif
+ top -= 1;
stack.next = byte_stack_list;
byte_stack_list = &stack;
stacke = stack.bottom - 1 + XFASTINT (maxdepth);
#endif
- if (! NILP (args_template))
- /* We should push some arguments on the stack. */
+ if (INTEGERP (args_template))
{
- Lisp_Object at;
- int pushed = 0, optional = 0;
-
- for (at = args_template; CONSP (at); at = XCDR (at))
- if (EQ (XCAR (at), Qand_optional))
- optional = 1;
- else if (EQ (XCAR (at), Qand_rest))
- {
- PUSH (Flist (nargs, args));
- pushed = nargs;
- at = Qnil;
- break;
- }
- else if (pushed < nargs)
- {
- PUSH (*args++);
- pushed++;
- }
- else if (optional)
- PUSH (Qnil);
- else
- break;
-
- if (pushed != nargs || !NILP (at))
+ EMACS_INT at = XINT (args_template);
+ int rest = at & 128;
+ int mandatory = at & 127;
+ EMACS_INT nonrest = at >> 8;
+ eassert (mandatory <= nonrest);
+ if (nargs <= nonrest)
+ {
+ EMACS_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)
+ {
+ ptrdiff_t 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 (args_template, Fcons (make_number (nargs), Qnil)));
+ 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)
{
Lisp_Object v1;
v1 = TOP;
- TOP = CAR (v1);
+ if (CONSP (v1))
+ TOP = XCAR (v1);
+ else if (NILP (v1))
+ TOP = Qnil;
+ else
+ {
+ BEFORE_POTENTIAL_GC ();
+ wrong_type_argument (Qlistp, v1);
+ AFTER_POTENTIAL_GC ();
+ }
break;
}
{
Lisp_Object v1;
v1 = TOP;
- TOP = CDR (v1);
+ if (CONSP (v1))
+ TOP = XCDR (v1);
+ else if (NILP (v1))
+ TOP = Qnil;
+ else
+ {
+ BEFORE_POTENTIAL_GC ();
+ wrong_type_argument (Qlistp, v1);
+ AFTER_POTENTIAL_GC ();
+ }
+ break;
break;
}
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 ();
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); /* FIXME: lexbind */
- AFTER_POTENTIAL_GC ();
- break;
+ case Bsave_window_excursion: /* Obsolete since 24.1. */
+ {
+ register ptrdiff_t count1 = SPECPDL_INDEX ();
+ record_unwind_protect (Fset_window_configuration,
+ Fcurrent_window_configuration (Qnil));
+ BEFORE_POTENTIAL_GC ();
+ TOP = Fprogn (TOP);
+ unbind_to (count1, 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, eval_sub, v1); /* FIXME: lexbind */
+ TOP = internal_catch (TOP, eval_sub, v1);
AFTER_POTENTIAL_GC ();
break;
}
- case Bunwind_protect:
- record_unwind_protect (Fprogn, POP); /* FIXME: lexbind */
+ 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;
body = POP;
BEFORE_POTENTIAL_GC ();
- TOP = internal_lisp_condition_case (TOP, body, handlers); /* FIXME: lexbind */
+ TOP = internal_lisp_condition_case (TOP, body, handlers);
AFTER_POTENTIAL_GC ();
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));
TOP = Vstandard_output;
break;
- case Btemp_output_buffer_show:
+ case Btemp_output_buffer_show: /* Obsolete since 24.1. */
{
Lisp_Object v1;
BEFORE_POTENTIAL_GC ();
case Bnth:
{
Lisp_Object v1, v2;
+ EMACS_INT n;
BEFORE_POTENTIAL_GC ();
v1 = POP;
v2 = TOP;
CHECK_NUMBER (v2);
- AFTER_POTENTIAL_GC ();
- op = XINT (v2);
+ n = XINT (v2);
immediate_quit = 1;
- while (--op >= 0 && CONSP (v1))
+ while (--n >= 0 && CONSP (v1))
v1 = XCDR (v1);
immediate_quit = 0;
TOP = CAR (v1);
+ AFTER_POTENTIAL_GC ();
break;
}
{
Lisp_Object v1;
BEFORE_POTENTIAL_GC ();
- XSETFASTINT (v1, (int) current_column ()); /* iftc */
+ XSETFASTINT (v1, current_column ());
AFTER_POTENTIAL_GC ();
PUSH (v1);
break;
AFTER_POTENTIAL_GC ();
break;
- case Binteractive_p:
+ case Binteractive_p: /* Obsolete since 24.1. */
PUSH (Finteractive_p ());
break;
CHECK_CHARACTER (TOP);
AFTER_POTENTIAL_GC ();
c = XFASTINT (TOP);
- if (NILP (current_buffer->enable_multibyte_characters))
+ if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
MAKE_CHAR_MULTIBYTE (c);
XSETFASTINT (TOP, syntax_code_spec[(int) SYNTAX (c)]);
}
if (CONSP (TOP))
{
/* Exchange args and then do nth. */
+ EMACS_INT n;
BEFORE_POTENTIAL_GC ();
v2 = POP;
v1 = TOP;
CHECK_NUMBER (v2);
AFTER_POTENTIAL_GC ();
- op = XINT (v2);
+ n = XINT (v2);
immediate_quit = 1;
- while (--op >= 0 && CONSP (v1))
+ while (--n >= 0 && CONSP (v1))
v1 = XCDR (v1);
immediate_quit = 0;
TOP = CAR (v1);
break;
#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:
case Bstack_ref+1:
case Bstack_ref+2:
case Bstack_ref+3:
case Bstack_ref+4:
case Bstack_ref+5:
- PUSH (stack.bottom[op - Bstack_ref]);
- break;
+ {
+ Lisp_Object *ptr = top - (op - Bstack_ref);
+ PUSH (*ptr);
+ break;
+ }
case Bstack_ref+6:
- PUSH (stack.bottom[FETCH]);
- break;
+ {
+ Lisp_Object *ptr = top - (FETCH);
+ PUSH (*ptr);
+ break;
+ }
case Bstack_ref+7:
- PUSH (stack.bottom[FETCH2]);
- break;
+ {
+ Lisp_Object *ptr = top - (FETCH2);
+ PUSH (*ptr);
+ break;
+ }
case Bstack_set:
- stack.bottom[FETCH] = POP;
- break;
+ /* stack-set-0 = discard; stack-set-1 = discard-1-preserve-tos. */
+ {
+ Lisp_Object *ptr = top - (FETCH);
+ *ptr = POP;
+ break;
+ }
case Bstack_set2:
- stack.bottom[FETCH2] = POP;
- break;
- case Bvec_ref:
- case Bvec_set:
- /* These byte-codes used mostly for variable references to
- lexically bound variables that are in an environment vector
- instead of on the byte-interpreter stack (generally those
- variables which might be shared with a closure). */
{
- int index = FETCH;
- Lisp_Object vec = POP;
-
- if (! VECTORP (vec))
- wrong_type_argument (Qvectorp, vec);
- else if (index < 0 || index >= XVECTOR (vec)->size)
- args_out_of_range (vec, make_number (index));
-
- if (op == Bvec_ref)
- PUSH (XVECTOR (vec)->contents[index]);
- else
- XVECTOR (vec)->contents[index] = POP;
+ Lisp_Object *ptr = top - (FETCH2);
+ *ptr = POP;
+ break;
}
- break;
case BdiscardN:
op = FETCH;
if (op & 0x80)
void
syms_of_bytecode (void)
{
- Qbytecode = intern_c_string ("byte-code");
- staticpro (&Qbytecode);
+ DEFSYM (Qbytecode, "byte-code");
defsubr (&Sbyte_code);
byte_metering_on = 0;
Vbyte_code_meter = Fmake_vector (make_number (256), make_number (0));
- Qbyte_code_meter = intern_c_string ("byte-code-meter");
- staticpro (&Qbyte_code_meter);
+ DEFSYM (Qbyte_code_meter, "byte-code-meter");
{
int i = 256;
while (i--)
HCoop / bpt / emacs.git / blobdiff