X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/b1d876f1a19ae65c8a8dd61c4ce17055ca53f16c..14af5f7fc4d7557ee712d3b6a8b46d9034c2ff39:/src/bytecode.c diff --git a/src/bytecode.c b/src/bytecode.c index ce2f06dfcc..6f945723d3 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -1,5 +1,5 @@ /* Execution of byte code produced by bytecomp.el. - Copyright (C) 1985-1988, 1993, 2000-2011 Free Software Foundation, Inc. + Copyright (C) 1985-1988, 1993, 2000-2012 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -83,6 +83,7 @@ Lisp_Object Qbytecode; /* 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 +133,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 @@ -143,7 +144,7 @@ Lisp_Object Qbytecode; #define Bcurrent_column 0151 #define Bindent_to 0152 #ifdef BYTE_CODE_SAFE -#define Bscan_buffer 0153 /* No longer generated as of v18 */ +#define Bscan_buffer 0153 /* No longer generated as of v18. */ #endif #define Beolp 0154 #define Beobp 0155 @@ -158,7 +159,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 +184,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 +229,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. */ @@ -265,7 +271,7 @@ struct byte_stack /* A list of currently active byte-code execution value stacks. Fbyte_code adds an entry to the head of this list before it starts processing byte-code, and it removed the entry again when it is - done. Signalling an error truncates the list analoguous to + done. Signaling an error truncates the list analogous to gcprolist. */ struct byte_stack *byte_stack_list; @@ -413,6 +419,21 @@ 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) +{ + 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, ptrdiff_t nargs, Lisp_Object *args) { int count = SPECPDL_INDEX (); #ifdef BYTE_CODE_METER @@ -423,10 +444,10 @@ If the third argument is incorrect, Emacs may crash. */) /* 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; @@ -443,7 +464,11 @@ If the third argument is incorrect, Emacs may crash. */) 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 @@ -453,12 +478,16 @@ If the third argument is incorrect, Emacs may crash. */) 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; + if (min (PTRDIFF_MAX, SIZE_MAX) / sizeof (Lisp_Object) < XFASTINT (maxdepth)) + memory_full (SIZE_MAX); top = (Lisp_Object *) alloca (XFASTINT (maxdepth) * sizeof (Lisp_Object)); #if BYTE_MAINTAIN_TOP @@ -473,6 +502,52 @@ If the third argument is incorrect, Emacs may crash. */) stacke = stack.bottom - 1 + XFASTINT (maxdepth); #endif + if (INTEGERP (args_template)) + { + ptrdiff_t at = XINT (args_template); + int rest = at & 128; + int mandatory = at & 127; + ptrdiff_t nonrest = at >> 8; + eassert (mandatory <= nonrest); + if (nargs <= nonrest) + { + ptrdiff_t 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 (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 @@ -554,7 +629,16 @@ If the third argument is incorrect, Emacs may crash. */) { 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; } @@ -580,7 +664,17 @@ If the third argument is incorrect, Emacs may crash. */) { 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; } @@ -714,7 +808,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 (); @@ -842,37 +936,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 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, 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; @@ -883,7 +983,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)); @@ -891,7 +991,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 (); @@ -911,13 +1011,13 @@ If the third argument is incorrect, Emacs may crash. */) v1 = POP; v2 = TOP; CHECK_NUMBER (v2); - AFTER_POTENTIAL_GC (); op = XINT (v2); immediate_quit = 1; while (--op >= 0 && CONSP (v1)) v1 = XCDR (v1); immediate_quit = 0; TOP = CAR (v1); + AFTER_POTENTIAL_GC (); break; } @@ -1363,7 +1463,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; @@ -1653,8 +1753,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; + } + case Bstack_set: + /* stack-set-0 = discard; stack-set-1 = discard-1-preserve-tos. */ + { + 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 @@ -1691,8 +1840,7 @@ If the third argument is incorrect, Emacs may crash. */) void syms_of_bytecode (void) { - Qbytecode = intern_c_string ("byte-code"); - staticpro (&Qbytecode); + DEFSYM (Qbytecode, "byte-code"); defsubr (&Sbyte_code); @@ -1714,8 +1862,7 @@ integer, it is incremented each time that symbol's function is called. */); 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--)