/* Evaluator for GNU Emacs Lisp interpreter.
- Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995 Free Software Foundation, Inc.
+ Copyright (C) 1985, 86, 87, 93, 94, 95, 1999 Free Software Foundation, Inc.
This file is part of GNU Emacs.
#include <config.h>
+
#include "lisp.h"
#include "blockinput.h"
int lisp_eval_depth;
int pdlcount;
int poll_suppress_count;
+ struct byte_stack *byte_stack;
};
struct catchtag *catchlist;
+#ifdef DEBUG_GCPRO
+/* Count levels of GCPRO to detect failure to UNGCPRO. */
+int gcpro_level;
+#endif
+
Lisp_Object Qautoload, Qmacro, Qexit, Qinteractive, Qcommandp, Qdefun;
Lisp_Object Qinhibit_quit, Vinhibit_quit, Vquit_flag;
Lisp_Object Qmocklisp_arguments, Vmocklisp_arguments, Qmocklisp;
Lisp_Object funcall_lambda ();
extern Lisp_Object ml_apply (); /* Apply a mocklisp function to unevaluated argument list */
+void
init_eval_once ()
{
specpdl_size = 50;
Vrun_hooks = Qnil;
}
+void
init_eval ()
{
specpdl_ptr = specpdl;
Vquit_flag = Qnil;
debug_on_next_call = 0;
lisp_eval_depth = 0;
+#ifdef DEBUG_GCPRO
+ gcpro_level = 0;
+#endif
/* This is less than the initial value of num_nonmacro_input_events. */
when_entered_debugger = -1;
}
return apply1 (Vdebugger, arg);
}
+void
do_debug_on_call (code)
Lisp_Object code;
{
val = Feval (Fcar (clause));
if (!NILP (val))
{
- if (!EQ (XCONS (clause)->cdr, Qnil))
- val = Fprogn (XCONS (clause)->cdr);
+ if (!EQ (XCDR (clause), Qnil))
+ val = Fprogn (XCDR (clause));
break;
}
- args = XCONS (args)->cdr;
+ args = XCDR (args);
}
UNGCPRO;
DEFUN ("defconst", Fdefconst, Sdefconst, 2, UNEVALLED, 0,
"(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\
+The intent is that neither programs nor users should ever change this value.\n\
Always sets the value of SYMBOL to the result of evalling INITVALUE.\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\
-Note: do not use `defconst' for user options in libraries that are not\n\
-normally loaded, since it is useful for users to be able to specify\n\
-their own values for such variables before loading the library.\n\
-Since `defconst' unconditionally assigns the variable,\n\
-it would override the user's choice.")
+DOCSTRING is optional.")
(args)
Lisp_Object args;
{
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)
+ && STRINGP (XCAR (documentation))
+ && INTEGERP (XCDR (documentation))
+ && XINT (XCDR (documentation)) < 0)
return Qt;
return Qnil;
}
if (!CONSP (form))
break;
/* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
- def = sym = XCONS (form)->car;
+ def = sym = XCAR (form);
tem = Qnil;
/* Trace symbols aliases to other symbols
until we get a symbol that is not an alias. */
if (EQ (def, Qunbound) || !CONSP (def))
/* Not defined or definition not suitable */
break;
- if (EQ (XCONS (def)->car, Qautoload))
+ if (EQ (XCAR (def), Qautoload))
{
/* Autoloading function: will it be a macro when loaded? */
tem = Fnth (make_number (4), def);
else
break;
}
- else if (!EQ (XCONS (def)->car, Qmacro))
+ else if (!EQ (XCAR (def), Qmacro))
break;
- else expander = XCONS (def)->cdr;
+ else expander = XCDR (def);
}
else
{
- expander = XCONS (tem)->cdr;
+ expander = XCDR (tem);
if (NILP (expander))
break;
}
- form = apply1 (expander, XCONS (form)->cdr);
+ form = apply1 (expander, XCDR (form));
}
return form;
}
\f
DEFUN ("catch", Fcatch, Scatch, 1, UNEVALLED, 0,
"(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.\n\
-TAG is evalled to get the tag to use. Then the BODY is executed.\n\
+TAG is evalled to get the tag to use; it must not be nil.\n\
+\n\
+Then the BODY is executed.\n\
Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.\n\
If no throw happens, `catch' returns the value of the last BODY form.\n\
If a throw happens, it specifies the value to return from `catch'.")
c.pdlcount = specpdl_ptr - specpdl;
c.poll_suppress_count = poll_suppress_count;
c.gcpro = gcprolist;
+ c.byte_stack = byte_stack_list;
catchlist = &c;
/* Call FUNC. */
}
while (! last_time);
+ byte_stack_list = catch->byte_stack;
gcprolist = catch->gcpro;
+#ifdef DEBUG_GCPRO
+ if (gcprolist != 0)
+ gcpro_level = gcprolist->level + 1;
+ else
+ gcpro_level = 0;
+#endif
backtrace_list = catch->backlist;
lisp_eval_depth = catch->lisp_eval_depth;
tem = Fcar (val);
if (! (NILP (tem)
|| (CONSP (tem)
- && (SYMBOLP (XCONS (tem)->car)
- || CONSP (XCONS (tem)->car)))))
+ && (SYMBOLP (XCAR (tem))
+ || CONSP (XCAR (tem))))))
error ("Invalid condition handler", tem);
}
c.pdlcount = specpdl_ptr - specpdl;
c.poll_suppress_count = poll_suppress_count;
c.gcpro = gcprolist;
+ c.byte_stack = byte_stack_list;
if (_setjmp (c.jmp))
{
if (!NILP (h.var))
c.pdlcount = specpdl_ptr - specpdl;
c.poll_suppress_count = poll_suppress_count;
c.gcpro = gcprolist;
+ c.byte_stack = byte_stack_list;
if (_setjmp (c.jmp))
{
return (*hfun) (c.val);
c.pdlcount = specpdl_ptr - specpdl;
c.poll_suppress_count = poll_suppress_count;
c.gcpro = gcprolist;
+ c.byte_stack = byte_stack_list;
if (_setjmp (c.jmp))
{
return (*hfun) (c.val);
(error_symbol, data)
Lisp_Object error_symbol, data;
{
+ /* When memory is full, ERROR-SYMBOL is nil,
+ and DATA is (REAL-ERROR-SYMBOL . REAL-DATA). */
register struct handler *allhandlers = handlerlist;
Lisp_Object conditions;
extern int gc_in_progress;
Lisp_Object debugger_value;
Lisp_Object string;
Lisp_Object real_error_symbol;
- Lisp_Object combined_data;
+ extern int display_busy_cursor_p;
- quit_error_check ();
immediate_quit = 0;
if (gc_in_progress || waiting_for_input)
abort ();
-#ifdef HAVE_WINDOW_SYSTEM
TOTALLY_UNBLOCK_INPUT;
-#endif
if (NILP (error_symbol))
real_error_symbol = Fcar (data);
else
real_error_symbol = error_symbol;
+#ifdef HAVE_X_WINDOWS
+ if (display_busy_cursor_p)
+ Fx_hide_busy_cursor (Qt);
+#endif
+
/* This hook is used by edebug. */
if (! NILP (Vsignal_hook_function))
call2 (Vsignal_hook_function, error_symbol, data);
data = Fcons (error_symbol, data);
string = Ferror_message_string (data);
- fatal (XSTRING (string)->data, 0, 0);
+ fatal ("%s", XSTRING (string)->data, 0);
}
/* Return nonzero iff LIST is a non-nil atom or
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))
+ this = XCAR (conditions);
+ for (tail = list; CONSP (tail); tail = XCDR (tail))
+ if (EQ (XCAR (tail), this))
return 1;
- conditions = XCONS (conditions)->cdr;
+ conditions = XCDR (conditions);
}
return 0;
}
Lisp_Object error_message;
for (tail = Vdebug_ignored_errors; CONSP (tail);
- tail = XCONS (tail)->cdr)
+ tail = XCDR (tail))
{
- if (STRINGP (XCONS (tail)->car))
+ if (STRINGP (XCAR (tail)))
{
if (first_string)
{
error_message = Ferror_message_string (data);
first_string = 0;
}
- if (fast_string_match (XCONS (tail)->car, error_message) >= 0)
+ if (fast_string_match (XCAR (tail), 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))
+ contail = XCDR (contail))
+ if (EQ (XCAR (tail), XCAR (contail)))
return 1;
}
}
/* Value of Qlambda means we have called debugger and user has continued.
There are two ways to pass SIG and DATA:
- - SIG is the error symbol, and DATA is the rest of the data.
+ = SIG is the error symbol, and DATA is the rest of the data.
= SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
+ This is for memory-full errors only.
Store value returned from debugger into *DEBUGGER_VALUE_PTR. */
int count = specpdl_ptr - specpdl;
int debugger_called = 0;
Lisp_Object sig_symbol, combined_data;
+ /* This is set to 1 if we are handling a memory-full error,
+ because these must not run the debugger.
+ (There is no room in memory to do that!) */
+ int no_debugger = 0;
if (NILP (sig))
{
combined_data = data;
sig_symbol = Fcar (data);
+ no_debugger = 1;
}
else
{
}
if (wants_debugger (Vstack_trace_on_error, conditions))
- internal_with_output_to_temp_buffer ("*Backtrace*", Fbacktrace, Qnil);
- if ((EQ (sig_symbol, Qquit)
- ? debug_on_quit
- : wants_debugger (Vdebug_on_error, conditions))
+ {
+#ifdef __STDC__
+ internal_with_output_to_temp_buffer ("*Backtrace*",
+ (Lisp_Object (*) (Lisp_Object)) Fbacktrace,
+ Qnil);
+#else
+ internal_with_output_to_temp_buffer ("*Backtrace*",
+ Fbacktrace, Qnil);
+#endif
+ }
+ if (! no_debugger
+ && (EQ (sig_symbol, Qquit)
+ ? debug_on_quit
+ : wants_debugger (Vdebug_on_error, conditions))
&& ! skip_debugger (conditions, combined_data)
&& when_entered_debugger < num_nonmacro_input_events)
{
tem = Fmemq (Fcar (condit), conditions);
if (!NILP (tem))
return handler;
- condit = XCONS (condit)->cdr;
+ condit = XCDR (condit);
}
}
}
while (1)
{
- int used = doprnt (buf, size, m, m + mlen, 3, args);
+ int used = doprnt (buffer, size, m, m + mlen, 3, args);
if (used < size)
break;
size *= 2;
}
}
- string = build_string (buf);
+ string = build_string (buffer);
if (allocated)
free (buffer);
{
register Lisp_Object fun;
register Lisp_Object funcar;
- register Lisp_Object tem;
- register int i = 0;
fun = function;
/* If function is defined and not as an autoload, don't override */
if (!EQ (XSYMBOL (function)->function, Qunbound)
&& !(CONSP (XSYMBOL (function)->function)
- && EQ (XCONS (XSYMBOL (function)->function)->car, Qautoload)))
+ && EQ (XCAR (XSYMBOL (function)->function), Qautoload)))
return Qnil;
#ifdef NO_ARG_ARRAY
FUNNAME is the symbol which is the function's name.
FUNDEF is the autoload definition (a list). */
+void
do_autoload (fundef, funname)
Lisp_Object fundef, funname;
{
int count = specpdl_ptr - specpdl;
- Lisp_Object fun, val, queue, first, second;
+ Lisp_Object fun, queue, first, second;
struct gcpro gcpro1, gcpro2, gcpro3;
fun = funname;
CHECK_SYMBOL (funname, 0);
GCPRO3 (fun, funname, fundef);
- /* Value saved here is to be restored into Vautoload_queue */
+ /* Preserve the match data. */
+ record_unwind_protect (Fset_match_data, Fmatch_data (Qnil, Qnil));
+
+ /* Value saved here is to be restored into Vautoload_queue. */
record_unwind_protect (un_autoload, Vautoload_queue);
Vautoload_queue = Qt;
Fload (Fcar (Fcdr (fundef)), Qnil, noninteractive ? Qt : Qnil, Qnil, Qt);
- /* Save the old autoloads, in case we ever do an unload. */
+ /* Save the old autoloads, in case we ever do an unload. */
queue = Vautoload_queue;
while (CONSP (queue))
{
/* Note: This test is subtle. The cdr of an autoload-queue entry
may be an atom if the autoload entry was generated by a defalias
- or fset. */
+ or fset. */
if (CONSP (second))
Fput (first, Qautoload, (Fcdr (second)));
struct backtrace backtrace;
struct gcpro gcpro1, gcpro2, gcpro3;
+ /* 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 ();
+
if (SYMBOLP (form))
{
if (EQ (Vmocklisp_arguments, Qt))
if (SUBRP (fun))
{
Lisp_Object numargs;
- Lisp_Object argvals[7];
+ Lisp_Object argvals[8];
Lisp_Object args_left;
register int i, maxargs;
argvals[6]);
goto done;
+ case 8:
+ val = (*XSUBR (fun)->function) (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
return Ffuncall (nargs - 1, args);
else if (numargs == 1)
{
- args [nargs - 1] = XCONS (spread_arg)->car;
+ args [nargs - 1] = XCAR (spread_arg);
return Ffuncall (nargs, args);
}
i = nargs - 1;
while (!NILP (spread_arg))
{
- funcall_args [i++] = XCONS (spread_arg)->car;
- spread_arg = XCONS (spread_arg)->cdr;
+ funcall_args [i++] = XCAR (spread_arg);
+ spread_arg = XCDR (spread_arg);
}
RETURN_UNGCPRO (Ffuncall (gcpro1.nvars, funcall_args));
enum run_hooks_condition cond;
{
Lisp_Object sym, val, ret;
- struct gcpro gcpro1, gcpro2;
+ Lisp_Object globals;
+ struct gcpro gcpro1, gcpro2, gcpro3;
/* If we are dying or still initializing,
don't do anything--it would probably crash if we tried. */
if (EQ (val, Qunbound) || NILP (val))
return ret;
- else if (!CONSP (val) || EQ (XCONS (val)->car, Qlambda))
+ else if (!CONSP (val) || EQ (XCAR (val), Qlambda))
{
args[0] = val;
return Ffuncall (nargs, args);
}
else
{
- GCPRO2 (sym, val);
+ globals = Qnil;
+ GCPRO3 (sym, val, globals);
for (;
CONSP (val) && ((cond == to_completion)
|| (cond == until_success ? NILP (ret)
: !NILP (ret)));
- val = XCONS (val)->cdr)
+ val = XCDR (val))
{
- if (EQ (XCONS (val)->car, Qt))
+ if (EQ (XCAR (val), 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)
+ globals = XCDR (globals))
{
- args[0] = XCONS (globals)->car;
+ 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))
}
else
{
- args[0] = XCONS (val)->car;
+ args[0] = XCAR (val);
ret = Ffuncall (nargs, args);
}
}
{
Lisp_Object sym;
Lisp_Object val;
- struct gcpro gcpro1, gcpro2;
+ Lisp_Object globals;
+ struct gcpro gcpro1, gcpro2, gcpro3;
sym = args[0];
- GCPRO2 (sym, val);
+ globals = Qnil;
+ GCPRO3 (sym, val, globals);
- for (val = funlist; CONSP (val); val = XCONS (val)->cdr)
+ for (val = funlist; CONSP (val); val = XCDR (val))
{
- if (EQ (XCONS (val)->car, Qt))
+ if (EQ (XCAR (val), 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)
+ globals = XCDR (globals))
{
- args[0] = XCONS (globals)->car;
+ 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))
}
else
{
- args[0] = XCONS (val)->car;
+ args[0] = XCAR (val);
Ffuncall (nargs, args);
}
}
internal_args[6]);
goto done;
+ case 8:
+ 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], internal_args[7]);
+ goto done;
+
default:
- /* If a subr takes more than 6 arguments without using MANY
+ /* 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 ();
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;
+ XVECTOR (object)->contents[COMPILED_BYTECODE] = XCAR (tem);
+ XVECTOR (object)->contents[COMPILED_CONSTANTS] = XCDR (tem);
}
return object;
}
void
record_unwind_protect (function, arg)
- Lisp_Object (*function)();
+ Lisp_Object (*function) P_ ((Lisp_Object));
Lisp_Object arg;
{
if (specpdl_ptr == specpdl + specpdl_size)
}
}
\f
+void
syms_of_eval ()
{
DEFVAR_INT ("max-specpdl-size", &max_specpdl_size,