/* Evaluator for GNU Emacs Lisp interpreter.
- Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
+ Copyright (C) 1985, 1986, 1987, 1992 Free Software Foundation, Inc.
This file is part of GNU Emacs.
#ifndef standalone
#include "commands.h"
+#include "keyboard.h"
#else
#define INTERACTIVE 1
#endif
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 */
+ int nargs; /* Length of vector.
+ If nargs is UNEVALLED, args points to slot holding
+ list of unevalled args */
char evalargs;
/* Nonzero means call value of debugger when done with this operation. */
char debug_on_exit;
struct backtrace *backtrace_list;
+/* This structure helps implement the `catch' and `throw' control
+ structure. A struct catchtag contains all the information needed
+ to restore the state of the interpreter after a non-local jump.
+
+ Handlers for error conditions (represented by `struct handler'
+ structures) just point to a catch tag to do the cleanup required
+ for their jumps.
+
+ catchtag structures are chained together in the C calling stack;
+ the `next' member points to the next outer catchtag.
+
+ A call like (throw TAG VAL) searches for a catchtag whose `tag'
+ member is TAG, and then unbinds to it. The `val' member is used to
+ hold VAL while the stack is unwound; `val' is returned as the value
+ of the catch form.
+
+ All the other members are concerned with restoring the interpreter
+ state. */
struct catchtag
{
Lisp_Object tag;
struct catchtag *catchlist;
Lisp_Object Qautoload, Qmacro, Qexit, Qinteractive, Qcommandp, Qdefun;
-Lisp_Object Vquit_flag, Vinhibit_quit;
+Lisp_Object Qinhibit_quit, Vinhibit_quit, Vquit_flag;
Lisp_Object Qmocklisp_arguments, Vmocklisp_arguments, Qmocklisp;
Lisp_Object Qand_rest, Qand_optional;
Lisp_Object Qdebug_on_error;
/* Nonzero means enter debugger before next function call */
int debug_on_next_call;
-/* Nonzero means display a backtrace if an error
- is handled by the command loop's error handler. */
-int stack_trace_on_error;
+/* 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;
-/* Nonzero means enter debugger if an error
- is handled by the command loop's error handler. */
-int debug_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;
/* Nonzero means enter debugger if a quit signal
- is handled by the command loop's error handler. */
+ is handled by the command loop's error handler. */
int debug_on_quit;
-/* Nonzero means we are trying to enter the debugger.
- This is to prevent recursive attempts. */
-int entering_debugger;
+/* The value of num_nonmacro_input_chars as of the last time we
+ started to enter the debugger. If we decide to enter the debugger
+ again when this is still equal to num_nonmacro_input_chars, then we
+ know that the debugger itself has an error, and we should just
+ signal the error instead of entering an infinite loop of debugger
+ invocations. */
+int when_entered_debugger;
Lisp_Object Vdebugger;
Vquit_flag = Qnil;
debug_on_next_call = 0;
lisp_eval_depth = 0;
- entering_debugger = 0;
+ when_entered_debugger = 0;
}
Lisp_Object
if (specpdl_size + 40 > max_specpdl_size)
max_specpdl_size = specpdl_size + 40;
debug_on_next_call = 0;
- entering_debugger = 1;
+ when_entered_debugger = num_nonmacro_input_chars;
return apply1 (Vdebugger, arg);
}
Lisp_Object args_left;
struct gcpro gcpro1;
- if (NULL(args))
+ if (NILP(args))
return Qnil;
args_left = args;
do
{
val = Feval (Fcar (args_left));
- if (!NULL (val))
+ if (!NILP (val))
break;
args_left = Fcdr (args_left);
}
- while (!NULL(args_left));
+ while (!NILP(args_left));
UNGCPRO;
return val;
Lisp_Object args_left;
struct gcpro gcpro1;
- if (NULL(args))
+ if (NILP(args))
return Qt;
args_left = args;
do
{
val = Feval (Fcar (args_left));
- if (NULL (val))
+ if (NILP (val))
break;
args_left = Fcdr (args_left);
}
- while (!NULL(args_left));
+ while (!NILP(args_left));
UNGCPRO;
return val;
cond = Feval (Fcar (args));
UNGCPRO;
- if (!NULL (cond))
+ if (!NILP (cond))
return Feval (Fcar (Fcdr (args)));
return Fprogn (Fcdr (Fcdr (args)));
}
val = Qnil;
GCPRO1 (args);
- while (!NULL (args))
+ while (!NILP (args))
{
clause = Fcar (args);
val = Feval (Fcar (clause));
- if (!NULL (val))
+ if (!NILP (val))
{
if (!EQ (XCONS (clause)->cdr, Qnil))
val = Fprogn (XCONS (clause)->cdr);
if (!EQ (Vmocklisp_arguments, Qt))
{
val = make_number (0);
- while (!NULL (args) && (tem = Fcar (args), XTYPE (tem) == Lisp_Symbol))
+ while (!NILP (args) && (tem = Fcar (args), XTYPE (tem) == Lisp_Symbol))
{
QUIT;
specbind (tem, val), args = Fcdr (args);
}
}
- if (NULL(args))
+ if (NILP(args))
return Qnil;
args_left = args;
val = Feval (Fcar (args_left));
args_left = Fcdr (args_left);
}
- while (!NULL(args_left));
+ while (!NILP(args_left));
UNGCPRO;
return val;
struct gcpro gcpro1, gcpro2;
register int argnum = 0;
- if (NULL(args))
+ if (NILP(args))
return Qnil;
args_left = args;
Feval (Fcar (args_left));
args_left = Fcdr (args_left);
}
- while (!NULL(args_left));
+ while (!NILP(args_left));
UNGCPRO;
return val;
val = Qnil;
- if (NULL(args))
+ if (NILP(args))
return Qnil;
args_left = args;
Feval (Fcar (args_left));
args_left = Fcdr (args_left);
}
- while (!NULL(args_left));
+ while (!NILP(args_left));
UNGCPRO;
return val;
register Lisp_Object val, sym;
struct gcpro gcpro1;
- if (NULL(args))
+ if (NILP(args))
return Qnil;
args_left = args;
Fset (sym, val);
args_left = Fcdr (Fcdr (args_left));
}
- while (!NULL(args_left));
+ while (!NILP(args_left));
UNGCPRO;
return val;
if (!INTERACTIVE)
return Qnil;
- /* Unless the object was compiled, skip the frame of interactive-p itself
- (if interpreted) or the frame of byte-code (if called from
- compiled function). */
btp = backtrace_list;
- if (! XTYPE (*btp->function) == Lisp_Compiled)
+
+ /* If this isn't a byte-compiled function, there may be a frame at
+ the top for Finteractive_p itself. If so, skip it. */
+ fun = Findirect_function (*btp->function);
+ if (XTYPE (fun) == Lisp_Subr
+ && (struct Lisp_Subr *) XPNTR (fun) == &Sinteractive_p)
btp = btp->next;
- for (;
- btp && (btp->nargs == UNEVALLED
- || EQ (*btp->function, Qbytecode));
- btp = btp->next)
- {}
- /* btp now points at the frame of the innermost function
- that DOES eval its args.
- If it is a built-in function (such as load or eval-region)
- return nil. */
- fun = *btp->function;
- while (XTYPE (fun) == Lisp_Symbol)
- {
- QUIT;
- fun = Fsymbol_function (fun);
- }
+
+ /* If we're running an Emacs 18-style byte-compiled function, there
+ may be a frame for Fbytecode. Now, given the strictest
+ definition, this function isn't really being called
+ interactively, but because that's the way Emacs 18 always builds
+ byte-compiled functions, we'll accept it for now. */
+ if (EQ (*btp->function, Qbytecode))
+ btp = btp->next;
+
+ /* 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 &&
+ 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 nil. */
+ fun = Findirect_function (*btp->function);
if (XTYPE (fun) == Lisp_Subr)
return Qnil;
/* btp points to the frame of a Lisp function that called interactive-p.
fn_name = Fcar (args);
defn = Fcons (Qlambda, Fcdr (args));
- if (!NULL (Vpurify_flag))
+ if (!NILP (Vpurify_flag))
defn = Fpurecopy (defn);
Ffset (fn_name, defn);
return fn_name;
fn_name = Fcar (args);
defn = Fcons (Qmacro, Fcons (Qlambda, Fcdr (args)));
- if (!NULL (Vpurify_flag))
+ if (!NILP (Vpurify_flag))
defn = Fpurecopy (defn);
Ffset (fn_name, defn);
return fn_name;
but the definition can supply documentation and an initial value\n\
in a way that tags can recognize.\n\n\
INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.\n\
-If SYMBOL is buffer-local, its default value is initialized in this way.\n\
+If SYMBOL is buffer-local, its default value is what is set;\n\
+ buffer-local values are not affected.\n\
INITVALUE and DOCSTRING are optional.\n\
If DOCSTRING starts with *, this variable is identified as a user option.\n\
This means that M-x set-variable and M-x edit-options recognize it.\n\
sym = Fcar (args);
tem = Fcdr (args);
- if (!NULL (tem))
+ if (!NILP (tem))
{
tem = Fdefault_boundp (sym);
- if (NULL (tem))
+ if (NILP (tem))
Fset_default (sym, Feval (Fcar (Fcdr (args))));
}
tem = Fcar (Fcdr (Fcdr (args)));
- if (!NULL (tem))
+ if (!NILP (tem))
{
- if (!NULL (Vpurify_flag))
+ if (!NILP (Vpurify_flag))
tem = Fpurecopy (tem);
Fput (sym, Qvariable_documentation, tem);
}
"(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant variable.\n\
The intent is that programs do not change this value, but users may.\n\
Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\
-If SYMBOL is buffer-local, its default value is initialized in this way.\n\
+If SYMBOL is buffer-local, its default value is what is set;\n\
+ buffer-local values are not affected.\n\
DOCSTRING is optional.\n\
If DOCSTRING starts with *, this variable is identified as a user option.\n\
This means that M-x set-variable and M-x edit-options recognize it.\n\n\
sym = Fcar (args);
Fset_default (sym, Feval (Fcar (Fcdr (args))));
tem = Fcar (Fcdr (Fcdr (args)));
- if (!NULL (tem))
+ if (!NILP (tem))
{
- if (!NULL (Vpurify_flag))
+ if (!NILP (Vpurify_flag))
tem = Fpurecopy (tem);
Fput (sym, Qvariable_documentation, tem);
}
GCPRO3 (args, elt, varlist);
varlist = Fcar (args);
- while (!NULL (varlist))
+ while (!NILP (varlist))
{
QUIT;
elt = Fcar (varlist);
if (XTYPE (elt) == Lisp_Symbol)
specbind (elt, Qnil);
+ else if (! NILP (Fcdr (Fcdr (elt))))
+ Fsignal (Qerror,
+ Fcons (build_string ("`let' bindings can have only one value-form"),
+ elt));
else
{
val = Feval (Fcar (Fcdr (elt)));
GCPRO2 (args, *temps);
gcpro2.nvars = 0;
- for (argnum = 0; !NULL (varlist); varlist = Fcdr (varlist))
+ for (argnum = 0; !NILP (varlist); varlist = Fcdr (varlist))
{
QUIT;
elt = Fcar (varlist);
if (XTYPE (elt) == Lisp_Symbol)
temps [argnum++] = Qnil;
+ else if (! NILP (Fcdr (Fcdr (elt))))
+ Fsignal (Qerror,
+ Fcons (build_string ("`let' bindings can have only one value-form"),
+ elt));
else
temps [argnum++] = Feval (Fcar (Fcdr (elt)));
gcpro2.nvars = argnum;
UNGCPRO;
varlist = Fcar (args);
- for (argnum = 0; !NULL (varlist); varlist = Fcdr (varlist))
+ for (argnum = 0; !NILP (varlist); varlist = Fcdr (varlist))
{
elt = Fcar (varlist);
tem = temps[argnum++];
test = Fcar (args);
body = Fcdr (args);
- while (tem = Feval (test), !NULL (tem))
+ while (tem = Feval (test), !NILP (tem))
{
QUIT;
Fprogn (body);
register Lisp_Object form;
Lisp_Object env;
{
+ /* With cleanups from Hallvard Furuseth. */
register Lisp_Object expander, sym, def, tem;
while (1)
in case it expands into another macro call. */
if (XTYPE (form) != Lisp_Cons)
break;
- sym = XCONS (form)->car;
- /* Detect ((macro lambda ...) ...) */
- if (XTYPE (sym) == Lisp_Cons
- && EQ (XCONS (sym)->car, Qmacro))
- {
- expander = XCONS (sym)->cdr;
- goto explicit;
- }
- if (XTYPE (sym) != Lisp_Symbol)
- break;
+ /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
+ def = sym = XCONS (form)->car;
+ tem = Qnil;
/* Trace symbols aliases to other symbols
until we get a symbol that is not an alias. */
- while (1)
+ while (XTYPE (def) == Lisp_Symbol)
{
QUIT;
+ sym = def;
tem = Fassq (sym, env);
- if (NULL (tem))
+ if (NILP (tem))
{
def = XSYMBOL (sym)->function;
- if (XTYPE (def) == Lisp_Symbol && !EQ (def, Qunbound))
- sym = def;
- else
- break;
- }
- else
- {
-#if 0 /* This is turned off because it caused an element (foo . bar)
- to have the effect of defining foo as an alias for the macro bar.
- That is inconsistent; bar should be a function to expand foo. */
- if (XTYPE (tem) == Lisp_Cons
- && XTYPE (XCONS (tem)->cdr) == Lisp_Symbol)
- sym = XCONS (tem)->cdr;
- else
-#endif
- break;
+ if (!EQ (def, Qunbound))
+ continue;
}
+ break;
}
/* Right now TEM is the result from SYM in ENV,
and if TEM is nil then DEF is SYM's function definition. */
- if (NULL (tem))
+ if (NILP (tem))
{
/* SYM is not mentioned in ENV.
Look at its function definition. */
{
/* Autoloading function: will it be a macro when loaded? */
tem = Fcar (Fnthcdr (make_number (4), def));
- if (NULL (tem))
+ if (NILP (tem))
break;
/* Yes, load it and try again. */
do_autoload (def, sym);
else
{
expander = XCONS (tem)->cdr;
- if (NULL (expander))
+ if (NILP (expander))
break;
}
- explicit:
form = apply1 (expander, XCONS (form)->cdr);
}
return form;
return c.val;
}
-/* Discard from the catchlist all catch tags back through CATCH.
- Before each catch is discarded, unbind all special bindings
- made within that catch. Also, when discarding a catch that
- corresponds to a condition handler, discard that handler.
+/* Unwind the specbind, catch, and handler stacks back to CATCH, and
+ jump to that CATCH, returning VALUE as the value of that catch.
+
+ This is the guts Fthrow and Fsignal; they differ only in the way
+ they choose the catch tag to throw to. A catch tag for a
+ condition-case form has a TAG of Qnil.
- At the end, restore some static info saved in CATCH.
+ Before each catch is discarded, unbind all special bindings and
+ execute all unwind-protect clauses made above that catch. Unwind
+ the handler stack as we go, so that the proper handlers are in
+ effect for each unwind-protect clause we run. At the end, restore
+ some static info saved in CATCH, and longjmp to the location
+ specified in the
- This is used for correct unwinding in Fthrow and Fsignal,
- before doing the longjmp that actually destroys the stack frames
- in which these handlers and catches reside. */
+ This is used for correct unwinding in Fthrow and Fsignal. */
static void
-unbind_catch (catch)
+unwind_to_catch (catch, value)
struct catchtag *catch;
+ Lisp_Object value;
{
register int last_time;
+ /* Save the value in the tag. */
+ catch->val = value;
+
+ /* Restore the polling-suppression count. */
+ if (catch->poll_suppress_count > poll_suppress_count)
+ abort ();
+ while (catch->poll_suppress_count < poll_suppress_count)
+ start_polling ();
+
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;
gcprolist = catch->gcpro;
backtrace_list = catch->backlist;
lisp_eval_depth = catch->lisp_eval_depth;
+
+ _longjmp (catch->jmp, 1);
}
DEFUN ("throw", Fthrow, Sthrow, 2, 2, 0,
while (1)
{
- if (!NULL (tag))
+ if (!NILP (tag))
for (c = catchlist; c; c = c->next)
{
if (EQ (c->tag, tag))
- {
- /* Restore the polling-suppression count. */
- if (c->poll_suppress_count > poll_suppress_count)
- abort ();
- while (c->poll_suppress_count < poll_suppress_count)
- start_polling ();
- c->val = val;
- unbind_catch (c);
- _longjmp (c->jmp, 1);
- }
+ unwind_to_catch (c, val);
}
tag = Fsignal (Qno_catch, Fcons (tag, Fcons (val, Qnil)));
}
Lisp_Object val;
struct catchtag c;
struct handler h;
- register Lisp_Object tem;
+ register Lisp_Object var, bodyform, handlers;
- tem = Fcar (args);
- CHECK_SYMBOL (tem, 0);
+ var = Fcar (args);
+ bodyform = Fcar (Fcdr (args));
+ handlers = Fcdr (Fcdr (args));
+ CHECK_SYMBOL (var, 0);
+
+ for (val = handlers; ! NILP (val); val = Fcdr (val))
+ {
+ Lisp_Object tem;
+ tem = Fcar (val);
+ if ((!NILP (tem)) &&
+ (!CONSP (tem) || (XTYPE (XCONS (tem)->car) != Lisp_Symbol)))
+ error ("Invalid condition handler", tem);
+ }
c.tag = Qnil;
c.val = Qnil;
c.gcpro = gcprolist;
if (_setjmp (c.jmp))
{
- if (!NULL (h.var))
+ if (!NILP (h.var))
specbind (h.var, Fcdr (c.val));
val = Fprogn (Fcdr (Fcar (c.val)));
+
+ /* 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 = Fcar (args);
- h.handler = Fcdr (Fcdr (args));
-
- for (val = h.handler; ! NULL (val); val = Fcdr (val))
- {
- tem = Fcar (val);
- if ((!NULL (tem)) &&
- (!CONSP (tem) || (XTYPE (XCONS (tem)->car) != Lisp_Symbol)))
- error ("Invalid condition handler", tem);
- }
+ h.var = var;
+ h.handler = handlers;
h.next = handlerlist;
- h.poll_suppress_count = poll_suppress_count;
h.tag = &c;
handlerlist = &h;
- val = Feval (Fcar (Fcdr (args)));
+ val = Feval (bodyform);
catchlist = c.next;
handlerlist = h.next;
return val;
catchlist = &c;
h.handler = handlers;
h.var = Qnil;
- h.poll_suppress_count = poll_suppress_count;
h.next = handlerlist;
h.tag = &c;
handlerlist = &h;
if (gc_in_progress || waiting_for_input)
abort ();
+#ifdef HAVE_X_WINDOWS
TOTALLY_UNBLOCK_INPUT;
+#endif
conditions = Fget (sig, Qerror_conditions);
return debugger_value;
#else
if (EQ (clause, Qlambda))
+ {
+ /* We can't return values to code which signalled an error, but we
+ can continue code which has signalled a quit. */
+ if (EQ (sig, Qquit))
+ return Qnil;
+ else
error ("Returning a value from an error is no longer supported");
+ }
#endif
- if (!NULL (clause))
+ if (!NILP (clause))
{
struct handler *h = handlerlist;
- /* Restore the polling-suppression count. */
- if (h->poll_suppress_count > poll_suppress_count)
- abort ();
- while (h->poll_suppress_count < poll_suppress_count)
- start_polling ();
handlerlist = allhandlers;
- unbind_catch (h->tag);
- h->tag->val = Fcons (clause, Fcons (sig, data));
- _longjmp (h->tag->jmp, 1);
+ unwind_to_catch (h->tag, Fcons (clause, Fcons (sig, data)));
}
}
Fthrow (Qtop_level, Qt);
}
-/* Value of Qlambda means we have called debugger and
- user has continued. Store value returned fromdebugger
- into *debugger_value_ptr */
+/* Return nonzero iff LIST is a non-nil atom or
+ a list containing one of CONDITIONS. */
+
+static int
+wants_debugger (list, conditions)
+ Lisp_Object list, conditions;
+{
+ if (NILP (list))
+ return 0;
+ if (! CONSP (list))
+ return 1;
+
+ while (CONSP (conditions))
+ {
+ Lisp_Object this, tail;
+ this = XCONS (conditions)->car;
+ for (tail = list; CONSP (tail); tail = XCONS (tail)->cdr)
+ if (EQ (XCONS (tail)->car, this))
+ return 1;
+ conditions = XCONS (conditions)->cdr;
+ }
+ return 0;
+}
+
+/* Value of Qlambda means we have called debugger and user has continued.
+ Store value returned from debugger into *DEBUGGER_VALUE_PTR. */
static Lisp_Object
find_handler_clause (handlers, conditions, sig, data, debugger_value_ptr)
return Qt;
if (EQ (handlers, Qerror)) /* error is used similarly, but means display a backtrace too */
{
- if (stack_trace_on_error)
+ if (wants_debugger (Vstack_trace_on_error, conditions))
internal_with_output_to_temp_buffer ("*Backtrace*", Fbacktrace, Qnil);
- if (!entering_debugger
- && EQ (sig, Qquit) ? debug_on_quit : debug_on_error)
+ if ((EQ (sig, Qquit)
+ ? debug_on_quit
+ : wants_debugger (Vdebug_on_error, conditions))
+ && when_entered_debugger < num_nonmacro_input_chars)
{
int count = specpdl_ptr - specpdl;
specbind (Qdebug_on_error, Qnil);
if (!CONSP (tem1))
continue;
tem = Fmemq (Fcar (tem1), conditions);
- if (!NULL (tem))
+ if (!NILP (tem))
return tem1;
}
return Qnil;
fun = function;
- /* Dereference symbols, but avoid infinte loops. Eech. */
- while (XTYPE (fun) == Lisp_Symbol)
- {
- if (++i > 10) return Qnil;
- tem = Ffboundp (fun);
- if (NULL (tem)) return Qnil;
- fun = Fsymbol_function (fun);
- }
+ fun = indirect_function (fun);
+ if (EQ (fun, Qunbound))
+ return Qnil;
/* Emacs primitives are interactive if their DEFUN specifies an
interactive spec. */
Vautoload_queue = Qt;
unbind_to (count, Qnil);
- while (XTYPE (fun) == Lisp_Symbol)
- {
- QUIT;
- val = XSYMBOL (fun)->function;
- if (EQ (val, Qunbound))
- Fsymbol_function (fun); /* Get the right kind of error! */
- fun = val;
- }
+ fun = Findirect_function (fun);
+
if (XTYPE (fun) == Lisp_Cons
&& EQ (XCONS (fun)->car, Qautoload))
error ("Autoloading failed to define function %s",
if (EQ (Vmocklisp_arguments, Qt))
return Fsymbol_value (form);
val = Fsymbol_value (form);
- if (NULL (val))
+ if (NILP (val))
XFASTINT (val) = 0;
else if (EQ (val, Qt))
XFASTINT (val) = 1;
/* At this point, only original_fun and original_args
have values that will be used below */
retry:
- fun = original_fun;
- while (XTYPE (fun) == Lisp_Symbol)
- {
- QUIT;
- val = XSYMBOL (fun)->function;
- if (EQ (val, Qunbound))
- Fsymbol_function (fun); /* Get the right kind of error! */
- fun = val;
- }
+ fun = Findirect_function (original_fun);
if (XTYPE (fun) == Lisp_Subr)
{
gcpro3.var = vals;
gcpro3.nvars = 0;
- while (!NULL (args_left))
+ while (!NILP (args_left))
{
vals[argnum++] = Feval (Fcar (args_left));
args_left = Fcdr (args_left);
gcpro3.nvars = argnum;
}
- UNGCPRO;
backtrace.args = vals;
backtrace.nargs = XINT (numargs);
val = (*XSUBR (fun)->function) (XINT (numargs), vals);
+ UNGCPRO;
goto done;
}
val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2],
argvals[3], argvals[4], argvals[5]);
goto done;
+ case 7:
+ val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2],
+ argvals[3], argvals[4], argvals[5],
+ argvals[6]);
+ goto done;
default:
- error ("Ffuncall doesn't handle that number of arguments.");
- goto done;
+ /* 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 (XTYPE (fun) == Lisp_Compiled)
done:
if (!EQ (Vmocklisp_arguments, Qt))
{
- if (NULL (val))
+ if (NILP (val))
XFASTINT (val) = 0;
else if (EQ (val, Qt))
XFASTINT (val) = 1;
register int i, numargs;
register Lisp_Object spread_arg;
register Lisp_Object *funcall_args;
- struct gcpro gcpro1;
Lisp_Object fun;
+ struct gcpro gcpro1;
fun = args [0];
funcall_args = 0;
return Ffuncall (nargs, args);
}
- numargs = nargs - 2 + numargs;
+ numargs += nargs - 2;
- while (XTYPE (fun) == Lisp_Symbol)
+ fun = indirect_function (fun);
+ if (EQ (fun, Qunbound))
{
- QUIT;
- fun = XSYMBOL (fun)->function;
- if (EQ (fun, Qunbound))
- {
- /* Let funcall get the error */
- fun = args[0];
- goto funcall;
- }
+ /* Let funcall get the error */
+ fun = args[0];
+ goto funcall;
}
if (XTYPE (fun) == Lisp_Subr)
* sizeof (Lisp_Object));
for (i = numargs; i < XSUBR (fun)->max_args;)
funcall_args[++i] = Qnil;
+ GCPRO1 (*funcall_args);
+ gcpro1.nvars = 1 + XSUBR (fun)->max_args;
}
}
funcall:
/* We add 1 to numargs because funcall_args includes the
function itself as well as its arguments. */
if (!funcall_args)
- funcall_args = (Lisp_Object *) alloca ((1 + numargs)
- * sizeof (Lisp_Object));
+ {
+ funcall_args = (Lisp_Object *) alloca ((1 + numargs)
+ * sizeof (Lisp_Object));
+ GCPRO1 (*funcall_args);
+ gcpro1.nvars = 1 + numargs;
+ }
+
bcopy (args, funcall_args, nargs * sizeof (Lisp_Object));
/* Spread the last arg we got. Its first element goes in
the slot that it used to occupy, hence this value of I. */
i = nargs - 1;
- while (!NULL (spread_arg))
+ while (!NILP (spread_arg))
{
funcall_args [i++] = XCONS (spread_arg)->car;
spread_arg = XCONS (spread_arg)->cdr;
}
-
- GCPRO1 (*funcall_args);
- gcpro1.nvars = numargs + 1;
- {
- Lisp_Object val = Ffuncall (numargs + 1, funcall_args);
- UNGCPRO;
- return val;
- }
+
+ RETURN_UNGCPRO (Ffuncall (gcpro1.nvars, funcall_args));
}
\f
/* Apply fn to arg */
apply1 (fn, arg)
Lisp_Object fn, arg;
{
- if (NULL (arg))
- return Ffuncall (1, &fn);
+ struct gcpro gcpro1;
+
+ GCPRO1 (fn);
+ if (NILP (arg))
+ RETURN_UNGCPRO (Ffuncall (1, &fn));
+ gcpro1.nvars = 2;
#ifdef NO_ARG_ARRAY
{
Lisp_Object args[2];
args[0] = fn;
args[1] = arg;
- return Fapply (2, args);
+ gcpro1.var = args;
+ RETURN_UNGCPRO (Fapply (2, args));
}
#else /* not NO_ARG_ARRAY */
- return Fapply (2, &fn);
+ RETURN_UNGCPRO (Fapply (2, &fn));
#endif /* not NO_ARG_ARRAY */
}
call0 (fn)
Lisp_Object fn;
{
- return Ffuncall (1, &fn);
+ struct gcpro gcpro1;
+
+ GCPRO1 (fn);
+ RETURN_UNGCPRO (Ffuncall (1, &fn));
}
/* Call function fn with argument arg */
call1 (fn, arg)
Lisp_Object fn, arg;
{
+ struct gcpro gcpro1;
#ifdef NO_ARG_ARRAY
- Lisp_Object args[2];
+ Lisp_Object args[2];
+
args[0] = fn;
args[1] = arg;
- return Ffuncall (2, args);
+ GCPRO1 (args[0]);
+ gcpro1.nvars = 2;
+ RETURN_UNGCPRO (Ffuncall (2, args));
#else /* not NO_ARG_ARRAY */
- return Ffuncall (2, &fn);
+ GCPRO1 (fn);
+ gcpro1.nvars = 2;
+ RETURN_UNGCPRO (Ffuncall (2, &fn));
#endif /* not NO_ARG_ARRAY */
}
call2 (fn, arg, arg1)
Lisp_Object fn, arg, arg1;
{
+ struct gcpro gcpro1;
#ifdef NO_ARG_ARRAY
Lisp_Object args[3];
args[0] = fn;
args[1] = arg;
args[2] = arg1;
- return Ffuncall (3, args);
+ GCPRO1 (args[0]);
+ gcpro1.nvars = 3;
+ RETURN_UNGCPRO (Ffuncall (3, args));
#else /* not NO_ARG_ARRAY */
- return Ffuncall (3, &fn);
+ GCPRO1 (fn);
+ gcpro1.nvars = 3;
+ RETURN_UNGCPRO (Ffuncall (3, &fn));
#endif /* not NO_ARG_ARRAY */
}
call3 (fn, arg, arg1, arg2)
Lisp_Object fn, arg, arg1, arg2;
{
+ struct gcpro gcpro1;
#ifdef NO_ARG_ARRAY
Lisp_Object args[4];
args[0] = fn;
args[1] = arg;
args[2] = arg1;
args[3] = arg2;
- return Ffuncall (4, args);
+ GCPRO1 (args[0]);
+ gcpro1.nvars = 4;
+ RETURN_UNGCPRO (Ffuncall (4, args));
#else /* not NO_ARG_ARRAY */
- return Ffuncall (4, &fn);
+ GCPRO1 (fn);
+ gcpro1.nvars = 4;
+ RETURN_UNGCPRO (Ffuncall (4, &fn));
#endif /* not NO_ARG_ARRAY */
}
if (consing_since_gc > gc_cons_threshold)
Fgarbage_collect ();
-
if (++lisp_eval_depth > max_lisp_eval_depth)
{
if (max_lisp_eval_depth < 100)
retry:
fun = args[0];
- while (XTYPE (fun) == Lisp_Symbol)
- {
- QUIT;
- val = XSYMBOL (fun)->function;
- if (EQ (val, Qunbound))
- Fsymbol_function (fun); /* Get the right kind of error! */
- fun = val;
- }
+
+ fun = Findirect_function (fun);
if (XTYPE (fun) == Lisp_Subr)
{
internal_args[2], internal_args[3],
internal_args[4], internal_args[5]);
goto done;
+ case 7:
+ val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1],
+ internal_args[2], internal_args[3],
+ internal_args[4], internal_args[5],
+ internal_args[6]);
+ goto done;
default:
- error ("funcall: this number of args not handled.");
+
+ /* If a subr takes more than 6 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 (XTYPE (fun) == Lisp_Compiled)
else abort ();
i = 0;
- for (; !NULL (syms_left); syms_left = Fcdr (syms_left))
+ for (; !NILP (syms_left); syms_left = Fcdr (syms_left))
{
QUIT;
next = Fcar (syms_left);
+ while (XTYPE (next) != Lisp_Symbol)
+ next = Fsignal (Qinvalid_function, Fcons (fun, Qnil));
if (EQ (next, Qand_rest))
rest = 1;
else if (EQ (next, Qand_optional))
optional = 1;
else if (rest)
{
- specbind (Fcar (syms_left), Flist (nargs - i, &arg_vector[i]));
+ specbind (next, Flist (nargs - i, &arg_vector[i]));
i = nargs;
}
else if (i < nargs)
max_specpdl_size = 400;
if (specpdl_size >= max_specpdl_size)
{
+ if (!NILP (Vdebug_on_error))
+ /* Leave room for some specpdl in the debugger. */
+ max_specpdl_size = specpdl_size + 100;
Fsignal (Qerror,
Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil));
- max_specpdl_size *= 2;
}
}
specpdl_size *= 2;
extern void store_symval_forwarding (); /* in eval.c */
Lisp_Object ovalue;
+ CHECK_SYMBOL (symbol, 0);
+
if (specpdl_ptr == specpdl + specpdl_size)
grow_specpdl ();
specpdl_ptr->symbol = symbol;
int count;
Lisp_Object value;
{
- int quitf = !NULL (Vquit_flag);
+ int quitf = !NILP (Vquit_flag);
struct gcpro gcpro1;
GCPRO1 (value);
(*specpdl_ptr->func) (specpdl_ptr->old_value);
/* Note that a "binding" of nil is really an unwind protect,
so in that case the "old value" is a list of forms to evaluate. */
- else if (NULL (specpdl_ptr->symbol))
+ else if (NILP (specpdl_ptr->symbol))
Fprogn (specpdl_ptr->old_value);
else
Fset (specpdl_ptr->symbol, specpdl_ptr->old_value);
}
- if (NULL (Vquit_flag) && quitf) Vquit_flag = Qt;
+ if (NILP (Vquit_flag) && quitf) Vquit_flag = Qt;
UNGCPRO;
}
if (backlist)
- backlist->debug_on_exit = !NULL (flag);
+ backlist->debug_on_exit = !NILP (flag);
return flag;
}
extern Lisp_Object Vprint_level;
struct gcpro gcpro1;
- entering_debugger = 0;
-
XFASTINT (Vprint_level) = 3;
tail = Qnil;
if (backlist->nargs == MANY)
{
for (tail = *backlist->args, i = 0;
- !NULL (tail);
+ !NILP (tail);
tail = Fcdr (tail), i++)
{
if (i) write_string (" ", -1);
before making `inhibit-quit' nil.");
Vinhibit_quit = Qnil;
+ Qinhibit_quit = intern ("inhibit-quit");
+ staticpro (&Qinhibit_quit);
+
Qautoload = intern ("autoload");
staticpro (&Qautoload);
Qand_optional = intern ("&optional");
staticpro (&Qand_optional);
- DEFVAR_BOOL ("stack-trace-on-error", &stack_trace_on_error,
+ DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error,
"*Non-nil means automatically display a backtrace buffer\n\
-after any error that is handled by the editor command loop.");
- stack_trace_on_error = 0;
+after any error that is handled by the editor command loop.\n\
+If the value is a list, an error only means to display a backtrace\n\
+if one of its condition symbols appears in the list.");
+ Vstack_trace_on_error = Qnil;
- DEFVAR_BOOL ("debug-on-error", &debug_on_error,
+ DEFVAR_LISP ("debug-on-error", &Vdebug_on_error,
"*Non-nil means enter debugger if an error is signaled.\n\
Does not apply to errors handled by `condition-case'.\n\
+If the value is a list, an error only means to enter the debugger\n\
+if one of its condition symbols appears in the list.\n\
See also variable `debug-on-quit'.");
- debug_on_error = 0;
+ Vdebug_on_error = Qnil;
DEFVAR_BOOL ("debug-on-quit", &debug_on_quit,
"*Non-nil means enter debugger if quit is signaled (C-G, for example).\n\