/* Evaluator for GNU Emacs Lisp interpreter.
- Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1999, 2000, 2001,
- 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
- Free Software Foundation, Inc.
+ Copyright (C) 1985-1987, 1993-1995, 1999-2011 Free Software Foundation, Inc.
This file is part of GNU Emacs.
#include "xterm.h"
#endif
-/* This definition is duplicated in alloc.c and keyboard.c */
-/* Putting it in lisp.h makes cc bomb out! */
+/* This definition is duplicated in alloc.c and keyboard.c. */
+/* Putting it in lisp.h makes cc bomb out! */
struct backtrace
{
struct backtrace *next;
Lisp_Object *function;
Lisp_Object *args; /* Points to vector of args. */
- int nargs; /* Length of vector.
- If nargs is UNEVALLED, args points to slot holding
- list of unevalled args */
+ size_t nargs; /* Length of vector.
+ If nargs is (size_t) UNEVALLED, args points
+ to slot holding list of unevalled args. */
char evalargs;
- /* Nonzero means call value of debugger when done with this operation. */
+ /* Nonzero means call value of debugger when done with this operation. */
char debug_on_exit;
};
#endif
Lisp_Object Qautoload, Qmacro, Qexit, Qinteractive, Qcommandp, Qdefun;
-Lisp_Object Qinhibit_quit, Vinhibit_quit, Vquit_flag;
+Lisp_Object Qinhibit_quit;
Lisp_Object Qand_rest, Qand_optional;
Lisp_Object Qdebug_on_error;
Lisp_Object Qdeclare;
Lisp_Object Qdebug;
-extern Lisp_Object Qinteractive_form;
/* This holds either the symbol `run-hooks' or nil.
It is nil at an early stage of startup, and when Emacs
/* Current number of specbindings allocated in specpdl. */
-int specpdl_size;
+EMACS_INT specpdl_size;
/* Pointer to beginning of specpdl. */
struct specbinding *specpdl_ptr;
-/* Maximum size allowed for specpdl allocation */
-
-EMACS_INT max_specpdl_size;
-
/* Depth in Lisp evaluations and function calls. */
-int lisp_eval_depth;
-
-/* Maximum allowed depth in Lisp evaluations and function calls. */
-
-EMACS_INT max_lisp_eval_depth;
-
-/* Nonzero means enter debugger before next function call */
-
-int debug_on_next_call;
-
-/* Non-zero means debugger may continue. This is zero when the
- debugger is called during redisplay, where it might not be safe to
- continue the interrupted redisplay. */
-
-int debugger_may_continue;
-
-/* List of conditions (non-nil atom means all) which cause a backtrace
- if an error is handled by the command loop's error handler. */
-
-Lisp_Object Vstack_trace_on_error;
-
-/* List of conditions (non-nil atom means all) which enter the debugger
- if an error is handled by the command loop's error handler. */
-
-Lisp_Object Vdebug_on_error;
-
-/* List of conditions and regexps specifying error messages which
- do not enter the debugger even if Vdebug_on_error says they should. */
-
-Lisp_Object Vdebug_ignored_errors;
-
-/* Non-nil means call the debugger even if the error will be handled. */
-
-Lisp_Object Vdebug_on_signal;
-
-/* Hook for edebug to use. */
-
-Lisp_Object Vsignal_hook_function;
-
-/* Nonzero means enter debugger if a quit signal
- is handled by the command loop's error handler. */
-
-int debug_on_quit;
+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
int when_entered_debugger;
-Lisp_Object Vdebugger;
-
/* The function from which the last `signal' was called. Set in
Fsignal. */
int handling_signal;
-/* Function to process declarations in defmacro forms. */
-
-Lisp_Object Vmacro_declaration_function;
-
-extern Lisp_Object Qrisky_local_variable;
-
-extern Lisp_Object Qfunction;
-
-static Lisp_Object funcall_lambda (Lisp_Object, int, Lisp_Object*);
+static Lisp_Object funcall_lambda (Lisp_Object, size_t, Lisp_Object*);
static void unwind_to_catch (struct catchtag *, Lisp_Object) NO_RETURN;
-
-#if __GNUC__
-/* "gcc -O3" enables automatic function inlining, which optimizes out
- the arguments for the invocations of these functions, whereas they
- expect these values on the stack. */
-Lisp_Object apply1 (Lisp_Object fn, Lisp_Object arg) __attribute__((noinline));
-Lisp_Object call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2) __attribute__((noinline));
-#endif
+static int interactive_p (int);
+static Lisp_Object apply_lambda (Lisp_Object, Lisp_Object, int);
\f
void
init_eval_once (void)
specpdl_ptr = specpdl;
/* Don't forget to update docs (lispref node "Local Variables"). */
max_specpdl_size = 1000;
- max_lisp_eval_depth = 500;
+ max_lisp_eval_depth = 600;
Vrun_hooks = Qnil;
}
when_entered_debugger = -1;
}
-/* unwind-protect function used by call_debugger. */
+/* Unwind-protect function used by call_debugger. */
static Lisp_Object
restore_stack_limits (Lisp_Object data)
/* Call the Lisp debugger, giving it argument ARG. */
-Lisp_Object
+static Lisp_Object
call_debugger (Lisp_Object arg)
{
int debug_while_redisplaying;
int count = SPECPDL_INDEX ();
Lisp_Object val;
- int old_max = max_specpdl_size;
+ EMACS_INT old_max = max_specpdl_size;
/* Temporarily bump up the stack limits,
so the debugger won't run out of stack. */
return unbind_to (count, val);
}
-void
+static void
do_debug_on_call (Lisp_Object code)
{
debug_on_next_call = 0;
do
{
if (!(argnum++))
- val = Feval (Fcar (args_left));
+ val = Feval (Fcar (args_left));
else
Feval (Fcar (args_left));
args_left = Fcdr (args_left);
do
{
if (!(argnum++))
- val = Feval (Fcar (args_left));
+ val = Feval (Fcar (args_left));
else
Feval (Fcar (args_left));
args_left = Fcdr (args_left);
EXCLUDE_SUBRS_P non-zero means always return 0 if the function
called is a built-in. */
-int
+static int
interactive_p (int exclude_subrs_p)
{
struct backtrace *btp;
looking at several frames for special forms. Skip past them. */
while (btp
&& (EQ (*btp->function, Qbytecode)
- || btp->nargs == UNEVALLED))
+ || btp->nargs == (size_t) UNEVALLED))
btp = btp->next;
- /* btp now points at the frame of the innermost function that isn't
+ /* `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 nil. */
if (exclude_subrs_p && SUBRP (fun))
return 0;
- /* btp points to the frame of a Lisp function that called interactive-p.
+ /* `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;
tail = XCDR (tail);
}
- while (CONSP (Fcar (tail))
- && EQ (Fcar (Fcar (tail)), Qdeclare))
+ if (CONSP (Fcar (tail))
+ && EQ (Fcar (Fcar (tail)), Qdeclare))
{
if (!NILP (Vmacro_declaration_function))
{
if (SYMBOL_CONSTANT_P (sym))
{
/* For upward compatibility, allow (defvar :foo (quote :foo)). */
- Lisp_Object tem = Fcar (tail);
- if (! (CONSP (tem)
- && EQ (XCAR (tem), Qquote)
- && CONSP (XCDR (tem))
- && EQ (XCAR (XCDR (tem)), sym)))
+ Lisp_Object tem1 = Fcar (tail);
+ if (! (CONSP (tem1)
+ && EQ (XCAR (tem1), Qquote)
+ && CONSP (XCDR (tem1))
+ && EQ (XCAR (XCDR (tem1)), sym)))
error ("Constant symbol `%s' specified in defvar",
SDATA (SYMBOL_NAME (sym)));
}
LOADHIST_ATTACH (sym);
}
else
- /* Simple (defvar <var>) should not count as a definition at all.
- It could get in the way of other definitions, and unloading this
- package could try to make the variable unbound. */
- ;
+ {
+ /* Simple (defvar <var>) should not count as a definition at all.
+ It could get in the way of other definitions, and unloading this
+ package could try to make the variable unbound. */
+ }
return sym;
}
static Lisp_Object
lisp_indirect_variable (Lisp_Object sym)
{
- XSETSYMBOL (sym, indirect_variable (XSYMBOL (sym)));
+ struct Lisp_Symbol *s = indirect_variable (XSYMBOL (sym));
+ XSETSYMBOL (sym, s);
return sym;
}
/* If indirect and there's an alias loop, don't check anything else. */
if (XSYMBOL (variable)->redirect == SYMBOL_VARALIAS
&& NILP (internal_condition_case_1 (lisp_indirect_variable, variable,
- Qt, user_variable_p_eh)))
+ Qt, user_variable_p_eh)))
return Qnil;
while (1)
{
documentation = Fget (variable, Qvariable_documentation);
if (INTEGERP (documentation) && XINT (documentation) < 0)
- return Qt;
+ return Qt;
if (STRINGP (documentation)
- && ((unsigned char) SREF (documentation, 0) == '*'))
- return Qt;
+ && ((unsigned char) SREF (documentation, 0) == '*'))
+ return Qt;
/* If it is (STRING . INTEGER), a negative integer means a user variable. */
if (CONSP (documentation)
- && STRINGP (XCAR (documentation))
- && INTEGERP (XCDR (documentation))
- && XINT (XCDR (documentation)) < 0)
- return Qt;
+ && STRINGP (XCAR (documentation))
+ && INTEGERP (XCDR (documentation))
+ && XINT (XCDR (documentation)) < 0)
+ return Qt;
/* Customizable? See `custom-variable-p'. */
if ((!NILP (Fget (variable, intern ("standard-value"))))
- || (!NILP (Fget (variable, intern ("custom-autoload")))))
- return Qt;
+ || (!NILP (Fget (variable, intern ("custom-autoload")))))
+ return Qt;
if (!(XSYMBOL (variable)->redirect == SYMBOL_VARALIAS))
- return Qnil;
+ return Qnil;
/* An indirect variable? Let's follow the chain. */
XSETSYMBOL (variable, SYMBOL_ALIAS (XSYMBOL (variable)));
Lisp_Object *temps, tem;
register Lisp_Object elt, varlist;
int count = SPECPDL_INDEX ();
- register int argnum;
+ register size_t argnum;
struct gcpro gcpro1, gcpro2;
+ USE_SAFE_ALLOCA;
varlist = Fcar (args);
- /* Make space to hold the values to give the bound variables */
+ /* Make space to hold the values to give the bound variables. */
elt = Flength (varlist);
- temps = (Lisp_Object *) alloca (XFASTINT (elt) * sizeof (Lisp_Object));
+ SAFE_ALLOCA_LISP (temps, XFASTINT (elt));
- /* Compute the values and store them in `temps' */
+ /* Compute the values and store them in `temps'. */
GCPRO2 (args, *temps);
gcpro2.nvars = 0;
}
elt = Fprogn (Fcdr (args));
+ SAFE_FREE ();
return unbind_to (count, elt);
}
/* SYM is not mentioned in ENVIRONMENT.
Look at its function definition. */
if (EQ (def, Qunbound) || !CONSP (def))
- /* Not defined or definition not suitable */
+ /* Not defined or definition not suitable. */
break;
if (EQ (XCAR (def), Qautoload))
{
last_time = catchlist == catch;
/* Unwind the specpdl stack, and then restore the proper set of
- handlers. */
+ handlers. */
unbind_to (catchlist->pdlcount, Qnil);
handlerlist = catchlist->handlerlist;
catchlist = catchlist->next;
/* If x_catch_errors was done, turn it off now.
(First we give unbind_to a chance to do that.) */
#if 0 /* This would disable x_catch_errors after x_connection_closed.
- * The catch must remain in effect during that delicate
- * state. --lorentey */
+ The catch must remain in effect during that delicate
+ state. --lorentey */
x_fully_uncatch_errors ();
#endif
#endif
byte_stack_list = catch->byte_stack;
gcprolist = catch->gcpro;
#ifdef DEBUG_GCPRO
- if (gcprolist != 0)
- gcpro_level = gcprolist->level + 1;
- else
- gcpro_level = 0;
+ gcpro_level = gcprolist ? gcprolist->level + 1 : gcpro_level = 0;
#endif
backtrace_list = catch->backlist;
lisp_eval_depth = catch->lisp_eval_depth;
When a handler handles an error, control returns to the `condition-case'
and it executes the handler's BODY...
with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
-(If VAR is nil, the handler can't access that information.)
+\(If VAR is nil, the handler can't access that information.)
Then the value of the last BODY form is returned from the `condition-case'
expression.
See also the function `signal' for more info.
usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
-(Lisp_Object args)
+ (Lisp_Object args)
{
register Lisp_Object bodyform, handlers;
volatile Lisp_Object var;
if (_setjmp (c.jmp))
{
if (!NILP (h.var))
- specbind (h.var, c.val);
+ specbind (h.var, c.val);
val = Fprogn (Fcdr (h.chosen_clause));
/* Note that this just undoes the binding of h.var; whoever
and ARGS as second argument. */
Lisp_Object
-internal_condition_case_n (Lisp_Object (*bfun) (int, Lisp_Object*),
- int nargs,
+internal_condition_case_n (Lisp_Object (*bfun) (size_t, Lisp_Object *),
+ size_t nargs,
Lisp_Object *args,
Lisp_Object handlers,
Lisp_Object (*hfun) (Lisp_Object))
\f
static Lisp_Object find_handler_clause (Lisp_Object, Lisp_Object,
- Lisp_Object, Lisp_Object);
+ Lisp_Object, Lisp_Object);
+static int maybe_call_debugger (Lisp_Object conditions, Lisp_Object sig,
+ Lisp_Object data);
DEFUN ("signal", Fsignal, Ssignal, 2, 2, 0,
doc: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
/* When memory is full, ERROR-SYMBOL is nil,
and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
That is a special case--don't do this in other situations. */
- register struct handler *allhandlers = handlerlist;
Lisp_Object conditions;
- extern int gc_in_progress;
- extern int waiting_for_input;
Lisp_Object string;
- Lisp_Object real_error_symbol;
+ Lisp_Object real_error_symbol
+ = (NILP (error_symbol) ? Fcar (data) : error_symbol);
+ register Lisp_Object clause = Qnil;
+ struct handler *h;
struct backtrace *bp;
immediate_quit = handling_signal = 0;
if (gc_in_progress || waiting_for_input)
abort ();
- if (NILP (error_symbol))
- real_error_symbol = Fcar (data);
- else
- real_error_symbol = error_symbol;
-
#if 0 /* rms: I don't know why this was here,
but it is surely wrong for an error that is handled. */
#ifdef HAVE_WINDOW_SYSTEM
Vsignaling_function = *bp->function;
}
- for (; handlerlist; handlerlist = handlerlist->next)
+ for (h = handlerlist; h; h = h->next)
{
- register Lisp_Object clause;
-
- clause = find_handler_clause (handlerlist->handler, conditions,
+ clause = find_handler_clause (h->handler, conditions,
error_symbol, data);
-
- if (EQ (clause, Qlambda))
- {
- /* We can't return values to code which signaled an error, but we
- can continue code which has signaled a quit. */
- if (EQ (real_error_symbol, Qquit))
- return Qnil;
- else
- error ("Cannot return from the debugger in an error");
- }
-
if (!NILP (clause))
- {
- Lisp_Object unwind_data;
- struct handler *h = handlerlist;
-
- handlerlist = allhandlers;
+ break;
+ }
- if (NILP (error_symbol))
- unwind_data = data;
- else
- unwind_data = Fcons (error_symbol, data);
- h->chosen_clause = clause;
- unwind_to_catch (h->tag, unwind_data);
- }
+ if (/* Don't run the debugger for a memory-full error.
+ (There is no room in memory to do that!) */
+ !NILP (error_symbol)
+ && (!NILP (Vdebug_on_signal)
+ /* If no handler is present now, try to run the debugger. */
+ || NILP (clause)
+ /* Special handler that means "print a message and run debugger
+ if requested". */
+ || EQ (h->handler, Qerror)))
+ {
+ int debugger_called
+ = maybe_call_debugger (conditions, error_symbol, data);
+ /* We can't return values to code which signaled an error, but we
+ can continue code which has signaled a quit. */
+ if (debugger_called && EQ (real_error_symbol, Qquit))
+ return Qnil;
}
- handlerlist = allhandlers;
- /* If no handler is present now, try to run the debugger,
- and if that fails, throw to top level. */
- find_handler_clause (Qerror, conditions, error_symbol, data);
- if (catchlist != 0)
- Fthrow (Qtop_level, Qt);
+ if (!NILP (clause))
+ {
+ Lisp_Object unwind_data
+ = (NILP (error_symbol) ? data : Fcons (error_symbol, data));
+
+ h->chosen_clause = clause;
+ unwind_to_catch (h->tag, unwind_data);
+ }
+ else
+ {
+ if (catchlist != 0)
+ Fthrow (Qtop_level, Qt);
+ }
if (! NILP (error_symbol))
data = Fcons (error_symbol, data);
If ARG is not a genuine list, make it a one-element list. */
void
-signal_error (char *s, Lisp_Object arg)
+signal_error (const char *s, Lisp_Object arg)
{
Lisp_Object tortoise, hare;
? debug_on_quit
: wants_debugger (Vdebug_on_error, conditions))
&& ! skip_debugger (conditions, combined_data)
- /* rms: what's this for? */
+ /* RMS: What's this for? */
&& when_entered_debugger < num_nonmacro_input_events)
{
call_debugger (Fcons (Qerror, Fcons (combined_data, Qnil)));
Lisp_Object sig, Lisp_Object data)
{
register Lisp_Object h;
- register Lisp_Object tem;
- int debugger_called = 0;
- int debugger_considered = 0;
/* t is used by handlers for all conditions, set up by C code. */
if (EQ (handlers, Qt))
return Qt;
- /* Don't run the debugger for a memory-full error.
- (There is no room in memory to do that!) */
- if (NILP (sig))
- debugger_considered = 1;
-
/* error is used similarly, but means print an error message
and run the debugger if that is enabled. */
- if (EQ (handlers, Qerror)
- || !NILP (Vdebug_on_signal)) /* This says call debugger even if
- there is a handler. */
- {
- if (!NILP (sig) && wants_debugger (Vstack_trace_on_error, conditions))
- {
- max_lisp_eval_depth += 15;
- max_specpdl_size++;
- if (noninteractive)
- Fbacktrace ();
- else
- internal_with_output_to_temp_buffer
- ("*Backtrace*",
- (Lisp_Object (*) (Lisp_Object)) Fbacktrace,
- Qnil);
- max_specpdl_size--;
- max_lisp_eval_depth -= 15;
- }
-
- if (!debugger_considered)
- {
- debugger_considered = 1;
- debugger_called = maybe_call_debugger (conditions, sig, data);
- }
-
- /* If there is no handler, return saying whether we ran the debugger. */
- if (EQ (handlers, Qerror))
- {
- if (debugger_called)
- return Qlambda;
- return Qt;
- }
- }
+ if (EQ (handlers, Qerror))
+ return Qt;
- for (h = handlers; CONSP (h); h = Fcdr (h))
+ for (h = handlers; CONSP (h); h = XCDR (h))
{
- Lisp_Object handler, condit;
+ Lisp_Object handler = XCAR (h);
+ Lisp_Object condit, tem;
- handler = Fcar (h);
if (!CONSP (handler))
continue;
- condit = Fcar (handler);
+ condit = XCAR (handler);
/* Handle a single condition name in handler HANDLER. */
if (SYMBOLP (condit))
{
Lisp_Object tail;
for (tail = condit; CONSP (tail); tail = XCDR (tail))
{
- tem = Fmemq (Fcar (tail), conditions);
+ tem = Fmemq (XCAR (tail), conditions);
if (!NILP (tem))
- {
- /* This handler is going to apply.
- Does it allow the debugger to run first? */
- if (! debugger_considered && !NILP (Fmemq (Qdebug, condit)))
- maybe_call_debugger (conditions, sig, data);
- return handler;
- }
+ return handler;
}
}
}
return Qnil;
}
-/* dump an error message; called like printf */
-/* VARARGS 1 */
+/* Dump an error message; called like vprintf. */
void
-error (m, a1, a2, a3)
- char *m;
- char *a1, *a2, *a3;
+verror (const char *m, va_list ap)
{
char buf[200];
- int size = 200;
+ EMACS_INT size = 200;
int mlen;
char *buffer = buf;
- char *args[3];
int allocated = 0;
Lisp_Object string;
- args[0] = a1;
- args[1] = a2;
- args[2] = a3;
-
mlen = strlen (m);
while (1)
{
- int used = doprnt (buffer, size, m, m + mlen, 3, args);
+ EMACS_INT used;
+ used = doprnt (buffer, size, m, m + mlen, ap);
if (used < size)
break;
size *= 2;
xsignal1 (Qerror, string);
}
+
+
+/* Dump an error message; called like printf. */
+
+/* VARARGS 1 */
+void
+error (const char *m, ...)
+{
+ va_list ap;
+ va_start (ap, m);
+ verror (m, ap);
+ va_end (ap);
+}
\f
DEFUN ("commandp", Fcommandp, Scommandp, 1, 2, 0,
doc: /* Non-nil if FUNCTION makes provisions for interactive calling.
CHECK_SYMBOL (function);
CHECK_STRING (file);
- /* If function is defined and not as an autoload, don't override */
+ /* If function is defined and not as an autoload, don't override. */
if (!EQ (XSYMBOL (function)->function, Qunbound)
&& !(CONSP (XSYMBOL (function)->function)
&& EQ (XCAR (XSYMBOL (function)->function), Qautoload)))
backtrace.next = backtrace_list;
backtrace_list = &backtrace;
- backtrace.function = &original_fun; /* This also protects them from gc */
+ backtrace.function = &original_fun; /* This also protects them from gc. */
backtrace.args = &original_args;
backtrace.nargs = UNEVALLED;
backtrace.evalargs = 1;
do_debug_on_call (Qt);
/* At this point, only original_fun and original_args
- have values that will be used below */
+ have values that will be used below. */
retry:
/* Optimize for no indirection. */
CHECK_CONS_LIST ();
- if (XINT (numargs) < XSUBR (fun)->min_args ||
- (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < XINT (numargs)))
+ if (XINT (numargs) < XSUBR (fun)->min_args
+ || (0 <= XSUBR (fun)->max_args
+ && XSUBR (fun)->max_args < XINT (numargs)))
xsignal2 (Qwrong_number_of_arguments, original_fun, numargs);
- if (XSUBR (fun)->max_args == UNEVALLED)
+ else if (XSUBR (fun)->max_args == UNEVALLED)
{
backtrace.evalargs = 0;
- val = (XSUBR (fun)->function.a1) (args_left);
- goto done;
+ val = (XSUBR (fun)->function.aUNEVALLED) (args_left);
}
-
- if (XSUBR (fun)->max_args == MANY)
+ else if (XSUBR (fun)->max_args == MANY)
{
- /* Pass a vector of evaluated arguments */
+ /* Pass a vector of evaluated arguments. */
Lisp_Object *vals;
- register int argnum = 0;
+ register size_t argnum = 0;
+ USE_SAFE_ALLOCA;
- vals = (Lisp_Object *) alloca (XINT (numargs) * sizeof (Lisp_Object));
+ SAFE_ALLOCA_LISP (vals, XINT (numargs));
GCPRO3 (args_left, fun, fun);
gcpro3.var = vals;
backtrace.args = vals;
backtrace.nargs = XINT (numargs);
- val = (XSUBR (fun)->function.am) (XINT (numargs), vals);
+ val = (XSUBR (fun)->function.aMANY) (XINT (numargs), vals);
UNGCPRO;
- goto done;
+ SAFE_FREE ();
}
-
- GCPRO3 (args_left, fun, fun);
- gcpro3.var = argvals;
- gcpro3.nvars = 0;
-
- maxargs = XSUBR (fun)->max_args;
- for (i = 0; i < maxargs; args_left = Fcdr (args_left))
+ else
{
- argvals[i] = Feval (Fcar (args_left));
- gcpro3.nvars = ++i;
- }
+ GCPRO3 (args_left, fun, fun);
+ gcpro3.var = argvals;
+ gcpro3.nvars = 0;
- UNGCPRO;
+ maxargs = XSUBR (fun)->max_args;
+ for (i = 0; i < maxargs; args_left = Fcdr (args_left))
+ {
+ argvals[i] = Feval (Fcar (args_left));
+ gcpro3.nvars = ++i;
+ }
- backtrace.args = argvals;
- backtrace.nargs = XINT (numargs);
+ UNGCPRO;
- switch (i)
- {
- case 0:
- val = (XSUBR (fun)->function.a0) ();
- goto done;
- case 1:
- val = (XSUBR (fun)->function.a1) (argvals[0]);
- goto done;
- case 2:
- val = (XSUBR (fun)->function.a2) (argvals[0], argvals[1]);
- goto done;
- case 3:
- val = (XSUBR (fun)->function.a3) (argvals[0], argvals[1],
- argvals[2]);
- goto done;
- case 4:
- val = (XSUBR (fun)->function.a4) (argvals[0], argvals[1],
- argvals[2], argvals[3]);
- goto done;
- case 5:
- val = (XSUBR (fun)->function.a5) (argvals[0], argvals[1], argvals[2],
- argvals[3], argvals[4]);
- goto done;
- case 6:
- val = (XSUBR (fun)->function.a6) (argvals[0], argvals[1], argvals[2],
- argvals[3], argvals[4], argvals[5]);
- goto done;
- case 7:
- val = (XSUBR (fun)->function.a7) (argvals[0], argvals[1], argvals[2],
- argvals[3], argvals[4], argvals[5],
- argvals[6]);
- goto done;
-
- case 8:
- val = (XSUBR (fun)->function.a8) (argvals[0], argvals[1], argvals[2],
- argvals[3], argvals[4], argvals[5],
- argvals[6], argvals[7]);
- goto done;
-
- default:
- /* Someone has created a subr that takes more arguments than
- is supported by this code. We need to either rewrite the
- subr to use a different argument protocol, or add more
- cases to this switch. */
- abort ();
+ backtrace.args = argvals;
+ backtrace.nargs = XINT (numargs);
+
+ switch (i)
+ {
+ case 0:
+ val = (XSUBR (fun)->function.a0 ());
+ break;
+ case 1:
+ val = (XSUBR (fun)->function.a1 (argvals[0]));
+ break;
+ case 2:
+ val = (XSUBR (fun)->function.a2 (argvals[0], argvals[1]));
+ break;
+ case 3:
+ val = (XSUBR (fun)->function.a3
+ (argvals[0], argvals[1], argvals[2]));
+ break;
+ case 4:
+ val = (XSUBR (fun)->function.a4
+ (argvals[0], argvals[1], argvals[2], argvals[3]));
+ break;
+ case 5:
+ val = (XSUBR (fun)->function.a5
+ (argvals[0], argvals[1], argvals[2], argvals[3],
+ argvals[4]));
+ break;
+ case 6:
+ val = (XSUBR (fun)->function.a6
+ (argvals[0], argvals[1], argvals[2], argvals[3],
+ argvals[4], argvals[5]));
+ break;
+ case 7:
+ val = (XSUBR (fun)->function.a7
+ (argvals[0], argvals[1], argvals[2], argvals[3],
+ argvals[4], argvals[5], argvals[6]));
+ break;
+
+ case 8:
+ val = (XSUBR (fun)->function.a8
+ (argvals[0], argvals[1], argvals[2], argvals[3],
+ argvals[4], argvals[5], argvals[6], argvals[7]));
+ break;
+
+ default:
+ /* Someone has created a subr that takes more arguments than
+ is supported by this code. We need to either rewrite the
+ subr to use a different argument protocol, or add more
+ cases to this switch. */
+ abort ();
+ }
}
}
- if (COMPILEDP (fun))
+ else if (COMPILEDP (fun))
val = apply_lambda (fun, original_args, 1);
else
{
else
xsignal1 (Qinvalid_function, original_fun);
}
- done:
CHECK_CONS_LIST ();
lisp_eval_depth--;
Then return the value FUNCTION returns.
Thus, (apply '+ 1 2 '(3 4)) returns 10.
usage: (apply FUNCTION &rest ARGUMENTS) */)
- (int nargs, Lisp_Object *args)
+ (size_t nargs, Lisp_Object *args)
{
- register int i, numargs;
+ register size_t i, numargs;
register Lisp_Object spread_arg;
register Lisp_Object *funcall_args;
- Lisp_Object fun;
+ Lisp_Object fun, retval;
struct gcpro gcpro1;
+ USE_SAFE_ALLOCA;
fun = args [0];
funcall_args = 0;
fun = indirect_function (fun);
if (EQ (fun, Qunbound))
{
- /* Let funcall get the error */
+ /* Let funcall get the error. */
fun = args[0];
goto funcall;
}
{
if (numargs < XSUBR (fun)->min_args
|| (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs))
- goto funcall; /* Let funcall get the error */
- else if (XSUBR (fun)->max_args > numargs)
+ goto funcall; /* Let funcall get the error. */
+ else if (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args > numargs)
{
/* Avoid making funcall cons up a yet another new vector of arguments
- by explicitly supplying nil's for optional values */
- funcall_args = (Lisp_Object *) alloca ((1 + XSUBR (fun)->max_args)
- * sizeof (Lisp_Object));
+ by explicitly supplying nil's for optional values. */
+ SAFE_ALLOCA_LISP (funcall_args, 1 + XSUBR (fun)->max_args);
for (i = numargs; i < XSUBR (fun)->max_args;)
funcall_args[++i] = Qnil;
GCPRO1 (*funcall_args);
function itself as well as its arguments. */
if (!funcall_args)
{
- funcall_args = (Lisp_Object *) alloca ((1 + numargs)
- * sizeof (Lisp_Object));
+ SAFE_ALLOCA_LISP (funcall_args, 1 + numargs);
GCPRO1 (*funcall_args);
gcpro1.nvars = 1 + numargs;
}
}
/* By convention, the caller needs to gcpro Ffuncall's args. */
- RETURN_UNGCPRO (Ffuncall (gcpro1.nvars, funcall_args));
+ retval = Ffuncall (gcpro1.nvars, funcall_args);
+ UNGCPRO;
+ SAFE_FREE ();
+
+ return retval;
}
\f
/* Run hook variables in various ways. */
-enum run_hooks_condition {to_completion, until_success, until_failure};
-static Lisp_Object run_hook_with_args (int, Lisp_Object *,
- enum run_hooks_condition);
+static Lisp_Object
+funcall_nil (size_t nargs, Lisp_Object *args)
+{
+ Ffuncall (nargs, args);
+ return Qnil;
+}
DEFUN ("run-hooks", Frun_hooks, Srun_hooks, 0, MANY, 0,
doc: /* Run each hook in HOOKS.
Do not use `make-local-variable' to make a hook variable buffer-local.
Instead, use `add-hook' and specify t for the LOCAL argument.
usage: (run-hooks &rest HOOKS) */)
- (int nargs, Lisp_Object *args)
+ (size_t nargs, Lisp_Object *args)
{
Lisp_Object hook[1];
- register int i;
+ register size_t i;
for (i = 0; i < nargs; i++)
{
hook[0] = args[i];
- run_hook_with_args (1, hook, to_completion);
+ run_hook_with_args (1, hook, funcall_nil);
}
return Qnil;
Do not use `make-local-variable' to make a hook variable buffer-local.
Instead, use `add-hook' and specify t for the LOCAL argument.
usage: (run-hook-with-args HOOK &rest ARGS) */)
- (int nargs, Lisp_Object *args)
+ (size_t nargs, Lisp_Object *args)
{
- return run_hook_with_args (nargs, args, to_completion);
+ return run_hook_with_args (nargs, args, funcall_nil);
}
DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success,
Do not use `make-local-variable' to make a hook variable buffer-local.
Instead, use `add-hook' and specify t for the LOCAL argument.
usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
- (int nargs, Lisp_Object *args)
+ (size_t nargs, Lisp_Object *args)
+{
+ return run_hook_with_args (nargs, args, Ffuncall);
+}
+
+static Lisp_Object
+funcall_not (size_t nargs, Lisp_Object *args)
{
- return run_hook_with_args (nargs, args, until_success);
+ return NILP (Ffuncall (nargs, args)) ? Qt : Qnil;
}
DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure,
Do not use `make-local-variable' to make a hook variable buffer-local.
Instead, use `add-hook' and specify t for the LOCAL argument.
usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
- (int nargs, Lisp_Object *args)
+ (size_t nargs, Lisp_Object *args)
+{
+ return NILP (run_hook_with_args (nargs, args, funcall_not)) ? Qt : Qnil;
+}
+
+static Lisp_Object
+run_hook_wrapped_funcall (size_t nargs, Lisp_Object *args)
{
- return run_hook_with_args (nargs, args, until_failure);
+ Lisp_Object tmp = args[0], ret;
+ args[0] = args[1];
+ args[1] = tmp;
+ ret = Ffuncall (nargs, args);
+ args[1] = args[0];
+ args[0] = tmp;
+ return ret;
+}
+
+DEFUN ("run-hook-wrapped", Frun_hook_wrapped, Srun_hook_wrapped, 2, MANY, 0,
+ doc: /* Run HOOK, passing each function through WRAP-FUNCTION.
+I.e. instead of calling each function FUN directly with arguments ARGS,
+it calls WRAP-FUNCTION with arguments FUN and ARGS.
+As soon as a call to WRAP-FUNCTION returns non-nil, `run-hook-wrapped'
+aborts and returns that value.
+usage: (run-hook-wrapped HOOK WRAP-FUNCTION &rest ARGS) */)
+ (size_t nargs, Lisp_Object *args)
+{
+ return run_hook_with_args (nargs, args, run_hook_wrapped_funcall);
}
/* ARGS[0] should be a hook symbol.
Call each of the functions in the hook value, passing each of them
as arguments all the rest of ARGS (all NARGS - 1 elements).
- COND specifies a condition to test after each call
- to decide whether to stop.
+ FUNCALL specifies how to call each function on the hook.
The caller (or its caller, etc) must gcpro all of ARGS,
except that it isn't necessary to gcpro ARGS[0]. */
-static Lisp_Object
-run_hook_with_args (int nargs, Lisp_Object *args, enum run_hooks_condition cond)
+Lisp_Object
+run_hook_with_args (size_t nargs, Lisp_Object *args,
+ Lisp_Object (*funcall) (size_t nargs, Lisp_Object *args))
{
- Lisp_Object sym, val, ret;
+ Lisp_Object sym, val, ret = Qnil;
struct gcpro gcpro1, gcpro2, gcpro3;
/* If we are dying or still initializing,
sym = args[0];
val = find_symbol_value (sym);
- ret = (cond == until_failure ? Qt : Qnil);
if (EQ (val, Qunbound) || NILP (val))
return ret;
else if (!CONSP (val) || EQ (XCAR (val), Qlambda))
{
args[0] = val;
- return Ffuncall (nargs, args);
+ return funcall (nargs, args);
}
else
{
- Lisp_Object globals = Qnil;
- GCPRO3 (sym, val, globals);
+ Lisp_Object global_vals = Qnil;
+ GCPRO3 (sym, val, global_vals);
for (;
- CONSP (val) && ((cond == to_completion)
- || (cond == until_success ? NILP (ret)
- : !NILP (ret)));
+ CONSP (val) && NILP (ret);
val = XCDR (val))
{
if (EQ (XCAR (val), Qt))
{
/* t indicates this hook has a local binding;
it means to run the global binding too. */
- globals = Fdefault_value (sym);
- if (NILP (globals)) continue;
+ global_vals = Fdefault_value (sym);
+ if (NILP (global_vals)) continue;
- if (!CONSP (globals) || EQ (XCAR (globals), Qlambda))
+ if (!CONSP (global_vals) || EQ (XCAR (global_vals), Qlambda))
{
- args[0] = globals;
- ret = Ffuncall (nargs, args);
+ args[0] = global_vals;
+ ret = funcall (nargs, args);
}
else
{
for (;
- CONSP (globals) && ((cond == to_completion)
- || (cond == until_success ? NILP (ret)
- : !NILP (ret)));
- globals = XCDR (globals))
+ CONSP (global_vals) && NILP (ret);
+ global_vals = XCDR (global_vals))
{
- args[0] = XCAR (globals);
+ args[0] = XCAR (global_vals);
/* In a global value, t should not occur. If it does, we
must ignore it to avoid an endless loop. */
if (!EQ (args[0], Qt))
- ret = Ffuncall (nargs, args);
+ ret = funcall (nargs, args);
}
}
}
else
{
args[0] = XCAR (val);
- ret = Ffuncall (nargs, args);
+ ret = funcall (nargs, args);
}
}
}
}
-/* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
- present value of that symbol.
- Call each element of FUNLIST,
- passing each of them the rest of ARGS.
- The caller (or its caller, etc) must gcpro all of ARGS,
- except that it isn't necessary to gcpro ARGS[0]. */
-
-Lisp_Object
-run_hook_list_with_args (Lisp_Object funlist, int nargs, Lisp_Object *args)
-{
- Lisp_Object sym;
- Lisp_Object val;
- Lisp_Object globals;
- struct gcpro gcpro1, gcpro2, gcpro3;
-
- sym = args[0];
- globals = Qnil;
- GCPRO3 (sym, val, globals);
-
- for (val = funlist; CONSP (val); val = XCDR (val))
- {
- if (EQ (XCAR (val), Qt))
- {
- /* t indicates this hook has a local binding;
- it means to run the global binding too. */
-
- for (globals = Fdefault_value (sym);
- CONSP (globals);
- globals = XCDR (globals))
- {
- args[0] = XCAR (globals);
- /* In a global value, t should not occur. If it does, we
- must ignore it to avoid an endless loop. */
- if (!EQ (args[0], Qt))
- Ffuncall (nargs, args);
- }
- }
- else
- {
- args[0] = XCAR (val);
- Ffuncall (nargs, args);
- }
- }
- UNGCPRO;
- return Qnil;
-}
-
/* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
void
Frun_hook_with_args (3, temp);
}
\f
-/* Apply fn to arg */
+/* Apply fn to arg. */
Lisp_Object
apply1 (Lisp_Object fn, Lisp_Object arg)
{
}
}
-/* Call function fn on no arguments */
+/* Call function fn on no arguments. */
Lisp_Object
call0 (Lisp_Object fn)
{
RETURN_UNGCPRO (Ffuncall (1, &fn));
}
-/* Call function fn with 1 argument arg1 */
+/* Call function fn with 1 argument arg1. */
/* ARGSUSED */
Lisp_Object
call1 (Lisp_Object fn, Lisp_Object arg1)
RETURN_UNGCPRO (Ffuncall (2, args));
}
-/* Call function fn with 2 arguments arg1, arg2 */
+/* Call function fn with 2 arguments arg1, arg2. */
/* ARGSUSED */
Lisp_Object
call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2)
RETURN_UNGCPRO (Ffuncall (3, args));
}
-/* Call function fn with 3 arguments arg1, arg2, arg3 */
+/* Call function fn with 3 arguments arg1, arg2, arg3. */
/* ARGSUSED */
Lisp_Object
call3 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3)
RETURN_UNGCPRO (Ffuncall (4, args));
}
-/* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
+/* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
/* ARGSUSED */
Lisp_Object
call4 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
RETURN_UNGCPRO (Ffuncall (5, args));
}
-/* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
+/* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
/* ARGSUSED */
Lisp_Object
call5 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
RETURN_UNGCPRO (Ffuncall (6, args));
}
-/* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
+/* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
/* ARGSUSED */
Lisp_Object
call6 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
RETURN_UNGCPRO (Ffuncall (7, args));
}
-/* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7 */
+/* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
/* ARGSUSED */
Lisp_Object
call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
Return the value that function returns.
Thus, (funcall 'cons 'x 'y) returns (x . y).
usage: (funcall FUNCTION &rest ARGUMENTS) */)
- (int nargs, Lisp_Object *args)
+ (size_t nargs, Lisp_Object *args)
{
Lisp_Object fun, original_fun;
Lisp_Object funcar;
- int numargs = nargs - 1;
+ size_t numargs = nargs - 1;
Lisp_Object lisp_numargs;
Lisp_Object val;
struct backtrace backtrace;
register Lisp_Object *internal_args;
- register int i;
+ register size_t i;
QUIT;
if ((consing_since_gc > gc_cons_threshold
if (SUBRP (fun))
{
- if (numargs < XSUBR (fun)->min_args
+ if (numargs < XSUBR (fun)->min_args
|| (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs))
{
XSETFASTINT (lisp_numargs, numargs);
xsignal2 (Qwrong_number_of_arguments, original_fun, lisp_numargs);
}
- if (XSUBR (fun)->max_args == UNEVALLED)
+ else if (XSUBR (fun)->max_args == UNEVALLED)
xsignal1 (Qinvalid_function, original_fun);
- if (XSUBR (fun)->max_args == MANY)
- {
- val = (XSUBR (fun)->function.am) (numargs, args + 1);
- goto done;
- }
-
- if (XSUBR (fun)->max_args > numargs)
- {
- internal_args = (Lisp_Object *) alloca (XSUBR (fun)->max_args * sizeof (Lisp_Object));
- memcpy (internal_args, args + 1, numargs * sizeof (Lisp_Object));
- for (i = numargs; i < XSUBR (fun)->max_args; i++)
- internal_args[i] = Qnil;
- }
+ else if (XSUBR (fun)->max_args == MANY)
+ val = (XSUBR (fun)->function.aMANY) (numargs, args + 1);
else
- internal_args = args + 1;
- switch (XSUBR (fun)->max_args)
{
- case 0:
- val = (XSUBR (fun)->function.a0) ();
- goto done;
- case 1:
- val = (XSUBR (fun)->function.a1) (internal_args[0]);
- goto done;
- case 2:
- val = (XSUBR (fun)->function.a2) (internal_args[0], internal_args[1]);
- goto done;
- case 3:
- val = (XSUBR (fun)->function.a3) (internal_args[0], internal_args[1],
- internal_args[2]);
- goto done;
- case 4:
- val = (XSUBR (fun)->function.a4) (internal_args[0], internal_args[1],
- internal_args[2], internal_args[3]);
- goto done;
- case 5:
- val = (XSUBR (fun)->function.a5) (internal_args[0], internal_args[1],
- internal_args[2], internal_args[3],
- internal_args[4]);
- goto done;
- case 6:
- val = (XSUBR (fun)->function.a6) (internal_args[0], internal_args[1],
- internal_args[2], internal_args[3],
- internal_args[4], internal_args[5]);
- goto done;
- case 7:
- val = (XSUBR (fun)->function.a7) (internal_args[0], internal_args[1],
- internal_args[2], internal_args[3],
- internal_args[4], internal_args[5],
- internal_args[6]);
- goto done;
-
- case 8:
- val = (XSUBR (fun)->function.a8) (internal_args[0], internal_args[1],
- internal_args[2], internal_args[3],
- internal_args[4], internal_args[5],
- internal_args[6], internal_args[7]);
- goto done;
-
- default:
-
- /* If a subr takes more than 8 arguments without using MANY
- or UNEVALLED, we need to extend this function to support it.
- Until this is done, there is no way to call the function. */
- abort ();
+ if (XSUBR (fun)->max_args > numargs)
+ {
+ internal_args = (Lisp_Object *) alloca (XSUBR (fun)->max_args * sizeof (Lisp_Object));
+ memcpy (internal_args, args + 1, numargs * sizeof (Lisp_Object));
+ for (i = numargs; i < XSUBR (fun)->max_args; i++)
+ internal_args[i] = Qnil;
+ }
+ else
+ internal_args = args + 1;
+ switch (XSUBR (fun)->max_args)
+ {
+ case 0:
+ val = (XSUBR (fun)->function.a0 ());
+ break;
+ case 1:
+ val = (XSUBR (fun)->function.a1 (internal_args[0]));
+ break;
+ case 2:
+ val = (XSUBR (fun)->function.a2
+ (internal_args[0], internal_args[1]));
+ break;
+ case 3:
+ val = (XSUBR (fun)->function.a3
+ (internal_args[0], internal_args[1], internal_args[2]));
+ break;
+ case 4:
+ val = (XSUBR (fun)->function.a4
+ (internal_args[0], internal_args[1], internal_args[2],
+ internal_args[3]));
+ break;
+ case 5:
+ val = (XSUBR (fun)->function.a5
+ (internal_args[0], internal_args[1], internal_args[2],
+ internal_args[3], internal_args[4]));
+ break;
+ case 6:
+ val = (XSUBR (fun)->function.a6
+ (internal_args[0], internal_args[1], internal_args[2],
+ internal_args[3], internal_args[4], internal_args[5]));
+ break;
+ case 7:
+ val = (XSUBR (fun)->function.a7
+ (internal_args[0], internal_args[1], internal_args[2],
+ internal_args[3], internal_args[4], internal_args[5],
+ internal_args[6]));
+ break;
+
+ case 8:
+ val = (XSUBR (fun)->function.a8
+ (internal_args[0], internal_args[1], internal_args[2],
+ internal_args[3], internal_args[4], internal_args[5],
+ internal_args[6], internal_args[7]));
+ break;
+
+ default:
+
+ /* If a subr takes more than 8 arguments without using MANY
+ or UNEVALLED, we need to extend this function to support it.
+ Until this is done, there is no way to call the function. */
+ abort ();
+ }
}
}
- if (COMPILEDP (fun))
+ else if (COMPILEDP (fun))
val = funcall_lambda (fun, numargs, args + 1);
else
{
else
xsignal1 (Qinvalid_function, original_fun);
}
- done:
CHECK_CONS_LIST ();
lisp_eval_depth--;
if (backtrace.debug_on_exit)
return val;
}
\f
-Lisp_Object
+static Lisp_Object
apply_lambda (Lisp_Object fun, Lisp_Object args, int eval_flag)
{
Lisp_Object args_left;
- Lisp_Object numargs;
+ size_t numargs;
register Lisp_Object *arg_vector;
struct gcpro gcpro1, gcpro2, gcpro3;
- register int i;
+ register size_t i;
register Lisp_Object tem;
+ USE_SAFE_ALLOCA;
- numargs = Flength (args);
- arg_vector = (Lisp_Object *) alloca (XINT (numargs) * sizeof (Lisp_Object));
+ numargs = XINT (Flength (args));
+ SAFE_ALLOCA_LISP (arg_vector, numargs);
args_left = args;
GCPRO3 (*arg_vector, args_left, fun);
gcpro1.nvars = 0;
- for (i = 0; i < XINT (numargs);)
+ for (i = 0; i < numargs; )
{
tem = Fcar (args_left), args_left = Fcdr (args_left);
if (eval_flag) tem = Feval (tem);
backtrace_list->nargs = i;
}
backtrace_list->evalargs = 0;
- tem = funcall_lambda (fun, XINT (numargs), arg_vector);
+ 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;
+ SAFE_FREE ();
return tem;
}
FUN must be either a lambda-expression or a compiled-code object. */
static Lisp_Object
-funcall_lambda (Lisp_Object fun, int nargs, register Lisp_Object *arg_vector)
+funcall_lambda (Lisp_Object fun, size_t nargs,
+ register Lisp_Object *arg_vector)
{
Lisp_Object val, syms_left, next;
int count = SPECPDL_INDEX ();
- int i, optional, rest;
+ size_t i;
+ int optional, rest;
if (CONSP (fun))
{
return object;
}
\f
-void
+static void
grow_specpdl (void)
{
register int count = SPECPDL_INDEX ();
specpdl_ptr = specpdl + count;
}
-/* specpdl_ptr->symbol is a field which describes which variable is
+/* `specpdl_ptr->symbol' is a field which 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
case SYMBOL_VARALIAS:
sym = indirect_variable (sym); XSETSYMBOL (symbol, sym); goto start;
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. */
- specpdl_ptr->symbol = symbol;
- specpdl_ptr->old_value = SYMBOL_VAL (sym);
- specpdl_ptr->func = NULL;
- ++specpdl_ptr;
- if (!sym->constant)
- SET_SYMBOL_VAL (sym, value);
- else
- set_internal (symbol, value, Qnil, 1);
- break;
- }
+ /* The most common case is that of a non-constant symbol with a
+ trivial value. Make that as fast as we can. */
+ specpdl_ptr->symbol = symbol;
+ specpdl_ptr->old_value = SYMBOL_VAL (sym);
+ specpdl_ptr->func = NULL;
+ ++specpdl_ptr;
+ if (!sym->constant)
+ SET_SYMBOL_VAL (sym, value);
+ else
+ set_internal (symbol, value, Qnil, 1);
+ break;
case SYMBOL_LOCALIZED:
if (SYMBOL_BLV (sym)->frame_local)
error ("Frame-local vars cannot be let-bound");
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. */
+ was current when the variable was bound. */
else if (CONSP (this_binding.symbol))
{
Lisp_Object symbol, where;
(void)
{
register struct backtrace *backlist = backtrace_list;
- register int i;
Lisp_Object tail;
Lisp_Object tem;
- extern Lisp_Object Vprint_level;
struct gcpro gcpro1;
+ Lisp_Object old_print_level = Vprint_level;
- XSETFASTINT (Vprint_level, 3);
+ if (NILP (Vprint_level))
+ XSETFASTINT (Vprint_level, 8);
tail = Qnil;
GCPRO1 (tail);
while (backlist)
{
write_string (backlist->debug_on_exit ? "* " : " ", 2);
- if (backlist->nargs == UNEVALLED)
+ if (backlist->nargs == (size_t) UNEVALLED)
{
Fprin1 (Fcons (*backlist->function, *backlist->args), Qnil);
write_string ("\n", -1);
else
{
tem = *backlist->function;
- Fprin1 (tem, Qnil); /* This can QUIT */
+ Fprin1 (tem, Qnil); /* This can QUIT. */
write_string ("(", -1);
- if (backlist->nargs == MANY)
+ if (backlist->nargs == (size_t) MANY)
{
+ int i;
for (tail = *backlist->args, i = 0;
!NILP (tail);
- tail = Fcdr (tail), i++)
+ tail = Fcdr (tail), i = 1)
{
if (i) write_string (" ", -1);
Fprin1 (Fcar (tail), Qnil);
}
else
{
+ size_t i;
for (i = 0; i < backlist->nargs; i++)
{
if (i) write_string (" ", -1);
backlist = backlist->next;
}
- Vprint_level = Qnil;
+ Vprint_level = old_print_level;
UNGCPRO;
return Qnil;
}
(Lisp_Object nframes)
{
register struct backtrace *backlist = backtrace_list;
- register int i;
+ register EMACS_INT i;
Lisp_Object tem;
CHECK_NATNUM (nframes);
if (!backlist)
return Qnil;
- if (backlist->nargs == UNEVALLED)
+ if (backlist->nargs == (size_t) UNEVALLED)
return Fcons (Qnil, Fcons (*backlist->function, *backlist->args));
else
{
- if (backlist->nargs == MANY)
+ if (backlist->nargs == (size_t) MANY)
tem = *backlist->args;
else
tem = Flist (backlist->nargs, backlist->args);
mark_backtrace (void)
{
register struct backtrace *backlist;
- register int i;
+ register size_t i;
for (backlist = backtrace_list; backlist; backlist = backlist->next)
{
mark_object (*backlist->function);
- if (backlist->nargs == UNEVALLED || backlist->nargs == MANY)
- i = 0;
+ if (backlist->nargs == (size_t) UNEVALLED
+ || backlist->nargs == (size_t) MANY)
+ i = 1;
else
- i = backlist->nargs - 1;
- for (; i >= 0; i--)
+ i = backlist->nargs;
+ while (i--)
mark_object (backlist->args[i]);
}
}
void
syms_of_eval (void)
{
- DEFVAR_INT ("max-specpdl-size", &max_specpdl_size,
+ DEFVAR_INT ("max-specpdl-size", max_specpdl_size,
doc: /* *Limit on number of Lisp variable bindings and `unwind-protect's.
If Lisp code tries to increase the total number past this amount,
an error is signaled.
if that proves inconveniently small. However, if you increase it too far,
Emacs could run out of memory trying to make the stack bigger. */);
- DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth,
+ DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth,
doc: /* *Limit on depth in `eval', `apply' and `funcall' before error.
This limit serves to catch infinite recursions for you before they cause
if that proves inconveniently small. However, if you increase it too far,
Emacs could overflow the real C stack, and crash. */);
- DEFVAR_LISP ("quit-flag", &Vquit_flag,
+ DEFVAR_LISP ("quit-flag", Vquit_flag,
doc: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
If the value is t, that means do an ordinary quit.
If the value equals `throw-on-input', that means quit by throwing
but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
Vquit_flag = Qnil;
- DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit,
+ DEFVAR_LISP ("inhibit-quit", Vinhibit_quit,
doc: /* Non-nil inhibits C-g quitting from happening immediately.
Note that `quit-flag' will still be set by typing C-g,
so a quit will be signaled as soon as `inhibit-quit' is nil.
Qdebug = intern_c_string ("debug");
staticpro (&Qdebug);
- DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error,
- doc: /* *Non-nil means errors display a backtrace buffer.
-More precisely, this happens for any error that is handled
-by the editor command loop.
-If the value is a list, an error only means to display a backtrace
-if one of its condition symbols appears in the list. */);
- Vstack_trace_on_error = Qnil;
-
- DEFVAR_LISP ("debug-on-error", &Vdebug_on_error,
+ DEFVAR_LISP ("debug-on-error", Vdebug_on_error,
doc: /* *Non-nil means enter debugger if an error is signaled.
Does not apply to errors handled by `condition-case' or those
matched by `debug-ignored-errors'.
See also the variable `debug-on-quit'. */);
Vdebug_on_error = Qnil;
- DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors,
+ DEFVAR_LISP ("debug-ignored-errors", Vdebug_ignored_errors,
doc: /* *List of errors for which the debugger should not be called.
Each element may be a condition-name or a regexp that matches error messages.
If any element applies to a given error, that error skips the debugger
It does not apply to errors handled by `condition-case'. */);
Vdebug_ignored_errors = Qnil;
- DEFVAR_BOOL ("debug-on-quit", &debug_on_quit,
+ DEFVAR_BOOL ("debug-on-quit", debug_on_quit,
doc: /* *Non-nil means enter debugger if quit is signaled (C-g, for example).
Does not apply if quit is handled by a `condition-case'. */);
debug_on_quit = 0;
- DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call,
+ DEFVAR_BOOL ("debug-on-next-call", debug_on_next_call,
doc: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
- DEFVAR_BOOL ("debugger-may-continue", &debugger_may_continue,
+ DEFVAR_BOOL ("debugger-may-continue", debugger_may_continue,
doc: /* Non-nil means debugger may continue execution.
This is nil when the debugger is called under circumstances where it
might not be safe to continue. */);
debugger_may_continue = 1;
- DEFVAR_LISP ("debugger", &Vdebugger,
+ DEFVAR_LISP ("debugger", Vdebugger,
doc: /* Function to call to invoke debugger.
If due to frame exit, args are `exit' and the value being returned;
this function's value will be returned instead of that.
If due to `eval' entry, one arg, t. */);
Vdebugger = Qnil;
- DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function,
+ DEFVAR_LISP ("signal-hook-function", Vsignal_hook_function,
doc: /* If non-nil, this is a function for `signal' to call.
It receives the same arguments that `signal' was given.
The Edebug package uses this to regain control. */);
Vsignal_hook_function = Qnil;
- DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal,
+ DEFVAR_LISP ("debug-on-signal", Vdebug_on_signal,
doc: /* *Non-nil means call the debugger regardless of condition handlers.
Note that `debug-on-error', `debug-on-quit' and friends
still determine whether to handle the particular condition. */);
Vdebug_on_signal = Qnil;
- DEFVAR_LISP ("macro-declaration-function", &Vmacro_declaration_function,
+ DEFVAR_LISP ("macro-declaration-function", Vmacro_declaration_function,
doc: /* Function to process declarations in a macro definition.
The function will be called with two args MACRO and DECL.
MACRO is the name of the macro being defined.
defsubr (&Srun_hook_with_args);
defsubr (&Srun_hook_with_args_until_success);
defsubr (&Srun_hook_with_args_until_failure);
+ defsubr (&Srun_hook_wrapped);
defsubr (&Sfetch_bytecode);
defsubr (&Sbacktrace_debug);
defsubr (&Sbacktrace);
defsubr (&Sbacktrace_frame);
}
-
-/* arch-tag: 014a07aa-33ab-4a8f-a3d2-ee8a4a9ff7fb
- (do not change this comment) */