/* Evaluator for GNU Emacs Lisp interpreter.
Copyright (C) 1985-1987, 1993-1995, 1999-2024 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 3 of the License, or (at
your option) any later version.
GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GNU Emacs. If not, see . */
#include
#include
#include
#include "lisp.h"
#include "blockinput.h"
#include "commands.h"
#include "keyboard.h"
#include "dispextern.h"
#include "buffer.h"
#include "pdumper.h"
#include "atimer.h"
/* Non-nil means record all fset's and provide's, to be undone
if the file being autoloaded is not fully loaded.
They are recorded by being consed onto the front of Vautoload_queue:
(FUN . ODEF) for a defun, (0 . OFEATURES) for a provide. */
Lisp_Object Vautoload_queue;
/* This holds either the symbol `run-hooks' or nil.
It is nil at an early stage of startup, and when Emacs
is shutting down. */
Lisp_Object Vrun_hooks;
/* The function from which the last `signal' was called. Set in
Fsignal. */
/* FIXME: We should probably get rid of this! */
Lisp_Object Vsignaling_function;
/* These would ordinarily be static, but they need to be visible to GDB. */
bool backtrace_p (union specbinding *) EXTERNALLY_VISIBLE;
union specbinding *backtrace_next (union specbinding *) EXTERNALLY_VISIBLE;
union specbinding *backtrace_top (void) EXTERNALLY_VISIBLE;
static Lisp_Object funcall_lambda (Lisp_Object, ptrdiff_t, Lisp_Object *);
static Lisp_Object apply_lambda (Lisp_Object, Lisp_Object, specpdl_ref);
static Lisp_Object lambda_arity (Lisp_Object);
static Lisp_Object
specpdl_symbol (union specbinding *pdl)
{
eassert (pdl->kind >= SPECPDL_LET);
return pdl->let.symbol;
}
static enum specbind_tag
specpdl_kind (union specbinding *pdl)
{
eassert (pdl->kind >= SPECPDL_LET);
return pdl->let.kind;
}
static Lisp_Object
specpdl_old_value (union specbinding *pdl)
{
eassert (pdl->kind >= SPECPDL_LET);
return pdl->let.old_value;
}
static void
set_specpdl_old_value (union specbinding *pdl, Lisp_Object val)
{
eassert (pdl->kind >= SPECPDL_LET);
pdl->let.old_value = val;
}
static Lisp_Object
specpdl_where (union specbinding *pdl)
{
eassert (pdl->kind > SPECPDL_LET);
return pdl->let.where.buf;
}
static KBOARD *
specpdl_kboard (union specbinding *pdl)
{
eassert (pdl->kind == SPECPDL_LET);
return pdl->let.where.kbd;
}
static Lisp_Object
specpdl_arg (union specbinding *pdl)
{
eassert (pdl->kind == SPECPDL_UNWIND);
return pdl->unwind.arg;
}
/* To work around GDB bug 32313
make
backtrace_* functions visible-to-GDB pointers instead of merely
being an externally visible functions themselves. Declare the
pointer first to pacify gcc -Wmissing-variable-declarations. */
#define GDB_FUNCPTR(func, resulttype, params) \
extern resulttype (*const func) params EXTERNALLY_VISIBLE; \
resulttype (*const func) params = func##_body
static Lisp_Object
backtrace_function_body (union specbinding *pdl)
{
eassert (pdl->kind == SPECPDL_BACKTRACE);
return pdl->bt.function;
}
GDB_FUNCPTR (backtrace_function, Lisp_Object, (union specbinding *));
static ptrdiff_t
backtrace_nargs (union specbinding *pdl)
{
eassert (pdl->kind == SPECPDL_BACKTRACE);
return pdl->bt.nargs;
}
static Lisp_Object *
backtrace_args_body (union specbinding *pdl)
{
eassert (pdl->kind == SPECPDL_BACKTRACE);
return pdl->bt.args;
}
GDB_FUNCPTR (backtrace_args, Lisp_Object *, (union specbinding *));
/* Functions to modify slots of backtrace records. */
static void
set_backtrace_args (union specbinding *pdl, Lisp_Object *args, ptrdiff_t nargs)
{
eassert (pdl->kind == SPECPDL_BACKTRACE);
pdl->bt.args = args;
pdl->bt.nargs = nargs;
}
static void
set_backtrace_debug_on_exit (union specbinding *pdl, bool doe)
{
eassert (pdl->kind == SPECPDL_BACKTRACE);
pdl->bt.debug_on_exit = doe;
}
/* Helper functions to scan the backtrace. */
bool
backtrace_p (union specbinding *pdl)
{ return specpdl ? pdl >= specpdl : false; }
static bool
backtrace_thread_p (struct thread_state *tstate, union specbinding *pdl)
{ return pdl >= tstate->m_specpdl; }
union specbinding *
backtrace_top (void)
{
/* This is so "xbacktrace" doesn't crash in pdumped Emacs if they
invoke the command before init_eval_once_for_pdumper initializes
specpdl machinery. See also backtrace_p above. */
if (!specpdl)
return NULL;
union specbinding *pdl = specpdl_ptr - 1;
while (backtrace_p (pdl) && pdl->kind != SPECPDL_BACKTRACE)
pdl--;
return pdl;
}
static union specbinding *
backtrace_thread_top (struct thread_state *tstate)
{
union specbinding *pdl = tstate->m_specpdl_ptr - 1;
while (backtrace_thread_p (tstate, pdl) && pdl->kind != SPECPDL_BACKTRACE)
pdl--;
return pdl;
}
union specbinding *
backtrace_next (union specbinding *pdl)
{
pdl--;
while (backtrace_p (pdl) && pdl->kind != SPECPDL_BACKTRACE)
pdl--;
return pdl;
}
static void init_eval_once_for_pdumper (void);
static union specbinding *
backtrace_thread_next (struct thread_state *tstate, union specbinding *pdl)
{
pdl--;
while (backtrace_thread_p (tstate, pdl) && pdl->kind != SPECPDL_BACKTRACE)
pdl--;
return pdl;
}
void
init_eval_once (void)
{
/* Don't forget to update docs (lispref node "Eval"). */
Vrun_hooks = Qnil;
pdumper_do_now_and_after_load (init_eval_once_for_pdumper);
}
static void
init_eval_once_for_pdumper (void)
{
enum { size = 50 };
union specbinding *pdlvec = malloc ((size + 1) * sizeof *specpdl);
specpdl = specpdl_ptr = pdlvec + 1;
specpdl_end = specpdl + size;
}
void
init_eval (void)
{
specpdl_ptr = specpdl;
{ /* Put a dummy catcher at top-level so that handlerlist is never NULL.
This is important since handlerlist->nextfree holds the freelist
which would otherwise leak every time we unwind back to top-level. */
handlerlist_sentinel = xzalloc (sizeof (struct handler));
handlerlist = handlerlist_sentinel->nextfree = handlerlist_sentinel;
struct handler *c = push_handler (Qunbound, CATCHER);
eassert (c == handlerlist_sentinel);
handlerlist_sentinel->nextfree = NULL;
handlerlist_sentinel->next = NULL;
}
Vquit_flag = Qnil;
debug_on_next_call = 0;
lisp_eval_depth = 0;
/* This is less than the initial value of num_nonmacro_input_events. */
when_entered_debugger = -1;
}
static void
restore_stack_limits (Lisp_Object data)
{
intmax_t old_depth;
integer_to_intmax (data, &old_depth);
lisp_eval_depth_reserve += max_lisp_eval_depth - old_depth;
max_lisp_eval_depth = old_depth;
}
/* Try and ensure that we have at least B dpeth available. */
static void
max_ensure_room (intmax_t b)
{
intmax_t sum = ckd_add (&sum, lisp_eval_depth, b) ? INTMAX_MAX : sum;
intmax_t diff = min (sum - max_lisp_eval_depth, lisp_eval_depth_reserve);
if (diff <= 0)
return;
intmax_t old_depth = max_lisp_eval_depth;
max_lisp_eval_depth += diff;
lisp_eval_depth_reserve -= diff;
/* Restore limits after leaving the debugger. */
record_unwind_protect (restore_stack_limits, make_int (old_depth));
}
/* Call the Lisp debugger, giving it argument ARG. */
Lisp_Object
call_debugger (Lisp_Object arg)
{
bool debug_while_redisplaying;
specpdl_ref count = SPECPDL_INDEX ();
Lisp_Object val;
/* The previous value of 40 is too small now that the debugger
prints using cl-prin1 instead of prin1. Printing lists nested 8
deep (which is the value of print-level used in the debugger)
currently requires 77 additional frames. See bug#31919. */
max_ensure_room (100);
#ifdef HAVE_WINDOW_SYSTEM
if (display_hourglass_p)
cancel_hourglass ();
#endif
debug_on_next_call = 0;
when_entered_debugger = num_nonmacro_input_events;
/* Resetting redisplaying_p to 0 makes sure that debug output is
displayed if the debugger is invoked during redisplay. */
debug_while_redisplaying = redisplaying_p;
redisplaying_p = 0;
specbind (Qdebugger_may_continue,
debug_while_redisplaying ? Qnil : Qt);
specbind (Qinhibit_redisplay, Qnil);
specbind (Qinhibit_debugger, Qt);
/* If we are debugging an error while `inhibit-changing-match-data'
is bound to non-nil (e.g., within a call to `string-match-p'),
then make sure debugger code can still use match data. */
specbind (Qinhibit_changing_match_data, Qnil);
#if 0 /* Binding this prevents execution of Lisp code during
redisplay, which necessarily leads to display problems. */
specbind (Qinhibit_eval_during_redisplay, Qt);
#endif
val = apply1 (Vdebugger, arg);
/* Interrupting redisplay and resuming it later is not safe under
all circumstances. So, when the debugger returns, abort the
interrupted redisplay by going back to the top-level. */
/* FIXME: Move this to the redisplay code? */
if (debug_while_redisplaying
&& !EQ (Vdebugger, Qdebug_early))
Ftop_level ();
return unbind_to (count, val);
}
void
do_debug_on_call (Lisp_Object code, specpdl_ref count)
{
debug_on_next_call = 0;
set_backtrace_debug_on_exit (specpdl_ref_to_ptr (count), true);
call_debugger (list1 (code));
}
DEFUN ("or", For, Sor, 0, UNEVALLED, 0,
doc: /* Eval args until one of them yields non-nil, then return that value.
The remaining args are not evalled at all.
If all args return nil, return nil.
usage: (or CONDITIONS...) */)
(Lisp_Object args)
{
Lisp_Object val = Qnil;
while (CONSP (args))
{
Lisp_Object arg = XCAR (args);
args = XCDR (args);
val = eval_sub (arg);
if (!NILP (val))
break;
}
return val;
}
DEFUN ("and", Fand, Sand, 0, UNEVALLED, 0,
doc: /* Eval args until one of them yields nil, then return nil.
The remaining args are not evalled at all.
If no arg yields nil, return the last arg's value.
usage: (and CONDITIONS...) */)
(Lisp_Object args)
{
Lisp_Object val = Qt;
while (CONSP (args))
{
Lisp_Object arg = XCAR (args);
args = XCDR (args);
val = eval_sub (arg);
if (NILP (val))
break;
}
return val;
}
DEFUN ("if", Fif, Sif, 2, UNEVALLED, 0,
doc: /* If COND yields non-nil, do THEN, else do ELSE...
Returns the value of THEN or the value of the last of the ELSE's.
THEN must be one expression, but ELSE... can be zero or more expressions.
If COND yields nil, and there are no ELSE's, the value is nil.
usage: (if COND THEN ELSE...) */)
(Lisp_Object args)
{
Lisp_Object cond;
cond = eval_sub (XCAR (args));
if (!NILP (cond))
return eval_sub (Fcar (XCDR (args)));
return Fprogn (Fcdr (XCDR (args)));
}
DEFUN ("cond", Fcond, Scond, 0, UNEVALLED, 0,
doc: /* Try each clause until one succeeds.
Each clause looks like (CONDITION BODY...). CONDITION is evaluated
and, if the value is non-nil, this clause succeeds:
then the expressions in BODY are evaluated and the last one's
value is the value of the cond-form.
If a clause has one element, as in (CONDITION), then the cond-form
returns CONDITION's value, if that is non-nil.
If no clause succeeds, cond returns nil.
usage: (cond CLAUSES...) */)
(Lisp_Object args)
{
Lisp_Object val = args;
while (CONSP (args))
{
Lisp_Object clause = XCAR (args);
val = eval_sub (Fcar (clause));
if (!NILP (val))
{
if (!NILP (XCDR (clause)))
val = Fprogn (XCDR (clause));
break;
}
args = XCDR (args);
}
return val;
}
DEFUN ("progn", Fprogn, Sprogn, 0, UNEVALLED, 0,
doc: /* Eval BODY forms sequentially and return value of last one.
usage: (progn BODY...) */)
(Lisp_Object body)
{
Lisp_Object val = Qnil;
while (CONSP (body))
{
Lisp_Object form = XCAR (body);
body = XCDR (body);
val = eval_sub (form);
}
return val;
}
/* Evaluate BODY sequentially, discarding its value. */
void
prog_ignore (Lisp_Object body)
{
Fprogn (body);
}
DEFUN ("prog1", Fprog1, Sprog1, 1, UNEVALLED, 0,
doc: /* Eval FIRST and BODY sequentially; return value from FIRST.
The value of FIRST is saved during the evaluation of the remaining args,
whose values are discarded.
usage: (prog1 FIRST BODY...) */)
(Lisp_Object args)
{
Lisp_Object val = eval_sub (XCAR (args));
prog_ignore (XCDR (args));
return val;
}
DEFUN ("setq", Fsetq, Ssetq, 0, UNEVALLED, 0,
doc: /* Set each SYM to the value of its VAL.
The symbols SYM are variables; they are literal (not evaluated).
The values VAL are expressions; they are evaluated.
Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
The second VAL is not computed until after the first SYM is set, and so on;
each VAL can use the new value of variables set earlier in the `setq'.
The return value of the `setq' form is the value of the last VAL.
usage: (setq [SYM VAL]...) */)
(Lisp_Object args)
{
Lisp_Object val = args, tail = args;
for (EMACS_INT nargs = 0; CONSP (tail); nargs += 2)
{
Lisp_Object sym = XCAR (tail);
tail = XCDR (tail);
if (!CONSP (tail))
xsignal2 (Qwrong_number_of_arguments, Qsetq, make_fixnum (nargs + 1));
Lisp_Object arg = XCAR (tail);
tail = XCDR (tail);
val = eval_sub (arg);
/* Like for eval_sub, we do not check declared_special here since
it's been done when let-binding. */
Lisp_Object lex_binding
= (SYMBOLP (sym)
? Fassq (sym, Vinternal_interpreter_environment)
: Qnil);
if (!NILP (lex_binding))
XSETCDR (lex_binding, val); /* SYM is lexically bound. */
else
Fset (sym, val); /* SYM is dynamically bound. */
}
return val;
}
DEFUN ("quote", Fquote, Squote, 1, UNEVALLED, 0,
doc: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
Warning: `quote' does not construct its return value, but just returns
the value that was pre-constructed by the Lisp reader (see info node
`(elisp)Printed Representation').
This means that \\='(a . b) is not identical to (cons \\='a \\='b): the former
does not cons. Quoting should be reserved for constants that will
never be modified by side-effects, unless you like self-modifying code.
See the common pitfall in info node `(elisp)Rearrangement' for an example
of unexpected results when a quoted object is modified.
usage: (quote ARG) */)
(Lisp_Object args)
{
if (!NILP (XCDR (args)))
xsignal2 (Qwrong_number_of_arguments, Qquote, Flength (args));
return XCAR (args);
}
DEFUN ("function", Ffunction, Sfunction, 1, UNEVALLED, 0,
doc: /* Like `quote', but preferred for objects which are functions.
In byte compilation, `function' causes its argument to be handled by
the byte compiler. Similarly, when expanding macros and expressions,
ARG can be examined and possibly expanded. If `quote' is used
instead, this doesn't happen.
usage: (function ARG) */)
(Lisp_Object args)
{
Lisp_Object quoted = XCAR (args);
if (!NILP (XCDR (args)))
xsignal2 (Qwrong_number_of_arguments, Qfunction, Flength (args));
if (CONSP (quoted)
&& EQ (XCAR (quoted), Qlambda))
{ /* This is a lambda expression within a lexical environment;
return an interpreted closure instead of a simple lambda. */
Lisp_Object cdr = XCDR (quoted);
Lisp_Object args = Fcar (cdr);
cdr = Fcdr (cdr);
Lisp_Object docstring = Qnil, iform = Qnil;
if (CONSP (cdr))
{
docstring = XCAR (cdr);
if (STRINGP (docstring))
{
Lisp_Object tmp = XCDR (cdr);
if (!NILP (tmp))
cdr = tmp;
else /* It's not a docstring, it's a return value. */
docstring = Qnil;
}
/* Handle the special (:documentation