/* Evaluator for GNU Emacs Lisp interpreter.
- Copyright (C) 1985-1987, 1993-1995, 1999-2012 Free Software Foundation, Inc.
+ Copyright (C) 1985-1987, 1993-1995, 1999-2013 Free Software
+ Foundation, Inc.
This file is part of GNU Emacs.
#include "xterm.h"
#endif
-struct backtrace *backtrace_list;
-
#if !BYTE_MARK_STACK
static
#endif
Lisp_Object Vautoload_queue;
-/* Current number of specbindings allocated in specpdl. */
+/* Current number of specbindings allocated in specpdl, not counting
+ the dummy entry specpdl[-1]. */
ptrdiff_t specpdl_size;
-/* Pointer to beginning of specpdl. */
+/* Pointer to beginning of specpdl. A dummy entry specpdl[-1] exists
+ only so that its address can be taken. */
-struct specbinding *specpdl;
+union specbinding *specpdl;
/* Pointer to first unused element in specpdl. */
-struct specbinding *specpdl_ptr;
+union specbinding *specpdl_ptr;
/* Depth in Lisp evaluations and function calls. */
/* 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
frame is half-initialized. */
Lisp_Object inhibit_lisp_code;
+/* These would ordinarily be static, but they need to be visible to GDB. */
+bool backtrace_p (union specbinding *) EXTERNALLY_VISIBLE;
+Lisp_Object *backtrace_args (union specbinding *) EXTERNALLY_VISIBLE;
+Lisp_Object backtrace_function (union specbinding *) EXTERNALLY_VISIBLE;
+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 bool interactive_p (void);
static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args);
-/* Functions to set Lisp_Object slots of struct specbinding. */
+static Lisp_Object
+specpdl_symbol (union specbinding *pdl)
+{
+ eassert (pdl->kind >= SPECPDL_LET);
+ return pdl->let.symbol;
+}
+
+static Lisp_Object
+specpdl_old_value (union specbinding *pdl)
+{
+ eassert (pdl->kind >= SPECPDL_LET);
+ return pdl->let.old_value;
+}
+
+static Lisp_Object
+specpdl_where (union specbinding *pdl)
+{
+ eassert (pdl->kind > SPECPDL_LET);
+ return pdl->let.where;
+}
+
+static Lisp_Object
+specpdl_arg (union specbinding *pdl)
+{
+ eassert (pdl->kind == SPECPDL_UNWIND);
+ 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)
+{
+ eassert (pdl->kind == SPECPDL_BACKTRACE);
+ return pdl->bt.function;
+}
+
+static ptrdiff_t
+backtrace_nargs (union specbinding *pdl)
+{
+ eassert (pdl->kind == SPECPDL_BACKTRACE);
+ return pdl->bt.nargs;
+}
+
+Lisp_Object *
+backtrace_args (union specbinding *pdl)
+{
+ eassert (pdl->kind == SPECPDL_BACKTRACE);
+ return pdl->bt.args;
+}
+
+static bool
+backtrace_debug_on_exit (union specbinding *pdl)
+{
+ eassert (pdl->kind == SPECPDL_BACKTRACE);
+ return pdl->bt.debug_on_exit;
+}
+
+/* Functions to modify slots of backtrace records. */
static void
-set_specpdl_symbol (Lisp_Object symbol)
+set_backtrace_args (union specbinding *pdl, Lisp_Object *args)
{
- specpdl_ptr->symbol = symbol;
+ eassert (pdl->kind == SPECPDL_BACKTRACE);
+ pdl->bt.args = args;
}
static void
-set_specpdl_old_value (Lisp_Object oldval)
+set_backtrace_nargs (union specbinding *pdl, ptrdiff_t n)
+{
+ eassert (pdl->kind == SPECPDL_BACKTRACE);
+ pdl->bt.nargs = n;
+}
+
+static void
+set_backtrace_debug_on_exit (union specbinding *pdl, bool doe)
+{
+ eassert (pdl->kind == SPECPDL_BACKTRACE);
+ pdl->bt.debug_on_exit = doe;
+}
+
+/* Helper functions to scan the backtrace. */
+
+bool
+backtrace_p (union specbinding *pdl)
+{ return pdl >= specpdl; }
+
+union specbinding *
+backtrace_top (void)
+{
+ union specbinding *pdl = specpdl_ptr - 1;
+ while (backtrace_p (pdl) && pdl->kind != SPECPDL_BACKTRACE)
+ pdl--;
+ return pdl;
+}
+
+union specbinding *
+backtrace_next (union specbinding *pdl)
{
- specpdl_ptr->old_value = oldval;
+ pdl--;
+ while (backtrace_p (pdl) && pdl->kind != SPECPDL_BACKTRACE)
+ pdl--;
+ return pdl;
}
+
void
init_eval_once (void)
{
enum { size = 50 };
- specpdl = xmalloc (size * sizeof *specpdl);
+ union specbinding *pdlvec = xmalloc ((size + 1) * sizeof *specpdl);
specpdl_size = size;
- specpdl_ptr = specpdl;
+ specpdl = specpdl_ptr = pdlvec + 1;
/* Don't forget to update docs (lispref node "Local Variables"). */
max_specpdl_size = 1300; /* 1000 is not enough for CEDET's c-by.el. */
max_lisp_eval_depth = 600;
specpdl_ptr = specpdl;
catchlist = 0;
handlerlist = 0;
- backtrace_list = 0;
Vquit_flag = Qnil;
debug_on_next_call = 0;
lisp_eval_depth = 0;
do_debug_on_call (Lisp_Object code)
{
debug_on_next_call = 0;
- backtrace_list->debug_on_exit = 1;
- call_debugger (Fcons (code, Qnil));
+ set_backtrace_debug_on_exit (specpdl_ptr - 1, true);
+ call_debugger (list1 (code));
}
\f
/* NOTE!!! Every function that can call EVAL must protect its args
}
-DEFUN ("interactive-p", Finteractive_p, Sinteractive_p, 0, 0, 0,
- doc: /* Return t if the containing function was run directly by user input.
-This means that the function was called with `call-interactively'
-\(which includes being called as the binding of a key)
-and input is currently coming from the keyboard (not a keyboard macro),
-and Emacs is not running in batch mode (`noninteractive' is nil).
-
-The only known proper use of `interactive-p' is in deciding whether to
-display a helpful message, or how to display it. If you're thinking
-of using it for any other purpose, it is quite likely that you're
-making a mistake. Think: what do you want to do when the command is
-called from a keyboard macro?
-
-To test whether your function was called with `call-interactively',
-either (i) add an extra optional argument and give it an `interactive'
-spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
-use `called-interactively-p'. */)
- (void)
-{
- return interactive_p () ? Qt : Qnil;
-}
-
-
-DEFUN ("called-interactively-p", Fcalled_interactively_p, Scalled_interactively_p, 0, 1, 0,
- doc: /* Return t if the containing function was called by `call-interactively'.
-If KIND is `interactive', then only return t if the call was made
-interactively by the user, i.e. not in `noninteractive' mode nor
-when `executing-kbd-macro'.
-If KIND is `any', on the other hand, it will return t for any kind of
-interactive call, including being called as the binding of a key, or
-from a keyboard macro, or in `noninteractive' mode.
-
-The only known proper use of `interactive' for KIND is in deciding
-whether to display a helpful message, or how to display it. If you're
-thinking of using it for any other purpose, it is quite likely that
-you're making a mistake. Think: what do you want to do when the
-command is called from a keyboard macro?
-
-Instead of using this function, it is sometimes cleaner to give your
-function an extra optional argument whose `interactive' spec specifies
-non-nil unconditionally (\"p\" is a good way to do this), or via
-\(not (or executing-kbd-macro noninteractive)). */)
- (Lisp_Object kind)
-{
- return (((INTERACTIVE || !EQ (kind, intern ("interactive")))
- && interactive_p ())
- ? Qt : Qnil);
-}
-
-
-/* Return true if function in which this appears was called using
- call-interactively and is not a built-in. */
-
-static bool
-interactive_p (void)
-{
- struct backtrace *btp;
- Lisp_Object fun;
-
- btp = backtrace_list;
-
- /* If this isn't a byte-compiled function, there may be a frame at
- the top for Finteractive_p. If so, skip it. */
- fun = Findirect_function (btp->function, Qnil);
- if (SUBRP (fun) && (XSUBR (fun) == &Sinteractive_p
- || XSUBR (fun) == &Scalled_interactively_p))
- btp = btp->next;
-
- /* If we're running an Emacs 18-style byte-compiled function, there
- may be a frame for Fbytecode at the top level. In any version of
- Emacs there can be Fbytecode frames for subexpressions evaluated
- inside catch and condition-case. Skip past them.
-
- If this isn't a byte-compiled function, then we may now be
- looking at several frames for special forms. Skip past them. */
- while (btp
- && (EQ (btp->function, Qbytecode)
- || btp->nargs == UNEVALLED))
- btp = btp->next;
-
- /* `btp' now points at the frame of the innermost function that isn't
- a special form, ignoring frames for Finteractive_p and/or
- Fbytecode at the top. If this frame is for a built-in function
- (such as load or eval-region) return false. */
- fun = Findirect_function (btp->function, Qnil);
- if (SUBRP (fun))
- return 0;
-
- /* `btp' points to the frame of a Lisp function that called interactive-p.
- Return t if that function was called interactively. */
- if (btp && btp->next && EQ (btp->next->function, Qcall_interactively))
- return 1;
- return 0;
-}
-
-
DEFUN ("defvaralias", Fdefvaralias, Sdefvaralias, 2, 3, 0,
doc: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
Aliased variables always have the same value; setting one sets the other.
set_internal (base_variable, find_symbol_value (new_alias), Qnil, 1);
{
- struct specbinding *p;
+ union 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");
}
else
{ /* Check if there is really a global binding rather than just a let
binding that shadows the global unboundness of the var. */
- struct specbinding *pdl = specpdl_ptr;
+ union 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",
- SYMBOL_NAME (sym), 1);
+ message_with_string
+ ("Warning: defvar ignored because %s is let-bound",
+ SYMBOL_NAME (sym), 1);
break;
}
}
/* A simple (defvar foo) with lexical scoping does "nothing" except
declare that var to be dynamically scoped *locally* (i.e. within
the current file or let-block). */
- Vinternal_interpreter_environment =
- Fcons (sym, Vinternal_interpreter_environment);
+ Vinternal_interpreter_environment
+ = Fcons (sym, Vinternal_interpreter_environment);
else
{
/* Simple (defvar <var>) should not count as a definition at all.
if (NILP (tem))
{
def = XSYMBOL (sym)->function;
- if (!EQ (def, Qunbound))
+ if (!NILP (def))
continue;
}
break;
GCPRO1 (form);
def = Fautoload_do_load (def, sym, Qmacro);
UNGCPRO;
- if (EQ (def, Qunbound) || !CONSP (def))
+ if (!CONSP (def))
/* Not defined or definition not suitable. */
break;
if (!EQ (XCAR (def), Qmacro))
/* 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)
c.next = catchlist;
c.tag = tag;
c.val = Qnil;
- c.backlist = backtrace_list;
c.handlerlist = handlerlist;
c.lisp_eval_depth = lisp_eval_depth;
c.pdlcount = SPECPDL_INDEX ();
#ifdef DEBUG_GCPRO
gcpro_level = gcprolist ? gcprolist->level + 1 : 0;
#endif
- backtrace_list = catch->backlist;
lisp_eval_depth = catch->lisp_eval_depth;
sys_longjmp (catch->jmp, 1);
c.tag = Qnil;
c.val = Qnil;
- c.backlist = backtrace_list;
c.handlerlist = handlerlist;
c.lisp_eval_depth = lisp_eval_depth;
c.pdlcount = SPECPDL_INDEX ();
/* 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;
}
c.tag = Qnil;
c.val = Qnil;
- c.backlist = backtrace_list;
c.handlerlist = handlerlist;
c.lisp_eval_depth = lisp_eval_depth;
c.pdlcount = SPECPDL_INDEX ();
c.tag = Qnil;
c.val = Qnil;
- c.backlist = backtrace_list;
c.handlerlist = handlerlist;
c.lisp_eval_depth = lisp_eval_depth;
c.pdlcount = SPECPDL_INDEX ();
c.tag = Qnil;
c.val = Qnil;
- c.backlist = backtrace_list;
c.handlerlist = handlerlist;
c.lisp_eval_depth = lisp_eval_depth;
c.pdlcount = SPECPDL_INDEX ();
c.tag = Qnil;
c.val = Qnil;
- c.backlist = backtrace_list;
c.handlerlist = handlerlist;
c.lisp_eval_depth = lisp_eval_depth;
c.pdlcount = SPECPDL_INDEX ();
= (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;
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;
+ union 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)
}
if (!NILP (hare))
- arg = Fcons (arg, Qnil); /* Make it a list. */
+ arg = list1 (arg);
xsignal (Qerror, Fcons (build_string (s), arg));
}
/* 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;
}
va_list ap;
va_start (ap, m);
verror (m, ap);
- va_end (ap);
}
\f
DEFUN ("commandp", Fcommandp, Scommandp, 1, 2, 0,
fun = function;
- fun = indirect_function (fun); /* Check cycles. */
- if (NILP (fun) || EQ (fun, Qunbound))
+ fun = indirect_function (fun); /* Check cycles. */
+ if (NILP (fun))
return Qnil;
/* Check an `interactive-form' property if present, analogous to the
- function-documentation property. */
+ function-documentation property. */
fun = function;
while (SYMBOLP (fun))
{
CHECK_STRING (file);
/* If function is defined and not as an autoload, don't override. */
- if (!EQ (XSYMBOL (function)->function, Qunbound)
+ if (!NILP (XSYMBOL (function)->function)
&& !AUTOLOADP (XSYMBOL (function)->function))
return Qnil;
{
ptrdiff_t count = SPECPDL_INDEX ();
specbind (Qinternal_interpreter_environment,
- NILP (lexical) ? Qnil : Fcons (Qt, Qnil));
+ CONSP (lexical) || NILP (lexical) ? lexical : list1 (Qt));
return unbind_to (count, eval_sub (form));
}
+/* Grow the specpdl stack by one entry.
+ The caller should have already initialized the entry.
+ Signal an error on stack overflow.
+
+ Make sure that there is always one unused entry past the top of the
+ stack, so that the just-initialized entry is safely unwound if
+ memory exhausted and an error is signaled here. Also, allocate a
+ never-used entry just before the bottom of the stack; sometimes its
+ address is taken. */
+
+static void
+grow_specpdl (void)
+{
+ specpdl_ptr++;
+
+ if (specpdl_ptr == specpdl + specpdl_size)
+ {
+ ptrdiff_t count = SPECPDL_INDEX ();
+ ptrdiff_t max_size = min (max_specpdl_size, PTRDIFF_MAX - 1000);
+ union specbinding *pdlvec = specpdl - 1;
+ ptrdiff_t pdlvecsize = specpdl_size + 1;
+ 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);
+ }
+ pdlvec = xpalloc (pdlvec, &pdlvecsize, 1, max_size + 1, sizeof *specpdl);
+ specpdl = pdlvec + 1;
+ specpdl_size = pdlvecsize - 1;
+ specpdl_ptr = specpdl + count;
+ }
+}
+
+void
+record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs)
+{
+ eassert (nargs >= UNEVALLED);
+ specpdl_ptr->bt.kind = SPECPDL_BACKTRACE;
+ specpdl_ptr->bt.debug_on_exit = false;
+ specpdl_ptr->bt.function = function;
+ specpdl_ptr->bt.args = args;
+ specpdl_ptr->bt.nargs = nargs;
+ grow_specpdl ();
+}
+
/* Eval a sub-expression of the current expression (i.e. in the same
lexical scope). */
Lisp_Object
{
Lisp_Object fun, val, original_fun, original_args;
Lisp_Object funcar;
- struct backtrace backtrace;
struct gcpro gcpro1, gcpro2, gcpro3;
if (SYMBOLP (form))
return form;
QUIT;
+
+ GCPRO1 (form);
maybe_gc ();
+ UNGCPRO;
if (++lisp_eval_depth > max_lisp_eval_depth)
{
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);
/* Optimize for no indirection. */
fun = original_fun;
- if (SYMBOLP (fun) && !EQ (fun, Qunbound)
+ if (SYMBOLP (fun) && !NILP (fun)
&& (fun = XSYMBOL (fun)->function, SYMBOLP (fun)))
fun = indirect_function (fun);
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;
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)
{
val = apply_lambda (fun, original_args);
else
{
- if (EQ (fun, Qunbound))
+ if (NILP (fun))
xsignal1 (Qvoid_function, original_fun);
if (!CONSP (fun))
xsignal1 (Qinvalid_function, original_fun);
check_cons_list ();
lisp_eval_depth--;
- if (backtrace.debug_on_exit)
- val = call_debugger (Fcons (Qexit, Fcons (val, Qnil)));
- backtrace_list = backtrace.next;
+ if (backtrace_debug_on_exit (specpdl_ptr - 1))
+ val = call_debugger (list2 (Qexit, val));
+ specpdl_ptr--;
return val;
}
numargs += nargs - 2;
/* Optimize for no indirection. */
- if (SYMBOLP (fun) && !EQ (fun, Qunbound)
+ if (SYMBOLP (fun) && !NILP (fun)
&& (fun = XSYMBOL (fun)->function, SYMBOLP (fun)))
fun = indirect_function (fun);
- if (EQ (fun, Qunbound))
+ if (NILP (fun))
{
/* Let funcall get the error. */
fun = args[0];
ptrdiff_t numargs = nargs - 1;
Lisp_Object lisp_numargs;
Lisp_Object val;
- struct backtrace backtrace;
register Lisp_Object *internal_args;
ptrdiff_t i;
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 ();
/* Optimize for no indirection. */
fun = original_fun;
- if (SYMBOLP (fun) && !EQ (fun, Qunbound)
+ if (SYMBOLP (fun) && !NILP (fun)
&& (fun = XSYMBOL (fun)->function, SYMBOLP (fun)))
fun = indirect_function (fun);
val = funcall_lambda (fun, numargs, args + 1);
else
{
- if (EQ (fun, Qunbound))
+ if (NILP (fun))
xsignal1 (Qvoid_function, original_fun);
if (!CONSP (fun))
xsignal1 (Qinvalid_function, original_fun);
}
check_cons_list ();
lisp_eval_depth--;
- if (backtrace.debug_on_exit)
- val = call_debugger (Fcons (Qexit, Fcons (val, Qnil)));
- backtrace_list = backtrace.next;
+ if (backtrace_debug_on_exit (specpdl_ptr - 1))
+ val = call_debugger (list2 (Qexit, val));
+ specpdl_ptr--;
return val;
}
\f
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 (list2 (Qexit, tem));
+ }
SAFE_FREE ();
return tem;
}
return object;
}
\f
-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;
+ union 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)
+{
+ union specbinding *p;
+
+ for (p = specpdl_ptr; p > specpdl; )
+ if ((--p)->kind >= SPECPDL_LET && EQ (specpdl_symbol (p), symbol))
+ return 1;
+
+ return 0;
}
/* `specpdl_ptr->symbol' is a field which describes which variable is
CHECK_SYMBOL (symbol);
sym = XSYMBOL (symbol);
- if (specpdl_ptr == specpdl + specpdl_size)
- grow_specpdl ();
start:
switch (sym->redirect)
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;
+ specpdl_ptr->let.kind = SPECPDL_LET;
+ specpdl_ptr->let.symbol = symbol;
+ specpdl_ptr->let.old_value = SYMBOL_VAL (sym);
+ grow_specpdl ();
if (!sym->constant)
SET_SYMBOL_VAL (sym, value);
else
case SYMBOL_FORWARDED:
{
Lisp_Object ovalue = find_symbol_value (symbol);
- specpdl_ptr->func = 0;
- set_specpdl_old_value (ovalue);
+ specpdl_ptr->let.kind = SPECPDL_LET_LOCAL;
+ specpdl_ptr->let.symbol = symbol;
+ specpdl_ptr->let.old_value = ovalue;
+ specpdl_ptr->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->let.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;
+ specpdl_ptr->let.kind = SPECPDL_LET_DEFAULT;
+ grow_specpdl ();
Fset_default (symbol, value);
return;
}
}
else
- set_specpdl_symbol (symbol);
+ specpdl_ptr->let.kind = SPECPDL_LET;
- specpdl_ptr++;
+ grow_specpdl ();
set_internal (symbol, value, Qnil, 1);
break;
}
void
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);
- specpdl_ptr++;
+ specpdl_ptr->unwind.kind = SPECPDL_UNWIND;
+ specpdl_ptr->unwind.func = function;
+ specpdl_ptr->unwind.arg = arg;
+ grow_specpdl ();
}
Lisp_Object
while (specpdl_ptr != specpdl + count)
{
- /* Copy the binding, and decrement specpdl_ptr, before we do
- the work to unbind it. We decrement first
- so that an error in unbinding won't try to unbind
- the same entry again, and we copy the binding first
- in case more bindings are made during some of the code we run. */
-
- struct specbinding this_binding;
- this_binding = *--specpdl_ptr;
-
- 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))
+ /* Decrement specpdl_ptr before we do the work to unbind it, so
+ that an error in unbinding won't try to unbind the same entry
+ again. Take care to copy any parts of the binding needed
+ before invoking any code that can make more bindings. */
+
+ specpdl_ptr--;
+
+ switch (specpdl_ptr->kind)
{
- 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);
+ case SPECPDL_UNWIND:
+ specpdl_func (specpdl_ptr) (specpdl_arg (specpdl_ptr));
+ 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));
+ 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 (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)))
+ set_internal (symbol, old_value, where, 1);
+ }
+ break;
}
- /* 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);
}
if (NILP (Vquit_flag) && !NILP (quitf))
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;
+ union 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;
}
Output stream used is value of `standard-output'. */)
(void)
{
- register struct backtrace *backlist = backtrace_list;
- Lisp_Object tail;
+ union 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;
}
If NFRAMES is more than the number of frames, the value is nil. */)
(Lisp_Object nframes)
{
- register struct backtrace *backlist = backtrace_list;
+ union 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));
}
}
\f
-#if BYTE_MARK_STACK
void
-mark_backtrace (void)
+mark_specpdl (void)
{
- register struct backtrace *backlist;
- ptrdiff_t i;
-
- for (backlist = backtrace_list; backlist; backlist = backlist->next)
+ union specbinding *pdl;
+ for (pdl = specpdl; pdl != specpdl_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));
+ /* Fall through. */
+ case SPECPDL_LET:
+ mark_object (specpdl_symbol (pdl));
+ mark_object (specpdl_old_value (pdl));
+ break;
+ }
+ }
+}
+
+void
+get_backtrace (Lisp_Object array)
+{
+ union 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)
+{
+ union specbinding *pdl = backtrace_top ();
+ return (backtrace_p (pdl) ? backtrace_function (pdl) : Qnil);
+}
void
syms_of_eval (void)
defsubr (&Sunwind_protect);
defsubr (&Scondition_case);
defsubr (&Ssignal);
- defsubr (&Sinteractive_p);
- defsubr (&Scalled_interactively_p);
defsubr (&Scommandp);
defsubr (&Sautoload);
defsubr (&Sautoload_do_load);
HCoop / bpt / emacs.git / blobdiff