X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/adf2aa61404305e58e71cde0193bb650aff2c4b3..785adfcc8dee02ac544f80e4f7f8d3d5b2965981:/src/eval.c diff --git a/src/eval.c b/src/eval.c index 5526b28b2e..5cadb1bc2d 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1,6 +1,7 @@ /* Evaluator for GNU Emacs Lisp interpreter. - Copyright (C) 1985-1987, 1993-1995, 1999-2013 Free Software - Foundation, Inc. + +Copyright (C) 1985-1987, 1993-1995, 1999-2015 Free Software Foundation, +Inc. This file is part of GNU Emacs. @@ -26,11 +27,7 @@ along with GNU Emacs. If not, see . */ #include "commands.h" #include "keyboard.h" #include "dispextern.h" -#include "frame.h" /* For XFRAME. */ - -#if HAVE_X_WINDOWS -#include "xterm.h" -#endif +#include "buffer.h" /* Chain of condition and catch handlers currently in effect. */ @@ -41,22 +38,6 @@ struct handler *handlerlist; int gcpro_level; #endif -Lisp_Object Qautoload, Qmacro, Qexit, Qinteractive, Qcommandp; -Lisp_Object Qinhibit_quit; -Lisp_Object Qand_rest; -static Lisp_Object Qand_optional; -static Lisp_Object Qinhibit_debugger; -static Lisp_Object Qdeclare; -Lisp_Object Qinternal_interpreter_environment, Qclosure; - -static Lisp_Object Qdebug; - -/* This holds either the symbol `run-hooks' or nil. - It is nil at an early stage of startup, and when Emacs - is shutting down. */ - -Lisp_Object Vrun_hooks; - /* Non-nil means record all fset's and provide's, to be undone if the file being autoloaded is not fully loaded. They are recorded by being consed onto the front of Vautoload_queue: @@ -64,6 +45,11 @@ Lisp_Object Vrun_hooks; Lisp_Object Vautoload_queue; +/* This holds either the symbol `run-hooks' or nil. + It is nil at an early stage of startup, and when Emacs + is shutting down. */ +Lisp_Object Vrun_hooks; + /* Current number of specbindings allocated in specpdl, not counting the dummy entry specpdl[-1]. */ @@ -96,10 +82,8 @@ static EMACS_INT when_entered_debugger; /* FIXME: We should probably get rid of this! */ Lisp_Object Vsignaling_function; -/* If non-nil, Lisp code must not be run since some part of Emacs is - in an inconsistent state. Currently, x-create-frame uses this to - avoid triggering window-configuration-change-hook while the new - frame is half-initialized. */ +/* If non-nil, Lisp code must not be run since some part of Emacs is in + an inconsistent state. Currently unused. */ Lisp_Object inhibit_lisp_code; /* These would ordinarily be static, but they need to be visible to GDB. */ @@ -110,7 +94,7 @@ union specbinding *backtrace_next (union specbinding *) EXTERNALLY_VISIBLE; union specbinding *backtrace_top (void) EXTERNALLY_VISIBLE; static Lisp_Object funcall_lambda (Lisp_Object, ptrdiff_t, Lisp_Object *); -static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args); +static Lisp_Object apply_lambda (Lisp_Object, Lisp_Object, ptrdiff_t); static Lisp_Object specpdl_symbol (union specbinding *pdl) @@ -178,17 +162,11 @@ backtrace_debug_on_exit (union specbinding *pdl) /* Functions to modify slots of backtrace records. */ static void -set_backtrace_args (union specbinding *pdl, Lisp_Object *args) +set_backtrace_args (union specbinding *pdl, Lisp_Object *args, ptrdiff_t nargs) { eassert (pdl->kind == SPECPDL_BACKTRACE); pdl->bt.args = args; -} - -static void -set_backtrace_nargs (union specbinding *pdl, ptrdiff_t n) -{ - eassert (pdl->kind == SPECPDL_BACKTRACE); - pdl->bt.nargs = n; + pdl->bt.nargs = nargs; } static void @@ -237,11 +215,22 @@ init_eval_once (void) Vrun_hooks = Qnil; } +static struct handler handlerlist_sentinel; + void init_eval (void) { specpdl_ptr = specpdl; - handlerlist = NULL; + { /* Put a dummy catcher at top-level so that handlerlist is never NULL. + This is important since handlerlist->nextfree holds the freelist + which would otherwise leak every time we unwind back to top-level. */ + struct handler *c; + handlerlist = handlerlist_sentinel.nextfree = &handlerlist_sentinel; + PUSH_HANDLER (c, Qunbound, CATCHER); + eassert (c == &handlerlist_sentinel); + handlerlist_sentinel.nextfree = NULL; + handlerlist_sentinel.next = NULL; + } Vquit_flag = Qnil; debug_on_next_call = 0; lisp_eval_depth = 0; @@ -261,6 +250,8 @@ restore_stack_limits (Lisp_Object data) max_lisp_eval_depth = XINT (XCDR (data)); } +static void grow_specpdl (void); + /* Call the Lisp debugger, giving it argument ARG. */ Lisp_Object @@ -269,22 +260,29 @@ call_debugger (Lisp_Object arg) bool debug_while_redisplaying; ptrdiff_t count = SPECPDL_INDEX (); Lisp_Object val; - EMACS_INT old_max = max_specpdl_size; - - /* Temporarily bump up the stack limits, - so the debugger won't run out of stack. */ - - max_specpdl_size += 1; - record_unwind_protect (restore_stack_limits, - Fcons (make_number (old_max), - make_number (max_lisp_eval_depth))); - max_specpdl_size = old_max; + EMACS_INT old_depth = max_lisp_eval_depth; + /* Do not allow max_specpdl_size less than actual depth (Bug#16603). */ + EMACS_INT old_max = max (max_specpdl_size, count); if (lisp_eval_depth + 40 > max_lisp_eval_depth) max_lisp_eval_depth = lisp_eval_depth + 40; - if (max_specpdl_size - 100 < SPECPDL_INDEX ()) - max_specpdl_size = SPECPDL_INDEX () + 100; + /* While debugging Bug#16603, previous value of 100 was found + too small to avoid specpdl overflow in the debugger itself. */ + if (max_specpdl_size - 200 < count) + max_specpdl_size = count + 200; + + if (old_max == count) + { + /* We can enter the debugger due to specpdl overflow (Bug#16603). */ + specpdl_ptr--; + grow_specpdl (); + } + + /* Restore limits after leaving the debugger. */ + record_unwind_protect (restore_stack_limits, + Fcons (make_number (old_max), + make_number (old_depth))); #ifdef HAVE_WINDOW_SYSTEM if (display_hourglass_p) @@ -320,10 +318,10 @@ call_debugger (Lisp_Object arg) } static void -do_debug_on_call (Lisp_Object code) +do_debug_on_call (Lisp_Object code, ptrdiff_t count) { debug_on_next_call = 0; - set_backtrace_debug_on_exit (specpdl_ptr - 1, true); + set_backtrace_debug_on_exit (specpdl + count, true); call_debugger (list1 (code)); } @@ -405,9 +403,9 @@ Each clause looks like (CONDITION BODY...). CONDITION is evaluated and, if the value is non-nil, this clause succeeds: then the expressions in BODY are evaluated and the last one's value is the value of the cond-form. +If a clause has one element, as in (CONDITION), then the cond-form +returns CONDITION's value, if that is non-nil. If no clause succeeds, cond returns nil. -If a clause has one element, as in (CONDITION), -CONDITION's value if non-nil is returned from the cond-form. usage: (cond CLAUSES...) */) (Lisp_Object args) { @@ -1072,6 +1070,12 @@ usage: (catch TAG BODY...) */) return internal_catch (tag, Fprogn, XCDR (args)); } +/* Assert that E is true, as a comment only. Use this instead of + eassert (E) when E contains variables that might be clobbered by a + longjmp. */ + +#define clobbered_eassert(E) ((void) 0) + /* Set up a catch, then call C function FUNC on argument ARG. FUNC should return a Lisp_Object. This is how catches are done from within C code. */ @@ -1089,14 +1093,14 @@ internal_catch (Lisp_Object tag, Lisp_Object (*func) (Lisp_Object), Lisp_Object if (! sys_setjmp (c->jmp)) { Lisp_Object val = (*func) (arg); - eassert (handlerlist == c); - handlerlist = c->next; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; return val; } else { /* Throw works by a longjmp that comes right here. */ Lisp_Object val = handlerlist->val; - eassert (handlerlist == c); + clobbered_eassert (handlerlist == c); handlerlist = handlerlist->next; return val; } @@ -1123,6 +1127,8 @@ unwind_to_catch (struct handler *catch, Lisp_Object value) { bool last_time; + eassert (catch->next); + /* Save the value in the tag. */ catch->val = value; @@ -1156,7 +1162,8 @@ unwind_to_catch (struct handler *catch, Lisp_Object value) DEFUN ("throw", Fthrow, Sthrow, 2, 2, 0, doc: /* Throw to the catch for TAG and return VALUE from it. -Both TAG and VALUE are evalled. */) +Both TAG and VALUE are evalled. */ + attributes: noreturn) (register Lisp_Object tag, Lisp_Object value) { struct handler *c; @@ -1250,8 +1257,12 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform, { /* The first clause is the one that should be checked first, so it should be added to handlerlist last. So we build in `clauses' a table that - contains `handlers' but in reverse order. */ - Lisp_Object *clauses = alloca (clausenb * sizeof (Lisp_Object *)); + contains `handlers' but in reverse order. SAFE_ALLOCA won't work + here due to the setjmp, so impose a MAX_ALLOCA limit. */ + if (MAX_ALLOCA / word_size < clausenb) + memory_full (SIZE_MAX); + Lisp_Object *clauses = alloca (clausenb * sizeof *clauses); + Lisp_Object *volatile clauses_volatile = clauses; int i = clausenb; for (val = handlers; CONSP (val); val = XCDR (val)) clauses[--i] = XCAR (val); @@ -1266,7 +1277,7 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform, { ptrdiff_t count = SPECPDL_INDEX (); Lisp_Object val = handlerlist->val; - Lisp_Object *chosen_clause = clauses; + Lisp_Object *chosen_clause = clauses_volatile; for (c = handlerlist->next; c != oldhandlerlist; c = c->next) chosen_clause++; handlerlist = oldhandlerlist; @@ -1288,7 +1299,7 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform, return val; } } - } + } val = eval_sub (bodyform); handlerlist = oldhandlerlist; @@ -1316,14 +1327,14 @@ internal_condition_case (Lisp_Object (*bfun) (void), Lisp_Object handlers, if (sys_setjmp (c->jmp)) { Lisp_Object val = handlerlist->val; - eassert (handlerlist == c); + clobbered_eassert (handlerlist == c); handlerlist = handlerlist->next; return (*hfun) (val); } val = (*bfun) (); - eassert (handlerlist == c); - handlerlist = c->next; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; return val; } @@ -1340,14 +1351,14 @@ internal_condition_case_1 (Lisp_Object (*bfun) (Lisp_Object), Lisp_Object arg, if (sys_setjmp (c->jmp)) { Lisp_Object val = handlerlist->val; - eassert (handlerlist == c); + clobbered_eassert (handlerlist == c); handlerlist = handlerlist->next; return (*hfun) (val); } val = (*bfun) (arg); - eassert (handlerlist == c); - handlerlist = c->next; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; return val; } @@ -1368,14 +1379,14 @@ internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object), if (sys_setjmp (c->jmp)) { Lisp_Object val = handlerlist->val; - eassert (handlerlist == c); + clobbered_eassert (handlerlist == c); handlerlist = handlerlist->next; return (*hfun) (val); } val = (*bfun) (arg1, arg2); - eassert (handlerlist == c); - handlerlist = c->next; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; return val; } @@ -1398,14 +1409,14 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *), if (sys_setjmp (c->jmp)) { Lisp_Object val = handlerlist->val; - eassert (handlerlist == c); + clobbered_eassert (handlerlist == c); handlerlist = handlerlist->next; return (*hfun) (val, nargs, args); } val = (*bfun) (nargs, args); - eassert (handlerlist == c); - handlerlist = c->next; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; return val; } @@ -1512,8 +1523,7 @@ See also the function `condition-case'. */) || NILP (clause) /* A `debug' symbol in the handler list disables the normal suppression of the debugger. */ - || (CONSP (clause) && CONSP (XCAR (clause)) - && !NILP (Fmemq (Qdebug, XCAR (clause)))) + || (CONSP (clause) && !NILP (Fmemq (Qdebug, clause))) /* Special handler that means "print a message and run debugger if requested". */ || EQ (h->tag_or_ch, Qerror))) @@ -1535,7 +1545,10 @@ See also the function `condition-case'. */) } else { - if (handlerlist != 0) + if (handlerlist != &handlerlist_sentinel) + /* FIXME: This will come right back here if there's no `top-level' + catcher. A better solution would be to abort here, and instead + add a catch-all condition handler so we never come here. */ Fthrow (Qtop_level, Qt); } @@ -1894,7 +1907,7 @@ DEFUN ("autoload-do-load", Fautoload_do_load, Sautoload_do_load, 1, 3, 0, If non-nil, FUNNAME should be the symbol whose function value is FUNDEF, in which case the function returns the new autoloaded function value. If equal to `macro', MACRO-ONLY specifies that FUNDEF should only be loaded if -it is defines a macro. */) +it defines a macro. */) (Lisp_Object fundef, Lisp_Object funname, Lisp_Object macro_only) { ptrdiff_t count = SPECPDL_INDEX (); @@ -2006,9 +2019,11 @@ grow_specpdl (void) } } -void +ptrdiff_t record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs) { + ptrdiff_t count = SPECPDL_INDEX (); + eassert (nargs >= UNEVALLED); specpdl_ptr->bt.kind = SPECPDL_BACKTRACE; specpdl_ptr->bt.debug_on_exit = false; @@ -2016,6 +2031,8 @@ record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs) specpdl_ptr->bt.args = args; specpdl_ptr->bt.nargs = nargs; grow_specpdl (); + + return count; } /* Eval a sub-expression of the current expression (i.e. in the same @@ -2026,6 +2043,7 @@ eval_sub (Lisp_Object form) Lisp_Object fun, val, original_fun, original_args; Lisp_Object funcar; struct gcpro gcpro1, gcpro2, gcpro3; + ptrdiff_t count; if (SYMBOLP (form)) { @@ -2063,10 +2081,10 @@ eval_sub (Lisp_Object form) original_args = XCDR (form); /* This also protects them from gc. */ - record_in_backtrace (original_fun, &original_args, UNEVALLED); + count = record_in_backtrace (original_fun, &original_args, UNEVALLED); if (debug_on_next_call) - do_debug_on_call (Qt); + do_debug_on_call (Qt, count); /* At this point, only original_fun and original_args have values that will be used below. */ @@ -2118,8 +2136,7 @@ eval_sub (Lisp_Object form) gcpro3.nvars = argnum; } - set_backtrace_args (specpdl_ptr - 1, vals); - set_backtrace_nargs (specpdl_ptr - 1, XINT (numargs)); + set_backtrace_args (specpdl + count, vals, XINT (numargs)); val = (XSUBR (fun)->function.aMANY) (XINT (numargs), vals); UNGCPRO; @@ -2140,8 +2157,7 @@ eval_sub (Lisp_Object form) UNGCPRO; - set_backtrace_args (specpdl_ptr - 1, argvals); - set_backtrace_nargs (specpdl_ptr - 1, XINT (numargs)); + set_backtrace_args (specpdl + count, argvals, XINT (numargs)); switch (i) { @@ -2194,7 +2210,7 @@ eval_sub (Lisp_Object form) } } else if (COMPILEDP (fun)) - val = apply_lambda (fun, original_args); + val = apply_lambda (fun, original_args, count); else { if (NILP (fun)) @@ -2211,7 +2227,7 @@ eval_sub (Lisp_Object form) } if (EQ (funcar, Qmacro)) { - ptrdiff_t count = SPECPDL_INDEX (); + ptrdiff_t count1 = SPECPDL_INDEX (); Lisp_Object exp; /* Bind lexical-binding during expansion of the macro, so the macro can know reliably if the code it outputs will be @@ -2219,19 +2235,19 @@ eval_sub (Lisp_Object form) specbind (Qlexical_binding, NILP (Vinternal_interpreter_environment) ? Qnil : Qt); exp = apply1 (Fcdr (fun), original_args); - unbind_to (count, Qnil); + unbind_to (count1, Qnil); val = eval_sub (exp); } else if (EQ (funcar, Qlambda) || EQ (funcar, Qclosure)) - val = apply_lambda (fun, original_args); + val = apply_lambda (fun, original_args, count); else xsignal1 (Qinvalid_function, original_fun); } check_cons_list (); lisp_eval_depth--; - if (backtrace_debug_on_exit (specpdl_ptr - 1)) + if (backtrace_debug_on_exit (specpdl + count)) val = call_debugger (list2 (Qexit, val)); specpdl_ptr--; @@ -2245,17 +2261,13 @@ Thus, (apply '+ 1 2 '(3 4)) returns 10. usage: (apply FUNCTION &rest ARGUMENTS) */) (ptrdiff_t nargs, Lisp_Object *args) { - ptrdiff_t i; - EMACS_INT numargs; - register Lisp_Object spread_arg; - register Lisp_Object *funcall_args; - Lisp_Object fun, retval; - struct gcpro gcpro1; + ptrdiff_t i, numargs, funcall_nargs; + register Lisp_Object *funcall_args = NULL; + register Lisp_Object spread_arg = args[nargs - 1]; + Lisp_Object fun = args[0]; + Lisp_Object retval; USE_SAFE_ALLOCA; - fun = args [0]; - funcall_args = 0; - spread_arg = args [nargs - 1]; CHECK_LIST (spread_arg); numargs = XINT (Flength (spread_arg)); @@ -2273,38 +2285,29 @@ usage: (apply FUNCTION &rest ARGUMENTS) */) /* Optimize for no indirection. */ if (SYMBOLP (fun) && !NILP (fun) && (fun = XSYMBOL (fun)->function, SYMBOLP (fun))) - fun = indirect_function (fun); - if (NILP (fun)) { - /* Let funcall get the error. */ - fun = args[0]; - goto funcall; + fun = indirect_function (fun); + if (NILP (fun)) + /* Let funcall get the error. */ + fun = args[0]; } - if (SUBRP (fun)) + if (SUBRP (fun) && XSUBR (fun)->max_args > numargs + /* Don't hide an error by adding missing arguments. */ + && numargs >= XSUBR (fun)->min_args) { - if (numargs < XSUBR (fun)->min_args - || (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs)) - goto funcall; /* Let funcall get the error. */ - else if (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args > numargs) - { - /* Avoid making funcall cons up a yet another new vector of arguments - by explicitly supplying nil's for optional values. */ - SAFE_ALLOCA_LISP (funcall_args, 1 + XSUBR (fun)->max_args); - for (i = numargs; i < XSUBR (fun)->max_args;) - funcall_args[++i] = Qnil; - GCPRO1 (*funcall_args); - gcpro1.nvars = 1 + XSUBR (fun)->max_args; - } + /* Avoid making funcall cons up a yet another new vector of arguments + by explicitly supplying nil's for optional values. */ + SAFE_ALLOCA_LISP (funcall_args, 1 + XSUBR (fun)->max_args); + for (i = numargs; i < XSUBR (fun)->max_args; /* nothing */) + funcall_args[++i] = Qnil; + funcall_nargs = 1 + XSUBR (fun)->max_args; } - funcall: - /* We add 1 to numargs because funcall_args includes the - function itself as well as its arguments. */ - if (!funcall_args) - { + else + { /* We add 1 to numargs because funcall_args includes the + function itself as well as its arguments. */ SAFE_ALLOCA_LISP (funcall_args, 1 + numargs); - GCPRO1 (*funcall_args); - gcpro1.nvars = 1 + numargs; + funcall_nargs = 1 + numargs; } memcpy (funcall_args, args, nargs * word_size); @@ -2317,11 +2320,10 @@ usage: (apply FUNCTION &rest ARGUMENTS) */) spread_arg = XCDR (spread_arg); } - /* By convention, the caller needs to gcpro Ffuncall's args. */ - retval = Ffuncall (gcpro1.nvars, funcall_args); - UNGCPRO; - SAFE_FREE (); + /* Ffuncall gcpro's all of its args. */ + retval = Ffuncall (funcall_nargs, funcall_args); + SAFE_FREE (); return retval; } @@ -2351,14 +2353,10 @@ Instead, use `add-hook' and specify t for the LOCAL argument. usage: (run-hooks &rest HOOKS) */) (ptrdiff_t nargs, Lisp_Object *args) { - Lisp_Object hook[1]; ptrdiff_t i; for (i = 0; i < nargs; i++) - { - hook[0] = args[i]; - run_hook_with_args (1, hook, funcall_nil); - } + run_hook (args[i]); return Qnil; } @@ -2472,7 +2470,7 @@ run_hook_with_args (ptrdiff_t nargs, Lisp_Object *args, if (EQ (val, Qunbound) || NILP (val)) return ret; - else if (!CONSP (val) || EQ (XCAR (val), Qlambda)) + else if (!CONSP (val) || FUNCTIONP (val)) { args[0] = val; return funcall (nargs, args); @@ -2524,46 +2522,35 @@ run_hook_with_args (ptrdiff_t nargs, Lisp_Object *args, } } +/* Run the hook HOOK, giving each function no args. */ + +void +run_hook (Lisp_Object hook) +{ + Frun_hook_with_args (1, &hook); +} + /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */ void run_hook_with_args_2 (Lisp_Object hook, Lisp_Object arg1, Lisp_Object arg2) { - Lisp_Object temp[3]; - temp[0] = hook; - temp[1] = arg1; - temp[2] = arg2; - - Frun_hook_with_args (3, temp); + Frun_hook_with_args (3, ((Lisp_Object []) { hook, arg1, arg2 })); } - + /* Apply fn to arg. */ Lisp_Object apply1 (Lisp_Object fn, Lisp_Object arg) { - struct gcpro gcpro1; - - GCPRO1 (fn); - if (NILP (arg)) - RETURN_UNGCPRO (Ffuncall (1, &fn)); - gcpro1.nvars = 2; - { - Lisp_Object args[2]; - args[0] = fn; - args[1] = arg; - gcpro1.var = args; - RETURN_UNGCPRO (Fapply (2, args)); - } + return (NILP (arg) ? Ffuncall (1, &fn) + : Fapply (2, ((Lisp_Object []) { fn, arg }))); } /* Call function fn on no arguments. */ Lisp_Object call0 (Lisp_Object fn) { - struct gcpro gcpro1; - - GCPRO1 (fn); - RETURN_UNGCPRO (Ffuncall (1, &fn)); + return Ffuncall (1, &fn); } /* Call function fn with 1 argument arg1. */ @@ -2571,14 +2558,7 @@ call0 (Lisp_Object fn) Lisp_Object call1 (Lisp_Object fn, Lisp_Object arg1) { - struct gcpro gcpro1; - Lisp_Object args[2]; - - args[0] = fn; - args[1] = arg1; - GCPRO1 (args[0]); - gcpro1.nvars = 2; - RETURN_UNGCPRO (Ffuncall (2, args)); + return Ffuncall (2, ((Lisp_Object []) { fn, arg1 })); } /* Call function fn with 2 arguments arg1, arg2. */ @@ -2586,14 +2566,7 @@ call1 (Lisp_Object fn, Lisp_Object arg1) Lisp_Object call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2) { - struct gcpro gcpro1; - Lisp_Object args[3]; - args[0] = fn; - args[1] = arg1; - args[2] = arg2; - GCPRO1 (args[0]); - gcpro1.nvars = 3; - RETURN_UNGCPRO (Ffuncall (3, args)); + return Ffuncall (3, ((Lisp_Object []) { fn, arg1, arg2 })); } /* Call function fn with 3 arguments arg1, arg2, arg3. */ @@ -2601,15 +2574,7 @@ call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2) Lisp_Object call3 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3) { - struct gcpro gcpro1; - Lisp_Object args[4]; - args[0] = fn; - args[1] = arg1; - args[2] = arg2; - args[3] = arg3; - GCPRO1 (args[0]); - gcpro1.nvars = 4; - RETURN_UNGCPRO (Ffuncall (4, args)); + return Ffuncall (4, ((Lisp_Object []) { fn, arg1, arg2, arg3 })); } /* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */ @@ -2618,16 +2583,7 @@ Lisp_Object call4 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4) { - struct gcpro gcpro1; - Lisp_Object args[5]; - args[0] = fn; - args[1] = arg1; - args[2] = arg2; - args[3] = arg3; - args[4] = arg4; - GCPRO1 (args[0]); - gcpro1.nvars = 5; - RETURN_UNGCPRO (Ffuncall (5, args)); + return Ffuncall (5, ((Lisp_Object []) { fn, arg1, arg2, arg3, arg4 })); } /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */ @@ -2636,17 +2592,7 @@ Lisp_Object call5 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5) { - struct gcpro gcpro1; - Lisp_Object args[6]; - args[0] = fn; - args[1] = arg1; - args[2] = arg2; - args[3] = arg3; - args[4] = arg4; - args[5] = arg5; - GCPRO1 (args[0]); - gcpro1.nvars = 6; - RETURN_UNGCPRO (Ffuncall (6, args)); + return Ffuncall (6, ((Lisp_Object []) { fn, arg1, arg2, arg3, arg4, arg5 })); } /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */ @@ -2655,18 +2601,8 @@ Lisp_Object call6 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6) { - struct gcpro gcpro1; - Lisp_Object args[7]; - args[0] = fn; - args[1] = arg1; - args[2] = arg2; - args[3] = arg3; - args[4] = arg4; - args[5] = arg5; - args[6] = arg6; - GCPRO1 (args[0]); - gcpro1.nvars = 7; - RETURN_UNGCPRO (Ffuncall (7, args)); + return Ffuncall (7, ((Lisp_Object []) + { fn, arg1, arg2, arg3, arg4, arg5, arg6 })); } /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */ @@ -2675,19 +2611,8 @@ Lisp_Object call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6, Lisp_Object arg7) { - struct gcpro gcpro1; - Lisp_Object args[8]; - args[0] = fn; - args[1] = arg1; - args[2] = arg2; - args[3] = arg3; - args[4] = arg4; - args[5] = arg5; - args[6] = arg6; - args[7] = arg7; - GCPRO1 (args[0]); - gcpro1.nvars = 8; - RETURN_UNGCPRO (Ffuncall (8, args)); + return Ffuncall (8, ((Lisp_Object []) + { fn, arg1, arg2, arg3, arg4, arg5, arg6, arg7 })); } /* The caller should GCPRO all the elements of ARGS. */ @@ -2714,7 +2639,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) Lisp_Object lisp_numargs; Lisp_Object val; register Lisp_Object *internal_args; - ptrdiff_t i; + ptrdiff_t i, count; QUIT; @@ -2727,13 +2652,13 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) } /* This also GCPROs them. */ - record_in_backtrace (args[0], &args[1], nargs - 1); + count = record_in_backtrace (args[0], &args[1], nargs - 1); /* Call GC after setting up the backtrace, so the latter GCPROs the args. */ maybe_gc (); if (debug_on_next_call) - do_debug_on_call (Qlambda); + do_debug_on_call (Qlambda, count); check_cons_list (); @@ -2763,10 +2688,11 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) val = (XSUBR (fun)->function.aMANY) (numargs, args + 1); else { + Lisp_Object internal_argbuf[8]; if (XSUBR (fun)->max_args > numargs) { - internal_args = alloca (XSUBR (fun)->max_args - * sizeof *internal_args); + eassert (XSUBR (fun)->max_args <= ARRAYELTS (internal_argbuf)); + internal_args = internal_argbuf; memcpy (internal_args, args + 1, numargs * word_size); for (i = numargs; i < XSUBR (fun)->max_args; i++) internal_args[i] = Qnil; @@ -2852,14 +2778,14 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) } check_cons_list (); lisp_eval_depth--; - if (backtrace_debug_on_exit (specpdl_ptr - 1)) + if (backtrace_debug_on_exit (specpdl + count)) val = call_debugger (list2 (Qexit, val)); specpdl_ptr--; return val; } static Lisp_Object -apply_lambda (Lisp_Object fun, Lisp_Object args) +apply_lambda (Lisp_Object fun, Lisp_Object args, ptrdiff_t count) { Lisp_Object args_left; ptrdiff_t i; @@ -2886,15 +2812,14 @@ apply_lambda (Lisp_Object fun, Lisp_Object args) UNGCPRO; - set_backtrace_args (specpdl_ptr - 1, arg_vector); - set_backtrace_nargs (specpdl_ptr - 1, i); + set_backtrace_args (specpdl + count, arg_vector, i); tem = funcall_lambda (fun, numargs, arg_vector); /* Do the debug-on-exit now, while arg_vector still exists. */ - if (backtrace_debug_on_exit (specpdl_ptr - 1)) + if (backtrace_debug_on_exit (specpdl + count)) { /* Don't do it again when we return to eval. */ - set_backtrace_debug_on_exit (specpdl_ptr - 1, false); + set_backtrace_debug_on_exit (specpdl + count, false); tem = call_debugger (list2 (Qexit, tem)); } SAFE_FREE (); @@ -3473,13 +3398,24 @@ backtrace_eval_unrewind (int distance) for (; distance > 0; distance--) { tmp += step; - /* */ switch (tmp->kind) { /* FIXME: Ideally we'd like to "temporarily unwind" (some of) those unwind_protect, but the problem is that we don't know how to rewind them afterwards. */ case SPECPDL_UNWIND: + { + Lisp_Object oldarg = tmp->unwind.arg; + if (tmp->unwind.func == set_buffer_if_live) + tmp->unwind.arg = Fcurrent_buffer (); + else if (tmp->unwind.func == save_excursion_restore) + tmp->unwind.arg = save_excursion_save (); + else + break; + tmp->unwind.func (oldarg); + break; + } + case SPECPDL_UNWIND_PTR: case SPECPDL_UNWIND_INT: case SPECPDL_UNWIND_VOID: @@ -3553,6 +3489,73 @@ NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. from the debugger. */ return unbind_to (count, eval_sub (exp)); } + +DEFUN ("backtrace--locals", Fbacktrace__locals, Sbacktrace__locals, 1, 2, NULL, + doc: /* Return names and values of local variables of a stack frame. +NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */) + (Lisp_Object nframes, Lisp_Object base) +{ + union specbinding *frame = get_backtrace_frame (nframes, base); + union specbinding *prevframe + = get_backtrace_frame (make_number (XFASTINT (nframes) - 1), base); + ptrdiff_t distance = specpdl_ptr - frame; + Lisp_Object result = Qnil; + eassert (distance >= 0); + + if (!backtrace_p (prevframe)) + error ("Activation frame not found!"); + if (!backtrace_p (frame)) + error ("Activation frame not found!"); + + /* The specpdl entries normally contain the symbol being bound along with its + `old_value', so it can be restored. The new value to which it is bound is + available in one of two places: either in the current value of the + variable (if it hasn't been rebound yet) or in the `old_value' slot of the + next specpdl entry for it. + `backtrace_eval_unrewind' happens to swap the role of `old_value' + and "new value", so we abuse it here, to fetch the new value. + It's ugly (we'd rather not modify global data) and a bit inefficient, + but it does the job for now. */ + backtrace_eval_unrewind (distance); + + /* Grab values. */ + { + union specbinding *tmp = prevframe; + for (; tmp > frame; tmp--) + { + switch (tmp->kind) + { + case SPECPDL_LET: + case SPECPDL_LET_DEFAULT: + case SPECPDL_LET_LOCAL: + { + Lisp_Object sym = specpdl_symbol (tmp); + Lisp_Object val = specpdl_old_value (tmp); + if (EQ (sym, Qinternal_interpreter_environment)) + { + Lisp_Object env = val; + for (; CONSP (env); env = XCDR (env)) + { + Lisp_Object binding = XCAR (env); + if (CONSP (binding)) + result = Fcons (Fcons (XCAR (binding), + XCDR (binding)), + result); + } + } + else + result = Fcons (Fcons (sym, val), result); + } + } + } + } + + /* Restore values from specpdl to original place. */ + backtrace_eval_unrewind (-distance); + + return result; +} + void mark_specpdl (void) @@ -3623,7 +3626,9 @@ If Lisp code tries to increase the total number past this amount, an error is signaled. You can safely use a value considerably larger than the default value, if that proves inconveniently small. However, if you increase it too far, -Emacs could run out of memory trying to make the stack bigger. */); +Emacs could run out of memory trying to make the stack bigger. +Note that this limit may be silently increased by the debugger +if `debug-on-error' or `debug-on-quit' is set. */); DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth, doc: /* Limit on depth in `eval', `apply' and `funcall' before error. @@ -3751,7 +3756,8 @@ alist of active lexical bindings. */); (Just imagine if someone makes it buffer-local). */ Funintern (Qinternal_interpreter_environment, Qnil); - DEFSYM (Vrun_hooks, "run-hooks"); + Vrun_hooks = intern_c_string ("run-hooks"); + staticpro (&Vrun_hooks); staticpro (&Vautoload_queue); Vautoload_queue = Qnil; @@ -3801,6 +3807,7 @@ alist of active lexical bindings. */); defsubr (&Sbacktrace); defsubr (&Sbacktrace_frame); defsubr (&Sbacktrace_eval); + defsubr (&Sbacktrace__locals); defsubr (&Sspecial_variable_p); defsubr (&Sfunctionp); }