/* Evaluator for GNU Emacs Lisp interpreter.
- Copyright (C) 1985, 1986, 1987, 1993 Free Software Foundation, Inc.
+ Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995 Free Software Foundation, Inc.
This file is part of GNU Emacs.
GNU Emacs is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 1, or (at your option)
+the Free Software Foundation; either version 2, or (at your option)
any later version.
GNU Emacs is distributed in the hope that it will be useful,
You should have received a copy of the GNU General Public License
along with GNU Emacs; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
-#include "config.h"
+#include <config.h>
#include "lisp.h"
#include "blockinput.h"
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_errors says they should. */
+Lisp_Object Vdebug_ignored_errors;
+
/* Nonzero means enter debugger if a quit signal
is handled by the command loop's error handler. */
int debug_on_quit;
void specbind (), record_unwind_protect ();
+Lisp_Object run_hook_with_args ();
+
Lisp_Object funcall_lambda ();
extern Lisp_Object ml_apply (); /* Apply a mocklisp function to unevaluated argument list */
init_eval_once ()
{
specpdl_size = 50;
- specpdl = (struct specbinding *) malloc (specpdl_size * sizeof (struct specbinding));
+ specpdl = (struct specbinding *) xmalloc (specpdl_size * sizeof (struct specbinding));
max_specpdl_size = 600;
max_lisp_eval_depth = 200;
+
+ Vrun_hooks = Qnil;
}
init_eval ()
Vquit_flag = Qnil;
debug_on_next_call = 0;
lisp_eval_depth = 0;
- when_entered_debugger = 0;
+ /* This is less than the initial value of num_nonmacro_input_chars. */
+ when_entered_debugger = -1;
}
Lisp_Object
if (!EQ (Vmocklisp_arguments, Qt))
{
val = make_number (0);
- while (!NILP (args) && (tem = Fcar (args), XTYPE (tem) == Lisp_Symbol))
+ while (!NILP (args) && (tem = Fcar (args), SYMBOLP (tem)))
{
QUIT;
specbind (tem, val), args = Fcdr (args);
}
DEFUN ("prog2", Fprog2, Sprog2, 2, UNEVALLED, 0,
- "(prog1 X Y BODY...): eval X, Y and BODY sequentially; value from Y.\n\
+ "(prog2 X Y BODY...): eval X, Y and BODY sequentially; value from Y.\n\
The value of Y is saved during the evaluation of the remaining args,\n\
whose values are discarded.")
(args)
val = Qnil;
- if (NILP(args))
+ if (NILP (args))
return Qnil;
args_left = args;
Feval (Fcar (args_left));
args_left = Fcdr (args_left);
}
- while (!NILP(args_left));
+ while (!NILP (args_left));
UNGCPRO;
return val;
DEFUN ("setq", Fsetq, Ssetq, 0, UNEVALLED, 0,
"(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.\n\
-The SYMs are not evaluated. Thus (setq x y) sets x to the value of y.\n\
-Each SYM is set before the next VAL is computed.")
+The symbols SYM are variables; they are literal (not evaluated).\n\
+The values VAL are expressions; they are evaluated.\n\
+Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.\n\
+The second VAL is not computed until after the first SYM is set, and so on;\n\
+each VAL can use the new value of variables set earlier in the `setq'.\n\
+The return value of the `setq' form is the value of the last VAL.")
(args)
Lisp_Object args;
{
/* 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)
+ if (SUBRP (fun) && XSUBR (fun) == &Sinteractive_p)
btp = btp->next;
/* If we're running an Emacs 18-style byte-compiled function, there
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)
+ if (SUBRP (fun))
return Qnil;
/* btp points to the frame of a Lisp function that called interactive-p.
Return t if that function was called interactively. */
(args)
Lisp_Object args;
{
- register Lisp_Object sym, tem;
+ register Lisp_Object sym, tem, tail;
sym = Fcar (args);
- tem = Fcdr (args);
- if (!NILP (tem))
+ tail = Fcdr (args);
+ if (!NILP (Fcdr (Fcdr (tail))))
+ error ("too many arguments");
+
+ if (!NILP (tail))
{
tem = Fdefault_boundp (sym);
if (NILP (tem))
Fset_default (sym, Feval (Fcar (Fcdr (args))));
}
- tem = Fcar (Fcdr (Fcdr (args)));
- if (!NILP (tem))
+ tail = Fcdr (Fcdr (args));
+ if (!NILP (Fcar (tail)))
{
+ tem = Fcar (tail);
if (!NILP (Vpurify_flag))
tem = Fpurecopy (tem);
Fput (sym, Qvariable_documentation, tem);
register Lisp_Object sym, tem;
sym = Fcar (args);
+ if (!NILP (Fcdr (Fcdr (Fcdr (args)))))
+ error ("too many arguments");
+
Fset_default (sym, Feval (Fcar (Fcdr (args))));
tem = Fcar (Fcdr (Fcdr (args)));
if (!NILP (tem))
"Returns t if VARIABLE is intended to be set and modified by users.\n\
\(The alternative is a variable used internally in a Lisp program.)\n\
Determined by whether the first character of the documentation\n\
-for the variable is \"*\"")
+for the variable is `*'.")
(variable)
Lisp_Object variable;
{
Lisp_Object documentation;
documentation = Fget (variable, Qvariable_documentation);
- if (XTYPE (documentation) == Lisp_Int && XINT (documentation) < 0)
+ if (INTEGERP (documentation) && XINT (documentation) < 0)
return Qt;
- if ((XTYPE (documentation) == Lisp_String) &&
- ((unsigned char) XSTRING (documentation)->data[0] == '*'))
+ if (STRINGP (documentation)
+ && ((unsigned char) XSTRING (documentation)->data[0] == '*'))
+ return Qt;
+ /* If it is (STRING . INTEGER), a negative integer means a user variable. */
+ if (CONSP (documentation)
+ && STRINGP (XCONS (documentation)->car)
+ && INTEGERP (XCONS (documentation)->cdr)
+ && XINT (XCONS (documentation)->cdr) < 0)
return Qt;
return Qnil;
}
{
QUIT;
elt = Fcar (varlist);
- if (XTYPE (elt) == Lisp_Symbol)
+ if (SYMBOLP (elt))
specbind (elt, Qnil);
else if (! NILP (Fcdr (Fcdr (elt))))
Fsignal (Qerror,
{
QUIT;
elt = Fcar (varlist);
- if (XTYPE (elt) == Lisp_Symbol)
+ if (SYMBOLP (elt))
temps [argnum++] = Qnil;
else if (! NILP (Fcdr (Fcdr (elt))))
Fsignal (Qerror,
{
elt = Fcar (varlist);
tem = temps[argnum++];
- if (XTYPE (elt) == Lisp_Symbol)
+ if (SYMBOLP (elt))
specbind (elt, tem);
else
specbind (Fcar (elt), tem);
test = Fcar (args);
body = Fcdr (args);
- while (tem = Feval (test), !NILP (tem))
+ while (tem = Feval (test),
+ (!EQ (Vmocklisp_arguments, Qt) ? XINT (tem) : !NILP (tem)))
{
QUIT;
Fprogn (body);
in place of FORM. When a non-macro-call results, it is returned.\n\n\
The second optional arg ENVIRONMENT species an environment of macro\n\
definitions to shadow the loaded ones for use in file byte-compilation.")
- (form, env)
+ (form, environment)
register Lisp_Object form;
- Lisp_Object env;
+ Lisp_Object environment;
{
/* With cleanups from Hallvard Furuseth. */
register Lisp_Object expander, sym, def, tem;
{
/* Come back here each time we expand a macro call,
in case it expands into another macro call. */
- if (XTYPE (form) != Lisp_Cons)
+ if (!CONSP (form))
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 (XTYPE (def) == Lisp_Symbol)
+ while (SYMBOLP (def))
{
QUIT;
sym = def;
- tem = Fassq (sym, env);
+ tem = Fassq (sym, environment);
if (NILP (tem))
{
def = XSYMBOL (sym)->function;
}
break;
}
- /* Right now TEM is the result from SYM in ENV,
+ /* Right now TEM is the result from SYM in ENVIRONMENT,
and if TEM is nil then DEF is SYM's function definition. */
if (NILP (tem))
{
- /* SYM is not mentioned in ENV.
+ /* SYM is not mentioned in ENVIRONMENT.
Look at its function definition. */
- if (EQ (def, Qunbound)
- || XTYPE (def) != Lisp_Cons)
+ if (EQ (def, Qunbound) || !CONSP (def))
/* Not defined or definition not suitable */
break;
if (EQ (XCONS (def)->car, Qautoload))
{
/* Autoloading function: will it be a macro when loaded? */
tem = Fnth (make_number (4), def);
- if (EQ (XCONS (tem)->car, Qt)
- || EQ (XCONS (tem)->car, Qmacro))
+ if (EQ (tem, Qt) || EQ (tem, Qmacro))
/* Yes, load it and try again. */
{
do_autoload (def, sym);
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 ();
+ set_poll_suppress_count (catch->poll_suppress_count);
do
{
DEFUN ("throw", Fthrow, Sthrow, 2, 2, 0,
"(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.\n\
Both TAG and VALUE are evalled.")
- (tag, val)
- register Lisp_Object tag, val;
+ (tag, value)
+ register Lisp_Object tag, value;
{
register struct catchtag *c;
for (c = catchlist; c; c = c->next)
{
if (EQ (c->tag, tag))
- unwind_to_catch (c, val);
+ unwind_to_catch (c, value);
}
- tag = Fsignal (Qno_catch, Fcons (tag, Fcons (val, Qnil)));
+ tag = Fsignal (Qno_catch, Fcons (tag, Fcons (value, Qnil)));
}
}
if CONDITION-NAME is one of the error's condition names.\n\
If an error happens, the first applicable handler is run.\n\
\n\
+The car of a handler may be a list of condition names\n\
+instead of a single condition name.\n\
+\n\
When a handler handles an error,\n\
control returns to the condition-case and the handler BODY... is executed\n\
with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\
{
Lisp_Object tem;
tem = Fcar (val);
- if ((!NILP (tem)) &&
- (!CONSP (tem) || (XTYPE (XCONS (tem)->car) != Lisp_Symbol)))
+ if (! (NILP (tem)
+ || (CONSP (tem)
+ && (SYMBOLP (XCONS (tem)->car)
+ || CONSP (XCONS (tem)->car)))))
error ("Invalid condition handler", tem);
}
if (_setjmp (c.jmp))
{
if (!NILP (h.var))
- specbind (h.var, Fcdr (c.val));
- val = Fprogn (Fcdr (Fcar (c.val)));
+ 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
struct catchtag c;
struct handler h;
+ /* Since Fsignal resets this to 0, it had better be 0 now
+ or else we have a potential bug. */
+ if (interrupt_input_blocked != 0)
+ abort ();
+
c.tag = Qnil;
c.val = Qnil;
c.backlist = backtrace_list;
c.gcpro = gcprolist;
if (_setjmp (c.jmp))
{
- return (*hfun) (Fcdr (c.val));
+ return (*hfun) (c.val);
}
c.next = catchlist;
catchlist = &c;
return val;
}
+Lisp_Object
+internal_condition_case_1 (bfun, arg, handlers, hfun)
+ Lisp_Object (*bfun) ();
+ Lisp_Object arg;
+ Lisp_Object handlers;
+ Lisp_Object (*hfun) ();
+{
+ Lisp_Object val;
+ struct catchtag c;
+ struct handler h;
+
+ c.tag = Qnil;
+ c.val = Qnil;
+ c.backlist = backtrace_list;
+ c.handlerlist = handlerlist;
+ c.lisp_eval_depth = lisp_eval_depth;
+ c.pdlcount = specpdl_ptr - specpdl;
+ c.poll_suppress_count = poll_suppress_count;
+ c.gcpro = gcprolist;
+ if (_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;
+
+ val = (*bfun) (arg);
+ catchlist = c.next;
+ handlerlist = h.next;
+ return val;
+}
+\f
static Lisp_Object find_handler_clause ();
DEFUN ("signal", Fsignal, Ssignal, 2, 2, 0,
- "Signal an error. Args are SIGNAL-NAME, and associated DATA.\n\
+ "Signal an error. Args are ERROR-SYMBOL and associated DATA.\n\
This function does not return.\n\n\
-A signal name is a symbol with an `error-conditions' property\n\
+An error symbol is a symbol with an `error-conditions' property\n\
that is a list of condition names.\n\
A handler for any of those names will get to handle this signal.\n\
The symbol `error' should normally be one of them.\n\
DATA should be a list. Its elements are printed as part of the error message.\n\
If the signal is handled, DATA is made available to the handler.\n\
See also the function `condition-case'.")
- (sig, data)
- Lisp_Object sig, data;
+ (error_symbol, data)
+ Lisp_Object error_symbol, data;
{
register struct handler *allhandlers = handlerlist;
Lisp_Object conditions;
TOTALLY_UNBLOCK_INPUT;
#endif
- conditions = Fget (sig, Qerror_conditions);
+ conditions = Fget (error_symbol, Qerror_conditions);
for (; handlerlist; handlerlist = handlerlist->next)
{
register Lisp_Object clause;
clause = find_handler_clause (handlerlist->handler, conditions,
- sig, data, &debugger_value);
+ error_symbol, data, &debugger_value);
#if 0 /* Most callers are not prepared to handle gc if this returns.
So, since this feature is not very useful, take it out. */
#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))
+ /* We can't return values to code which signaled an error, but we
+ can continue code which has signaled a quit. */
+ if (EQ (error_symbol, Qquit))
return Qnil;
else
- error ("Returning a value from an error is no longer supported");
+ error ("Cannot return from the debugger in an error");
}
#endif
if (!NILP (clause))
{
+ Lisp_Object unwind_data;
struct handler *h = handlerlist;
+
handlerlist = allhandlers;
- unwind_to_catch (h->tag, Fcons (clause, Fcons (sig, data)));
+ if (EQ (data, memory_signal_data))
+ unwind_data = memory_signal_data;
+ else
+ unwind_data = Fcons (error_symbol, data);
+ h->chosen_clause = clause;
+ unwind_to_catch (h->tag, unwind_data);
}
}
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, sig, data, &debugger_value);
+ find_handler_clause (Qerror, conditions, error_symbol, data, &debugger_value);
Fthrow (Qtop_level, Qt);
}
return 0;
}
+/* Return 1 if an error with condition-symbols CONDITIONS,
+ and described by SIGNAL-DATA, should skip the debugger
+ according to debugger-ignore-errors. */
+
+static int
+skip_debugger (conditions, data)
+ Lisp_Object conditions, data;
+{
+ Lisp_Object tail;
+ int first_string = 1;
+ Lisp_Object error_message;
+
+ for (tail = Vdebug_ignored_errors; CONSP (tail);
+ tail = XCONS (tail)->cdr)
+ {
+ if (STRINGP (XCONS (tail)->car))
+ {
+ if (first_string)
+ {
+ error_message = Ferror_message_string (data);
+ first_string = 0;
+ }
+ if (fast_string_match (XCONS (tail)->car, error_message) >= 0)
+ return 1;
+ }
+ else
+ {
+ Lisp_Object contail;
+
+ for (contail = conditions; CONSP (contail);
+ contail = XCONS (contail)->cdr)
+ if (EQ (XCONS (tail)->car, XCONS (contail)->car))
+ return 1;
+ }
+ }
+
+ return 0;
+}
+
/* Value of Qlambda means we have called debugger and user has continued.
Store value returned from debugger into *DEBUGGER_VALUE_PTR. */
{
register Lisp_Object h;
register Lisp_Object tem;
- register Lisp_Object tem1;
if (EQ (handlers, Qt)) /* t is used by handlers for all conditions, set up by C code. */
return Qt;
if ((EQ (sig, Qquit)
? debug_on_quit
: wants_debugger (Vdebug_on_error, conditions))
+ && ! skip_debugger (conditions, Fcons (sig, data))
&& when_entered_debugger < num_nonmacro_input_chars)
{
int count = specpdl_ptr - specpdl;
specbind (Qdebug_on_error, Qnil);
- *debugger_value_ptr =
- call_debugger (Fcons (Qerror,
- Fcons (Fcons (sig, data),
- Qnil)));
+ *debugger_value_ptr
+ = call_debugger (Fcons (Qerror,
+ Fcons (Fcons (sig, data),
+ Qnil)));
return unbind_to (count, Qlambda);
}
return Qt;
}
for (h = handlers; CONSP (h); h = Fcdr (h))
{
- tem1 = Fcar (h);
- if (!CONSP (tem1))
+ Lisp_Object handler, condit;
+
+ handler = Fcar (h);
+ if (!CONSP (handler))
continue;
- tem = Fmemq (Fcar (tem1), conditions);
- if (!NILP (tem))
- return tem1;
+ condit = Fcar (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))
+ {
+ while (CONSP (condit))
+ {
+ tem = Fmemq (Fcar (condit), conditions);
+ if (!NILP (tem))
+ return handler;
+ condit = XCONS (condit)->cdr;
+ }
+ }
}
return Qnil;
}
void
error (m, a1, a2, a3)
char *m;
+ char *a1, *a2, *a3;
{
char buf[200];
- sprintf (buf, m, a1, a2, a3);
+ 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)
- Fsignal (Qerror, Fcons (build_string (buf), Qnil));
+ {
+ int used = doprnt (buf, size, m, m + mlen, 3, args);
+ if (used < size)
+ break;
+ size *= 2;
+ if (allocated)
+ buffer = (char *) xrealloc (buffer, size);
+ else
+ {
+ buffer = (char *) xmalloc (size);
+ allocated = 1;
+ }
+ }
+
+ string = build_string (buf);
+ if (allocated)
+ free (buffer);
+
+ Fsignal (Qerror, Fcons (string, Qnil));
}
\f
DEFUN ("commandp", Fcommandp, Scommandp, 1, 1, 0,
/* Emacs primitives are interactive if their DEFUN specifies an
interactive spec. */
- if (XTYPE (fun) == Lisp_Subr)
+ if (SUBRP (fun))
{
if (XSUBR (fun)->prompt)
return Qt;
/* Bytecode objects are interactive if they are long enough to
have an element whose index is COMPILED_INTERACTIVE, which is
where the interactive spec is stored. */
- else if (XTYPE (fun) == Lisp_Compiled)
- return (XVECTOR (fun)->size > COMPILED_INTERACTIVE
+ else if (COMPILEDP (fun))
+ return ((XVECTOR (fun)->size & PSEUDOVECTOR_SIZE_MASK) > COMPILED_INTERACTIVE
? Qt : Qnil);
/* Strings and vectors are keyboard macros. */
- if (XTYPE (fun) == Lisp_String
- || XTYPE (fun) == Lisp_Vector)
+ if (STRINGP (fun) || VECTORP (fun))
return Qt;
/* Lists may represent commands. */
if (!CONSP (fun))
return Qnil;
funcar = Fcar (fun);
- if (XTYPE (funcar) != Lisp_Symbol)
+ if (!SYMBOLP (funcar))
return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
if (EQ (funcar, Qlambda))
return Fassq (Qinteractive, Fcdr (Fcdr (fun)));
/* If function is defined and not as an autoload, don't override */
if (!EQ (XSYMBOL (function)->function, Qunbound)
- && !(XTYPE (XSYMBOL (function)->function) == Lisp_Cons
+ && !(CONSP (XSYMBOL (function)->function)
&& EQ (XCONS (XSYMBOL (function)->function)->car, Qautoload)))
return Qnil;
may be an atom if the autoload entry was generated by a defalias
or fset. */
if (CONSP (second))
- Fput(first, Qautoload, (Fcdr (second)));
+ Fput (first, Qautoload, (Fcdr (second)));
queue = Fcdr (queue);
}
fun = Findirect_function (fun);
- if (XTYPE (fun) == Lisp_Cons
- && EQ (XCONS (fun)->car, Qautoload))
+ if (!NILP (Fequal (fun, fundef)))
error ("Autoloading failed to define function %s",
XSYMBOL (funname)->name->data);
}
struct backtrace backtrace;
struct gcpro gcpro1, gcpro2, gcpro3;
- if (XTYPE (form) == Lisp_Symbol)
+ if (SYMBOLP (form))
{
if (EQ (Vmocklisp_arguments, Qt))
return Fsymbol_value (form);
val = Fsymbol_value (form);
if (NILP (val))
- XFASTINT (val) = 0;
+ XSETFASTINT (val, 0);
else if (EQ (val, Qt))
- XFASTINT (val) = 1;
+ XSETFASTINT (val, 1);
return val;
}
if (!CONSP (form))
retry:
fun = Findirect_function (original_fun);
- if (XTYPE (fun) == Lisp_Subr)
+ if (SUBRP (fun))
{
Lisp_Object numargs;
Lisp_Object argvals[7];
abort ();
}
}
- if (XTYPE (fun) == Lisp_Compiled)
+ if (COMPILEDP (fun))
val = apply_lambda (fun, original_args, 1);
else
{
if (!CONSP (fun))
return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
funcar = Fcar (fun);
- if (XTYPE (funcar) != Lisp_Symbol)
+ if (!SYMBOLP (funcar))
return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
if (EQ (funcar, Qautoload))
{
if (!EQ (Vmocklisp_arguments, Qt))
{
if (NILP (val))
- XFASTINT (val) = 0;
+ XSETFASTINT (val, 0);
else if (EQ (val, Qt))
- XFASTINT (val) = 1;
+ XSETFASTINT (val, 1);
}
lisp_eval_depth--;
if (backtrace.debug_on_exit)
\f
DEFUN ("apply", Fapply, Sapply, 2, MANY, 0,
"Call FUNCTION with our remaining args, using our last arg as list of args.\n\
+Then return the value FUNCTION returns.\n\
Thus, (apply '+ 1 2 '(3 4)) returns 10.")
(nargs, args)
int nargs;
goto funcall;
}
- if (XTYPE (fun) == Lisp_Subr)
+ if (SUBRP (fun))
{
if (numargs < XSUBR (fun)->min_args
|| (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs))
RETURN_UNGCPRO (Ffuncall (gcpro1.nvars, funcall_args));
}
\f
+/* Run hook variables in various ways. */
+
+enum run_hooks_condition {to_completion, until_success, until_failure};
+
+DEFUN ("run-hooks", Frun_hooks, Srun_hooks, 1, MANY, 0,
+ "Run each hook in HOOKS. Major mode functions use this.\n\
+Each argument should be a symbol, a hook variable.\n\
+These symbols are processed in the order specified.\n\
+If a hook symbol has a non-nil value, that value may be a function\n\
+or a list of functions to be called to run the hook.\n\
+If the value is a function, it is called with no arguments.\n\
+If it is a list, the elements are called, in order, with no arguments.\n\
+\n\
+To make a hook variable buffer-local, use `make-local-hook',\n\
+not `make-local-variable'.")
+ (nargs, args)
+ int nargs;
+ Lisp_Object *args;
+{
+ Lisp_Object hook[1];
+ register int i;
+
+ for (i = 0; i < nargs; i++)
+ {
+ hook[0] = args[i];
+ run_hook_with_args (1, hook, to_completion);
+ }
+
+ return Qnil;
+}
+
+DEFUN ("run-hook-with-args",
+ Frun_hook_with_args, Srun_hook_with_args, 1, MANY, 0,
+ "Run HOOK with the specified arguments ARGS.\n\
+HOOK should be a symbol, a hook variable. If HOOK has a non-nil\n\
+value, that value may be a function or a list of functions to be\n\
+called to run the hook. If the value is a function, it is called with\n\
+the given arguments and its return value is returned. If it is a list\n\
+of functions, those functions are called, in order,\n\
+with the given arguments ARGS.\n\
+It is best not to depend on the value return by `run-hook-with-args',\n\
+as that may change.\n\
+\n\
+To make a hook variable buffer-local, use `make-local-hook',\n\
+not `make-local-variable'.")
+ (nargs, args)
+ int nargs;
+ Lisp_Object *args;
+{
+ return run_hook_with_args (nargs, args, to_completion);
+}
+
+DEFUN ("run-hook-with-args-until-success",
+ Frun_hook_with_args_until_success, Srun_hook_with_args_until_success,
+ 1, MANY, 0,
+ "Run HOOK with the specified arguments ARGS.\n\
+HOOK should be a symbol, a hook variable. Its value should\n\
+be a list of functions. We call those functions, one by one,\n\
+passing arguments ARGS to each of them, until one of them\n\
+returns a non-nil value. Then we return that value.\n\
+If all the functions return nil, we return nil.\n\
+\n\
+To make a hook variable buffer-local, use `make-local-hook',\n\
+not `make-local-variable'.")
+ (nargs, args)
+ int nargs;
+ Lisp_Object *args;
+{
+ return run_hook_with_args (nargs, args, until_success);
+}
+
+DEFUN ("run-hook-with-args-until-failure",
+ Frun_hook_with_args_until_failure, Srun_hook_with_args_until_failure,
+ 1, MANY, 0,
+ "Run HOOK with the specified arguments ARGS.\n\
+HOOK should be a symbol, a hook variable. Its value should\n\
+be a list of functions. We call those functions, one by one,\n\
+passing arguments ARGS to each of them, until one of them\n\
+returns nil. Then we return nil.\n\
+If all the functions return non-nil, we return non-nil.\n\
+\n\
+To make a hook variable buffer-local, use `make-local-hook',\n\
+not `make-local-variable'.")
+ (nargs, args)
+ int nargs;
+ Lisp_Object *args;
+{
+ return run_hook_with_args (nargs, args, until_failure);
+}
+
+/* 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.
+ 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_with_args (nargs, args, cond)
+ int nargs;
+ Lisp_Object *args;
+ enum run_hooks_condition cond;
+{
+ Lisp_Object sym, val, ret;
+ struct gcpro gcpro1, gcpro2;
+
+ 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 (XCONS (val)->car, Qlambda))
+ {
+ args[0] = val;
+ return Ffuncall (nargs, args);
+ }
+ else
+ {
+ GCPRO2 (sym, val);
+
+ for (;
+ CONSP (val) && ((cond == to_completion)
+ || (cond == until_success ? NILP (ret)
+ : !NILP (ret)));
+ val = XCONS (val)->cdr)
+ {
+ if (EQ (XCONS (val)->car, Qt))
+ {
+ /* t indicates this hook has a local binding;
+ it means to run the global binding too. */
+ Lisp_Object globals;
+
+ for (globals = Fdefault_value (sym);
+ CONSP (globals) && ((cond == to_completion)
+ || (cond == until_success ? NILP (ret)
+ : !NILP (ret)));
+ globals = XCONS (globals)->cdr)
+ {
+ args[0] = XCONS (globals)->car;
+ /* 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);
+ }
+ }
+ else
+ {
+ args[0] = XCONS (val)->car;
+ ret = Ffuncall (nargs, args);
+ }
+ }
+
+ UNGCPRO;
+ return ret;
+ }
+}
+
+/* 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 (funlist, nargs, args)
+ Lisp_Object funlist;
+ int nargs;
+ Lisp_Object *args;
+{
+ Lisp_Object sym;
+ Lisp_Object val;
+ struct gcpro gcpro1, gcpro2;
+
+ sym = args[0];
+ GCPRO2 (sym, val);
+
+ for (val = funlist; CONSP (val); val = XCONS (val)->cdr)
+ {
+ if (EQ (XCONS (val)->car, Qt))
+ {
+ /* t indicates this hook has a local binding;
+ it means to run the global binding too. */
+ Lisp_Object globals;
+
+ for (globals = Fdefault_value (sym);
+ CONSP (globals);
+ globals = XCONS (globals)->cdr)
+ {
+ args[0] = XCONS (globals)->car;
+ /* 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] = XCONS (val)->car;
+ Ffuncall (nargs, args);
+ }
+ }
+ UNGCPRO;
+ return Qnil;
+}
+
+/* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
+
+void
+run_hook_with_args_2 (hook, arg1, arg2)
+ Lisp_Object hook, arg1, arg2;
+{
+ Lisp_Object temp[3];
+ temp[0] = hook;
+ temp[1] = arg1;
+ temp[2] = arg2;
+
+ Frun_hook_with_args (3, temp);
+}
+\f
/* Apply fn to arg */
Lisp_Object
apply1 (fn, arg)
RETURN_UNGCPRO (Ffuncall (1, &fn));
}
-/* Call function fn with argument arg */
+/* Call function fn with 1 argument arg1 */
/* ARGSUSED */
Lisp_Object
-call1 (fn, arg)
- Lisp_Object fn, arg;
+call1 (fn, arg1)
+ Lisp_Object fn, arg1;
{
struct gcpro gcpro1;
#ifdef NO_ARG_ARRAY
Lisp_Object args[2];
args[0] = fn;
- args[1] = arg;
+ args[1] = arg1;
GCPRO1 (args[0]);
gcpro1.nvars = 2;
RETURN_UNGCPRO (Ffuncall (2, args));
#endif /* not NO_ARG_ARRAY */
}
-/* Call function fn with arguments arg, arg1 */
+/* Call function fn with 2 arguments arg1, arg2 */
/* ARGSUSED */
Lisp_Object
-call2 (fn, arg, arg1)
- Lisp_Object fn, arg, arg1;
+call2 (fn, arg1, arg2)
+ Lisp_Object fn, arg1, arg2;
{
struct gcpro gcpro1;
#ifdef NO_ARG_ARRAY
Lisp_Object args[3];
args[0] = fn;
- args[1] = arg;
- args[2] = arg1;
+ args[1] = arg1;
+ args[2] = arg2;
GCPRO1 (args[0]);
gcpro1.nvars = 3;
RETURN_UNGCPRO (Ffuncall (3, args));
#endif /* not NO_ARG_ARRAY */
}
-/* Call function fn with arguments arg, arg1, arg2 */
+/* Call function fn with 3 arguments arg1, arg2, arg3 */
/* ARGSUSED */
Lisp_Object
-call3 (fn, arg, arg1, arg2)
- Lisp_Object fn, arg, arg1, arg2;
+call3 (fn, arg1, arg2, arg3)
+ Lisp_Object fn, arg1, arg2, arg3;
{
struct gcpro gcpro1;
#ifdef NO_ARG_ARRAY
Lisp_Object args[4];
args[0] = fn;
- args[1] = arg;
- args[2] = arg1;
- args[3] = arg2;
+ args[1] = arg1;
+ args[2] = arg2;
+ args[3] = arg3;
GCPRO1 (args[0]);
gcpro1.nvars = 4;
RETURN_UNGCPRO (Ffuncall (4, args));
#endif /* not NO_ARG_ARRAY */
}
+/* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
+/* ARGSUSED */
+Lisp_Object
+call4 (fn, arg1, arg2, arg3, arg4)
+ Lisp_Object fn, arg1, arg2, arg3, arg4;
+{
+ struct gcpro gcpro1;
+#ifdef NO_ARG_ARRAY
+ 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));
+#else /* not NO_ARG_ARRAY */
+ GCPRO1 (fn);
+ gcpro1.nvars = 5;
+ RETURN_UNGCPRO (Ffuncall (5, &fn));
+#endif /* not NO_ARG_ARRAY */
+}
+
+/* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
+/* ARGSUSED */
+Lisp_Object
+call5 (fn, arg1, arg2, arg3, arg4, arg5)
+ Lisp_Object fn, arg1, arg2, arg3, arg4, arg5;
+{
+ struct gcpro gcpro1;
+#ifdef NO_ARG_ARRAY
+ 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));
+#else /* not NO_ARG_ARRAY */
+ GCPRO1 (fn);
+ gcpro1.nvars = 6;
+ RETURN_UNGCPRO (Ffuncall (6, &fn));
+#endif /* not NO_ARG_ARRAY */
+}
+
+/* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
+/* ARGSUSED */
+Lisp_Object
+call6 (fn, arg1, arg2, arg3, arg4, arg5, arg6)
+ Lisp_Object fn, arg1, arg2, arg3, arg4, arg5, arg6;
+{
+ struct gcpro gcpro1;
+#ifdef NO_ARG_ARRAY
+ 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));
+#else /* not NO_ARG_ARRAY */
+ GCPRO1 (fn);
+ gcpro1.nvars = 7;
+ RETURN_UNGCPRO (Ffuncall (7, &fn));
+#endif /* not NO_ARG_ARRAY */
+}
+
DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0,
"Call first argument as a function, passing remaining arguments to it.\n\
+Return the value that function returns.\n\
Thus, (funcall 'cons 'x 'y) returns (x . y).")
(nargs, args)
int nargs;
fun = Findirect_function (fun);
- if (XTYPE (fun) == Lisp_Subr)
+ if (SUBRP (fun))
{
if (numargs < XSUBR (fun)->min_args
|| (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs))
{
- XFASTINT (lisp_numargs) = numargs;
+ XSETFASTINT (lisp_numargs, numargs);
return Fsignal (Qwrong_number_of_arguments, Fcons (fun, Fcons (lisp_numargs, Qnil)));
}
abort ();
}
}
- if (XTYPE (fun) == Lisp_Compiled)
+ if (COMPILEDP (fun))
val = funcall_lambda (fun, numargs, args + 1);
else
{
if (!CONSP (fun))
return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
funcar = Fcar (fun);
- if (XTYPE (funcar) != Lisp_Symbol)
+ if (!SYMBOLP (funcar))
return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
if (EQ (funcar, Qlambda))
val = funcall_lambda (fun, numargs, args + 1);
specbind (Qmocklisp_arguments, Qt); /* t means NOT mocklisp! */
- XFASTINT (numargs) = nargs;
+ XSETFASTINT (numargs, nargs);
- if (XTYPE (fun) == Lisp_Cons)
+ if (CONSP (fun))
syms_left = Fcar (Fcdr (fun));
- else if (XTYPE (fun) == Lisp_Compiled)
+ else if (COMPILEDP (fun))
syms_left = XVECTOR (fun)->contents[COMPILED_ARGLIST];
else abort ();
{
QUIT;
next = Fcar (syms_left);
- while (XTYPE (next) != Lisp_Symbol)
+ while (!SYMBOLP (next))
next = Fsignal (Qinvalid_function, Fcons (fun, Qnil));
if (EQ (next, Qand_rest))
rest = 1;
if (i < nargs)
return Fsignal (Qwrong_number_of_arguments, Fcons (fun, Fcons (numargs, Qnil)));
- if (XTYPE (fun) == Lisp_Cons)
+ if (CONSP (fun))
val = Fprogn (Fcdr (Fcdr (fun)));
else
- val = Fbyte_code (XVECTOR (fun)->contents[COMPILED_BYTECODE],
- XVECTOR (fun)->contents[COMPILED_CONSTANTS],
- XVECTOR (fun)->contents[COMPILED_STACK_DEPTH]);
+ {
+ /* If we have not actually read the bytecode string
+ and constants vector yet, fetch them from the file. */
+ if (CONSP (XVECTOR (fun)->contents[COMPILED_BYTECODE]))
+ Ffetch_bytecode (fun);
+ val = Fbyte_code (XVECTOR (fun)->contents[COMPILED_BYTECODE],
+ XVECTOR (fun)->contents[COMPILED_CONSTANTS],
+ XVECTOR (fun)->contents[COMPILED_STACK_DEPTH]);
+ }
return unbind_to (count, val);
}
+
+DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode,
+ 1, 1, 0,
+ "If byte-compiled OBJECT is lazy-loaded, fetch it now.")
+ (object)
+ Lisp_Object object;
+{
+ Lisp_Object tem;
+
+ if (COMPILEDP (object)
+ && CONSP (XVECTOR (object)->contents[COMPILED_BYTECODE]))
+ {
+ tem = read_doc_string (XVECTOR (object)->contents[COMPILED_BYTECODE]);
+ if (!CONSP (tem))
+ error ("invalid byte code");
+ XVECTOR (object)->contents[COMPILED_BYTECODE] = XCONS (tem)->car;
+ XVECTOR (object)->contents[COMPILED_CONSTANTS] = XCONS (tem)->cdr;
+ }
+ return object;
+}
\f
void
grow_specpdl ()
specbind (symbol, value)
Lisp_Object symbol, value;
{
- extern void store_symval_forwarding (); /* in eval.c */
Lisp_Object ovalue;
CHECK_SYMBOL (symbol, 0);
grow_specpdl ();
specpdl_ptr->symbol = symbol;
specpdl_ptr->func = 0;
- ovalue = XSYMBOL (symbol)->value;
- specpdl_ptr->old_value = EQ (ovalue, Qunbound) ? Qunbound : Fsymbol_value (symbol);
+ specpdl_ptr->old_value = ovalue = find_symbol_value (symbol);
specpdl_ptr++;
- if (XTYPE (ovalue) == Lisp_Buffer_Objfwd)
+ if (BUFFER_OBJFWDP (ovalue) || KBOARD_OBJFWDP (ovalue))
store_symval_forwarding (symbol, ovalue, value);
else
Fset (symbol, value);
extern Lisp_Object Vprint_level;
struct gcpro gcpro1;
- XFASTINT (Vprint_level) = 3;
+ XSETFASTINT (Vprint_level, 3);
tail = Qnil;
GCPRO1 (tail);
if (backlist->nargs == UNEVALLED)
{
Fprin1 (Fcons (*backlist->function, *backlist->args), Qnil);
+ write_string ("\n", -1);
}
else
{
Fprin1 (backlist->args[i], Qnil);
}
}
+ write_string (")\n", -1);
}
- write_string (")\n", -1);
backlist = backlist->next;
}
}
DEFUN ("backtrace-frame", Fbacktrace_frame, Sbacktrace_frame, 1, 1, "",
- "Return the function and arguments N frames up from current execution point.\n\
+ "Return the function and arguments NFRAMES up from current execution point.\n\
If that frame has not evaluated the arguments yet (or is a special form),\n\
the value is (nil FUNCTION ARG-FORMS...).\n\
If that frame has evaluated its arguments and called its function already,\n\
A &rest arg is represented as the tail of the list ARG-VALUES.\n\
FUNCTION is whatever was supplied as car of evaluated list,\n\
or a lambda expression for macro calls.\n\
-If N is more than the number of frames, the value is nil.")
+If NFRAMES is more than the number of frames, the value is nil.")
(nframes)
Lisp_Object nframes;
{
CHECK_NATNUM (nframes, 0);
/* Find the frame requested. */
- for (i = 0; i < XFASTINT (nframes); i++)
+ for (i = 0; backlist && i < XFASTINT (nframes); i++)
backlist = backlist->next;
if (!backlist)
DEFVAR_LISP ("quit-flag", &Vquit_flag,
"Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
-Typing C-G sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
+Typing C-g sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
Vquit_flag = Qnil;
DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit,
"Non-nil inhibits C-g quitting from happening immediately.\n\
Note that `quit-flag' will still be set by typing C-g,\n\
-so a quit will be signalled as soon as `inhibit-quit' is nil.\n\
+so a quit will be signaled as soon as `inhibit-quit' is nil.\n\
To prevent this happening, set `quit-flag' to nil\n\
before making `inhibit-quit' nil.");
Vinhibit_quit = Qnil;
See also variable `debug-on-quit'.");
Vdebug_on_error = Qnil;
+ DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors,
+ "*List of errors for which the debugger should not be called.\n\
+Each element may be a condition-name or a regexp that matches error messages.\n\
+If any element applies to a given error, that error skips the debugger\n\
+and just returns to top level.\n\
+This overrides the variable `debug-on-error'.\n\
+It does not apply to errors handled by `condition-case'.");
+ Vdebug_ignored_errors = Qnil;
+
DEFVAR_BOOL ("debug-on-quit", &debug_on_quit,
- "*Non-nil means enter debugger if quit is signaled (C-G, for example).\n\
+ "*Non-nil means enter debugger if quit is signaled (C-g, for example).\n\
Does not apply if quit is handled by a `condition-case'.");
debug_on_quit = 0;
DEFVAR_LISP ("run-hooks", &Vrun_hooks,
"Set to the function `run-hooks', if that function has been defined.\n\
Otherwise, nil (in a bare Emacs without preloaded Lisp code).");
- Vrun_hooks = Qnil;
staticpro (&Vautoload_queue);
Vautoload_queue = Qnil;
defsubr (&Seval);
defsubr (&Sapply);
defsubr (&Sfuncall);
+ defsubr (&Srun_hooks);
+ defsubr (&Srun_hook_with_args);
+ defsubr (&Srun_hook_with_args_until_success);
+ defsubr (&Srun_hook_with_args_until_failure);
+ defsubr (&Sfetch_bytecode);
defsubr (&Sbacktrace_debug);
defsubr (&Sbacktrace);
defsubr (&Sbacktrace_frame);
HCoop / bpt / emacs.git / blobdiff