/* 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,
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))
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) &&
+ if ((STRINGP (documentation)) &&
((unsigned char) XSTRING (documentation)->data[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);
{
/* 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;
{
/* SYM is not mentioned in ENV.
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);
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
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. */
{
/* 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))
+ if (EQ (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;
- 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);
}
{
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;
}
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;
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)
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))
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]))
+ {
+ tem = read_doc_string (XVECTOR (fun)->contents[COMPILED_BYTECODE]);
+ XVECTOR (fun)->contents[COMPILED_BYTECODE] = XCONS (tem)->car;
+ XVECTOR (fun)->contents[COMPILED_CONSTANTS] = XCONS (tem)->cdr;
+ }
+ val = Fbyte_code (XVECTOR (fun)->contents[COMPILED_BYTECODE],
+ XVECTOR (fun)->contents[COMPILED_CONSTANTS],
+ XVECTOR (fun)->contents[COMPILED_STACK_DEPTH]);
+ }
return unbind_to (count, val);
}
\f
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))
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;
}
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,
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\
+ "*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;
HCoop / bpt / emacs.git / blobdiff