/* 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.
#include "commands.h"
#include "keyboard.h"
#include "dispextern.h"
-#include "frame.h" /* For XFRAME. */
-
-#if HAVE_X_WINDOWS
-#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
/* 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
/* FIXME: We should probably get rid of this! */
Lisp_Object Vsignaling_function;
-/* If non-nil, Lisp code must not be run since some part of Emacs is
- in an inconsistent state. Currently, x-create-frame uses this to
- avoid triggering window-configuration-change-hook while the new
- frame is half-initialized. */
+/* If non-nil, Lisp code must not be run since some part of Emacs is in
+ an inconsistent state. Currently unused. */
Lisp_Object inhibit_lisp_code;
/* These would ordinarily be static, but they need to be visible to GDB. */
union specbinding *backtrace_top (void) EXTERNALLY_VISIBLE;
static Lisp_Object funcall_lambda (Lisp_Object, ptrdiff_t, Lisp_Object *);
-static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args);
+static Lisp_Object apply_lambda (Lisp_Object, Lisp_Object, ptrdiff_t);
static Lisp_Object
specpdl_symbol (union specbinding *pdl)
/* Functions to modify slots of backtrace records. */
static void
-set_backtrace_args (union specbinding *pdl, Lisp_Object *args)
+set_backtrace_args (union specbinding *pdl, Lisp_Object *args, ptrdiff_t nargs)
{
eassert (pdl->kind == SPECPDL_BACKTRACE);
pdl->bt.args = args;
-}
-
-static void
-set_backtrace_nargs (union specbinding *pdl, ptrdiff_t n)
-{
- eassert (pdl->kind == SPECPDL_BACKTRACE);
- pdl->bt.nargs = n;
+ pdl->bt.nargs = nargs;
}
static void
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;
max_lisp_eval_depth = XINT (XCDR (data));
}
+static void grow_specpdl (void);
+
/* Call the Lisp debugger, giving it argument ARG. */
Lisp_Object
bool debug_while_redisplaying;
ptrdiff_t count = SPECPDL_INDEX ();
Lisp_Object val;
- EMACS_INT old_max = max_specpdl_size;
-
- /* Temporarily bump up the stack limits,
- so the debugger won't run out of stack. */
-
- max_specpdl_size += 1;
- record_unwind_protect (restore_stack_limits,
- Fcons (make_number (old_max),
- make_number (max_lisp_eval_depth)));
- max_specpdl_size = old_max;
+ EMACS_INT old_depth = max_lisp_eval_depth;
+ /* Do not allow max_specpdl_size less than actual depth (Bug#16603). */
+ EMACS_INT old_max = max (max_specpdl_size, count);
if (lisp_eval_depth + 40 > max_lisp_eval_depth)
max_lisp_eval_depth = lisp_eval_depth + 40;
- if (max_specpdl_size - 100 < SPECPDL_INDEX ())
- max_specpdl_size = SPECPDL_INDEX () + 100;
+ /* While debugging Bug#16603, previous value of 100 was found
+ too small to avoid specpdl overflow in the debugger itself. */
+ if (max_specpdl_size - 200 < count)
+ max_specpdl_size = count + 200;
+
+ if (old_max == count)
+ {
+ /* We can enter the debugger due to specpdl overflow (Bug#16603). */
+ specpdl_ptr--;
+ grow_specpdl ();
+ }
+
+ /* Restore limits after leaving the debugger. */
+ record_unwind_protect (restore_stack_limits,
+ Fcons (make_number (old_max),
+ make_number (old_depth)));
#ifdef HAVE_WINDOW_SYSTEM
if (display_hourglass_p)
}
static void
-do_debug_on_call (Lisp_Object code)
+do_debug_on_call (Lisp_Object code, ptrdiff_t count)
{
debug_on_next_call = 0;
- set_backtrace_debug_on_exit (specpdl_ptr - 1, true);
+ set_backtrace_debug_on_exit (specpdl + count, true);
call_debugger (list1 (code));
}
\f
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)
{
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. */
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
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;
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
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);
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))
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;
- }
- c.next = catchlist;
- catchlist = &c;
-
- h.var = var;
- h.handler = handlers;
- h.next = handlerlist;
- h.tag = &c;
- handlerlist = &h;
+ { /* 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. SAFE_ALLOCA won't work
+ here due to the setjmp, so impose a MAX_ALLOCA limit. */
+ if (MAX_ALLOCA / word_size < clausenb)
+ memory_full (SIZE_MAX);
+ Lisp_Object *clauses = alloca (clausenb * sizeof *clauses);
+ Lisp_Object *volatile clauses_volatile = clauses;
+ int i = clausenb;
+ for (val = handlers; CONSP (val); val = XCDR (val))
+ clauses[--i] = XCAR (val);
+ 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;
+ }
+ }
+ }
val = eval_sub (bodyform);
- catchlist = c.next;
- handlerlist = h.next;
+ handlerlist = oldhandlerlist;
return val;
}
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;
}
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;
}
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;
}
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;
}
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;
}
|| NILP (clause)
/* A `debug' symbol in the handler list disables the normal
suppression of the debugger. */
- || (CONSP (clause) && CONSP (XCAR (clause))
- && !NILP (Fmemq (Qdebug, XCAR (clause))))
+ || (CONSP (clause) && CONSP (clause)
+ && !NILP (Fmemq (Qdebug, 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);
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);
}
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;
\f
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 ();
}
}
-void
+ptrdiff_t
record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs)
{
+ ptrdiff_t count = SPECPDL_INDEX ();
+
eassert (nargs >= UNEVALLED);
specpdl_ptr->bt.kind = SPECPDL_BACKTRACE;
specpdl_ptr->bt.debug_on_exit = false;
specpdl_ptr->bt.args = args;
specpdl_ptr->bt.nargs = nargs;
grow_specpdl ();
+
+ return count;
}
/* Eval a sub-expression of the current expression (i.e. in the same
Lisp_Object fun, val, original_fun, original_args;
Lisp_Object funcar;
struct gcpro gcpro1, gcpro2, gcpro3;
+ ptrdiff_t count;
if (SYMBOLP (form))
{
original_args = XCDR (form);
/* This also protects them from gc. */
- record_in_backtrace (original_fun, &original_args, UNEVALLED);
+ count = record_in_backtrace (original_fun, &original_args, UNEVALLED);
if (debug_on_next_call)
- do_debug_on_call (Qt);
+ do_debug_on_call (Qt, count);
/* At this point, only original_fun and original_args
have values that will be used below. */
/* 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))
gcpro3.nvars = argnum;
}
- set_backtrace_args (specpdl_ptr - 1, vals);
- set_backtrace_nargs (specpdl_ptr - 1, XINT (numargs));
+ set_backtrace_args (specpdl + count, vals, XINT (numargs));
val = (XSUBR (fun)->function.aMANY) (XINT (numargs), vals);
UNGCPRO;
UNGCPRO;
- set_backtrace_args (specpdl_ptr - 1, argvals);
- set_backtrace_nargs (specpdl_ptr - 1, XINT (numargs));
+ set_backtrace_args (specpdl + count, argvals, XINT (numargs));
switch (i)
{
}
}
else if (COMPILEDP (fun))
- val = apply_lambda (fun, original_args);
+ val = apply_lambda (fun, original_args, count);
else
{
if (NILP (fun))
}
if (EQ (funcar, Qmacro))
{
- ptrdiff_t count = SPECPDL_INDEX ();
+ ptrdiff_t count1 = SPECPDL_INDEX ();
Lisp_Object exp;
/* Bind lexical-binding during expansion of the macro, so the
macro can know reliably if the code it outputs will be
specbind (Qlexical_binding,
NILP (Vinternal_interpreter_environment) ? Qnil : Qt);
exp = apply1 (Fcdr (fun), original_args);
- unbind_to (count, Qnil);
+ unbind_to (count1, Qnil);
val = eval_sub (exp);
}
else if (EQ (funcar, Qlambda)
|| EQ (funcar, Qclosure))
- val = apply_lambda (fun, original_args);
+ val = apply_lambda (fun, original_args, count);
else
xsignal1 (Qinvalid_function, original_fun);
}
check_cons_list ();
lisp_eval_depth--;
- if (backtrace_debug_on_exit (specpdl_ptr - 1))
+ if (backtrace_debug_on_exit (specpdl + count))
val = call_debugger (list2 (Qexit, val));
specpdl_ptr--;
usage: (apply FUNCTION &rest ARGUMENTS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
- ptrdiff_t i;
- EMACS_INT numargs;
+ ptrdiff_t i, numargs, funcall_nargs;
register Lisp_Object spread_arg;
register Lisp_Object *funcall_args;
Lisp_Object fun, retval;
- struct gcpro gcpro1;
USE_SAFE_ALLOCA;
fun = args [0];
/* Avoid making funcall cons up a yet another new vector of arguments
by explicitly supplying nil's for optional values. */
SAFE_ALLOCA_LISP (funcall_args, 1 + XSUBR (fun)->max_args);
- for (i = numargs; i < XSUBR (fun)->max_args;)
+ for (i = numargs; i < XSUBR (fun)->max_args; /* nothing */)
funcall_args[++i] = Qnil;
- GCPRO1 (*funcall_args);
- gcpro1.nvars = 1 + XSUBR (fun)->max_args;
+ funcall_nargs = 1 + XSUBR (fun)->max_args;
}
}
funcall:
if (!funcall_args)
{
SAFE_ALLOCA_LISP (funcall_args, 1 + numargs);
- GCPRO1 (*funcall_args);
- gcpro1.nvars = 1 + numargs;
+ funcall_nargs = 1 + numargs;
}
memcpy (funcall_args, args, nargs * word_size);
spread_arg = XCDR (spread_arg);
}
- /* By convention, the caller needs to gcpro Ffuncall's args. */
- retval = Ffuncall (gcpro1.nvars, funcall_args);
- UNGCPRO;
- SAFE_FREE ();
+ /* Ffuncall gcpro's all of its args. */
+ retval = Ffuncall (funcall_nargs, funcall_args);
+ SAFE_FREE ();
return retval;
}
\f
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);
void
run_hook_with_args_2 (Lisp_Object hook, Lisp_Object arg1, Lisp_Object arg2)
{
- Lisp_Object temp[3];
- temp[0] = hook;
- temp[1] = arg1;
- temp[2] = arg2;
-
- Frun_hook_with_args (3, temp);
+ Frun_hook_with_args (3, ((Lisp_Object []) { hook, arg1, arg2 }));
}
-\f
+
/* Apply fn to arg. */
Lisp_Object
apply1 (Lisp_Object fn, Lisp_Object arg)
{
- struct gcpro gcpro1;
-
- GCPRO1 (fn);
- if (NILP (arg))
- RETURN_UNGCPRO (Ffuncall (1, &fn));
- gcpro1.nvars = 2;
- {
- Lisp_Object args[2];
- args[0] = fn;
- args[1] = arg;
- gcpro1.var = args;
- RETURN_UNGCPRO (Fapply (2, args));
- }
+ return (NILP (arg) ? Ffuncall (1, &fn)
+ : Fapply (2, ((Lisp_Object []) { fn, arg })));
}
/* Call function fn on no arguments. */
Lisp_Object
call0 (Lisp_Object fn)
{
- struct gcpro gcpro1;
-
- GCPRO1 (fn);
- RETURN_UNGCPRO (Ffuncall (1, &fn));
+ return Ffuncall (1, &fn);
}
/* Call function fn with 1 argument arg1. */
Lisp_Object
call1 (Lisp_Object fn, Lisp_Object arg1)
{
- struct gcpro gcpro1;
- Lisp_Object args[2];
-
- args[0] = fn;
- args[1] = arg1;
- GCPRO1 (args[0]);
- gcpro1.nvars = 2;
- RETURN_UNGCPRO (Ffuncall (2, args));
+ return Ffuncall (2, ((Lisp_Object []) { fn, arg1 }));
}
/* Call function fn with 2 arguments arg1, arg2. */
Lisp_Object
call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2)
{
- struct gcpro gcpro1;
- Lisp_Object args[3];
- args[0] = fn;
- args[1] = arg1;
- args[2] = arg2;
- GCPRO1 (args[0]);
- gcpro1.nvars = 3;
- RETURN_UNGCPRO (Ffuncall (3, args));
+ return Ffuncall (3, ((Lisp_Object []) { fn, arg1, arg2 }));
}
/* Call function fn with 3 arguments arg1, arg2, arg3. */
Lisp_Object
call3 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3)
{
- struct gcpro gcpro1;
- Lisp_Object args[4];
- args[0] = fn;
- args[1] = arg1;
- args[2] = arg2;
- args[3] = arg3;
- GCPRO1 (args[0]);
- gcpro1.nvars = 4;
- RETURN_UNGCPRO (Ffuncall (4, args));
+ return Ffuncall (4, ((Lisp_Object []) { fn, arg1, arg2, arg3 }));
}
/* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
call4 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
Lisp_Object arg4)
{
- struct gcpro gcpro1;
- Lisp_Object args[5];
- args[0] = fn;
- args[1] = arg1;
- args[2] = arg2;
- args[3] = arg3;
- args[4] = arg4;
- GCPRO1 (args[0]);
- gcpro1.nvars = 5;
- RETURN_UNGCPRO (Ffuncall (5, args));
+ return Ffuncall (5, ((Lisp_Object []) { fn, arg1, arg2, arg3, arg4 }));
}
/* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
call5 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
Lisp_Object arg4, Lisp_Object arg5)
{
- struct gcpro gcpro1;
- Lisp_Object args[6];
- args[0] = fn;
- args[1] = arg1;
- args[2] = arg2;
- args[3] = arg3;
- args[4] = arg4;
- args[5] = arg5;
- GCPRO1 (args[0]);
- gcpro1.nvars = 6;
- RETURN_UNGCPRO (Ffuncall (6, args));
+ return Ffuncall (6, ((Lisp_Object []) { fn, arg1, arg2, arg3, arg4, arg5 }));
}
/* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
call6 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6)
{
- struct gcpro gcpro1;
- Lisp_Object args[7];
- args[0] = fn;
- args[1] = arg1;
- args[2] = arg2;
- args[3] = arg3;
- args[4] = arg4;
- args[5] = arg5;
- args[6] = arg6;
- GCPRO1 (args[0]);
- gcpro1.nvars = 7;
- RETURN_UNGCPRO (Ffuncall (7, args));
+ return Ffuncall (7, ((Lisp_Object [])
+ { fn, arg1, arg2, arg3, arg4, arg5, arg6 }));
}
/* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6, Lisp_Object arg7)
{
- struct gcpro gcpro1;
- Lisp_Object args[8];
- args[0] = fn;
- args[1] = arg1;
- args[2] = arg2;
- args[3] = arg3;
- args[4] = arg4;
- args[5] = arg5;
- args[6] = arg6;
- args[7] = arg7;
- GCPRO1 (args[0]);
- gcpro1.nvars = 8;
- RETURN_UNGCPRO (Ffuncall (8, args));
+ return Ffuncall (8, ((Lisp_Object [])
+ { fn, arg1, arg2, arg3, arg4, arg5, arg6, arg7 }));
}
/* The caller should GCPRO all the elements of ARGS. */
Lisp_Object lisp_numargs;
Lisp_Object val;
register Lisp_Object *internal_args;
- ptrdiff_t i;
+ ptrdiff_t i, count;
QUIT;
}
/* This also GCPROs them. */
- record_in_backtrace (args[0], &args[1], nargs - 1);
+ count = record_in_backtrace (args[0], &args[1], nargs - 1);
/* Call GC after setting up the backtrace, so the latter GCPROs the args. */
maybe_gc ();
if (debug_on_next_call)
- do_debug_on_call (Qlambda);
+ do_debug_on_call (Qlambda, count);
check_cons_list ();
val = (XSUBR (fun)->function.aMANY) (numargs, args + 1);
else
{
+ Lisp_Object internal_argbuf[8];
if (XSUBR (fun)->max_args > numargs)
{
- internal_args = alloca (XSUBR (fun)->max_args
- * sizeof *internal_args);
+ eassert (XSUBR (fun)->max_args <= ARRAYELTS (internal_argbuf));
+ internal_args = internal_argbuf;
memcpy (internal_args, args + 1, numargs * word_size);
for (i = numargs; i < XSUBR (fun)->max_args; i++)
internal_args[i] = Qnil;
}
check_cons_list ();
lisp_eval_depth--;
- if (backtrace_debug_on_exit (specpdl_ptr - 1))
+ if (backtrace_debug_on_exit (specpdl + count))
val = call_debugger (list2 (Qexit, val));
specpdl_ptr--;
return val;
}
\f
static Lisp_Object
-apply_lambda (Lisp_Object fun, Lisp_Object args)
+apply_lambda (Lisp_Object fun, Lisp_Object args, ptrdiff_t count)
{
Lisp_Object args_left;
ptrdiff_t i;
UNGCPRO;
- set_backtrace_args (specpdl_ptr - 1, arg_vector);
- set_backtrace_nargs (specpdl_ptr - 1, i);
+ set_backtrace_args (specpdl + count, arg_vector, i);
tem = funcall_lambda (fun, numargs, arg_vector);
/* Do the debug-on-exit now, while arg_vector still exists. */
- if (backtrace_debug_on_exit (specpdl_ptr - 1))
+ if (backtrace_debug_on_exit (specpdl + count))
{
/* Don't do it again when we return to eval. */
- set_backtrace_debug_on_exit (specpdl_ptr - 1, false);
+ set_backtrace_debug_on_exit (specpdl + count, false);
tem = call_debugger (list2 (Qexit, tem));
}
SAFE_FREE ();
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)
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)
{
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;
+}
+
\f
void
mark_specpdl (void)
an error is signaled.
You can safely use a value considerably larger than the default value,
if that proves inconveniently small. However, if you increase it too far,
-Emacs could run out of memory trying to make the stack bigger. */);
+Emacs could run out of memory trying to make the stack bigger.
+Note that this limit may be silently increased by the debugger
+if `debug-on-error' or `debug-on-quit' is set. */);
DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth,
doc: /* Limit on depth in `eval', `apply' and `funcall' before error.
defsubr (&Sbacktrace);
defsubr (&Sbacktrace_frame);
defsubr (&Sbacktrace_eval);
+ defsubr (&Sbacktrace__locals);
defsubr (&Sspecial_variable_p);
defsubr (&Sfunctionp);
}