diff options
Diffstat (limited to 'src/eval.c')
| -rw-r--r-- | src/eval.c | 494 |
1 files changed, 267 insertions, 227 deletions
diff --git a/src/eval.c b/src/eval.c index a58a1508aaf..be9de93bf1f 100644 --- a/src/eval.c +++ b/src/eval.c @@ -32,8 +32,6 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ #include "xterm.h" #endif -/* static struct backtrace *backtrace_list; */ - /* #if !BYTE_MARK_STACK */ /* static */ /* #endif */ @@ -105,7 +103,7 @@ static EMACS_INT when_entered_debugger; /* The function from which the last `signal' was called. Set in Fsignal. */ - +/* 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 @@ -117,26 +115,39 @@ Lisp_Object inhibit_lisp_code; static Lisp_Object funcall_lambda (Lisp_Object, ptrdiff_t, Lisp_Object *); static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args); -/* Functions to set Lisp_Object slots of struct specbinding. */ +/* Functions to modify slots of backtrace records. */ -static void -set_specpdl_symbol (Lisp_Object symbol) -{ - specpdl_ptr->symbol = symbol; -} +static void set_backtrace_args (struct specbinding *pdl, Lisp_Object *args) +{ eassert (pdl->kind == SPECPDL_BACKTRACE); pdl->v.bt.args = args; } -static void -set_specpdl_old_value (Lisp_Object oldval) +static void set_backtrace_nargs (struct specbinding *pdl, ptrdiff_t n) +{ eassert (pdl->kind == SPECPDL_BACKTRACE); pdl->v.bt.nargs = n; } + +void set_backtrace_debug_on_exit (struct specbinding *pdl, bool doe) +{ eassert (pdl->kind == SPECPDL_BACKTRACE); pdl->v.bt.debug_on_exit = doe; } + +/* Helper functions to scan the backtrace. */ + +EXTERN_INLINE bool backtrace_p (struct specbinding *pdl) +{ return pdl >= specpdl; } + +EXTERN_INLINE struct specbinding *backtrace_top (void) { - specpdl_ptr->old_value = oldval; + struct specbinding *pdl = specpdl_ptr - 1; + while (backtrace_p (pdl) && pdl->kind != SPECPDL_BACKTRACE) + pdl--; + return pdl; } -static inline void -set_specpdl_saved_value (Lisp_Object savedval) +EXTERN_INLINE struct specbinding *backtrace_next (struct specbinding *pdl) { - specpdl_ptr->saved_value = savedval; + pdl--; + while (backtrace_p (pdl) && pdl->kind != SPECPDL_BACKTRACE) + pdl--; + return pdl; } + void init_eval_once (void) { @@ -157,7 +168,6 @@ init_eval (void) specpdl_ptr = specpdl; catchlist = 0; handlerlist = 0; - backtrace_list = 0; Vquit_flag = Qnil; debug_on_next_call = 0; lisp_eval_depth = 0; @@ -253,7 +263,7 @@ static void do_debug_on_call (Lisp_Object code) { debug_on_next_call = 0; - backtrace_list->debug_on_exit = 1; + set_backtrace_debug_on_exit (specpdl_ptr - 1, true); call_debugger (Fcons (code, Qnil)); } @@ -549,9 +559,8 @@ The return value is BASE-VARIABLE. */) struct specbinding *p; for (p = specpdl_ptr; p > specpdl; ) - if ((--p)->func == NULL - && (EQ (new_alias, - CONSP (p->symbol) ? XCAR (p->symbol) : p->symbol))) + if ((--p)->kind >= SPECPDL_LET + && (EQ (new_alias, specpdl_symbol (p)))) error ("Don't know how to make a let-bound variable an alias"); } @@ -616,8 +625,9 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */) struct specbinding *pdl = specpdl_ptr; while (pdl > specpdl) { - if (EQ ((--pdl)->symbol, sym) && !pdl->func - && EQ (pdl->old_value, 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", @@ -956,7 +966,7 @@ usage: (catch TAG BODY...) */) /* 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. */ + This is how catches are done from within C code. */ Lisp_Object internal_catch (Lisp_Object tag, Lisp_Object (*func) (Lisp_Object), Lisp_Object arg) @@ -968,7 +978,6 @@ internal_catch (Lisp_Object tag, Lisp_Object (*func) (Lisp_Object), Lisp_Object c.next = catchlist; c.tag = tag; c.val = Qnil; - c.backlist = backtrace_list; c.f_handlerlist = handlerlist; c.f_lisp_eval_depth = lisp_eval_depth; c.pdlcount = SPECPDL_INDEX (); @@ -1033,7 +1042,6 @@ unwind_to_catch (struct catchtag *catch, Lisp_Object value) #ifdef DEBUG_GCPRO gcpro_level = gcprolist ? gcprolist->level + 1 : 0; #endif - backtrace_list = catch->backlist; lisp_eval_depth = catch->f_lisp_eval_depth; sys_longjmp (catch->jmp, 1); @@ -1134,7 +1142,6 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform, c.tag = Qnil; c.val = Qnil; - c.backlist = backtrace_list; c.f_handlerlist = handlerlist; c.f_lisp_eval_depth = lisp_eval_depth; c.pdlcount = SPECPDL_INDEX (); @@ -1150,7 +1157,7 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform, /* Note that this just undoes the binding of h.var; whoever longjumped to us unwound the stack to c.pdlcount before - throwing. */ + throwing. */ unbind_to (c.pdlcount, Qnil); return val; } @@ -1189,7 +1196,6 @@ internal_condition_case (Lisp_Object (*bfun) (void), Lisp_Object handlers, c.tag = Qnil; c.val = Qnil; - c.backlist = backtrace_list; c.f_handlerlist = handlerlist; c.f_lisp_eval_depth = lisp_eval_depth; c.pdlcount = SPECPDL_INDEX (); @@ -1227,7 +1233,6 @@ internal_condition_case_1 (Lisp_Object (*bfun) (Lisp_Object), Lisp_Object arg, c.tag = Qnil; c.val = Qnil; - c.backlist = backtrace_list; c.f_handlerlist = handlerlist; c.f_lisp_eval_depth = lisp_eval_depth; c.pdlcount = SPECPDL_INDEX (); @@ -1269,7 +1274,6 @@ internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object), c.tag = Qnil; c.val = Qnil; - c.backlist = backtrace_list; c.f_handlerlist = handlerlist; c.f_lisp_eval_depth = lisp_eval_depth; c.pdlcount = SPECPDL_INDEX (); @@ -1313,7 +1317,6 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *), c.tag = Qnil; c.val = Qnil; - c.backlist = backtrace_list; c.f_handlerlist = handlerlist; c.f_lisp_eval_depth = lisp_eval_depth; c.pdlcount = SPECPDL_INDEX (); @@ -1381,7 +1384,6 @@ See also the function `condition-case'. */) = (NILP (error_symbol) ? Fcar (data) : error_symbol); register Lisp_Object clause = Qnil; struct handler *h; - struct backtrace *bp; immediate_quit = 0; abort_on_gc = 0; @@ -1417,13 +1419,13 @@ See also the function `condition-case'. */) too. Don't do this when ERROR_SYMBOL is nil, because that is a memory-full error. */ Vsignaling_function = Qnil; - if (backtrace_list && !NILP (error_symbol)) + if (!NILP (error_symbol)) { - bp = backtrace_list->next; - if (bp && EQ (bp->function, Qerror)) - bp = bp->next; - if (bp) - Vsignaling_function = bp->function; + struct specbinding *pdl = backtrace_next (backtrace_top ()); + if (backtrace_p (pdl) && EQ (backtrace_function (pdl), Qerror)) + pdl = backtrace_next (pdl); + if (backtrace_p (pdl)) + Vsignaling_function = backtrace_function (pdl); } for (h = handlerlist; h; h = h->next) @@ -1920,6 +1922,36 @@ If LEXICAL is t, evaluate using lexical scoping. */) return unbind_to (count, eval_sub (form)); } +static void +grow_specpdl (void) +{ + register ptrdiff_t count = SPECPDL_INDEX (); + ptrdiff_t max_size = min (max_specpdl_size, PTRDIFF_MAX); + if (max_size <= specpdl_size) + { + if (max_specpdl_size < 400) + max_size = max_specpdl_size = 400; + if (max_size <= specpdl_size) + signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil); + } + specpdl = xpalloc (specpdl, &specpdl_size, 1, max_size, sizeof *specpdl); + specpdl_ptr = specpdl + count; +} + +LISP_INLINE void +record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs) +{ + eassert (nargs >= UNEVALLED); + if (specpdl_ptr == specpdl + specpdl_size) + grow_specpdl (); + specpdl_ptr->kind = SPECPDL_BACKTRACE; + specpdl_ptr->v.bt.function = function; + specpdl_ptr->v.bt.args = args; + specpdl_ptr->v.bt.nargs = nargs; + specpdl_ptr->v.bt.debug_on_exit = false; + specpdl_ptr++; +} + /* Eval a sub-expression of the current expression (i.e. in the same lexical scope). */ Lisp_Object @@ -1927,7 +1959,6 @@ eval_sub (Lisp_Object form) { Lisp_Object fun, val, original_fun, original_args; Lisp_Object funcar; - struct backtrace backtrace; struct gcpro gcpro1, gcpro2, gcpro3; if (SYMBOLP (form)) @@ -1965,12 +1996,8 @@ eval_sub (Lisp_Object form) original_fun = XCAR (form); original_args = XCDR (form); - backtrace.next = backtrace_list; - backtrace.function = original_fun; /* This also protects them from gc. */ - backtrace.args = &original_args; - backtrace.nargs = UNEVALLED; - backtrace.debug_on_exit = 0; - backtrace_list = &backtrace; + /* This also protects them from gc. */ + record_in_backtrace (original_fun, &original_args, UNEVALLED); if (debug_on_next_call) do_debug_on_call (Qt); @@ -2024,8 +2051,8 @@ eval_sub (Lisp_Object form) gcpro3.nvars = argnum; } - backtrace.args = vals; - backtrace.nargs = XINT (numargs); + set_backtrace_args (specpdl_ptr - 1, vals); + set_backtrace_nargs (specpdl_ptr - 1, XINT (numargs)); val = (XSUBR (fun)->function.aMANY) (XINT (numargs), vals); UNGCPRO; @@ -2046,8 +2073,8 @@ eval_sub (Lisp_Object form) UNGCPRO; - backtrace.args = argvals; - backtrace.nargs = XINT (numargs); + set_backtrace_args (specpdl_ptr - 1, argvals); + set_backtrace_nargs (specpdl_ptr - 1, XINT (numargs)); switch (i) { @@ -2137,9 +2164,9 @@ eval_sub (Lisp_Object form) check_cons_list (); lisp_eval_depth--; - if (backtrace.debug_on_exit) + if (backtrace_debug_on_exit (specpdl_ptr - 1)) val = call_debugger (Fcons (Qexit, Fcons (val, Qnil))); - backtrace_list = backtrace.next; + specpdl_ptr--; return val; } @@ -2619,7 +2646,6 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) ptrdiff_t numargs = nargs - 1; Lisp_Object lisp_numargs; Lisp_Object val; - struct backtrace backtrace; register Lisp_Object *internal_args; ptrdiff_t i; @@ -2633,12 +2659,8 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) error ("Lisp nesting exceeds `max-lisp-eval-depth'"); } - backtrace.next = backtrace_list; - backtrace.function = args[0]; - backtrace.args = &args[1]; /* This also GCPROs them. */ - backtrace.nargs = nargs - 1; - backtrace.debug_on_exit = 0; - backtrace_list = &backtrace; + /* This also GCPROs them. */ + record_in_backtrace (args[0], &args[1], nargs - 1); /* Call GC after setting up the backtrace, so the latter GCPROs the args. */ maybe_gc (); @@ -2763,9 +2785,9 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) } check_cons_list (); lisp_eval_depth--; - if (backtrace.debug_on_exit) + if (backtrace_debug_on_exit (specpdl_ptr - 1)) val = call_debugger (Fcons (Qexit, Fcons (val, Qnil))); - backtrace_list = backtrace.next; + specpdl_ptr--; return val; } @@ -2797,15 +2819,17 @@ apply_lambda (Lisp_Object fun, Lisp_Object args) UNGCPRO; - backtrace_list->args = arg_vector; - backtrace_list->nargs = i; + set_backtrace_args (specpdl_ptr - 1, arg_vector); + set_backtrace_nargs (specpdl_ptr - 1, i); tem = funcall_lambda (fun, numargs, arg_vector); /* Do the debug-on-exit now, while arg_vector still exists. */ - if (backtrace_list->debug_on_exit) - tem = call_debugger (Fcons (Qexit, Fcons (tem, Qnil))); - /* Don't do it again when we return to eval. */ - backtrace_list->debug_on_exit = 0; + if (backtrace_debug_on_exit (specpdl_ptr - 1)) + { + /* 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))); + } SAFE_FREE (); return tem; } @@ -2955,20 +2979,38 @@ DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode, return object; } -static void -grow_specpdl (void) +/* Return true if SYMBOL currently has a let-binding + which was made in the buffer that is now current. */ + +bool +let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol) { - register ptrdiff_t count = SPECPDL_INDEX (); - ptrdiff_t max_size = min (max_specpdl_size, PTRDIFF_MAX); - if (max_size <= specpdl_size) - { - if (max_specpdl_size < 400) - max_size = max_specpdl_size = 400; - if (max_size <= specpdl_size) - signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil); - } - specpdl = xpalloc (specpdl, &specpdl_size, 1, max_size, sizeof *specpdl); - specpdl_ptr = specpdl + count; + struct specbinding *p; + Lisp_Object buf = Fcurrent_buffer (); + + for (p = specpdl_ptr; p > specpdl; ) + if ((--p)->kind > SPECPDL_LET) + { + struct Lisp_Symbol *let_bound_symbol = XSYMBOL (specpdl_symbol (p)); + eassert (let_bound_symbol->redirect != SYMBOL_VARALIAS); + if (symbol == let_bound_symbol + && EQ (specpdl_where (p), buf)) + return 1; + } + + return 0; +} + +bool +let_shadows_global_binding_p (Lisp_Object symbol) +{ + struct specbinding *p; + + for (p = specpdl_ptr; p > specpdl; ) + if ((--p)->kind >= SPECPDL_LET && EQ (specpdl_symbol (p), symbol)) + return 1; + + return 0; } static Lisp_Object @@ -3050,10 +3092,10 @@ specbind (Lisp_Object symbol, Lisp_Object value) case SYMBOL_PLAINVAL: /* The most common case is that of a non-constant symbol with a trivial value. Make that as fast as we can. */ - set_specpdl_symbol (symbol); - set_specpdl_old_value (SYMBOL_VAL (sym)); - specpdl_ptr->func = NULL; - specpdl_ptr->saved_value = Qnil; + specpdl_ptr->kind = SPECPDL_LET; + specpdl_ptr->v.let.symbol = symbol; + specpdl_ptr->v.let.old_value = SYMBOL_VAL (sym); + specpdl_ptr->v.let.saved_value = Qnil; ++specpdl_ptr; do_specbind (sym, specpdl_ptr - 1, value); break; @@ -3063,59 +3105,36 @@ specbind (Lisp_Object symbol, Lisp_Object value) case SYMBOL_FORWARDED: { Lisp_Object ovalue = find_symbol_value (symbol); - specpdl_ptr->func = 0; - set_specpdl_old_value (ovalue); + specpdl_ptr->kind = SPECPDL_LET_LOCAL; + specpdl_ptr->v.let.symbol = symbol; + specpdl_ptr->v.let.old_value = ovalue; + specpdl_ptr->v.let.where = Fcurrent_buffer (); eassert (sym->redirect != SYMBOL_LOCALIZED - || (EQ (SYMBOL_BLV (sym)->where, - SYMBOL_BLV (sym)->frame_local ? - Fselected_frame () : Fcurrent_buffer ()))); + || (EQ (SYMBOL_BLV (sym)->where, Fcurrent_buffer ()))); - if (sym->redirect == SYMBOL_LOCALIZED - || BUFFER_OBJFWDP (SYMBOL_FWD (sym))) + if (sym->redirect == SYMBOL_LOCALIZED) + { + if (!blv_found (SYMBOL_BLV (sym))) + specpdl_ptr->kind = SPECPDL_LET_DEFAULT; + } + else if (BUFFER_OBJFWDP (SYMBOL_FWD (sym))) { - Lisp_Object where, cur_buf = Fcurrent_buffer (); - - /* For a local variable, record both the symbol and which - buffer's or frame's value we are saving. */ - if (!NILP (Flocal_variable_p (symbol, Qnil))) - { - eassert (sym->redirect != SYMBOL_LOCALIZED - || (blv_found (SYMBOL_BLV (sym)) - && EQ (cur_buf, SYMBOL_BLV (sym)->where))); - where = cur_buf; - } - else if (sym->redirect == SYMBOL_LOCALIZED - && blv_found (SYMBOL_BLV (sym))) - where = SYMBOL_BLV (sym)->where; - else - where = Qnil; - - /* We're not using the `unused' slot in the specbinding - structure because this would mean we have to do more - work for simple variables. */ - /* FIXME: The third value `current_buffer' is only used in - let_shadows_buffer_binding_p which is itself only used - in set_internal for local_if_set. */ - eassert (NILP (where) || EQ (where, cur_buf)); - set_specpdl_symbol (Fcons (symbol, Fcons (where, cur_buf))); - /* If SYMBOL is a per-buffer variable which doesn't have a buffer-local value here, make the `let' change the global value by changing the value of SYMBOL in all buffers not having their own value. This is consistent with what happens with other buffer-local variables. */ - if (NILP (where) - && sym->redirect == SYMBOL_FORWARDED) + if (NILP (Flocal_variable_p (symbol, Qnil))) { - eassert (BUFFER_OBJFWDP (SYMBOL_FWD (sym))); + specpdl_ptr->kind = SPECPDL_LET_DEFAULT; ++specpdl_ptr; do_specbind (sym, specpdl_ptr - 1, value); return; } } else - set_specpdl_symbol (symbol); + specpdl_ptr->kind = SPECPDL_LET; specpdl_ptr++; do_specbind (sym, specpdl_ptr - 1, value); @@ -3130,10 +3149,9 @@ record_unwind_protect (Lisp_Object (*function) (Lisp_Object), Lisp_Object arg) { if (specpdl_ptr == specpdl + specpdl_size) grow_specpdl (); - specpdl_ptr->func = function; - set_specpdl_symbol (Qnil); - set_specpdl_old_value (arg); - set_specpdl_saved_value (Qnil); + specpdl_ptr->kind = SPECPDL_UNWIND; + specpdl_ptr->v.unwind.func = function; + specpdl_ptr->v.unwind.arg = arg; specpdl_ptr++; } @@ -3144,7 +3162,7 @@ rebind_for_thread_switch (void) for (bind = specpdl; bind != specpdl_ptr; ++bind) { - if (bind->func == NULL) + if (bind->kind >= SPECPDL_LET) { Lisp_Object value = bind->saved_value; @@ -3157,41 +3175,50 @@ rebind_for_thread_switch (void) static void do_one_unbind (const struct specbinding *this_binding, int unwinding) { - if (this_binding->func != 0) - (*this_binding->func) (this_binding->old_value); - /* 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. */ - else if (CONSP (this_binding->symbol)) - { - Lisp_Object symbol, where; - - symbol = XCAR (this_binding->symbol); - where = XCAR (XCDR (this_binding->symbol)); - - if (NILP (where)) - Fset_default (symbol, this_binding->old_value); - /* If `where' is non-nil, reset the value in the appropriate - local binding, but only if that binding still exists. */ - else if (BUFFERP (where) - ? !NILP (Flocal_variable_p (symbol, where)) - : !NILP (Fassq (symbol, XFRAME (where)->param_alist))) - set_internal (symbol, this_binding->old_value, where, 1); - } - /* 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. */ - else if (XSYMBOL (this_binding->symbol)->redirect == SYMBOL_PLAINVAL) - SET_SYMBOL_VAL (XSYMBOL (this_binding->symbol), - this_binding->old_value); - 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 (this_binding->symbol, this_binding->old_value); + switch (this_binding->kind) + { + case SPECPDL_UNWIND: + (*specpdl_func (this_binding)) (specpdl_arg (this_binding)); + 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 (this_binding))->redirect + == SYMBOL_PLAINVAL) + SET_SYMBOL_VAL (XSYMBOL (specpdl_symbol (this_binding)), + specpdl_old_value (this_binding)); + 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 (this_binding), + specpdl_old_value (this_binding)); + break; + case SPECPDL_BACKTRACE: + break; + case SPECPDL_LET_LOCAL: + 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. */ + Lisp_Object symbol = specpdl_symbol (this_binding); + Lisp_Object where = specpdl_where (this_binding); + eassert (BUFFERP (where)); + + if (this_binding->kind == SPECPDL_LET_DEFAULT) + Fset_default (symbol, specpdl_old_value (this_binding)); + /* 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))) + set_internal (symbol, specpdl_old_value (this_binding), + where, 1); + } + break; + } } Lisp_Object @@ -3231,7 +3258,7 @@ unbind_for_thread_switch (void) for (bind = specpdl_ptr; bind != specpdl; --bind) { - if (bind->func == NULL) + if (bind->kind >= SPECPDL_LET) { bind->saved_value = find_symbol_value (binding_symbol (bind)); do_one_unbind (bind, 0); @@ -3255,18 +3282,16 @@ DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0, The debugger is entered when that frame exits, if the flag is non-nil. */) (Lisp_Object level, Lisp_Object flag) { - register struct backtrace *backlist = backtrace_list; + struct specbinding *pdl = backtrace_top (); register EMACS_INT i; CHECK_NUMBER (level); - for (i = 0; backlist && i < XINT (level); i++) - { - backlist = backlist->next; - } + for (i = 0; backtrace_p (pdl) && i < XINT (level); i++) + pdl = backtrace_next (pdl); - if (backlist) - backlist->debug_on_exit = !NILP (flag); + if (backtrace_p (pdl)) + set_backtrace_debug_on_exit (pdl, !NILP (flag)); return flag; } @@ -3276,58 +3301,41 @@ DEFUN ("backtrace", Fbacktrace, Sbacktrace, 0, 0, "", Output stream used is value of `standard-output'. */) (void) { - register struct backtrace *backlist = backtrace_list; - Lisp_Object tail; + struct specbinding *pdl = backtrace_top (); Lisp_Object tem; - struct gcpro gcpro1; Lisp_Object old_print_level = Vprint_level; if (NILP (Vprint_level)) XSETFASTINT (Vprint_level, 8); - tail = Qnil; - GCPRO1 (tail); - - while (backlist) + while (backtrace_p (pdl)) { - write_string (backlist->debug_on_exit ? "* " : " ", 2); - if (backlist->nargs == UNEVALLED) + write_string (backtrace_debug_on_exit (pdl) ? "* " : " ", 2); + if (backtrace_nargs (pdl) == UNEVALLED) { - Fprin1 (Fcons (backlist->function, *backlist->args), Qnil); + Fprin1 (Fcons (backtrace_function (pdl), *backtrace_args (pdl)), + Qnil); write_string ("\n", -1); } else { - tem = backlist->function; + tem = backtrace_function (pdl); Fprin1 (tem, Qnil); /* This can QUIT. */ write_string ("(", -1); - if (backlist->nargs == MANY) - { /* FIXME: Can this happen? */ - bool later_arg = 0; - for (tail = *backlist->args; !NILP (tail); tail = Fcdr (tail)) - { - if (later_arg) - write_string (" ", -1); - Fprin1 (Fcar (tail), Qnil); - later_arg = 1; - } - } - else - { - ptrdiff_t i; - for (i = 0; i < backlist->nargs; i++) - { - if (i) write_string (" ", -1); - Fprin1 (backlist->args[i], Qnil); - } - } + { + ptrdiff_t i; + for (i = 0; i < backtrace_nargs (pdl); i++) + { + if (i) write_string (" ", -1); + Fprin1 (backtrace_args (pdl)[i], Qnil); + } + } write_string (")\n", -1); } - backlist = backlist->next; + pdl = backtrace_next (pdl); } Vprint_level = old_print_level; - UNGCPRO; return Qnil; } @@ -3343,53 +3351,85 @@ or a lambda expression for macro calls. If NFRAMES is more than the number of frames, the value is nil. */) (Lisp_Object nframes) { - register struct backtrace *backlist = backtrace_list; + struct specbinding *pdl = backtrace_top (); register EMACS_INT i; - Lisp_Object tem; CHECK_NATNUM (nframes); /* Find the frame requested. */ - for (i = 0; backlist && i < XFASTINT (nframes); i++) - backlist = backlist->next; + for (i = 0; backtrace_p (pdl) && i < XFASTINT (nframes); i++) + pdl = backtrace_next (pdl); - if (!backlist) + if (!backtrace_p (pdl)) return Qnil; - if (backlist->nargs == UNEVALLED) - return Fcons (Qnil, Fcons (backlist->function, *backlist->args)); + if (backtrace_nargs (pdl) == UNEVALLED) + return Fcons (Qnil, + Fcons (backtrace_function (pdl), *backtrace_args (pdl))); else { - if (backlist->nargs == MANY) /* FIXME: Can this happen? */ - tem = *backlist->args; - else - tem = Flist (backlist->nargs, backlist->args); + Lisp_Object tem = Flist (backtrace_nargs (pdl), backtrace_args (pdl)); - return Fcons (Qt, Fcons (backlist->function, tem)); + return Fcons (Qt, Fcons (backtrace_function (pdl), tem)); } } -#if BYTE_MARK_STACK void -mark_backtrace (void) +mark_specpdl (struct specbinding *first, struct specbinding *ptr) { - register struct backtrace *backlist; - ptrdiff_t i; - - for (backlist = backtrace_list; backlist; backlist = backlist->next) + struct specbinding *pdl; + for (pdl = first; pdl != ptr; pdl++) { - mark_object (backlist->function); + switch (pdl->kind) + { + case SPECPDL_UNWIND: + mark_object (specpdl_arg (pdl)); + break; + case SPECPDL_BACKTRACE: + { + ptrdiff_t nargs = backtrace_nargs (pdl); + mark_object (backtrace_function (pdl)); + if (nargs == UNEVALLED) + nargs = 1; + while (nargs--) + mark_object (backtrace_args (pdl)[nargs]); + } + break; + case SPECPDL_LET_DEFAULT: + case SPECPDL_LET_LOCAL: + mark_object (specpdl_where (pdl)); + case SPECPDL_LET: + mark_object (specpdl_symbol (pdl)); + mark_object (specpdl_old_value (pdl)); + mark_object (specpdl_saved_value (pdl)); + } + } +} + +void +get_backtrace (Lisp_Object array) +{ + struct specbinding *pdl = backtrace_next (backtrace_top ()); + ptrdiff_t i = 0, asize = ASIZE (array); - if (backlist->nargs == UNEVALLED - || backlist->nargs == MANY) /* FIXME: Can this happen? */ - i = 1; + /* Copy the backtrace contents into working memory. */ + for (; i < asize; i++) + { + if (backtrace_p (pdl)) + { + ASET (array, i, backtrace_function (pdl)); + pdl = backtrace_next (pdl); + } else - i = backlist->nargs; - while (i--) - mark_object (backlist->args[i]); + ASET (array, i, Qnil); } } -#endif + +Lisp_Object backtrace_top_function (void) +{ + struct specbinding *pdl = backtrace_top (); + return (backtrace_p (pdl) ? backtrace_function (pdl) : Qnil); +} void syms_of_eval (void) |
