X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/bba90ab24e80476efcad6b6a770fd5fda522a621..cbeeab2eab5d53f0fba452d4790d7a58071605e2:/src/bytecode.c diff --git a/src/bytecode.c b/src/bytecode.c index bd8abe85e0..55789b41ad 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-2013 Free Software Foundation, + Copyright (C) 1985-1988, 1993, 2000-2015 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -36,8 +36,10 @@ by Hallvard: #include #include "lisp.h" +#include "blockinput.h" #include "character.h" #include "buffer.h" +#include "keyboard.h" #include "syntax.h" #include "window.h" @@ -59,14 +61,14 @@ by Hallvard: indirect threaded, using GCC's computed goto extension. This code, as currently implemented, is incompatible with BYTE_CODE_SAFE and BYTE_CODE_METER. */ -#if defined (__GNUC__) && !defined (BYTE_CODE_SAFE) && !defined (BYTE_CODE_METER) +#if (defined __GNUC__ && !defined __STRICT_ANSI__ \ + && !defined BYTE_CODE_SAFE && !defined BYTE_CODE_METER) #define BYTE_CODE_THREADED #endif #ifdef BYTE_CODE_METER -Lisp_Object Qbyte_code_meter; #define METER_2(code1, code2) AREF (AREF (Vbyte_code_meter, code1), code2) #define METER_1(code) METER_2 (0, code) @@ -140,6 +142,10 @@ DEFINE (Bunbind5, 055) \ DEFINE (Bunbind6, 056) \ DEFINE (Bunbind7, 057) \ \ +DEFINE (Bpophandler, 060) \ +DEFINE (Bpushconditioncase, 061) \ +DEFINE (Bpushcatch, 062) \ + \ DEFINE (Bnth, 070) \ DEFINE (Bsymbolp, 071) \ DEFINE (Bconsp, 072) \ @@ -285,7 +291,7 @@ enum byte_code_op #ifdef BYTE_CODE_SAFE Bscan_buffer = 0153, /* No longer generated as of v18. */ - Bset_mark = 0163 /* this loser is no longer generated as of v18 */ + Bset_mark = 0163, /* this loser is no longer generated as of v18 */ #endif }; @@ -313,9 +319,11 @@ struct byte_stack Lisp_Object byte_string; const unsigned char *byte_string_start; +#if BYTE_MARK_STACK /* The vector of constants used during byte-code execution. Storing this here protects it from GC because mark_byte_stack marks it. */ Lisp_Object constants; +#endif /* Next entry in byte_stack_list. */ struct byte_stack *next; @@ -323,7 +331,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 + processing byte-code, and it removes the entry again when it is done. Signaling an error truncates the list analogous to gcprolist. */ @@ -379,12 +387,16 @@ unmark_byte_stack (void) } -/* Fetch the next byte from the bytecode stream */ +/* Fetch the next byte from the bytecode stream. */ +#ifdef BYTE_CODE_SAFE +#define FETCH (eassert (stack.byte_string_start == SDATA (stack.byte_string)), *stack.pc++) +#else #define FETCH *stack.pc++ +#endif /* Fetch two bytes from the bytecode stream and make a 16-bit number - out of them */ + out of them. */ #define FETCH2 (op = FETCH, op + (FETCH << 8)) @@ -404,7 +416,7 @@ unmark_byte_stack (void) #define DISCARD(n) (top -= (n)) /* Get the value which is at the top of the execution stack, but don't - pop it. */ + pop it. */ #define TOP (*top) @@ -473,6 +485,12 @@ If the third argument is incorrect, Emacs may crash. */) return exec_byte_code (bytestr, vector, maxdepth, Qnil, 0, NULL); } +static void +bcall0 (Lisp_Object f) +{ + Ffuncall (1, &f); +} + /* 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 @@ -487,7 +505,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, { ptrdiff_t count = SPECPDL_INDEX (); #ifdef BYTE_CODE_METER - int this_op = 0; + int volatile this_op = 0; int prev_op; #endif int op; @@ -501,6 +519,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, struct byte_stack stack; Lisp_Object *top; Lisp_Object result; + enum handlertype type; #if 0 /* CHECK_FRAME_FONT */ { @@ -535,7 +554,9 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, stack.byte_string = bytestr; stack.pc = stack.byte_string_start = SDATA (bytestr); +#if BYTE_MARK_STACK stack.constants = vector; +#endif if (MAX_ALLOCA / word_size <= XFASTINT (maxdepth)) memory_full (SIZE_MAX); top = alloca ((XFASTINT (maxdepth) + 1) * sizeof *top); @@ -565,9 +586,9 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, if (nargs < mandatory) /* Too few arguments. */ Fsignal (Qwrong_number_of_arguments, - Fcons (Fcons (make_number (mandatory), + list2 (Fcons (make_number (mandatory), rest ? Qand_rest : make_number (nonrest)), - Fcons (make_number (nargs), Qnil))); + make_number (nargs))); else { for (; i < nonrest; i++) @@ -586,9 +607,8 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, else /* Too many arguments. */ Fsignal (Qwrong_number_of_arguments, - Fcons (Fcons (make_number (mandatory), - make_number (nonrest)), - Fcons (make_number (nargs), Qnil))); + list2 (Fcons (make_number (mandatory), make_number (nonrest)), + make_number (nargs))); } else if (! NILP (args_template)) /* We should push some arguments on the stack. */ @@ -656,9 +676,12 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, the table clearer. */ #define LABEL(OP) [OP] = &&insn_ ## OP -#if (__GNUC__ == 4 && 6 <= __GNUC_MINOR__) || 4 < __GNUC__ +#if 4 < __GNUC__ + (6 <= __GNUC_MINOR__) # pragma GCC diagnostic push # pragma GCC diagnostic ignored "-Woverride-init" +#elif defined __clang__ +# pragma GCC diagnostic push +# pragma GCC diagnostic ignored "-Winitializer-overrides" #endif /* This is the dispatch table for the threaded interpreter. */ @@ -672,7 +695,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, #undef DEFINE }; -#if (__GNUC__ == 4 && 6 <= __GNUC_MINOR__) || 4 < __GNUC__ +#if 4 < __GNUC__ + (6 <= __GNUC_MINOR__) || defined __clang__ # pragma GCC diagnostic pop #endif @@ -751,7 +774,6 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, { BEFORE_POTENTIAL_GC (); wrong_type_argument (Qlistp, v1); - AFTER_POTENTIAL_GC (); } NEXT; } @@ -786,7 +808,6 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, { BEFORE_POTENTIAL_GC (); wrong_type_argument (Qlistp, v1); - AFTER_POTENTIAL_GC (); } NEXT; } @@ -1056,8 +1077,8 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CASE (Bsave_window_excursion): /* Obsolete since 24.1. */ { - register ptrdiff_t count1 = SPECPDL_INDEX (); - record_unwind_protect (Fset_window_configuration, + ptrdiff_t count1 = SPECPDL_INDEX (); + record_unwind_protect (restore_window_configuration, Fcurrent_window_configuration (Qnil)); BEFORE_POTENTIAL_GC (); TOP = Fprogn (TOP); @@ -1071,7 +1092,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, save_restriction_save ()); NEXT; - CASE (Bcatch): /* FIXME: ill-suited for lexbind. */ + CASE (Bcatch): /* Obsolete since 24.4. */ { Lisp_Object v1; BEFORE_POTENTIAL_GC (); @@ -1081,11 +1102,58 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, NEXT; } + CASE (Bpushcatch): /* New in 24.4. */ + type = CATCHER; + goto pushhandler; + CASE (Bpushconditioncase): /* New in 24.4. */ + { + struct handler *c; + Lisp_Object tag; + int dest; + + type = CONDITION_CASE; + pushhandler: + tag = POP; + dest = FETCH2; + + PUSH_HANDLER (c, tag, type); + c->bytecode_dest = dest; + c->bytecode_top = top; + + if (sys_setjmp (c->jmp)) + { + struct handler *c = handlerlist; + int dest; + top = c->bytecode_top; + dest = c->bytecode_dest; + handlerlist = c->next; + PUSH (c->val); + CHECK_RANGE (dest); + /* Might have been re-set by longjmp! */ + stack.byte_string_start = SDATA (stack.byte_string); + stack.pc = stack.byte_string_start + dest; + } + + NEXT; + } + + CASE (Bpophandler): /* New in 24.4. */ + { + handlerlist = handlerlist->next; + NEXT; + } + CASE (Bunwind_protect): /* FIXME: avoid closure for lexbind. */ - record_unwind_protect (Fprogn, POP); - NEXT; + { + Lisp_Object handler = POP; + /* Support for a function here is new in 24.4. */ + record_unwind_protect (NILP (Ffunctionp (handler)) + ? unwind_body : bcall0, + handler); + NEXT; + } - CASE (Bcondition_case): /* FIXME: ill-suited for lexbind. */ + CASE (Bcondition_case): /* Obsolete since 24.4. */ { Lisp_Object handlers, body; handlers = POP; @@ -1164,14 +1232,14 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, } CASE (Blist1): - TOP = Fcons (TOP, Qnil); + TOP = list1 (TOP); NEXT; CASE (Blist2): { Lisp_Object v1; v1 = POP; - TOP = Fcons (TOP, Fcons (v1, Qnil)); + TOP = list2 (TOP, v1); NEXT; } @@ -1360,7 +1428,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, Lisp_Object v1; BEFORE_POTENTIAL_GC (); v1 = POP; - TOP = Fgtr (TOP, v1); + TOP = arithcompare (TOP, v1, ARITH_GRTR); AFTER_POTENTIAL_GC (); NEXT; } @@ -1370,7 +1438,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, Lisp_Object v1; BEFORE_POTENTIAL_GC (); v1 = POP; - TOP = Flss (TOP, v1); + TOP = arithcompare (TOP, v1, ARITH_LESS); AFTER_POTENTIAL_GC (); NEXT; } @@ -1380,7 +1448,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, Lisp_Object v1; BEFORE_POTENTIAL_GC (); v1 = POP; - TOP = Fleq (TOP, v1); + TOP = arithcompare (TOP, v1, ARITH_LESS_OR_EQUAL); AFTER_POTENTIAL_GC (); NEXT; } @@ -1390,7 +1458,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, Lisp_Object v1; BEFORE_POTENTIAL_GC (); v1 = POP; - TOP = Fgeq (TOP, v1); + TOP = arithcompare (TOP, v1, ARITH_GRTR_OR_EQUAL); AFTER_POTENTIAL_GC (); NEXT; } @@ -1631,7 +1699,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, c = XFASTINT (TOP); if (NILP (BVAR (current_buffer, enable_multibyte_characters))) MAKE_CHAR_MULTIBYTE (c); - XSETFASTINT (TOP, syntax_code_spec[(int) SYNTAX (c)]); + XSETFASTINT (TOP, syntax_code_spec[SYNTAX (c)]); } NEXT; @@ -1877,7 +1945,10 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, /* Actually this is Bstack_ref with offset 0, but we use Bdup for that instead. */ /* CASE (Bstack_ref): */ - error ("Invalid byte opcode"); + call3 (Qerror, + build_string ("Invalid byte opcode: op=%s, ptr=%d"), + make_number (op), + make_number ((stack.pc - 1) - stack.byte_string_start)); /* Handy byte-codes for lexical binding. */ CASE (Bstack_ref1): @@ -1950,11 +2021,11 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, /* Binds and unbinds are supposed to be compiled balanced. */ if (SPECPDL_INDEX () != count) -#ifdef BYTE_CODE_SAFE - error ("binding stack not balanced (serious byte compiler bug)"); -#else - emacs_abort (); -#endif + { + if (SPECPDL_INDEX () > count) + unbind_to (count, Qnil); + error ("binding stack not balanced (serious byte compiler bug)"); + } return result; }