X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/5e301d7651c0691bb2bc7f3fbe711fdbe26ac471..e9be0a138c07b93576c07c7fe7c94defee9adfc6:/src/eval.c diff --git a/src/eval.c b/src/eval.c index 0e231bdb28..8d0c08b2e3 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-2014 Free Software Foundation, +Inc. This file is part of GNU Emacs. @@ -32,20 +33,8 @@ along with GNU Emacs. If not, see . */ #include "xterm.h" #endif -#if !BYTE_MARK_STACK -static -#endif -struct catchtag *catchlist; - -/* Chain of condition handlers currently in effect. - The elements of this chain are contained in the stack frames - of Fcondition_case and internal_condition_case. - When an error is signaled (by calling Fsignal, below), - this chain is searched for an element that applies. */ +/* Chain of condition and catch handlers currently in effect. */ -#if !BYTE_MARK_STACK -static -#endif struct handler *handlerlist; #ifdef DEBUG_GCPRO @@ -92,7 +81,7 @@ union specbinding *specpdl_ptr; /* Depth in Lisp evaluations and function calls. */ -static EMACS_INT lisp_eval_depth; +EMACS_INT lisp_eval_depth; /* The value of num_nonmacro_input_events as of the last time we started to enter the debugger. If we decide to enter the debugger @@ -138,6 +127,13 @@ specpdl_old_value (union specbinding *pdl) return pdl->let.old_value; } +static void +set_specpdl_old_value (union specbinding *pdl, Lisp_Object val) +{ + eassert (pdl->kind >= SPECPDL_LET); + pdl->let.old_value = val; +} + static Lisp_Object specpdl_where (union specbinding *pdl) { @@ -152,13 +148,6 @@ specpdl_arg (union specbinding *pdl) return pdl->unwind.arg; } -static specbinding_func -specpdl_func (union specbinding *pdl) -{ - eassert (pdl->kind == SPECPDL_UNWIND); - return pdl->unwind.func; -} - Lisp_Object backtrace_function (union specbinding *pdl) { @@ -249,12 +238,22 @@ init_eval_once (void) Vrun_hooks = Qnil; } +static struct handler handlerlist_sentinel; + void init_eval (void) { specpdl_ptr = specpdl; - catchlist = 0; - handlerlist = 0; + { /* 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; @@ -267,12 +266,11 @@ init_eval (void) /* Unwind-protect function used by call_debugger. */ -static Lisp_Object +static void restore_stack_limits (Lisp_Object data) { max_specpdl_size = XINT (XCAR (data)); max_lisp_eval_depth = XINT (XCDR (data)); - return Qnil; } /* Call the Lisp debugger, giving it argument ARG. */ @@ -338,7 +336,7 @@ do_debug_on_call (Lisp_Object code) { debug_on_next_call = 0; set_backtrace_debug_on_exit (specpdl_ptr - 1, true); - call_debugger (Fcons (code, Qnil)); + call_debugger (list1 (code)); } /* NOTE!!! Every function that can call EVAL must protect its args @@ -401,16 +399,16 @@ If COND yields nil, and there are no ELSE's, the value is nil. usage: (if COND THEN ELSE...) */) (Lisp_Object args) { - register Lisp_Object cond; + Lisp_Object cond; struct gcpro gcpro1; GCPRO1 (args); - cond = eval_sub (Fcar (args)); + cond = eval_sub (XCAR (args)); UNGCPRO; if (!NILP (cond)) - return eval_sub (Fcar (Fcdr (args))); - return Fprogn (Fcdr (Fcdr (args))); + return eval_sub (Fcar (XCDR (args))); + return Fprogn (XCDR (XCDR (args))); } DEFUN ("cond", Fcond, Scond, 0, UNEVALLED, 0, @@ -419,24 +417,23 @@ 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) { - register Lisp_Object clause, val; + Lisp_Object val = args; struct gcpro gcpro1; - val = Qnil; GCPRO1 (args); - while (!NILP (args)) + while (CONSP (args)) { - clause = Fcar (args); + Lisp_Object clause = XCAR (args); val = eval_sub (Fcar (clause)); if (!NILP (val)) { - if (!EQ (XCDR (clause), Qnil)) + if (!NILP (XCDR (clause))) val = Fprogn (XCDR (clause)); break; } @@ -450,23 +447,32 @@ usage: (cond CLAUSES...) */) DEFUN ("progn", Fprogn, Sprogn, 0, UNEVALLED, 0, doc: /* Eval BODY forms sequentially and return value of last one. usage: (progn BODY...) */) - (Lisp_Object args) + (Lisp_Object body) { - register Lisp_Object val = Qnil; + Lisp_Object val = Qnil; struct gcpro gcpro1; - GCPRO1 (args); + GCPRO1 (body); - while (CONSP (args)) + while (CONSP (body)) { - val = eval_sub (XCAR (args)); - args = XCDR (args); + val = eval_sub (XCAR (body)); + body = XCDR (body); } UNGCPRO; return val; } +/* Evaluate BODY sequentially, discarding its value. Suitable for + record_unwind_protect. */ + +void +unwind_body (Lisp_Object body) +{ + Fprogn (body); +} + DEFUN ("prog1", Fprog1, Sprog1, 1, UNEVALLED, 0, doc: /* Eval FIRST and BODY sequentially; return value from FIRST. The value of FIRST is saved during the evaluation of the remaining args, @@ -475,11 +481,11 @@ usage: (prog1 FIRST BODY...) */) (Lisp_Object args) { Lisp_Object val; - register Lisp_Object args_left; + Lisp_Object args_left; struct gcpro gcpro1, gcpro2; args_left = args; - val = Qnil; + val = args; GCPRO2 (args, val); val = eval_sub (XCAR (args_left)); @@ -516,36 +522,37 @@ The return value of the `setq' form is the value of the last VAL. usage: (setq [SYM VAL]...) */) (Lisp_Object args) { - register Lisp_Object args_left; - register Lisp_Object val, sym, lex_binding; - struct gcpro gcpro1; - - if (NILP (args)) - return Qnil; + Lisp_Object val, sym, lex_binding; - args_left = args; - GCPRO1 (args); - - do + val = args; + if (CONSP (args)) { - val = eval_sub (Fcar (Fcdr (args_left))); - sym = Fcar (args_left); + Lisp_Object args_left = args; + struct gcpro gcpro1; + GCPRO1 (args); - /* Like for eval_sub, we do not check declared_special here since - it's been done when let-binding. */ - if (!NILP (Vinternal_interpreter_environment) /* Mere optimization! */ - && SYMBOLP (sym) - && !NILP (lex_binding - = Fassq (sym, Vinternal_interpreter_environment))) - XSETCDR (lex_binding, val); /* SYM is lexically bound. */ - else - Fset (sym, val); /* SYM is dynamically bound. */ + do + { + val = eval_sub (Fcar (XCDR (args_left))); + sym = XCAR (args_left); + + /* Like for eval_sub, we do not check declared_special here since + it's been done when let-binding. */ + if (!NILP (Vinternal_interpreter_environment) /* Mere optimization! */ + && SYMBOLP (sym) + && !NILP (lex_binding + = Fassq (sym, Vinternal_interpreter_environment))) + XSETCDR (lex_binding, val); /* SYM is lexically bound. */ + else + Fset (sym, val); /* SYM is dynamically bound. */ - args_left = Fcdr (Fcdr (args_left)); + args_left = Fcdr (XCDR (args_left)); + } + while (CONSP (args_left)); + + UNGCPRO; } - while (!NILP (args_left)); - UNGCPRO; return val; } @@ -562,9 +569,9 @@ of unexpected results when a quoted object is modified. usage: (quote ARG) */) (Lisp_Object args) { - if (!NILP (Fcdr (args))) + if (CONSP (XCDR (args))) xsignal2 (Qwrong_number_of_arguments, Qquote, Flength (args)); - return Fcar (args); + return XCAR (args); } DEFUN ("function", Ffunction, Sfunction, 1, UNEVALLED, 0, @@ -576,7 +583,7 @@ usage: (function ARG) */) { Lisp_Object quoted = XCAR (args); - if (!NILP (Fcdr (args))) + if (CONSP (XCDR (args))) xsignal2 (Qwrong_number_of_arguments, Qfunction, Flength (args)); if (!NILP (Vinternal_interpreter_environment) @@ -650,6 +657,51 @@ The return value is BASE-VARIABLE. */) return base_variable; } +static union specbinding * +default_toplevel_binding (Lisp_Object symbol) +{ + union specbinding *binding = NULL; + union specbinding *pdl = specpdl_ptr; + while (pdl > specpdl) + { + switch ((--pdl)->kind) + { + case SPECPDL_LET_DEFAULT: + case SPECPDL_LET: + if (EQ (specpdl_symbol (pdl), symbol)) + binding = pdl; + break; + } + } + return binding; +} + +DEFUN ("default-toplevel-value", Fdefault_toplevel_value, Sdefault_toplevel_value, 1, 1, 0, + doc: /* Return SYMBOL's toplevel default value. +"Toplevel" means outside of any let binding. */) + (Lisp_Object symbol) +{ + union specbinding *binding = default_toplevel_binding (symbol); + Lisp_Object value + = binding ? specpdl_old_value (binding) : Fdefault_value (symbol); + if (!EQ (value, Qunbound)) + return value; + xsignal1 (Qvoid_variable, symbol); +} + +DEFUN ("set-default-toplevel-value", Fset_default_toplevel_value, + Sset_default_toplevel_value, 2, 2, 0, + doc: /* Set SYMBOL's toplevel default value to VALUE. +"Toplevel" means outside of any let binding. */) + (Lisp_Object symbol, Lisp_Object value) +{ + union specbinding *binding = default_toplevel_binding (symbol); + if (binding) + set_specpdl_old_value (binding, value); + else + Fset_default (symbol, value); + return Qnil; +} DEFUN ("defvar", Fdefvar, Sdefvar, 1, UNEVALLED, 0, doc: /* Define SYMBOL as a variable, and return SYMBOL. @@ -678,39 +730,33 @@ To define a user option, use `defcustom' instead of `defvar'. usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */) (Lisp_Object args) { - register Lisp_Object sym, tem, tail; + Lisp_Object sym, tem, tail; - sym = Fcar (args); - tail = Fcdr (args); - if (!NILP (Fcdr (Fcdr (tail)))) - error ("Too many arguments"); + sym = XCAR (args); + tail = XCDR (args); - tem = Fdefault_boundp (sym); - if (!NILP (tail)) + if (CONSP (tail)) { + if (CONSP (XCDR (tail)) && CONSP (XCDR (XCDR (tail)))) + error ("Too many arguments"); + + tem = Fdefault_boundp (sym); + /* Do it before evaluating the initial value, for self-references. */ XSYMBOL (sym)->declared_special = 1; if (NILP (tem)) - Fset_default (sym, eval_sub (Fcar (tail))); + Fset_default (sym, eval_sub (XCAR (tail))); else { /* Check if there is really a global binding rather than just a let binding that shadows the global unboundness of the var. */ - union specbinding *pdl = specpdl_ptr; - while (pdl > specpdl) + union specbinding *binding = default_toplevel_binding (sym); + if (binding && EQ (specpdl_old_value (binding), Qunbound)) { - if ((--pdl)->kind >= SPECPDL_LET - && EQ (specpdl_symbol (pdl), sym) - && EQ (specpdl_old_value (pdl), Qunbound)) - { - message_with_string - ("Warning: defvar ignored because %s is let-bound", - SYMBOL_NAME (sym), 1); - break; - } + set_specpdl_old_value (binding, eval_sub (XCAR (tail))); } } - tail = Fcdr (tail); + tail = XCDR (tail); tem = Fcar (tail); if (!NILP (tem)) { @@ -755,18 +801,18 @@ The optional DOCSTRING specifies the variable's documentation string. usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */) (Lisp_Object args) { - register Lisp_Object sym, tem; + Lisp_Object sym, tem; - sym = Fcar (args); - if (!NILP (Fcdr (Fcdr (Fcdr (args))))) + sym = XCAR (args); + if (CONSP (Fcdr (XCDR (XCDR (args))))) error ("Too many arguments"); - tem = eval_sub (Fcar (Fcdr (args))); + tem = eval_sub (Fcar (XCDR (args))); if (!NILP (Vpurify_flag)) tem = Fpurecopy (tem); Fset_default (sym, tem); XSYMBOL (sym)->declared_special = 1; - tem = Fcar (Fcdr (Fcdr (args))); + tem = Fcar (XCDR (XCDR (args))); if (!NILP (tem)) { if (!NILP (Vpurify_flag)) @@ -807,7 +853,7 @@ usage: (let* VARLIST BODY...) */) lexenv = Vinternal_interpreter_environment; - varlist = Fcar (args); + varlist = XCAR (args); while (CONSP (varlist)) { QUIT; @@ -848,7 +894,7 @@ usage: (let* VARLIST BODY...) */) varlist = XCDR (varlist); } UNGCPRO; - val = Fprogn (Fcdr (args)); + val = Fprogn (XCDR (args)); return unbind_to (count, val); } @@ -868,7 +914,7 @@ usage: (let VARLIST BODY...) */) struct gcpro gcpro1, gcpro2; USE_SAFE_ALLOCA; - varlist = Fcar (args); + varlist = XCAR (args); /* Make space to hold the values to give the bound variables. */ elt = Flength (varlist); @@ -895,7 +941,7 @@ usage: (let VARLIST BODY...) */) lexenv = Vinternal_interpreter_environment; - varlist = Fcar (args); + varlist = XCAR (args); for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist)) { Lisp_Object var; @@ -918,7 +964,7 @@ usage: (let VARLIST BODY...) */) /* Instantiate a new lexical environment. */ specbind (Qinternal_interpreter_environment, lexenv); - elt = Fprogn (Fcdr (args)); + elt = Fprogn (XCDR (args)); SAFE_FREE (); return unbind_to (count, elt); } @@ -935,8 +981,8 @@ usage: (while TEST BODY...) */) GCPRO2 (test, body); - test = Fcar (args); - body = Fcdr (args); + test = XCAR (args); + body = XCDR (args); while (!NILP (eval_sub (test))) { QUIT; @@ -1033,11 +1079,17 @@ usage: (catch TAG BODY...) */) struct gcpro gcpro1; GCPRO1 (args); - tag = eval_sub (Fcar (args)); + tag = eval_sub (XCAR (args)); UNGCPRO; - return internal_catch (tag, Fprogn, Fcdr (args)); + 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. */ @@ -1046,28 +1098,26 @@ Lisp_Object internal_catch (Lisp_Object tag, Lisp_Object (*func) (Lisp_Object), Lisp_Object arg) { /* This structure is made part of the chain `catchlist'. */ - struct catchtag c; + struct handler *c; /* Fill in the components of c, and put it on the list. */ - c.next = catchlist; - c.tag = tag; - c.val = Qnil; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; - c.pdlcount = SPECPDL_INDEX (); - c.poll_suppress_count = poll_suppress_count; - c.interrupt_input_blocked = interrupt_input_blocked; - c.gcpro = gcprolist; - c.byte_stack = byte_stack_list; - catchlist = &c; + PUSH_HANDLER (c, tag, CATCHER); /* Call FUNC. */ - if (! sys_setjmp (c.jmp)) - c.val = (*func) (arg); - - /* Throw works by a longjmp that comes right here. */ - catchlist = c.next; - return c.val; + if (! sys_setjmp (c->jmp)) + { + Lisp_Object val = (*func) (arg); + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; + return val; + } + else + { /* Throw works by a longjmp that comes right here. */ + Lisp_Object val = handlerlist->val; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; + return val; + } } /* Unwind the specbind, catch, and handler stacks back to CATCH, and @@ -1087,10 +1137,12 @@ internal_catch (Lisp_Object tag, Lisp_Object (*func) (Lisp_Object), Lisp_Object This is used for correct unwinding in Fthrow and Fsignal. */ static _Noreturn void -unwind_to_catch (struct catchtag *catch, Lisp_Object value) +unwind_to_catch (struct handler *catch, Lisp_Object value) { bool last_time; + eassert (catch->next); + /* Save the value in the tag. */ catch->val = value; @@ -1101,16 +1153,17 @@ unwind_to_catch (struct catchtag *catch, Lisp_Object value) do { - last_time = catchlist == catch; - /* Unwind the specpdl stack, and then restore the proper set of handlers. */ - unbind_to (catchlist->pdlcount, Qnil); - handlerlist = catchlist->handlerlist; - catchlist = catchlist->next; + unbind_to (handlerlist->pdlcount, Qnil); + last_time = handlerlist == catch; + if (! last_time) + handlerlist = handlerlist->next; } while (! last_time); + eassert (handlerlist == catch); + byte_stack_list = catch->byte_stack; gcprolist = catch->gcpro; #ifdef DEBUG_GCPRO @@ -1126,12 +1179,12 @@ DEFUN ("throw", Fthrow, Sthrow, 2, 2, 0, Both TAG and VALUE are evalled. */) (register Lisp_Object tag, Lisp_Object value) { - register struct catchtag *c; + struct handler *c; if (!NILP (tag)) - for (c = catchlist; c; c = c->next) + for (c = handlerlist; c; c = c->next) { - if (EQ (c->tag, tag)) + if (c->type == CATCHER && EQ (c->tag_or_ch, tag)) unwind_to_catch (c, value); } xsignal2 (Qno_catch, tag, value); @@ -1149,8 +1202,8 @@ usage: (unwind-protect BODYFORM UNWINDFORMS...) */) Lisp_Object val; ptrdiff_t count = SPECPDL_INDEX (); - record_unwind_protect (Fprogn, Fcdr (args)); - val = eval_sub (Fcar (args)); + record_unwind_protect (unwind_body, XCDR (args)); + val = eval_sub (XCAR (args)); return unbind_to (count, val); } @@ -1182,9 +1235,9 @@ See also the function `signal' for more info. usage: (condition-case VAR BODYFORM &rest HANDLERS) */) (Lisp_Object args) { - Lisp_Object var = Fcar (args); - Lisp_Object bodyform = Fcar (Fcdr (args)); - Lisp_Object handlers = Fcdr (Fcdr (args)); + Lisp_Object var = XCAR (args); + Lisp_Object bodyform = XCAR (XCDR (args)); + Lisp_Object handlers = XCDR (XCDR (args)); return internal_lisp_condition_case (var, bodyform, handlers); } @@ -1197,15 +1250,16 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform, Lisp_Object handlers) { Lisp_Object val; - struct catchtag c; - struct handler h; + struct handler *c; + struct handler *oldhandlerlist = handlerlist; + int clausenb = 0; CHECK_SYMBOL (var); for (val = handlers; CONSP (val); val = XCDR (val)) { - Lisp_Object tem; - tem = XCAR (val); + Lisp_Object tem = XCAR (val); + clausenb++; if (! (NILP (tem) || (CONSP (tem) && (SYMBOLP (XCAR (tem)) @@ -1214,39 +1268,51 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform, SDATA (Fprin1_to_string (tem, Qt))); } - c.tag = Qnil; - c.val = Qnil; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; - c.pdlcount = SPECPDL_INDEX (); - c.poll_suppress_count = poll_suppress_count; - c.interrupt_input_blocked = interrupt_input_blocked; - c.gcpro = gcprolist; - c.byte_stack = byte_stack_list; - if (sys_setjmp (c.jmp)) - { - if (!NILP (h.var)) - specbind (h.var, c.val); - val = Fprogn (Fcdr (h.chosen_clause)); - - /* Note that this just undoes the binding of h.var; whoever - longjumped to us unwound the stack to c.pdlcount before - throwing. */ - unbind_to (c.pdlcount, Qnil); - return val; + { /* 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 *)); + Lisp_Object *volatile clauses_volatile = clauses; + int i = clausenb; + for (val = handlers; CONSP (val); val = XCDR (val)) + clauses[--i] = XCAR (val); + for (i = 0; i < clausenb; i++) + { + Lisp_Object clause = clauses[i]; + Lisp_Object condition = XCAR (clause); + if (!CONSP (condition)) + condition = Fcons (condition, Qnil); + PUSH_HANDLER (c, condition, CONDITION_CASE); + if (sys_setjmp (c->jmp)) + { + ptrdiff_t count = SPECPDL_INDEX (); + Lisp_Object val = handlerlist->val; + Lisp_Object *chosen_clause = clauses_volatile; + for (c = handlerlist->next; c != oldhandlerlist; c = c->next) + chosen_clause++; + handlerlist = oldhandlerlist; + if (!NILP (var)) + { + if (!NILP (Vinternal_interpreter_environment)) + specbind (Qinternal_interpreter_environment, + Fcons (Fcons (var, val), + Vinternal_interpreter_environment)); + else + specbind (var, val); + } + val = Fprogn (XCDR (*chosen_clause)); + /* Note that this just undoes the binding of var; whoever + longjumped to us unwound the stack to c.pdlcount before + throwing. */ + if (!NILP (var)) + unbind_to (count, Qnil); + return val; + } + } } - c.next = catchlist; - catchlist = &c; - - h.var = var; - h.handler = handlers; - h.next = handlerlist; - h.tag = &c; - handlerlist = &h; val = eval_sub (bodyform); - catchlist = c.next; - handlerlist = h.next; + handlerlist = oldhandlerlist; return val; } @@ -1265,33 +1331,20 @@ internal_condition_case (Lisp_Object (*bfun) (void), Lisp_Object handlers, Lisp_Object (*hfun) (Lisp_Object)) { Lisp_Object val; - struct catchtag c; - struct handler h; - - c.tag = Qnil; - c.val = Qnil; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; - c.pdlcount = SPECPDL_INDEX (); - c.poll_suppress_count = poll_suppress_count; - c.interrupt_input_blocked = interrupt_input_blocked; - c.gcpro = gcprolist; - c.byte_stack = byte_stack_list; - if (sys_setjmp (c.jmp)) - { - return (*hfun) (c.val); - } - c.next = catchlist; - catchlist = &c; - h.handler = handlers; - h.var = Qnil; - h.next = handlerlist; - h.tag = &c; - handlerlist = &h; + struct handler *c; + + PUSH_HANDLER (c, handlers, CONDITION_CASE); + if (sys_setjmp (c->jmp)) + { + Lisp_Object val = handlerlist->val; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; + return (*hfun) (val); + } val = (*bfun) (); - catchlist = c.next; - handlerlist = h.next; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; return val; } @@ -1302,33 +1355,20 @@ internal_condition_case_1 (Lisp_Object (*bfun) (Lisp_Object), Lisp_Object arg, Lisp_Object handlers, Lisp_Object (*hfun) (Lisp_Object)) { Lisp_Object val; - struct catchtag c; - struct handler h; - - c.tag = Qnil; - c.val = Qnil; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; - c.pdlcount = SPECPDL_INDEX (); - c.poll_suppress_count = poll_suppress_count; - c.interrupt_input_blocked = interrupt_input_blocked; - c.gcpro = gcprolist; - c.byte_stack = byte_stack_list; - if (sys_setjmp (c.jmp)) - { - return (*hfun) (c.val); - } - c.next = catchlist; - catchlist = &c; - h.handler = handlers; - h.var = Qnil; - h.next = handlerlist; - h.tag = &c; - handlerlist = &h; + struct handler *c; + + PUSH_HANDLER (c, handlers, CONDITION_CASE); + if (sys_setjmp (c->jmp)) + { + Lisp_Object val = handlerlist->val; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; + return (*hfun) (val); + } val = (*bfun) (arg); - catchlist = c.next; - handlerlist = h.next; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; return val; } @@ -1343,33 +1383,20 @@ internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object), Lisp_Object (*hfun) (Lisp_Object)) { Lisp_Object val; - struct catchtag c; - struct handler h; - - c.tag = Qnil; - c.val = Qnil; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; - c.pdlcount = SPECPDL_INDEX (); - c.poll_suppress_count = poll_suppress_count; - c.interrupt_input_blocked = interrupt_input_blocked; - c.gcpro = gcprolist; - c.byte_stack = byte_stack_list; - if (sys_setjmp (c.jmp)) - { - return (*hfun) (c.val); - } - c.next = catchlist; - catchlist = &c; - h.handler = handlers; - h.var = Qnil; - h.next = handlerlist; - h.tag = &c; - handlerlist = &h; + struct handler *c; + + PUSH_HANDLER (c, handlers, CONDITION_CASE); + if (sys_setjmp (c->jmp)) + { + Lisp_Object val = handlerlist->val; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; + return (*hfun) (val); + } val = (*bfun) (arg1, arg2); - catchlist = c.next; - handlerlist = h.next; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; return val; } @@ -1386,33 +1413,20 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *), Lisp_Object *args)) { Lisp_Object val; - struct catchtag c; - struct handler h; - - c.tag = Qnil; - c.val = Qnil; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; - c.pdlcount = SPECPDL_INDEX (); - c.poll_suppress_count = poll_suppress_count; - c.interrupt_input_blocked = interrupt_input_blocked; - c.gcpro = gcprolist; - c.byte_stack = byte_stack_list; - if (sys_setjmp (c.jmp)) - { - return (*hfun) (c.val, nargs, args); - } - c.next = catchlist; - catchlist = &c; - h.handler = handlers; - h.var = Qnil; - h.next = handlerlist; - h.tag = &c; - handlerlist = &h; + struct handler *c; + + PUSH_HANDLER (c, handlers, CONDITION_CASE); + if (sys_setjmp (c->jmp)) + { + Lisp_Object val = handlerlist->val; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; + return (*hfun) (val, nargs, args); + } val = (*bfun) (nargs, args); - catchlist = c.next; - handlerlist = h.next; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; return val; } @@ -1504,7 +1518,9 @@ See also the function `condition-case'. */) for (h = handlerlist; h; h = h->next) { - clause = find_handler_clause (h->handler, conditions); + if (h->type != CONDITION_CASE) + continue; + clause = find_handler_clause (h->tag_or_ch, conditions); if (!NILP (clause)) break; } @@ -1521,7 +1537,7 @@ See also the function `condition-case'. */) && !NILP (Fmemq (Qdebug, XCAR (clause)))) /* Special handler that means "print a message and run debugger if requested". */ - || EQ (h->handler, Qerror))) + || EQ (h->tag_or_ch, Qerror))) { bool debugger_called = maybe_call_debugger (conditions, error_symbol, data); @@ -1536,12 +1552,14 @@ See also the function `condition-case'. */) Lisp_Object unwind_data = (NILP (error_symbol) ? data : Fcons (error_symbol, data)); - h->chosen_clause = clause; - unwind_to_catch (h->tag, unwind_data); + unwind_to_catch (h, unwind_data); } else { - if (catchlist != 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); } @@ -1611,7 +1629,7 @@ signal_error (const char *s, Lisp_Object arg) } if (!NILP (hare)) - arg = Fcons (arg, Qnil); /* Make it a list. */ + arg = list1 (arg); xsignal (Qerror, Fcons (build_string (s), arg)); } @@ -1703,7 +1721,7 @@ maybe_call_debugger (Lisp_Object conditions, Lisp_Object sig, Lisp_Object data) /* RMS: What's this for? */ && when_entered_debugger < num_nonmacro_input_events) { - call_debugger (Fcons (Qerror, Fcons (combined_data, Qnil))); + call_debugger (list2 (Qerror, combined_data)); return 1; } @@ -1727,29 +1745,8 @@ find_handler_clause (Lisp_Object handlers, Lisp_Object conditions) for (h = handlers; CONSP (h); h = XCDR (h)) { Lisp_Object handler = XCAR (h); - Lisp_Object condit, tem; - - if (!CONSP (handler)) - continue; - condit = XCAR (handler); - /* Handle a single condition name in handler HANDLER. */ - if (SYMBOLP (condit)) - { - tem = Fmemq (Fcar (handler), conditions); - if (!NILP (tem)) - return handler; - } - /* Handle a list of condition names in handler HANDLER. */ - else if (CONSP (condit)) - { - Lisp_Object tail; - for (tail = condit; CONSP (tail); tail = XCDR (tail)) - { - tem = Fmemq (XCAR (tail), conditions); - if (!NILP (tem)) - return handler; - } - } + if (!NILP (Fmemq (handler, conditions))) + return handlers; } return Qnil; @@ -1890,10 +1887,10 @@ this does nothing and returns nil. */) Qnil); } -Lisp_Object +void un_autoload (Lisp_Object oldqueue) { - register Lisp_Object queue, first, second; + Lisp_Object queue, first, second; /* Queue to unwind is current value of Vautoload_queue. oldqueue is the shadowed value to leave in Vautoload_queue. */ @@ -1910,7 +1907,6 @@ un_autoload (Lisp_Object oldqueue) Ffset (first, second); queue = XCDR (queue); } - return Qnil; } /* Load an autoloaded function. @@ -1987,12 +1983,14 @@ it is defines a macro. */) DEFUN ("eval", Feval, Seval, 1, 2, 0, doc: /* Evaluate FORM and return its value. -If LEXICAL is t, evaluate using lexical scoping. */) +If LEXICAL is t, evaluate using lexical scoping. +LEXICAL can also be an actual lexical environment, in the form of an +alist mapping symbols to their value. */) (Lisp_Object form, Lisp_Object lexical) { ptrdiff_t count = SPECPDL_INDEX (); specbind (Qinternal_interpreter_environment, - CONSP (lexical) || NILP (lexical) ? lexical : Fcons (Qt, Qnil)); + CONSP (lexical) || NILP (lexical) ? lexical : list1 (Qt)); return unbind_to (count, eval_sub (form)); } @@ -2100,8 +2098,9 @@ eval_sub (Lisp_Object form) /* Optimize for no indirection. */ fun = original_fun; - if (SYMBOLP (fun) && !NILP (fun) - && (fun = XSYMBOL (fun)->function, SYMBOLP (fun))) + if (!SYMBOLP (fun)) + fun = Ffunction (Fcons (fun, Qnil)); + else if (!NILP (fun) && (fun = XSYMBOL (fun)->function, SYMBOLP (fun))) fun = indirect_function (fun); if (SUBRP (fun)) @@ -2257,7 +2256,7 @@ eval_sub (Lisp_Object form) lisp_eval_depth--; if (backtrace_debug_on_exit (specpdl_ptr - 1)) - val = call_debugger (Fcons (Qexit, Fcons (val, Qnil))); + val = call_debugger (list2 (Qexit, val)); specpdl_ptr--; return val; @@ -2497,7 +2496,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); @@ -2878,7 +2877,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) check_cons_list (); lisp_eval_depth--; if (backtrace_debug_on_exit (specpdl_ptr - 1)) - val = call_debugger (Fcons (Qexit, Fcons (val, Qnil))); + val = call_debugger (list2 (Qexit, val)); specpdl_ptr--; return val; } @@ -2920,7 +2919,7 @@ apply_lambda (Lisp_Object fun, Lisp_Object args) { /* Don't do it again when we return to eval. */ set_backtrace_debug_on_exit (specpdl_ptr - 1, false); - tem = call_debugger (Fcons (Qexit, Fcons (tem, Qnil))); + tem = call_debugger (list2 (Qexit, tem)); } SAFE_FREE (); return tem; @@ -3105,20 +3104,17 @@ let_shadows_global_binding_p (Lisp_Object symbol) return 0; } -/* `specpdl_ptr->symbol' is a field which describes which variable is +/* `specpdl_ptr' describes which variable is let-bound, so it can be properly undone when we unbind_to. - It can have the following two shapes: - - SYMBOL : if it's a plain symbol, it means that we have let-bound - a symbol that is not buffer-local (at least at the time - the let binding started). Note also that it should not be + It can be either a plain SPECPDL_LET or a SPECPDL_LET_LOCAL/DEFAULT. + - SYMBOL is the variable being bound. Note that it should not be aliased (i.e. when let-binding V1 that's aliased to V2, we want to record V2 here). - - (SYMBOL WHERE . BUFFER) : this means that it is a let-binding for - variable SYMBOL which can be buffer-local. WHERE tells us - which buffer is affected (or nil if the let-binding affects the - global value of the variable) and BUFFER tells us which buffer was - current (i.e. if WHERE is non-nil, then BUFFER==WHERE, otherwise - BUFFER did not yet have a buffer-local value). */ + - WHERE tells us in which buffer the binding took place. + This is used for SPECPDL_LET_LOCAL bindings (i.e. bindings to a + buffer-local variable) as well as for SPECPDL_LET_DEFAULT bindings, + i.e. bindings to the default value of a variable which can be + buffer-local. */ void specbind (Lisp_Object symbol, Lisp_Object value) @@ -3190,8 +3186,10 @@ specbind (Lisp_Object symbol, Lisp_Object value) } } +/* Push unwind-protect entries of various types. */ + void -record_unwind_protect (Lisp_Object (*function) (Lisp_Object), Lisp_Object arg) +record_unwind_protect (void (*function) (Lisp_Object), Lisp_Object arg) { specpdl_ptr->unwind.kind = SPECPDL_UNWIND; specpdl_ptr->unwind.func = function; @@ -3199,6 +3197,82 @@ record_unwind_protect (Lisp_Object (*function) (Lisp_Object), Lisp_Object arg) grow_specpdl (); } +void +record_unwind_protect_ptr (void (*function) (void *), void *arg) +{ + specpdl_ptr->unwind_ptr.kind = SPECPDL_UNWIND_PTR; + specpdl_ptr->unwind_ptr.func = function; + specpdl_ptr->unwind_ptr.arg = arg; + grow_specpdl (); +} + +void +record_unwind_protect_int (void (*function) (int), int arg) +{ + specpdl_ptr->unwind_int.kind = SPECPDL_UNWIND_INT; + specpdl_ptr->unwind_int.func = function; + specpdl_ptr->unwind_int.arg = arg; + grow_specpdl (); +} + +void +record_unwind_protect_void (void (*function) (void)) +{ + specpdl_ptr->unwind_void.kind = SPECPDL_UNWIND_VOID; + specpdl_ptr->unwind_void.func = function; + grow_specpdl (); +} + +static void +do_nothing (void) +{} + +/* Push an unwind-protect entry that does nothing, so that + set_unwind_protect_ptr can overwrite it later. */ + +void +record_unwind_protect_nothing (void) +{ + record_unwind_protect_void (do_nothing); +} + +/* Clear the unwind-protect entry COUNT, so that it does nothing. + It need not be at the top of the stack. */ + +void +clear_unwind_protect (ptrdiff_t count) +{ + union specbinding *p = specpdl + count; + p->unwind_void.kind = SPECPDL_UNWIND_VOID; + p->unwind_void.func = do_nothing; +} + +/* Set the unwind-protect entry COUNT so that it invokes FUNC (ARG). + It need not be at the top of the stack. Discard the entry's + previous value without invoking it. */ + +void +set_unwind_protect (ptrdiff_t count, void (*func) (Lisp_Object), + Lisp_Object arg) +{ + union specbinding *p = specpdl + count; + p->unwind.kind = SPECPDL_UNWIND; + p->unwind.func = func; + p->unwind.arg = arg; +} + +void +set_unwind_protect_ptr (ptrdiff_t count, void (*func) (void *), void *arg) +{ + union specbinding *p = specpdl + count; + p->unwind_ptr.kind = SPECPDL_UNWIND_PTR; + p->unwind_ptr.func = func; + p->unwind_ptr.arg = arg; +} + +/* Pop and execute entries from the unwind-protect stack until the + depth COUNT is reached. Return VALUE. */ + Lisp_Object unbind_to (ptrdiff_t count, Lisp_Object value) { @@ -3220,43 +3294,49 @@ unbind_to (ptrdiff_t count, Lisp_Object value) switch (specpdl_ptr->kind) { case SPECPDL_UNWIND: - specpdl_func (specpdl_ptr) (specpdl_arg (specpdl_ptr)); + specpdl_ptr->unwind.func (specpdl_ptr->unwind.arg); break; - case SPECPDL_LET: - /* If variable has a trivial value (no forwarding), we can - just set it. No need to check for constant symbols here, - since that was already done by specbind. */ - if (XSYMBOL (specpdl_symbol (specpdl_ptr))->redirect - == SYMBOL_PLAINVAL) - SET_SYMBOL_VAL (XSYMBOL (specpdl_symbol (specpdl_ptr)), - specpdl_old_value (specpdl_ptr)); - else - /* NOTE: we only ever come here if make_local_foo was used for - the first time on this var within this let. */ - Fset_default (specpdl_symbol (specpdl_ptr), - specpdl_old_value (specpdl_ptr)); + case SPECPDL_UNWIND_PTR: + specpdl_ptr->unwind_ptr.func (specpdl_ptr->unwind_ptr.arg); + break; + case SPECPDL_UNWIND_INT: + specpdl_ptr->unwind_int.func (specpdl_ptr->unwind_int.arg); + break; + case SPECPDL_UNWIND_VOID: + specpdl_ptr->unwind_void.func (); break; case SPECPDL_BACKTRACE: break; - case SPECPDL_LET_LOCAL: + case SPECPDL_LET: + { /* If variable has a trivial value (no forwarding), we can + just set it. No need to check for constant symbols here, + since that was already done by specbind. */ + struct Lisp_Symbol *sym = XSYMBOL (specpdl_symbol (specpdl_ptr)); + if (sym->redirect == SYMBOL_PLAINVAL) + { + SET_SYMBOL_VAL (sym, specpdl_old_value (specpdl_ptr)); + break; + } + else + { /* FALLTHROUGH!! + NOTE: we only ever come here if make_local_foo was used for + the first time on this var within this let. */ + } + } case SPECPDL_LET_DEFAULT: - { /* If the symbol is a list, it is really (SYMBOL WHERE - . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a - frame. If WHERE is a buffer or frame, this indicates we - bound a variable that had a buffer-local or frame-local - binding. WHERE nil means that the variable had the default - value when it was bound. CURRENT-BUFFER is the buffer that - was current when the variable was bound. */ + Fset_default (specpdl_symbol (specpdl_ptr), + specpdl_old_value (specpdl_ptr)); + break; + case SPECPDL_LET_LOCAL: + { Lisp_Object symbol = specpdl_symbol (specpdl_ptr); Lisp_Object where = specpdl_where (specpdl_ptr); Lisp_Object old_value = specpdl_old_value (specpdl_ptr); eassert (BUFFERP (where)); - if (specpdl_ptr->kind == SPECPDL_LET_DEFAULT) - Fset_default (symbol, old_value); /* If this was a local binding, reset the value in the appropriate buffer, but only if that buffer's binding still exists. */ - else if (!NILP (Flocal_variable_p (symbol, where))) + if (!NILP (Flocal_variable_p (symbol, where))) set_internal (symbol, old_value, where, 1); } break; @@ -3343,7 +3423,30 @@ Output stream used is value of `standard-output'. */) return Qnil; } -DEFUN ("backtrace-frame", Fbacktrace_frame, Sbacktrace_frame, 1, 1, NULL, +static union specbinding * +get_backtrace_frame (Lisp_Object nframes, Lisp_Object base) +{ + union specbinding *pdl = backtrace_top (); + register EMACS_INT i; + + CHECK_NATNUM (nframes); + + if (!NILP (base)) + { /* Skip up to `base'. */ + base = Findirect_function (base, Qt); + while (backtrace_p (pdl) + && !EQ (base, Findirect_function (backtrace_function (pdl), Qt))) + pdl = backtrace_next (pdl); + } + + /* Find the frame requested. */ + for (i = XFASTINT (nframes); i > 0 && backtrace_p (pdl); i--) + pdl = backtrace_next (pdl); + + return pdl; +} + +DEFUN ("backtrace-frame", Fbacktrace_frame, Sbacktrace_frame, 1, 2, NULL, doc: /* Return the function and arguments NFRAMES up from current execution point. If that frame has not evaluated the arguments yet (or is a special form), the value is (nil FUNCTION ARG-FORMS...). @@ -3352,17 +3455,12 @@ the value is (t FUNCTION ARG-VALUES...). A &rest arg is represented as the tail of the list ARG-VALUES. FUNCTION is whatever was supplied as car of evaluated list, or a lambda expression for macro calls. -If NFRAMES is more than the number of frames, the value is nil. */) - (Lisp_Object nframes) +If NFRAMES is more than the number of frames, the value is nil. +If BASE is non-nil, it should be a function and NFRAMES counts from its +nearest activation frame. */) + (Lisp_Object nframes, Lisp_Object base) { - union specbinding *pdl = backtrace_top (); - register EMACS_INT i; - - CHECK_NATNUM (nframes); - - /* Find the frame requested. */ - for (i = 0; backtrace_p (pdl) && i < XFASTINT (nframes); i++) - pdl = backtrace_next (pdl); + union specbinding *pdl = get_backtrace_frame (nframes, base); if (!backtrace_p (pdl)) return Qnil; @@ -3377,6 +3475,175 @@ If NFRAMES is more than the number of frames, the value is nil. */) } } +/* For backtrace-eval, we want to temporarily unwind the last few elements of + the specpdl stack, and then rewind them. We store the pre-unwind values + directly in the pre-existing specpdl elements (i.e. we swap the current + value and the old value stored in the specpdl), kind of like the inplace + pointer-reversal trick. As it turns out, the rewind does the same as the + unwind, except it starts from the other end of the specpdl stack, so we use + the same function for both unwind and rewind. */ +static void +backtrace_eval_unrewind (int distance) +{ + union specbinding *tmp = specpdl_ptr; + int step = -1; + if (distance < 0) + { /* It's a rewind rather than unwind. */ + tmp += distance - 1; + step = 1; + distance = -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: + case SPECPDL_UNWIND_PTR: + case SPECPDL_UNWIND_INT: + case SPECPDL_UNWIND_VOID: + case SPECPDL_BACKTRACE: + break; + case SPECPDL_LET: + { /* If variable has a trivial value (no forwarding), we can + just set it. No need to check for constant symbols here, + since that was already done by specbind. */ + struct Lisp_Symbol *sym = XSYMBOL (specpdl_symbol (tmp)); + if (sym->redirect == SYMBOL_PLAINVAL) + { + Lisp_Object old_value = specpdl_old_value (tmp); + set_specpdl_old_value (tmp, SYMBOL_VAL (sym)); + SET_SYMBOL_VAL (sym, old_value); + break; + } + else + { /* FALLTHROUGH!! + NOTE: we only ever come here if make_local_foo was used for + the first time on this var within this let. */ + } + } + case SPECPDL_LET_DEFAULT: + { + Lisp_Object sym = specpdl_symbol (tmp); + Lisp_Object old_value = specpdl_old_value (tmp); + set_specpdl_old_value (tmp, Fdefault_value (sym)); + Fset_default (sym, old_value); + } + break; + case SPECPDL_LET_LOCAL: + { + Lisp_Object symbol = specpdl_symbol (tmp); + Lisp_Object where = specpdl_where (tmp); + Lisp_Object old_value = specpdl_old_value (tmp); + eassert (BUFFERP (where)); + + /* If this was a local binding, reset the value in the appropriate + buffer, but only if that buffer's binding still exists. */ + if (!NILP (Flocal_variable_p (symbol, where))) + { + set_specpdl_old_value + (tmp, Fbuffer_local_value (symbol, where)); + set_internal (symbol, old_value, where, 1); + } + } + break; + } + } +} + +DEFUN ("backtrace-eval", Fbacktrace_eval, Sbacktrace_eval, 2, 3, NULL, + doc: /* Evaluate EXP in the context of some activation frame. +NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */) + (Lisp_Object exp, Lisp_Object nframes, Lisp_Object base) +{ + union specbinding *pdl = get_backtrace_frame (nframes, base); + ptrdiff_t count = SPECPDL_INDEX (); + ptrdiff_t distance = specpdl_ptr - pdl; + eassert (distance >= 0); + + if (!backtrace_p (pdl)) + error ("Activation frame not found!"); + + backtrace_eval_unrewind (distance); + record_unwind_protect_int (backtrace_eval_unrewind, -distance); + + /* Use eval_sub rather than Feval since the main motivation behind + backtrace-eval is to be able to get/set the value of lexical variables + 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) @@ -3594,6 +3861,8 @@ alist of active lexical bindings. */); defsubr (&Ssetq); defsubr (&Squote); defsubr (&Sfunction); + defsubr (&Sdefault_toplevel_value); + defsubr (&Sset_default_toplevel_value); defsubr (&Sdefvar); defsubr (&Sdefvaralias); defsubr (&Sdefconst); @@ -3622,6 +3891,8 @@ alist of active lexical bindings. */); defsubr (&Sbacktrace_debug); defsubr (&Sbacktrace); defsubr (&Sbacktrace_frame); + defsubr (&Sbacktrace_eval); + defsubr (&Sbacktrace__locals); defsubr (&Sspecial_variable_p); defsubr (&Sfunctionp); }