X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/ab422c4d6899b1442cb6954c1829c1fb656b006c..19411656ce2ada9b559362b71a7bff56a1095a96:/src/eval.c
diff --git a/src/eval.c b/src/eval.c
index 7709b8ba2d..b34e692f85 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -1,6 +1,7 @@
/* Evaluator for GNU Emacs Lisp interpreter.
- Copyright (C) 1985-1987, 1993-1995, 1999-2013 Free Software
- Foundation, Inc.
+
+Copyright (C) 1985-1987, 1993-1995, 1999-2014 Free Software Foundation,
+Inc.
This file is part of GNU Emacs.
@@ -26,28 +27,12 @@ along with GNU Emacs. If not, see . */
#include "commands.h"
#include "keyboard.h"
#include "dispextern.h"
-#include "frame.h" /* For XFRAME. */
-
-#if HAVE_X_WINDOWS
-#include "xterm.h"
-#endif
-
-struct backtrace *backtrace_list;
+#include "guile.h"
-#if !BYTE_MARK_STACK
-static
-#endif
-struct catchtag *catchlist;
+static void unbind_once (void *ignore);
-/* Chain of condition handlers currently in effect.
- The elements of this chain are contained in the stack frames
- of Fcondition_case and internal_condition_case.
- When an error is signaled (by calling Fsignal, below),
- this chain is searched for an element that applies. */
+/* Chain of condition and catch handlers currently in effect. */
-#if !BYTE_MARK_STACK
-static
-#endif
struct handler *handlerlist;
#ifdef DEBUG_GCPRO
@@ -78,21 +63,23 @@ Lisp_Object Vrun_hooks;
Lisp_Object Vautoload_queue;
-/* Current number of specbindings allocated in specpdl. */
+/* Current number of specbindings allocated in specpdl, not counting
+ the dummy entry specpdl[-1]. */
ptrdiff_t specpdl_size;
-/* Pointer to beginning of specpdl. */
+/* Pointer to beginning of specpdl. A dummy entry specpdl[-1] exists
+ only so that its address can be taken. */
-struct specbinding *specpdl;
+union specbinding *specpdl;
/* Pointer to first unused element in specpdl. */
-struct specbinding *specpdl_ptr;
+union specbinding *specpdl_ptr;
/* Depth in Lisp evaluations and function calls. */
-static EMACS_INT lisp_eval_depth;
+EMACS_INT lisp_eval_depth;
/* The value of num_nonmacro_input_events as of the last time we
started to enter the debugger. If we decide to enter the debugger
@@ -105,7 +92,7 @@ static EMACS_INT when_entered_debugger;
/* The function from which the last `signal' was called. Set in
Fsignal. */
-
+/* FIXME: We should probably get rid of this! */
Lisp_Object Vsignaling_function;
/* If non-nil, Lisp code must not be run since some part of Emacs is
@@ -114,31 +101,160 @@ Lisp_Object Vsignaling_function;
frame is half-initialized. */
Lisp_Object inhibit_lisp_code;
+/* These would ordinarily be static, but they need to be visible to GDB. */
+bool backtrace_p (union specbinding *) EXTERNALLY_VISIBLE;
+Lisp_Object *backtrace_args (union specbinding *) EXTERNALLY_VISIBLE;
+Lisp_Object backtrace_function (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 bool interactive_p (void);
static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args);
-/* Functions to set Lisp_Object slots of struct specbinding. */
+static Lisp_Object
+specpdl_symbol (union specbinding *pdl)
+{
+ eassert (pdl->kind >= SPECPDL_LET);
+ return pdl->let.symbol;
+}
+
+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;
+}
+
+Lisp_Object
+backtrace_function (union specbinding *pdl)
+{
+ eassert (pdl->kind == SPECPDL_BACKTRACE);
+ return pdl->bt.function;
+}
+
+static ptrdiff_t
+backtrace_nargs (union specbinding *pdl)
+{
+ eassert (pdl->kind == SPECPDL_BACKTRACE);
+ return pdl->bt.nargs;
+}
+
+Lisp_Object *
+backtrace_args (union specbinding *pdl)
+{
+ eassert (pdl->kind == SPECPDL_BACKTRACE);
+ return pdl->bt.args;
+}
+
+static bool
+backtrace_debug_on_exit (union specbinding *pdl)
+{
+ eassert (pdl->kind == SPECPDL_BACKTRACE);
+ return pdl->bt.debug_on_exit;
+}
+
+/* Functions to modify slots of backtrace records. */
+
+static void
+set_backtrace_args (union specbinding *pdl, Lisp_Object *args)
+{
+ eassert (pdl->kind == SPECPDL_BACKTRACE);
+ pdl->bt.args = args;
+}
static void
-set_specpdl_symbol (Lisp_Object symbol)
+set_backtrace_nargs (union specbinding *pdl, ptrdiff_t n)
{
- specpdl_ptr->symbol = symbol;
+ eassert (pdl->kind == SPECPDL_BACKTRACE);
+ pdl->bt.nargs = n;
}
static void
-set_specpdl_old_value (Lisp_Object oldval)
+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 pdl >= specpdl; }
+
+union specbinding *
+backtrace_top (void)
+{
+ union specbinding *pdl = specpdl_ptr - 1;
+ while (backtrace_p (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;
+}
+
+struct handler *
+make_catch_handler (Lisp_Object tag)
+{
+ struct handler *c = xmalloc (sizeof (*c));
+ c->type = CATCHER;
+ c->tag_or_ch = tag;
+ c->val = Qnil;
+ c->var = Qnil;
+ c->body = Qnil;
+ c->next = handlerlist;
+ c->lisp_eval_depth = lisp_eval_depth;
+ c->poll_suppress_count = poll_suppress_count;
+ c->interrupt_input_blocked = interrupt_input_blocked;
+ c->ptag = make_prompt_tag ();
+ return c;
+}
+
+struct handler *
+make_condition_handler (Lisp_Object tag)
{
- specpdl_ptr->old_value = oldval;
+ struct handler *c = xmalloc (sizeof (*c));
+ c->type = CONDITION_CASE;
+ c->tag_or_ch = tag;
+ c->val = Qnil;
+ c->var = Qnil;
+ c->body = Qnil;
+ c->next = handlerlist;
+ c->lisp_eval_depth = lisp_eval_depth;
+ c->poll_suppress_count = poll_suppress_count;
+ c->interrupt_input_blocked = interrupt_input_blocked;
+ c->ptag = make_prompt_tag ();
+ return c;
}
void
init_eval_once (void)
{
enum { size = 50 };
- specpdl = xmalloc (size * sizeof *specpdl);
+ union specbinding *pdlvec = xmalloc ((size + 1) * sizeof *specpdl);
specpdl_size = size;
- specpdl_ptr = specpdl;
+ specpdl = specpdl_ptr = pdlvec + 1;
/* Don't forget to update docs (lispref node "Local Variables"). */
max_specpdl_size = 1300; /* 1000 is not enough for CEDET's c-by.el. */
max_lisp_eval_depth = 600;
@@ -146,13 +262,14 @@ init_eval_once (void)
Vrun_hooks = Qnil;
}
+static struct handler *handlerlist_sentinel;
+
void
init_eval (void)
{
specpdl_ptr = specpdl;
- catchlist = 0;
- handlerlist = 0;
- backtrace_list = 0;
+ handlerlist_sentinel = make_catch_handler (Qunbound);
+ handlerlist = handlerlist_sentinel;
Vquit_flag = Qnil;
debug_on_next_call = 0;
lisp_eval_depth = 0;
@@ -165,38 +282,34 @@ init_eval (void)
/* Unwind-protect function used by call_debugger. */
-static Lisp_Object
+static void
restore_stack_limits (Lisp_Object data)
{
max_specpdl_size = XINT (XCAR (data));
max_lisp_eval_depth = XINT (XCDR (data));
- return Qnil;
}
+static void grow_specpdl (void);
+
/* Call the Lisp debugger, giving it argument ARG. */
Lisp_Object
call_debugger (Lisp_Object arg)
{
bool debug_while_redisplaying;
- ptrdiff_t count = SPECPDL_INDEX ();
+ dynwind_begin ();
Lisp_Object val;
+ EMACS_INT old_depth = max_lisp_eval_depth;
+ /* Do not allow max_specpdl_size less than actual depth (Bug#16603). */
EMACS_INT old_max = max_specpdl_size;
- /* Temporarily bump up the stack limits,
- so the debugger won't run out of stack. */
-
- max_specpdl_size += 1;
- record_unwind_protect (restore_stack_limits,
- Fcons (make_number (old_max),
- make_number (max_lisp_eval_depth)));
- max_specpdl_size = old_max;
-
if (lisp_eval_depth + 40 > max_lisp_eval_depth)
max_lisp_eval_depth = lisp_eval_depth + 40;
- if (max_specpdl_size - 100 < SPECPDL_INDEX ())
- max_specpdl_size = SPECPDL_INDEX () + 100;
+ /* Restore limits after leaving the debugger. */
+ record_unwind_protect (restore_stack_limits,
+ Fcons (make_number (old_max),
+ make_number (old_depth)));
#ifdef HAVE_WINDOW_SYSTEM
if (display_hourglass_p)
@@ -228,15 +341,16 @@ call_debugger (Lisp_Object arg)
if (debug_while_redisplaying)
Ftop_level ();
- return unbind_to (count, val);
+ dynwind_end ();
+ return val;
}
static void
do_debug_on_call (Lisp_Object code)
{
debug_on_next_call = 0;
- backtrace_list->debug_on_exit = 1;
- call_debugger (Fcons (code, Qnil));
+ set_backtrace_debug_on_exit (specpdl_ptr - 1, true);
+ call_debugger (list1 (code));
}
/* NOTE!!! Every function that can call EVAL must protect its args
@@ -299,16 +413,16 @@ If COND yields nil, and there are no ELSE's, the value is nil.
usage: (if COND THEN ELSE...) */)
(Lisp_Object args)
{
- register Lisp_Object cond;
+ Lisp_Object cond;
struct gcpro gcpro1;
GCPRO1 (args);
- cond = eval_sub (Fcar (args));
+ cond = eval_sub (XCAR (args));
UNGCPRO;
if (!NILP (cond))
- return eval_sub (Fcar (Fcdr (args)));
- return Fprogn (Fcdr (Fcdr (args)));
+ return eval_sub (Fcar (XCDR (args)));
+ return Fprogn (XCDR (XCDR (args)));
}
DEFUN ("cond", Fcond, Scond, 0, UNEVALLED, 0,
@@ -317,24 +431,23 @@ 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.
-If a clause has one element, as in (CONDITION),
-CONDITION's value if non-nil is returned from the cond-form.
usage: (cond CLAUSES...) */)
(Lisp_Object args)
{
- register Lisp_Object clause, val;
+ Lisp_Object val = args;
struct gcpro gcpro1;
- val = Qnil;
GCPRO1 (args);
- while (!NILP (args))
+ while (CONSP (args))
{
- clause = Fcar (args);
+ Lisp_Object clause = XCAR (args);
val = eval_sub (Fcar (clause));
if (!NILP (val))
{
- if (!EQ (XCDR (clause), Qnil))
+ if (!NILP (XCDR (clause)))
val = Fprogn (XCDR (clause));
break;
}
@@ -348,23 +461,32 @@ usage: (cond CLAUSES...) */)
DEFUN ("progn", Fprogn, Sprogn, 0, UNEVALLED, 0,
doc: /* Eval BODY forms sequentially and return value of last one.
usage: (progn BODY...) */)
- (Lisp_Object args)
+ (Lisp_Object body)
{
- register Lisp_Object val = Qnil;
+ Lisp_Object val = Qnil;
struct gcpro gcpro1;
- GCPRO1 (args);
+ GCPRO1 (body);
- while (CONSP (args))
+ while (CONSP (body))
{
- val = eval_sub (XCAR (args));
- args = XCDR (args);
+ val = eval_sub (XCAR (body));
+ body = XCDR (body);
}
UNGCPRO;
return val;
}
+/* Evaluate BODY sequentially, discarding its value. Suitable for
+ record_unwind_protect. */
+
+void
+unwind_body (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,
@@ -373,11 +495,11 @@ usage: (prog1 FIRST BODY...) */)
(Lisp_Object args)
{
Lisp_Object val;
- register Lisp_Object args_left;
+ Lisp_Object args_left;
struct gcpro gcpro1, gcpro2;
args_left = args;
- val = Qnil;
+ val = args;
GCPRO2 (args, val);
val = eval_sub (XCAR (args_left));
@@ -414,36 +536,37 @@ The return value of the `setq' form is the value of the last VAL.
usage: (setq [SYM VAL]...) */)
(Lisp_Object args)
{
- register Lisp_Object args_left;
- register Lisp_Object val, sym, lex_binding;
- struct gcpro gcpro1;
-
- if (NILP (args))
- return Qnil;
-
- args_left = args;
- GCPRO1 (args);
+ Lisp_Object val, sym, lex_binding;
- do
+ val = args;
+ if (CONSP (args))
{
- val = eval_sub (Fcar (Fcdr (args_left)));
- sym = Fcar (args_left);
+ Lisp_Object args_left = args;
+ struct gcpro gcpro1;
+ GCPRO1 (args);
- /* Like for eval_sub, we do not check declared_special here since
- it's been done when let-binding. */
- if (!NILP (Vinternal_interpreter_environment) /* Mere optimization! */
- && SYMBOLP (sym)
- && !NILP (lex_binding
- = Fassq (sym, Vinternal_interpreter_environment)))
- XSETCDR (lex_binding, val); /* SYM is lexically bound. */
- else
- Fset (sym, val); /* SYM is dynamically bound. */
+ do
+ {
+ val = eval_sub (Fcar (XCDR (args_left)));
+ sym = XCAR (args_left);
+
+ /* Like for eval_sub, we do not check declared_special here since
+ it's been done when let-binding. */
+ if (!NILP (Vinternal_interpreter_environment) /* Mere optimization! */
+ && SYMBOLP (sym)
+ && !NILP (lex_binding
+ = Fassq (sym, Vinternal_interpreter_environment)))
+ XSETCDR (lex_binding, val); /* SYM is lexically bound. */
+ else
+ Fset (sym, val); /* SYM is dynamically bound. */
+
+ args_left = Fcdr (XCDR (args_left));
+ }
+ while (CONSP (args_left));
- args_left = Fcdr (Fcdr (args_left));
+ UNGCPRO;
}
- while (!NILP (args_left));
- UNGCPRO;
return val;
}
@@ -460,9 +583,9 @@ of unexpected results when a quoted object is modified.
usage: (quote ARG) */)
(Lisp_Object args)
{
- if (!NILP (Fcdr (args)))
+ if (CONSP (XCDR (args)))
xsignal2 (Qwrong_number_of_arguments, Qquote, Flength (args));
- return Fcar (args);
+ return XCAR (args);
}
DEFUN ("function", Ffunction, Sfunction, 1, UNEVALLED, 0,
@@ -474,7 +597,7 @@ usage: (function ARG) */)
{
Lisp_Object quoted = XCAR (args);
- if (!NILP (Fcdr (args)))
+ if (CONSP (XCDR (args)))
xsignal2 (Qwrong_number_of_arguments, Qfunction, Flength (args));
if (!NILP (Vinternal_interpreter_environment)
@@ -490,102 +613,6 @@ usage: (function ARG) */)
}
-DEFUN ("interactive-p", Finteractive_p, Sinteractive_p, 0, 0, 0,
- doc: /* Return t if the containing function was run directly by user input.
-This means that the function was called with `call-interactively'
-\(which includes being called as the binding of a key)
-and input is currently coming from the keyboard (not a keyboard macro),
-and Emacs is not running in batch mode (`noninteractive' is nil).
-
-The only known proper use of `interactive-p' is in deciding whether to
-display a helpful message, or how to display it. If you're thinking
-of using it for any other purpose, it is quite likely that you're
-making a mistake. Think: what do you want to do when the command is
-called from a keyboard macro?
-
-To test whether your function was called with `call-interactively',
-either (i) add an extra optional argument and give it an `interactive'
-spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
-use `called-interactively-p'. */)
- (void)
-{
- return (INTERACTIVE && interactive_p ()) ? Qt : Qnil;
-}
-
-
-DEFUN ("called-interactively-p", Fcalled_interactively_p, Scalled_interactively_p, 0, 1, 0,
- doc: /* Return t if the containing function was called by `call-interactively'.
-If KIND is `interactive', then only return t if the call was made
-interactively by the user, i.e. not in `noninteractive' mode nor
-when `executing-kbd-macro'.
-If KIND is `any', on the other hand, it will return t for any kind of
-interactive call, including being called as the binding of a key, or
-from a keyboard macro, or in `noninteractive' mode.
-
-The only known proper use of `interactive' for KIND is in deciding
-whether to display a helpful message, or how to display it. If you're
-thinking of using it for any other purpose, it is quite likely that
-you're making a mistake. Think: what do you want to do when the
-command is called from a keyboard macro?
-
-Instead of using this function, it is sometimes cleaner to give your
-function an extra optional argument whose `interactive' spec specifies
-non-nil unconditionally (\"p\" is a good way to do this), or via
-\(not (or executing-kbd-macro noninteractive)). */)
- (Lisp_Object kind)
-{
- return (((INTERACTIVE || !EQ (kind, intern ("interactive")))
- && interactive_p ())
- ? Qt : Qnil);
-}
-
-
-/* Return true if function in which this appears was called using
- call-interactively and is not a built-in. */
-
-static bool
-interactive_p (void)
-{
- struct backtrace *btp;
- Lisp_Object fun;
-
- btp = backtrace_list;
-
- /* If this isn't a byte-compiled function, there may be a frame at
- the top for Finteractive_p. If so, skip it. */
- fun = Findirect_function (btp->function, Qnil);
- if (SUBRP (fun) && (XSUBR (fun) == &Sinteractive_p
- || XSUBR (fun) == &Scalled_interactively_p))
- btp = btp->next;
-
- /* If we're running an Emacs 18-style byte-compiled function, there
- may be a frame for Fbytecode at the top level. In any version of
- Emacs there can be Fbytecode frames for subexpressions evaluated
- inside catch and condition-case. Skip past them.
-
- 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
- && (EQ (btp->function, Qbytecode)
- || 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 false. */
- fun = Findirect_function (btp->function, Qnil);
- if (SUBRP (fun))
- return 0;
-
- /* `btp' points to the frame of a Lisp function that called interactive-p.
- Return t if that function was called interactively. */
- if (btp && btp->next && EQ (btp->next->function, Qcall_interactively))
- return 1;
- return 0;
-}
-
-
DEFUN ("defvaralias", Fdefvaralias, Sdefvaralias, 2, 3, 0,
doc: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
Aliased variables always have the same value; setting one sets the other.
@@ -624,12 +651,11 @@ The return value is BASE-VARIABLE. */)
set_internal (base_variable, find_symbol_value (new_alias), Qnil, 1);
{
- struct specbinding *p;
+ union specbinding *p;
for (p = specpdl_ptr; p > specpdl; )
- if ((--p)->func == NULL
- && (EQ (new_alias,
- CONSP (p->symbol) ? XCAR (p->symbol) : p->symbol)))
+ if ((--p)->kind >= SPECPDL_LET
+ && (EQ (new_alias, specpdl_symbol (p))))
error ("Don't know how to make a let-bound variable an alias");
}
@@ -645,6 +671,51 @@ The return value is BASE-VARIABLE. */)
return base_variable;
}
+static union specbinding *
+default_toplevel_binding (Lisp_Object symbol)
+{
+ union specbinding *binding = NULL;
+ union specbinding *pdl = specpdl_ptr;
+ while (pdl > specpdl)
+ {
+ switch ((--pdl)->kind)
+ {
+ case SPECPDL_LET_DEFAULT:
+ case SPECPDL_LET:
+ if (EQ (specpdl_symbol (pdl), symbol))
+ binding = pdl;
+ break;
+ }
+ }
+ return binding;
+}
+
+DEFUN ("default-toplevel-value", Fdefault_toplevel_value, Sdefault_toplevel_value, 1, 1, 0,
+ doc: /* Return SYMBOL's toplevel default value.
+"Toplevel" means outside of any let binding. */)
+ (Lisp_Object symbol)
+{
+ union specbinding *binding = default_toplevel_binding (symbol);
+ Lisp_Object value
+ = binding ? specpdl_old_value (binding) : Fdefault_value (symbol);
+ if (!EQ (value, Qunbound))
+ return value;
+ xsignal1 (Qvoid_variable, symbol);
+}
+
+DEFUN ("set-default-toplevel-value", Fset_default_toplevel_value,
+ Sset_default_toplevel_value, 2, 2, 0,
+ doc: /* Set SYMBOL's toplevel default value to VALUE.
+"Toplevel" means outside of any let binding. */)
+ (Lisp_Object symbol, Lisp_Object value)
+{
+ union specbinding *binding = default_toplevel_binding (symbol);
+ if (binding)
+ set_specpdl_old_value (binding, value);
+ else
+ Fset_default (symbol, value);
+ return Qnil;
+}
DEFUN ("defvar", Fdefvar, Sdefvar, 1, UNEVALLED, 0,
doc: /* Define SYMBOL as a variable, and return SYMBOL.
@@ -673,37 +744,33 @@ To define a user option, use `defcustom' instead of `defvar'.
usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
(Lisp_Object args)
{
- register Lisp_Object sym, tem, tail;
+ Lisp_Object sym, tem, tail;
- sym = Fcar (args);
- tail = Fcdr (args);
- if (!NILP (Fcdr (Fcdr (tail))))
- error ("Too many arguments");
+ sym = XCAR (args);
+ tail = XCDR (args);
- tem = Fdefault_boundp (sym);
- if (!NILP (tail))
+ if (CONSP (tail))
{
+ if (CONSP (XCDR (tail)) && CONSP (XCDR (XCDR (tail))))
+ error ("Too many arguments");
+
+ tem = Fdefault_boundp (sym);
+
/* Do it before evaluating the initial value, for self-references. */
XSYMBOL (sym)->declared_special = 1;
if (NILP (tem))
- Fset_default (sym, eval_sub (Fcar (tail)));
+ Fset_default (sym, eval_sub (XCAR (tail)));
else
{ /* Check if there is really a global binding rather than just a let
binding that shadows the global unboundness of the var. */
- struct specbinding *pdl = specpdl_ptr;
- while (pdl > specpdl)
+ union specbinding *binding = default_toplevel_binding (sym);
+ if (binding && EQ (specpdl_old_value (binding), Qunbound))
{
- if (EQ ((--pdl)->symbol, sym) && !pdl->func
- && EQ (pdl->old_value, Qunbound))
- {
- message_with_string ("Warning: defvar ignored because %s is let-bound",
- SYMBOL_NAME (sym), 1);
- break;
- }
+ set_specpdl_old_value (binding, eval_sub (XCAR (tail)));
}
}
- tail = Fcdr (tail);
+ tail = XCDR (tail);
tem = Fcar (tail);
if (!NILP (tem))
{
@@ -718,8 +785,8 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
/* A simple (defvar foo) with lexical scoping does "nothing" except
declare that var to be dynamically scoped *locally* (i.e. within
the current file or let-block). */
- Vinternal_interpreter_environment =
- Fcons (sym, Vinternal_interpreter_environment);
+ Vinternal_interpreter_environment
+ = Fcons (sym, Vinternal_interpreter_environment);
else
{
/* Simple (defvar ) should not count as a definition at all.
@@ -748,18 +815,18 @@ The optional DOCSTRING specifies the variable's documentation string.
usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
(Lisp_Object args)
{
- register Lisp_Object sym, tem;
+ Lisp_Object sym, tem;
- sym = Fcar (args);
- if (!NILP (Fcdr (Fcdr (Fcdr (args)))))
+ sym = XCAR (args);
+ if (CONSP (Fcdr (XCDR (XCDR (args)))))
error ("Too many arguments");
- tem = eval_sub (Fcar (Fcdr (args)));
+ tem = eval_sub (Fcar (XCDR (args)));
if (!NILP (Vpurify_flag))
tem = Fpurecopy (tem);
Fset_default (sym, tem);
XSYMBOL (sym)->declared_special = 1;
- tem = Fcar (Fcdr (Fcdr (args)));
+ tem = Fcar (XCDR (XCDR (args)));
if (!NILP (tem))
{
if (!NILP (Vpurify_flag))
@@ -793,14 +860,14 @@ usage: (let* VARLIST BODY...) */)
(Lisp_Object args)
{
Lisp_Object varlist, var, val, elt, lexenv;
- ptrdiff_t count = SPECPDL_INDEX ();
+ dynwind_begin ();
struct gcpro gcpro1, gcpro2, gcpro3;
GCPRO3 (args, elt, varlist);
lexenv = Vinternal_interpreter_environment;
- varlist = Fcar (args);
+ varlist = XCAR (args);
while (CONSP (varlist))
{
QUIT;
@@ -841,8 +908,9 @@ usage: (let* VARLIST BODY...) */)
varlist = XCDR (varlist);
}
UNGCPRO;
- val = Fprogn (Fcdr (args));
- return unbind_to (count, val);
+ val = Fprogn (XCDR (args));
+ dynwind_end ();
+ return val;
}
DEFUN ("let", Flet, Slet, 1, UNEVALLED, 0,
@@ -856,12 +924,12 @@ usage: (let VARLIST BODY...) */)
{
Lisp_Object *temps, tem, lexenv;
register Lisp_Object elt, varlist;
- ptrdiff_t count = SPECPDL_INDEX ();
+ dynwind_begin ();
ptrdiff_t argnum;
struct gcpro gcpro1, gcpro2;
USE_SAFE_ALLOCA;
- varlist = Fcar (args);
+ varlist = XCAR (args);
/* Make space to hold the values to give the bound variables. */
elt = Flength (varlist);
@@ -888,7 +956,7 @@ usage: (let VARLIST BODY...) */)
lexenv = Vinternal_interpreter_environment;
- varlist = Fcar (args);
+ varlist = XCAR (args);
for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist))
{
Lisp_Object var;
@@ -911,9 +979,10 @@ usage: (let VARLIST BODY...) */)
/* Instantiate a new lexical environment. */
specbind (Qinternal_interpreter_environment, lexenv);
- elt = Fprogn (Fcdr (args));
+ elt = Fprogn (XCDR (args));
SAFE_FREE ();
- return unbind_to (count, elt);
+ dynwind_end ();
+ return elt;
}
DEFUN ("while", Fwhile, Swhile, 1, UNEVALLED, 0,
@@ -928,8 +997,8 @@ usage: (while TEST BODY...) */)
GCPRO2 (test, body);
- test = Fcar (args);
- body = Fcdr (args);
+ test = XCAR (args);
+ body = XCDR (args);
while (!NILP (eval_sub (test)))
{
QUIT;
@@ -971,8 +1040,8 @@ definitions to shadow the loaded ones for use in file byte-compilation. */)
tem = Fassq (sym, environment);
if (NILP (tem))
{
- def = XSYMBOL (sym)->function;
- if (!EQ (def, Qunbound))
+ def = SYMBOL_FUNCTION (sym);
+ if (!NILP (def))
continue;
}
break;
@@ -987,7 +1056,7 @@ definitions to shadow the loaded ones for use in file byte-compilation. */)
GCPRO1 (form);
def = Fautoload_do_load (def, sym, Qmacro);
UNGCPRO;
- if (EQ (def, Qunbound) || !CONSP (def))
+ if (!CONSP (def))
/* Not defined or definition not suitable. */
break;
if (!EQ (XCAR (def), Qmacro))
@@ -1026,42 +1095,152 @@ usage: (catch TAG BODY...) */)
struct gcpro gcpro1;
GCPRO1 (args);
- tag = eval_sub (Fcar (args));
+ tag = eval_sub (XCAR (args));
UNGCPRO;
- return internal_catch (tag, Fprogn, Fcdr (args));
+ return internal_catch (tag, Fprogn, XCDR (args));
+}
+
+/* Assert that E is true, as a comment only. Use this instead of
+ eassert (E) when E contains variables that might be clobbered by a
+ longjmp. */
+
+#define clobbered_eassert(E) ((void) 0)
+
+static void
+set_handlerlist (void *data)
+{
+ handlerlist = data;
+}
+
+static void
+restore_handler (void *data)
+{
+ struct handler *c = data;
+ set_poll_suppress_count (c->poll_suppress_count);
+ unblock_input_to (c->interrupt_input_blocked);
+ immediate_quit = 0;
+}
+
+struct icc_thunk_env
+{
+ enum { ICC_0, ICC_1, ICC_2, ICC_3, ICC_N } type;
+ union
+ {
+ Lisp_Object (*fun0) (void);
+ Lisp_Object (*fun1) (Lisp_Object);
+ Lisp_Object (*fun2) (Lisp_Object, Lisp_Object);
+ Lisp_Object (*fun3) (Lisp_Object, Lisp_Object, Lisp_Object);
+ Lisp_Object (*funn) (ptrdiff_t, Lisp_Object *);
+ };
+ union
+ {
+ struct
+ {
+ Lisp_Object arg1;
+ Lisp_Object arg2;
+ Lisp_Object arg3;
+ };
+ struct
+ {
+ ptrdiff_t nargs;
+ Lisp_Object *args;
+ };
+ };
+ struct handler *c;
+};
+
+static Lisp_Object
+icc_thunk (void *data)
+{
+ Lisp_Object tem;
+ struct icc_thunk_env *e = data;
+ scm_dynwind_begin (0);
+ scm_dynwind_unwind_handler (restore_handler, e->c, 0);
+ scm_dynwind_unwind_handler (set_handlerlist,
+ handlerlist,
+ SCM_F_WIND_EXPLICITLY);
+ handlerlist = e->c;
+ switch (e->type)
+ {
+ case ICC_0:
+ tem = e->fun0 ();
+ break;
+ case ICC_1:
+ tem = e->fun1 (e->arg1);
+ break;
+ case ICC_2:
+ tem = e->fun2 (e->arg1, e->arg2);
+ break;
+ case ICC_3:
+ tem = e->fun3 (e->arg1, e->arg2, e->arg3);
+ break;
+ case ICC_N:
+ tem = e->funn (e->nargs, e->args);
+ break;
+ default:
+ emacs_abort ();
+ }
+ scm_dynwind_end ();
+ return tem;
+}
+
+static Lisp_Object
+icc_handler (void *data, Lisp_Object k, Lisp_Object v)
+{
+ Lisp_Object (*f) (Lisp_Object) = data;
+ return f (v);
+}
+
+struct icc_handler_n_env
+{
+ Lisp_Object (*fun) (Lisp_Object, ptrdiff_t, Lisp_Object *);
+ ptrdiff_t nargs;
+ Lisp_Object *args;
+};
+
+static Lisp_Object
+icc_handler_n (void *data, Lisp_Object k, Lisp_Object v)
+{
+ struct icc_handler_n_env *e = data;
+ return e->fun (v, e->nargs, e->args);
+}
+
+static Lisp_Object
+icc_lisp_handler (void *data, Lisp_Object k, Lisp_Object val)
+{
+ Lisp_Object tem;
+ struct handler *h = data;
+ Lisp_Object var = h->var;
+ scm_dynwind_begin (0);
+ if (!NILP (var))
+ {
+ if (!NILP (Vinternal_interpreter_environment))
+ specbind (Qinternal_interpreter_environment,
+ Fcons (Fcons (var, val),
+ Vinternal_interpreter_environment));
+ else
+ specbind (var, val);
+ }
+ tem = Fprogn (h->body);
+ scm_dynwind_end ();
+ return tem;
}
/* Set up a catch, then call C function FUNC on argument ARG.
FUNC should return a Lisp_Object.
- This is how catches are done from within C code. */
+ This is how catches are done from within C code. */
Lisp_Object
internal_catch (Lisp_Object tag, Lisp_Object (*func) (Lisp_Object), Lisp_Object arg)
{
- /* This structure is made part of the chain `catchlist'. */
- struct catchtag c;
-
- /* Fill in the components of c, and put it on the list. */
- c.next = catchlist;
- c.tag = tag;
- c.val = Qnil;
- c.backlist = backtrace_list;
- c.handlerlist = handlerlist;
- c.lisp_eval_depth = lisp_eval_depth;
- c.pdlcount = SPECPDL_INDEX ();
- c.poll_suppress_count = poll_suppress_count;
- c.interrupt_input_blocked = interrupt_input_blocked;
- c.gcpro = gcprolist;
- c.byte_stack = byte_stack_list;
- catchlist = &c;
-
- /* Call FUNC. */
- if (! sys_setjmp (c.jmp))
- c.val = (*func) (arg);
-
- /* Throw works by a longjmp that comes right here. */
- catchlist = c.next;
- return c.val;
+ struct handler *c = make_catch_handler (tag);
+ struct icc_thunk_env env = { .type = ICC_1,
+ .fun1 = func,
+ .arg1 = arg,
+ .c = c };
+ return call_with_prompt (c->ptag,
+ make_c_closure (icc_thunk, &env, 0, 0),
+ make_c_closure (icc_handler, Fidentity, 2, 0));
}
/* Unwind the specbind, catch, and handler stacks back to CATCH, and
@@ -1080,40 +1259,12 @@ internal_catch (Lisp_Object tag, Lisp_Object (*func) (Lisp_Object), Lisp_Object
This is used for correct unwinding in Fthrow and Fsignal. */
+static Lisp_Object unbind_to_1 (ptrdiff_t, Lisp_Object, bool);
+
static _Noreturn void
-unwind_to_catch (struct catchtag *catch, Lisp_Object value)
+unwind_to_catch (struct handler *catch, Lisp_Object value)
{
- bool last_time;
-
- /* Save the value in the tag. */
- catch->val = value;
-
- /* Restore certain special C variables. */
- set_poll_suppress_count (catch->poll_suppress_count);
- unblock_input_to (catch->interrupt_input_blocked);
- immediate_quit = 0;
-
- 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;
- }
- while (! last_time);
-
- byte_stack_list = catch->byte_stack;
- gcprolist = catch->gcpro;
-#ifdef DEBUG_GCPRO
- gcpro_level = gcprolist ? gcprolist->level + 1 : 0;
-#endif
- backtrace_list = catch->backlist;
- lisp_eval_depth = catch->lisp_eval_depth;
-
- sys_longjmp (catch->jmp, 1);
+ abort_to_prompt (catch->ptag, scm_list_1 (value));
}
DEFUN ("throw", Fthrow, Sthrow, 2, 2, 0,
@@ -1121,12 +1272,12 @@ DEFUN ("throw", Fthrow, Sthrow, 2, 2, 0,
Both TAG and VALUE are evalled. */)
(register Lisp_Object tag, Lisp_Object value)
{
- register struct catchtag *c;
+ struct handler *c;
if (!NILP (tag))
- for (c = catchlist; c; c = c->next)
+ for (c = handlerlist; c; c = c->next)
{
- if (EQ (c->tag, tag))
+ if (c->type == CATCHER && EQ (c->tag_or_ch, tag))
unwind_to_catch (c, value);
}
xsignal2 (Qno_catch, tag, value);
@@ -1142,11 +1293,12 @@ usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
(Lisp_Object args)
{
Lisp_Object val;
- ptrdiff_t count = SPECPDL_INDEX ();
+ dynwind_begin ();
- record_unwind_protect (Fprogn, Fcdr (args));
- val = eval_sub (Fcar (args));
- return unbind_to (count, val);
+ record_unwind_protect (unwind_body, XCDR (args));
+ val = eval_sub (XCAR (args));
+ dynwind_end ();
+ return val;
}
DEFUN ("condition-case", Fcondition_case, Scondition_case, 2, UNEVALLED, 0,
@@ -1177,13 +1329,42 @@ See also the function `signal' for more info.
usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
(Lisp_Object args)
{
- Lisp_Object var = Fcar (args);
- Lisp_Object bodyform = Fcar (Fcdr (args));
- Lisp_Object handlers = Fcdr (Fcdr (args));
+ Lisp_Object var = XCAR (args);
+ Lisp_Object bodyform = XCAR (XCDR (args));
+ Lisp_Object handlers = XCDR (XCDR (args));
return internal_lisp_condition_case (var, bodyform, handlers);
}
+static Lisp_Object
+ilcc1 (Lisp_Object var, Lisp_Object bodyform, Lisp_Object handlers)
+{
+ if (CONSP (handlers))
+ {
+ Lisp_Object clause = XCAR (handlers);
+ Lisp_Object condition = XCAR (clause);
+ Lisp_Object body = XCDR (clause);
+ if (!CONSP (condition))
+ condition = Fcons (condition, Qnil);
+ struct handler *c = make_condition_handler (condition);
+ c->var = var;
+ c->body = body;
+ struct icc_thunk_env env = { .type = ICC_3,
+ .fun3 = ilcc1,
+ .arg1 = var,
+ .arg2 = bodyform,
+ .arg3 = XCDR (handlers),
+ .c = c };
+ return call_with_prompt (c->ptag,
+ make_c_closure (icc_thunk, &env, 0, 0),
+ make_c_closure (icc_lisp_handler, c, 2, 0));
+ }
+ else
+ {
+ return eval_sub (bodyform);
+ }
+}
+
/* Like Fcondition_case, but the args are separate
rather than passed in a list. Used by Fbyte_code. */
@@ -1192,15 +1373,14 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform,
Lisp_Object handlers)
{
Lisp_Object val;
- struct catchtag c;
- struct handler h;
+ struct handler *c;
+ struct handler *oldhandlerlist = handlerlist;
CHECK_SYMBOL (var);
for (val = handlers; CONSP (val); val = XCDR (val))
{
- Lisp_Object tem;
- tem = XCAR (val);
+ Lisp_Object tem = XCAR (val);
if (! (NILP (tem)
|| (CONSP (tem)
&& (SYMBOLP (XCAR (tem))
@@ -1209,41 +1389,7 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform,
SDATA (Fprin1_to_string (tem, Qt)));
}
- c.tag = Qnil;
- c.val = Qnil;
- c.backlist = backtrace_list;
- c.handlerlist = handlerlist;
- c.lisp_eval_depth = lisp_eval_depth;
- c.pdlcount = SPECPDL_INDEX ();
- c.poll_suppress_count = poll_suppress_count;
- c.interrupt_input_blocked = interrupt_input_blocked;
- c.gcpro = gcprolist;
- c.byte_stack = byte_stack_list;
- if (sys_setjmp (c.jmp))
- {
- if (!NILP (h.var))
- 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
- throwing. */
- unbind_to (c.pdlcount, Qnil);
- return val;
- }
- c.next = catchlist;
- catchlist = &c;
-
- h.var = var;
- h.handler = handlers;
- h.next = handlerlist;
- h.tag = &c;
- handlerlist = &h;
-
- val = eval_sub (bodyform);
- catchlist = c.next;
- handlerlist = h.next;
- return val;
+ return ilcc1 (var, bodyform, Freverse (handlers));
}
/* Call the function BFUN with no arguments, catching errors within it
@@ -1261,35 +1407,12 @@ internal_condition_case (Lisp_Object (*bfun) (void), Lisp_Object handlers,
Lisp_Object (*hfun) (Lisp_Object))
{
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_INDEX ();
- c.poll_suppress_count = poll_suppress_count;
- c.interrupt_input_blocked = interrupt_input_blocked;
- c.gcpro = gcprolist;
- c.byte_stack = byte_stack_list;
- if (sys_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) ();
- catchlist = c.next;
- handlerlist = h.next;
- return val;
+ struct handler *c = make_condition_handler (handlers);
+
+ struct icc_thunk_env env = { .type = ICC_0, .fun0 = bfun, .c = c };
+ return call_with_prompt (c->ptag,
+ make_c_closure (icc_thunk, &env, 0, 0),
+ make_c_closure (icc_handler, hfun, 2, 0));
}
/* Like internal_condition_case but call BFUN with ARG as its argument. */
@@ -1299,35 +1422,15 @@ internal_condition_case_1 (Lisp_Object (*bfun) (Lisp_Object), Lisp_Object arg,
Lisp_Object handlers, Lisp_Object (*hfun) (Lisp_Object))
{
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_INDEX ();
- c.poll_suppress_count = poll_suppress_count;
- c.interrupt_input_blocked = interrupt_input_blocked;
- c.gcpro = gcprolist;
- c.byte_stack = byte_stack_list;
- if (sys_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;
+ struct handler *c = make_condition_handler (handlers);
+
+ struct icc_thunk_env env = { .type = ICC_1,
+ .fun1 = bfun,
+ .arg1 = arg,
+ .c = c };
+ return call_with_prompt (c->ptag,
+ make_c_closure (icc_thunk, &env, 0, 0),
+ make_c_closure (icc_handler, hfun, 2, 0));
}
/* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as
@@ -1341,35 +1444,15 @@ internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object),
Lisp_Object (*hfun) (Lisp_Object))
{
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_INDEX ();
- c.poll_suppress_count = poll_suppress_count;
- c.interrupt_input_blocked = interrupt_input_blocked;
- c.gcpro = gcprolist;
- c.byte_stack = byte_stack_list;
- if (sys_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) (arg1, arg2);
- catchlist = c.next;
- handlerlist = h.next;
- return val;
+ struct handler *c = make_condition_handler (handlers);
+ struct icc_thunk_env env = { .type = ICC_2,
+ .fun2 = bfun,
+ .arg1 = arg1,
+ .arg2 = arg2,
+ .c = c };
+ return call_with_prompt (c->ptag,
+ make_c_closure (icc_thunk, &env, 0, 0),
+ make_c_closure (icc_handler, hfun, 2, 0));
}
/* Like internal_condition_case but call BFUN with NARGS as first,
@@ -1385,35 +1468,17 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *),
Lisp_Object *args))
{
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_INDEX ();
- c.poll_suppress_count = poll_suppress_count;
- c.interrupt_input_blocked = interrupt_input_blocked;
- c.gcpro = gcprolist;
- c.byte_stack = byte_stack_list;
- if (sys_setjmp (c.jmp))
- {
- return (*hfun) (c.val, nargs, args);
- }
- c.next = catchlist;
- catchlist = &c;
- h.handler = handlers;
- h.var = Qnil;
- h.next = handlerlist;
- h.tag = &c;
- handlerlist = &h;
-
- val = (*bfun) (nargs, args);
- catchlist = c.next;
- handlerlist = h.next;
- return val;
+ struct handler *c = make_condition_handler (handlers);
+
+ struct icc_thunk_env env = { .type = ICC_N,
+ .funn = bfun,
+ .nargs = nargs,
+ .args = args,
+ .c = c };
+ struct icc_handler_n_env henv = { .fun = hfun, .nargs = nargs, .args = args };
+ return call_with_prompt (c->ptag,
+ make_c_closure (icc_thunk, &env, 0, 0),
+ make_c_closure (icc_handler_n, &henv, 2, 0));
}
@@ -1458,11 +1523,9 @@ See also the function `condition-case'. */)
= (NILP (error_symbol) ? Fcar (data) : error_symbol);
register Lisp_Object clause = Qnil;
struct handler *h;
- struct backtrace *bp;
immediate_quit = 0;
- abort_on_gc = 0;
- if (gc_in_progress || waiting_for_input)
+ if (waiting_for_input)
emacs_abort ();
#if 0 /* rms: I don't know why this was here,
@@ -1494,18 +1557,20 @@ See also the function `condition-case'. */)
too. Don't do this when ERROR_SYMBOL is nil, because that
is a memory-full error. */
Vsignaling_function = Qnil;
- if (backtrace_list && !NILP (error_symbol))
+ if (!NILP (error_symbol))
{
- bp = backtrace_list->next;
- if (bp && EQ (bp->function, Qerror))
- bp = bp->next;
- if (bp)
- Vsignaling_function = bp->function;
+ union specbinding *pdl = backtrace_next (backtrace_top ());
+ if (backtrace_p (pdl) && EQ (backtrace_function (pdl), Qerror))
+ pdl = backtrace_next (pdl);
+ if (backtrace_p (pdl))
+ Vsignaling_function = backtrace_function (pdl);
}
for (h = handlerlist; h; h = h->next)
{
- clause = find_handler_clause (h->handler, conditions);
+ if (h->type != CONDITION_CASE)
+ continue;
+ clause = find_handler_clause (h->tag_or_ch, conditions);
if (!NILP (clause))
break;
}
@@ -1518,11 +1583,11 @@ See also the function `condition-case'. */)
|| NILP (clause)
/* A `debug' symbol in the handler list disables the normal
suppression of the debugger. */
- || (CONSP (clause) && CONSP (XCAR (clause))
- && !NILP (Fmemq (Qdebug, XCAR (clause))))
+ || (CONSP (clause) && CONSP (clause)
+ && !NILP (Fmemq (Qdebug, clause)))
/* Special handler that means "print a message and run debugger
if requested". */
- || EQ (h->handler, Qerror)))
+ || EQ (h->tag_or_ch, Qerror)))
{
bool debugger_called
= maybe_call_debugger (conditions, error_symbol, data);
@@ -1537,12 +1602,14 @@ See also the function `condition-case'. */)
Lisp_Object unwind_data
= (NILP (error_symbol) ? data : Fcons (error_symbol, data));
- h->chosen_clause = clause;
- unwind_to_catch (h->tag, unwind_data);
+ unwind_to_catch (h, unwind_data);
}
else
{
- if (catchlist != 0)
+ if (handlerlist != handlerlist_sentinel)
+ /* FIXME: This will come right back here if there's no `top-level'
+ catcher. A better solution would be to abort here, and instead
+ add a catch-all condition handler so we never come here. */
Fthrow (Qtop_level, Qt);
}
@@ -1612,7 +1679,7 @@ signal_error (const char *s, Lisp_Object arg)
}
if (!NILP (hare))
- arg = Fcons (arg, Qnil); /* Make it a list. */
+ arg = list1 (arg);
xsignal (Qerror, Fcons (build_string (s), arg));
}
@@ -1704,7 +1771,7 @@ maybe_call_debugger (Lisp_Object conditions, Lisp_Object sig, Lisp_Object data)
/* RMS: What's this for? */
&& when_entered_debugger < num_nonmacro_input_events)
{
- call_debugger (Fcons (Qerror, Fcons (combined_data, Qnil)));
+ call_debugger (list2 (Qerror, combined_data));
return 1;
}
@@ -1728,29 +1795,8 @@ find_handler_clause (Lisp_Object handlers, Lisp_Object conditions)
for (h = handlers; CONSP (h); h = XCDR (h))
{
Lisp_Object handler = XCAR (h);
- Lisp_Object condit, tem;
-
- if (!CONSP (handler))
- continue;
- condit = XCAR (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))
- {
- Lisp_Object tail;
- for (tail = condit; CONSP (tail); tail = XCDR (tail))
- {
- tem = Fmemq (XCAR (tail), conditions);
- if (!NILP (tem))
- return handler;
- }
- }
+ if (!NILP (Fmemq (handler, conditions)))
+ return handlers;
}
return Qnil;
@@ -1786,7 +1832,6 @@ error (const char *m, ...)
va_list ap;
va_start (ap, m);
verror (m, ap);
- va_end (ap);
}
DEFUN ("commandp", Fcommandp, Scommandp, 1, 2, 0,
@@ -1812,12 +1857,12 @@ then strings and vectors are not accepted. */)
fun = function;
- fun = indirect_function (fun); /* Check cycles. */
- if (NILP (fun) || EQ (fun, Qunbound))
+ fun = indirect_function (fun); /* Check cycles. */
+ if (NILP (fun))
return Qnil;
/* Check an `interactive-form' property if present, analogous to the
- function-documentation property. */
+ function-documentation property. */
fun = function;
while (SYMBOLP (fun))
{
@@ -1827,11 +1872,9 @@ then strings and vectors are not accepted. */)
fun = Fsymbol_function (fun);
}
- /* Emacs primitives are interactive if their DEFUN specifies an
- interactive spec. */
- if (SUBRP (fun))
- return XSUBR (fun)->intspec ? Qt : if_prop;
-
+ if (scm_is_true (scm_procedure_p (fun)))
+ return (scm_is_true (scm_procedure_property (fun, Qinteractive_form))
+ ? Qt : if_prop);
/* 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. */
@@ -1877,32 +1920,19 @@ this does nothing and returns nil. */)
CHECK_STRING (file);
/* If function is defined and not as an autoload, don't override. */
- if ((CONSP (XSYMBOL (function)->function)
- && EQ (XCAR (XSYMBOL (function)->function), Qautoload)))
- /* Remember that the function was already an autoload. */
- LOADHIST_ATTACH (Fcons (Qt, function));
- else if (!EQ (XSYMBOL (function)->function, Qunbound))
+ if (!NILP (SYMBOL_FUNCTION (function))
+ && !AUTOLOADP (SYMBOL_FUNCTION (function)))
return Qnil;
- if (NILP (Vpurify_flag))
- /* Only add entries after dumping, because the ones before are
- not useful and else we get loads of them from the loaddefs.el. */
- LOADHIST_ATTACH (Fcons (Qautoload, function));
- else if (EQ (docstring, make_number (0)))
- /* `read1' in lread.c has found the docstring starting with "\
- and assumed the docstring will be provided by Snarf-documentation, so it
- passed us 0 instead. But that leads to accidental sharing in purecopy's
- hash-consing, so we use a (hopefully) unique integer instead. */
- docstring = make_number (XUNTAG (function, Lisp_Symbol));
- return Ffset (function,
- Fpurecopy (list5 (Qautoload, file, docstring,
- interactive, type)));
+ return Fdefalias (function,
+ list5 (Qautoload, file, docstring, interactive, type),
+ Qnil);
}
-Lisp_Object
+void
un_autoload (Lisp_Object oldqueue)
{
- register Lisp_Object queue, first, second;
+ Lisp_Object queue, first, second;
/* Queue to unwind is current value of Vautoload_queue.
oldqueue is the shadowed value to leave in Vautoload_queue. */
@@ -1919,7 +1949,6 @@ un_autoload (Lisp_Object oldqueue)
Ffset (first, second);
queue = XCDR (queue);
}
- return Qnil;
}
/* Load an autoloaded function.
@@ -1934,17 +1963,21 @@ If equal to `macro', MACRO-ONLY specifies that FUNDEF should only be loaded if
it is defines a macro. */)
(Lisp_Object fundef, Lisp_Object funname, Lisp_Object macro_only)
{
- ptrdiff_t count = SPECPDL_INDEX ();
+ dynwind_begin ();
struct gcpro gcpro1, gcpro2, gcpro3;
- if (!CONSP (fundef) || !EQ (Qautoload, XCAR (fundef)))
+ if (!CONSP (fundef) || !EQ (Qautoload, XCAR (fundef))) {
+ dynwind_end ();
return fundef;
+ }
if (EQ (macro_only, Qmacro))
{
Lisp_Object kind = Fnth (make_number (4), fundef);
- if (! (EQ (kind, Qt) || EQ (kind, Qmacro)))
- return fundef;
+ if (! (EQ (kind, Qt) || EQ (kind, Qmacro))) {
+ dynwind_end ();
+ return fundef;
+ }
}
/* This is to make sure that loadup.el gives a clear picture
@@ -1975,7 +2008,7 @@ it is defines a macro. */)
/* Once loading finishes, don't undo it. */
Vautoload_queue = Qt;
- unbind_to (count, Qnil);
+ dynwind_end ();
UNGCPRO;
@@ -1996,37 +2029,96 @@ it is defines a macro. */)
DEFUN ("eval", Feval, Seval, 1, 2, 0,
doc: /* Evaluate FORM and return its value.
-If LEXICAL is t, evaluate using lexical scoping. */)
+If LEXICAL is t, evaluate using lexical scoping.
+LEXICAL can also be an actual lexical environment, in the form of an
+alist mapping symbols to their value. */)
(Lisp_Object form, Lisp_Object lexical)
{
- ptrdiff_t count = SPECPDL_INDEX ();
+ dynwind_begin ();
specbind (Qinternal_interpreter_environment,
- NILP (lexical) ? Qnil : Fcons (Qt, Qnil));
- return unbind_to (count, eval_sub (form));
+ CONSP (lexical) || NILP (lexical) ? lexical : list1 (Qt));
+ Lisp_Object tem0 = eval_sub (form);
+ dynwind_end ();
+ return tem0;
}
-/* Eval a sub-expression of the current expression (i.e. in the same
- lexical scope). */
-Lisp_Object
-eval_sub (Lisp_Object form)
+/* Grow the specpdl stack by one entry.
+ The caller should have already initialized the entry.
+ Signal an error on stack overflow.
+
+ Make sure that there is always one unused entry past the top of the
+ stack, so that the just-initialized entry is safely unwound if
+ memory exhausted and an error is signaled here. Also, allocate a
+ never-used entry just before the bottom of the stack; sometimes its
+ address is taken. */
+
+static void
+grow_specpdl (void)
{
- Lisp_Object fun, val, original_fun, original_args;
- Lisp_Object funcar;
- struct backtrace backtrace;
- struct gcpro gcpro1, gcpro2, gcpro3;
+ specpdl_ptr++;
- if (SYMBOLP (form))
+ if (specpdl_ptr == specpdl + specpdl_size)
{
- /* Look up its binding in the lexical environment.
- We do not pay attention to the declared_special flag here, since we
- already did that when let-binding the variable. */
- Lisp_Object lex_binding
- = !NILP (Vinternal_interpreter_environment) /* Mere optimization! */
- ? Fassq (form, Vinternal_interpreter_environment)
- : Qnil;
- if (CONSP (lex_binding))
- return XCDR (lex_binding);
- else
+ ptrdiff_t count = SPECPDL_INDEX ();
+ ptrdiff_t max_size = min (max_specpdl_size, PTRDIFF_MAX - 1000);
+ union specbinding *pdlvec = specpdl - 1;
+ ptrdiff_t pdlvecsize = specpdl_size + 1;
+ if (max_size <= specpdl_size)
+ {
+ if (max_specpdl_size < 400)
+ max_size = max_specpdl_size = 400;
+ if (max_size <= specpdl_size)
+ signal_error ("Variable binding depth exceeds max-specpdl-size",
+ Qnil);
+ }
+ pdlvec = xpalloc (pdlvec, &pdlvecsize, 1, max_size + 1, sizeof *specpdl);
+ specpdl = pdlvec + 1;
+ specpdl_size = pdlvecsize - 1;
+ specpdl_ptr = specpdl + count;
+ }
+}
+
+void
+record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs)
+{
+ eassert (nargs >= UNEVALLED);
+ specpdl_ptr->bt.kind = SPECPDL_BACKTRACE;
+ specpdl_ptr->bt.debug_on_exit = false;
+ specpdl_ptr->bt.function = function;
+ specpdl_ptr->bt.args = args;
+ specpdl_ptr->bt.nargs = nargs;
+ grow_specpdl ();
+ scm_dynwind_unwind_handler (unbind_once, NULL, SCM_F_WIND_EXPLICITLY);
+}
+
+static void
+set_lisp_eval_depth (void *data)
+{
+ EMACS_INT n = (EMACS_INT) data;
+ lisp_eval_depth = n;
+}
+
+/* Eval a sub-expression of the current expression (i.e. in the same
+ lexical scope). */
+static Lisp_Object
+eval_sub_1 (Lisp_Object form)
+{
+ Lisp_Object fun, val, original_fun, original_args;
+ Lisp_Object funcar;
+ struct gcpro gcpro1, gcpro2, gcpro3;
+
+ if (SYMBOLP (form))
+ {
+ /* Look up its binding in the lexical environment.
+ We do not pay attention to the declared_special flag here, since we
+ already did that when let-binding the variable. */
+ Lisp_Object lex_binding
+ = !NILP (Vinternal_interpreter_environment) /* Mere optimization! */
+ ? Fassq (form, Vinternal_interpreter_environment)
+ : Qnil;
+ if (CONSP (lex_binding))
+ return XCDR (lex_binding);
+ else
return Fsymbol_value (form);
}
@@ -2034,7 +2126,15 @@ eval_sub (Lisp_Object form)
return form;
QUIT;
+
+ GCPRO1 (form);
maybe_gc ();
+ UNGCPRO;
+
+ scm_dynwind_begin (0);
+ scm_dynwind_unwind_handler (set_lisp_eval_depth,
+ (void *) lisp_eval_depth,
+ SCM_F_WIND_EXPLICITLY);
if (++lisp_eval_depth > max_lisp_eval_depth)
{
@@ -2047,12 +2147,8 @@ eval_sub (Lisp_Object form)
original_fun = XCAR (form);
original_args = XCDR (form);
- backtrace.next = backtrace_list;
- backtrace.function = original_fun; /* This also protects them from gc. */
- backtrace.args = &original_args;
- backtrace.nargs = UNEVALLED;
- backtrace.debug_on_exit = 0;
- backtrace_list = &backtrace;
+ /* This also protects them from gc. */
+ record_in_backtrace (original_fun, &original_args, UNEVALLED);
if (debug_on_next_call)
do_debug_on_call (Qt);
@@ -2063,129 +2159,38 @@ eval_sub (Lisp_Object form)
/* Optimize for no indirection. */
fun = original_fun;
- if (SYMBOLP (fun) && !EQ (fun, Qunbound)
- && (fun = XSYMBOL (fun)->function, SYMBOLP (fun)))
+ if (!SYMBOLP (fun))
+ fun = Ffunction (Fcons (fun, Qnil));
+ else if (!NILP (fun) && (fun = SYMBOL_FUNCTION (fun), SYMBOLP (fun)))
fun = indirect_function (fun);
- if (SUBRP (fun))
+ if (scm_is_true (scm_procedure_p (fun)))
{
- Lisp_Object numargs;
- Lisp_Object argvals[8];
- Lisp_Object args_left;
- register int i, maxargs;
+ Lisp_Object args_left = original_args;
+ Lisp_Object nargs = Flength (args_left);
+ Lisp_Object *args;
+ size_t argnum = 0;
- args_left = original_args;
- numargs = Flength (args_left);
+ SAFE_ALLOCA_LISP (args, XINT (nargs));
- check_cons_list ();
-
- if (XINT (numargs) < XSUBR (fun)->min_args
- || (XSUBR (fun)->max_args >= 0
- && XSUBR (fun)->max_args < XINT (numargs)))
- xsignal2 (Qwrong_number_of_arguments, original_fun, numargs);
-
- else if (XSUBR (fun)->max_args == UNEVALLED)
- val = (XSUBR (fun)->function.aUNEVALLED) (args_left);
- else if (XSUBR (fun)->max_args == MANY)
- {
- /* Pass a vector of evaluated arguments. */
- Lisp_Object *vals;
- ptrdiff_t argnum = 0;
- USE_SAFE_ALLOCA;
-
- SAFE_ALLOCA_LISP (vals, XINT (numargs));
-
- GCPRO3 (args_left, fun, fun);
- gcpro3.var = vals;
- gcpro3.nvars = 0;
-
- while (!NILP (args_left))
- {
- vals[argnum++] = eval_sub (Fcar (args_left));
- args_left = Fcdr (args_left);
- gcpro3.nvars = argnum;
- }
-
- backtrace.args = vals;
- backtrace.nargs = XINT (numargs);
-
- val = (XSUBR (fun)->function.aMANY) (XINT (numargs), vals);
- UNGCPRO;
- SAFE_FREE ();
- }
- else
- {
- GCPRO3 (args_left, fun, fun);
- gcpro3.var = argvals;
- gcpro3.nvars = 0;
-
- maxargs = XSUBR (fun)->max_args;
- for (i = 0; i < maxargs; args_left = Fcdr (args_left))
- {
- argvals[i] = eval_sub (Fcar (args_left));
- gcpro3.nvars = ++i;
- }
-
- UNGCPRO;
-
- backtrace.args = argvals;
- backtrace.nargs = XINT (numargs);
-
- switch (i)
- {
- case 0:
- val = (XSUBR (fun)->function.a0 ());
- break;
- case 1:
- val = (XSUBR (fun)->function.a1 (argvals[0]));
- break;
- case 2:
- val = (XSUBR (fun)->function.a2 (argvals[0], argvals[1]));
- break;
- case 3:
- val = (XSUBR (fun)->function.a3
- (argvals[0], argvals[1], argvals[2]));
- break;
- case 4:
- val = (XSUBR (fun)->function.a4
- (argvals[0], argvals[1], argvals[2], argvals[3]));
- break;
- case 5:
- val = (XSUBR (fun)->function.a5
- (argvals[0], argvals[1], argvals[2], argvals[3],
- argvals[4]));
- break;
- case 6:
- val = (XSUBR (fun)->function.a6
- (argvals[0], argvals[1], argvals[2], argvals[3],
- argvals[4], argvals[5]));
- break;
- case 7:
- val = (XSUBR (fun)->function.a7
- (argvals[0], argvals[1], argvals[2], argvals[3],
- argvals[4], argvals[5], argvals[6]));
- break;
-
- case 8:
- val = (XSUBR (fun)->function.a8
- (argvals[0], argvals[1], argvals[2], argvals[3],
- argvals[4], argvals[5], argvals[6], argvals[7]));
- break;
-
- default:
- /* 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. */
- emacs_abort ();
- }
- }
+ while (! NILP (args_left))
+ {
+ args[argnum++] = eval_sub (Fcar (args_left));
+ args_left = Fcdr (args_left);
+ }
+ set_backtrace_args (specpdl_ptr - 1, args);
+ set_backtrace_nargs (specpdl_ptr - 1, argnum);
+ val = scm_call_n (fun, args, argnum);
+ }
+ else if (CONSP (fun) && EQ (XCAR (fun), Qspecial_operator))
+ {
+ val = scm_apply_0 (XCDR (fun), original_args);
}
else if (COMPILEDP (fun))
val = apply_lambda (fun, original_args);
else
{
- if (EQ (fun, Qunbound))
+ if (NILP (fun))
xsignal1 (Qvoid_function, original_fun);
if (!CONSP (fun))
xsignal1 (Qinvalid_function, original_fun);
@@ -2199,7 +2204,7 @@ eval_sub (Lisp_Object form)
}
if (EQ (funcar, Qmacro))
{
- ptrdiff_t count = SPECPDL_INDEX ();
+ dynwind_begin ();
Lisp_Object exp;
/* Bind lexical-binding during expansion of the macro, so the
macro can know reliably if the code it outputs will be
@@ -2207,7 +2212,7 @@ eval_sub (Lisp_Object form)
specbind (Qlexical_binding,
NILP (Vinternal_interpreter_environment) ? Qnil : Qt);
exp = apply1 (Fcdr (fun), original_args);
- unbind_to (count, Qnil);
+ dynwind_end ();
val = eval_sub (exp);
}
else if (EQ (funcar, Qlambda)
@@ -2216,13 +2221,59 @@ eval_sub (Lisp_Object form)
else
xsignal1 (Qinvalid_function, original_fun);
}
- check_cons_list ();
- lisp_eval_depth--;
- if (backtrace.debug_on_exit)
- val = call_debugger (Fcons (Qexit, Fcons (val, Qnil)));
- backtrace_list = backtrace.next;
+ if (backtrace_debug_on_exit (specpdl_ptr - 1))
+ val = call_debugger (list2 (Qexit, val));
+ scm_dynwind_end ();
+
+ return val;
+}
+
+Lisp_Object
+eval_sub (Lisp_Object form)
+{
+ return scm_c_value_ref (eval_sub_1 (form), 0);
+}
+
+static Lisp_Object
+values_to_list (Lisp_Object values)
+{
+ Lisp_Object list = Qnil;
+ for (int i = scm_c_nvalues (values) - 1; i >= 0; i--)
+ list = Fcons (scm_c_value_ref (values, i), list);
+ return list;
+}
+
+DEFUN ("multiple-value-call", Fmultiple_value_call, Smultiple_value_call,
+ 2, UNEVALLED, 0,
+ doc: /* Call with multiple values.
+usage: (multiple-value-call FUNCTION-FORM FORM) */)
+ (Lisp_Object args)
+{
+ Lisp_Object function_form = eval_sub (XCAR (args));
+ Lisp_Object values = Qnil;
+ while (CONSP (args = XCDR (args)))
+ values = nconc2 (Fnreverse (values_to_list (eval_sub_1 (XCAR (args)))),
+ values);
+ return apply1 (function_form, Fnreverse (values));
+}
+DEFUN ("values", Fvalues, Svalues, 0, MANY, 0,
+ doc: /* Return multiple values. */)
+ (ptrdiff_t nargs, Lisp_Object *args)
+{
+ return scm_c_values (args, nargs);
+}
+
+DEFUN ("bind-symbol", Fbind_symbol, Sbind_symbol, 3, 3, 0,
+ doc: /* Bind symbol. */)
+ (Lisp_Object symbol, Lisp_Object value, Lisp_Object thunk)
+{
+ Lisp_Object val;
+ dynwind_begin ();
+ specbind (symbol, value);
+ val = call0 (thunk);
+ dynwind_end ();
return val;
}
@@ -2259,33 +2310,15 @@ usage: (apply FUNCTION &rest ARGUMENTS) */)
numargs += nargs - 2;
/* Optimize for no indirection. */
- if (SYMBOLP (fun) && !EQ (fun, Qunbound)
- && (fun = XSYMBOL (fun)->function, SYMBOLP (fun)))
+ if (SYMBOLP (fun) && !NILP (fun)
+ && (fun = SYMBOL_FUNCTION (fun), SYMBOLP (fun)))
fun = indirect_function (fun);
- if (EQ (fun, Qunbound))
+ if (NILP (fun))
{
/* Let funcall get the error. */
fun = args[0];
- goto funcall;
}
- if (SUBRP (fun))
- {
- if (numargs < XSUBR (fun)->min_args
- || (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs))
- goto funcall; /* Let funcall get the error. */
- else if (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args > numargs)
- {
- /* Avoid making funcall cons up a yet another new vector of arguments
- by explicitly supplying nil's for optional values. */
- SAFE_ALLOCA_LISP (funcall_args, 1 + XSUBR (fun)->max_args);
- 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)
@@ -2460,7 +2493,7 @@ run_hook_with_args (ptrdiff_t nargs, Lisp_Object *args,
if (EQ (val, Qunbound) || NILP (val))
return ret;
- else if (!CONSP (val) || EQ (XCAR (val), Qlambda))
+ else if (!CONSP (val) || FUNCTIONP (val))
{
args[0] = val;
return funcall (nargs, args);
@@ -2533,14 +2566,14 @@ apply1 (Lisp_Object fn, Lisp_Object arg)
GCPRO1 (fn);
if (NILP (arg))
- RETURN_UNGCPRO (Ffuncall (1, &fn));
+ return Ffuncall (1, &fn);
gcpro1.nvars = 2;
{
Lisp_Object args[2];
args[0] = fn;
args[1] = arg;
gcpro1.var = args;
- RETURN_UNGCPRO (Fapply (2, args));
+ return Fapply (2, args);
}
}
@@ -2551,7 +2584,7 @@ call0 (Lisp_Object fn)
struct gcpro gcpro1;
GCPRO1 (fn);
- RETURN_UNGCPRO (Ffuncall (1, &fn));
+ return Ffuncall (1, &fn);
}
/* Call function fn with 1 argument arg1. */
@@ -2566,7 +2599,7 @@ call1 (Lisp_Object fn, Lisp_Object arg1)
args[1] = arg1;
GCPRO1 (args[0]);
gcpro1.nvars = 2;
- RETURN_UNGCPRO (Ffuncall (2, args));
+ return Ffuncall (2, args);
}
/* Call function fn with 2 arguments arg1, arg2. */
@@ -2581,7 +2614,7 @@ call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2)
args[2] = arg2;
GCPRO1 (args[0]);
gcpro1.nvars = 3;
- RETURN_UNGCPRO (Ffuncall (3, args));
+ return Ffuncall (3, args);
}
/* Call function fn with 3 arguments arg1, arg2, arg3. */
@@ -2597,7 +2630,7 @@ call3 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3)
args[3] = arg3;
GCPRO1 (args[0]);
gcpro1.nvars = 4;
- RETURN_UNGCPRO (Ffuncall (4, args));
+ return Ffuncall (4, args);
}
/* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
@@ -2615,7 +2648,7 @@ call4 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
args[4] = arg4;
GCPRO1 (args[0]);
gcpro1.nvars = 5;
- RETURN_UNGCPRO (Ffuncall (5, args));
+ return Ffuncall (5, args);
}
/* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
@@ -2634,7 +2667,7 @@ call5 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
args[5] = arg5;
GCPRO1 (args[0]);
gcpro1.nvars = 6;
- RETURN_UNGCPRO (Ffuncall (6, args));
+ return Ffuncall (6, args);
}
/* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
@@ -2654,7 +2687,7 @@ call6 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
args[6] = arg6;
GCPRO1 (args[0]);
gcpro1.nvars = 7;
- RETURN_UNGCPRO (Ffuncall (7, args));
+ return Ffuncall (7, args);
}
/* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
@@ -2675,7 +2708,7 @@ call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
args[7] = arg7;
GCPRO1 (args[0]);
gcpro1.nvars = 8;
- RETURN_UNGCPRO (Ffuncall (8, args));
+ return Ffuncall (8, args);
}
/* The caller should GCPRO all the elements of ARGS. */
@@ -2689,7 +2722,7 @@ DEFUN ("functionp", Ffunctionp, Sfunctionp, 1, 1, 0,
return Qnil;
}
-DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0,
+DEFUN ("funcall", Ffuncall1, Sfuncall, 1, MANY, 0,
doc: /* Call first argument as a function, passing remaining arguments to it.
Return the value that function returns.
Thus, (funcall 'cons 'x 'y) returns (x . y).
@@ -2701,12 +2734,16 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
ptrdiff_t numargs = nargs - 1;
Lisp_Object lisp_numargs;
Lisp_Object val;
- struct backtrace backtrace;
register Lisp_Object *internal_args;
ptrdiff_t i;
QUIT;
+ scm_dynwind_begin (0);
+ scm_dynwind_unwind_handler (set_lisp_eval_depth,
+ (void *) lisp_eval_depth,
+ SCM_F_WIND_EXPLICITLY);
+
if (++lisp_eval_depth > max_lisp_eval_depth)
{
if (max_lisp_eval_depth < 100)
@@ -2715,12 +2752,8 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
error ("Lisp nesting exceeds `max-lisp-eval-depth'");
}
- backtrace.next = backtrace_list;
- backtrace.function = args[0];
- backtrace.args = &args[1]; /* This also GCPROs them. */
- backtrace.nargs = nargs - 1;
- backtrace.debug_on_exit = 0;
- backtrace_list = &backtrace;
+ /* This also GCPROs them. */
+ record_in_backtrace (args[0], &args[1], nargs - 1);
/* Call GC after setting up the backtrace, so the latter GCPROs the args. */
maybe_gc ();
@@ -2728,103 +2761,25 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
if (debug_on_next_call)
do_debug_on_call (Qlambda);
- check_cons_list ();
-
original_fun = args[0];
retry:
/* Optimize for no indirection. */
fun = original_fun;
- if (SYMBOLP (fun) && !EQ (fun, Qunbound)
- && (fun = XSYMBOL (fun)->function, SYMBOLP (fun)))
+ if (SYMBOLP (fun) && !NILP (fun)
+ && (fun = SYMBOL_FUNCTION (fun), SYMBOLP (fun)))
fun = indirect_function (fun);
- if (SUBRP (fun))
+ if (scm_is_true (scm_procedure_p (fun)))
{
- if (numargs < XSUBR (fun)->min_args
- || (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs))
- {
- XSETFASTINT (lisp_numargs, numargs);
- xsignal2 (Qwrong_number_of_arguments, original_fun, lisp_numargs);
- }
-
- else if (XSUBR (fun)->max_args == UNEVALLED)
- xsignal1 (Qinvalid_function, original_fun);
-
- else if (XSUBR (fun)->max_args == MANY)
- val = (XSUBR (fun)->function.aMANY) (numargs, args + 1);
- else
- {
- if (XSUBR (fun)->max_args > numargs)
- {
- internal_args = alloca (XSUBR (fun)->max_args
- * sizeof *internal_args);
- memcpy (internal_args, args + 1, numargs * word_size);
- for (i = numargs; i < XSUBR (fun)->max_args; i++)
- internal_args[i] = Qnil;
- }
- else
- internal_args = args + 1;
- switch (XSUBR (fun)->max_args)
- {
- case 0:
- val = (XSUBR (fun)->function.a0 ());
- break;
- case 1:
- val = (XSUBR (fun)->function.a1 (internal_args[0]));
- break;
- case 2:
- val = (XSUBR (fun)->function.a2
- (internal_args[0], internal_args[1]));
- break;
- case 3:
- val = (XSUBR (fun)->function.a3
- (internal_args[0], internal_args[1], internal_args[2]));
- break;
- case 4:
- val = (XSUBR (fun)->function.a4
- (internal_args[0], internal_args[1], internal_args[2],
- internal_args[3]));
- break;
- case 5:
- val = (XSUBR (fun)->function.a5
- (internal_args[0], internal_args[1], internal_args[2],
- internal_args[3], internal_args[4]));
- break;
- case 6:
- val = (XSUBR (fun)->function.a6
- (internal_args[0], internal_args[1], internal_args[2],
- internal_args[3], internal_args[4], internal_args[5]));
- break;
- case 7:
- val = (XSUBR (fun)->function.a7
- (internal_args[0], internal_args[1], internal_args[2],
- internal_args[3], internal_args[4], internal_args[5],
- internal_args[6]));
- break;
-
- case 8:
- val = (XSUBR (fun)->function.a8
- (internal_args[0], internal_args[1], internal_args[2],
- internal_args[3], internal_args[4], internal_args[5],
- internal_args[6], internal_args[7]));
- break;
-
- default:
-
- /* 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. */
- emacs_abort ();
- }
- }
+ val = scm_call_n (fun, args + 1, numargs);
}
else if (COMPILEDP (fun))
val = funcall_lambda (fun, numargs, args + 1);
else
{
- if (EQ (fun, Qunbound))
+ if (NILP (fun))
xsignal1 (Qvoid_function, original_fun);
if (!CONSP (fun))
xsignal1 (Qinvalid_function, original_fun);
@@ -2837,19 +2792,22 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
else if (EQ (funcar, Qautoload))
{
Fautoload_do_load (fun, original_fun, Qnil);
- check_cons_list ();
goto retry;
}
else
xsignal1 (Qinvalid_function, original_fun);
}
- check_cons_list ();
- lisp_eval_depth--;
- if (backtrace.debug_on_exit)
- val = call_debugger (Fcons (Qexit, Fcons (val, Qnil)));
- backtrace_list = backtrace.next;
+ if (backtrace_debug_on_exit (specpdl_ptr - 1))
+ val = call_debugger (list2 (Qexit, val));
+ scm_dynwind_end ();
return val;
}
+
+Lisp_Object
+Ffuncall (ptrdiff_t nargs, Lisp_Object *args)
+{
+ return scm_c_value_ref (Ffuncall1 (nargs, args), 0);
+}
static Lisp_Object
apply_lambda (Lisp_Object fun, Lisp_Object args)
@@ -2879,15 +2837,17 @@ apply_lambda (Lisp_Object fun, Lisp_Object args)
UNGCPRO;
- backtrace_list->args = arg_vector;
- backtrace_list->nargs = i;
+ set_backtrace_args (specpdl_ptr - 1, arg_vector);
+ set_backtrace_nargs (specpdl_ptr - 1, i);
tem = funcall_lambda (fun, numargs, arg_vector);
/* Do the debug-on-exit now, while arg_vector still exists. */
- if (backtrace_list->debug_on_exit)
- tem = call_debugger (Fcons (Qexit, Fcons (tem, Qnil)));
- /* Don't do it again when we return to eval. */
- backtrace_list->debug_on_exit = 0;
+ if (backtrace_debug_on_exit (specpdl_ptr - 1))
+ {
+ /* Don't do it again when we return to eval. */
+ set_backtrace_debug_on_exit (specpdl_ptr - 1, false);
+ tem = call_debugger (list2 (Qexit, tem));
+ }
SAFE_FREE ();
return tem;
}
@@ -2901,7 +2861,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
register Lisp_Object *arg_vector)
{
Lisp_Object val, syms_left, next, lexenv;
- ptrdiff_t count = SPECPDL_INDEX ();
+ dynwind_begin ();
ptrdiff_t i;
bool optional, rest;
@@ -2938,6 +2898,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
and constants vector yet, fetch them from the file. */
if (CONSP (AREF (fun, COMPILED_BYTECODE)))
Ffetch_bytecode (fun);
+ dynwind_end ();
return exec_byte_code (AREF (fun, COMPILED_BYTECODE),
AREF (fun, COMPILED_CONSTANTS),
AREF (fun, COMPILED_STACK_DEPTH),
@@ -3010,7 +2971,8 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
Qnil, 0, 0);
}
- return unbind_to (count, val);
+ dynwind_end ();
+ return val;
}
DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode,
@@ -3037,36 +2999,51 @@ DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode,
return object;
}
-static void
-grow_specpdl (void)
+/* Return true if SYMBOL currently has a let-binding
+ which was made in the buffer that is now current. */
+
+bool
+let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol)
{
- register ptrdiff_t count = SPECPDL_INDEX ();
- ptrdiff_t max_size = min (max_specpdl_size, PTRDIFF_MAX);
- if (max_size <= specpdl_size)
- {
- if (max_specpdl_size < 400)
- max_size = max_specpdl_size = 400;
- if (max_size <= specpdl_size)
- signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil);
- }
- specpdl = xpalloc (specpdl, &specpdl_size, 1, max_size, sizeof *specpdl);
- specpdl_ptr = specpdl + count;
+ union specbinding *p;
+ Lisp_Object buf = Fcurrent_buffer ();
+
+ for (p = specpdl_ptr; p > specpdl; )
+ if ((--p)->kind > SPECPDL_LET)
+ {
+ struct Lisp_Symbol *let_bound_symbol = XSYMBOL (specpdl_symbol (p));
+ eassert (let_bound_symbol->redirect != SYMBOL_VARALIAS);
+ if (symbol == let_bound_symbol
+ && EQ (specpdl_where (p), buf))
+ return 1;
+ }
+
+ return 0;
+}
+
+bool
+let_shadows_global_binding_p (Lisp_Object symbol)
+{
+ union specbinding *p;
+
+ for (p = specpdl_ptr; p > specpdl; )
+ if ((--p)->kind >= SPECPDL_LET && EQ (specpdl_symbol (p), symbol))
+ return 1;
+
+ return 0;
}
-/* `specpdl_ptr->symbol' is a field which describes which variable is
+/* `specpdl_ptr' describes which variable is
let-bound, so it can be properly undone when we unbind_to.
- It can have the following two shapes:
- - SYMBOL : if it's a plain symbol, it means that we have let-bound
- a symbol that is not buffer-local (at least at the time
- the let binding started). Note also that it should not be
+ It can be either a plain SPECPDL_LET or a SPECPDL_LET_LOCAL/DEFAULT.
+ - SYMBOL is the variable being bound. Note that it should not be
aliased (i.e. when let-binding V1 that's aliased to V2, we want
to record V2 here).
- - (SYMBOL WHERE . BUFFER) : this means that it is a let-binding for
- variable SYMBOL which can be buffer-local. WHERE tells us
- which buffer is affected (or nil if the let-binding affects the
- global value of the variable) and BUFFER tells us which buffer was
- current (i.e. if WHERE is non-nil, then BUFFER==WHERE, otherwise
- BUFFER did not yet have a buffer-local value). */
+ - WHERE tells us in which buffer the binding took place.
+ This is used for SPECPDL_LET_LOCAL bindings (i.e. bindings to a
+ buffer-local variable) as well as for SPECPDL_LET_DEFAULT bindings,
+ i.e. bindings to the default value of a variable which can be
+ buffer-local. */
void
specbind (Lisp_Object symbol, Lisp_Object value)
@@ -3075,8 +3052,6 @@ specbind (Lisp_Object symbol, Lisp_Object value)
CHECK_SYMBOL (symbol);
sym = XSYMBOL (symbol);
- if (specpdl_ptr == specpdl + specpdl_size)
- grow_specpdl ();
start:
switch (sym->redirect)
@@ -3086,10 +3061,10 @@ specbind (Lisp_Object symbol, Lisp_Object value)
case SYMBOL_PLAINVAL:
/* The most common case is that of a non-constant symbol with a
trivial value. Make that as fast as we can. */
- set_specpdl_symbol (symbol);
- set_specpdl_old_value (SYMBOL_VAL (sym));
- specpdl_ptr->func = NULL;
- ++specpdl_ptr;
+ specpdl_ptr->let.kind = SPECPDL_LET;
+ specpdl_ptr->let.symbol = symbol;
+ specpdl_ptr->let.old_value = SYMBOL_VAL (sym);
+ grow_specpdl ();
if (!sym->constant)
SET_SYMBOL_VAL (sym, value);
else
@@ -3101,141 +3076,172 @@ specbind (Lisp_Object symbol, Lisp_Object value)
case SYMBOL_FORWARDED:
{
Lisp_Object ovalue = find_symbol_value (symbol);
- specpdl_ptr->func = 0;
- set_specpdl_old_value (ovalue);
+ specpdl_ptr->let.kind = SPECPDL_LET_LOCAL;
+ specpdl_ptr->let.symbol = symbol;
+ specpdl_ptr->let.old_value = ovalue;
+ specpdl_ptr->let.where = Fcurrent_buffer ();
eassert (sym->redirect != SYMBOL_LOCALIZED
- || (EQ (SYMBOL_BLV (sym)->where,
- SYMBOL_BLV (sym)->frame_local ?
- Fselected_frame () : Fcurrent_buffer ())));
+ || (EQ (SYMBOL_BLV (sym)->where, Fcurrent_buffer ())));
- if (sym->redirect == SYMBOL_LOCALIZED
- || BUFFER_OBJFWDP (SYMBOL_FWD (sym)))
+ if (sym->redirect == SYMBOL_LOCALIZED)
+ {
+ if (!blv_found (SYMBOL_BLV (sym)))
+ specpdl_ptr->let.kind = SPECPDL_LET_DEFAULT;
+ }
+ else if (BUFFER_OBJFWDP (SYMBOL_FWD (sym)))
{
- Lisp_Object where, cur_buf = Fcurrent_buffer ();
-
- /* For a local variable, record both the symbol and which
- buffer's or frame's value we are saving. */
- if (!NILP (Flocal_variable_p (symbol, Qnil)))
- {
- eassert (sym->redirect != SYMBOL_LOCALIZED
- || (blv_found (SYMBOL_BLV (sym))
- && EQ (cur_buf, SYMBOL_BLV (sym)->where)));
- where = cur_buf;
- }
- else if (sym->redirect == SYMBOL_LOCALIZED
- && blv_found (SYMBOL_BLV (sym)))
- where = SYMBOL_BLV (sym)->where;
- else
- where = Qnil;
-
- /* We're not using the `unused' slot in the specbinding
- structure because this would mean we have to do more
- work for simple variables. */
- /* FIXME: The third value `current_buffer' is only used in
- let_shadows_buffer_binding_p which is itself only used
- in set_internal for local_if_set. */
- eassert (NILP (where) || EQ (where, cur_buf));
- set_specpdl_symbol (Fcons (symbol, Fcons (where, cur_buf)));
-
/* If SYMBOL is a per-buffer variable which doesn't have a
buffer-local value here, make the `let' change the global
value by changing the value of SYMBOL in all buffers not
having their own value. This is consistent with what
happens with other buffer-local variables. */
- if (NILP (where)
- && sym->redirect == SYMBOL_FORWARDED)
+ if (NILP (Flocal_variable_p (symbol, Qnil)))
{
- eassert (BUFFER_OBJFWDP (SYMBOL_FWD (sym)));
- ++specpdl_ptr;
+ specpdl_ptr->let.kind = SPECPDL_LET_DEFAULT;
+ grow_specpdl ();
Fset_default (symbol, value);
- return;
+ goto done;
}
}
else
- set_specpdl_symbol (symbol);
+ specpdl_ptr->let.kind = SPECPDL_LET;
- specpdl_ptr++;
+ grow_specpdl ();
set_internal (symbol, value, Qnil, 1);
break;
}
default: emacs_abort ();
}
+
+ done:
+ scm_dynwind_unwind_handler (unbind_once, NULL, SCM_F_WIND_EXPLICITLY);
}
+/* Push unwind-protect entries of various types. */
+
void
-record_unwind_protect (Lisp_Object (*function) (Lisp_Object), Lisp_Object arg)
+record_unwind_protect_1 (void (*function) (Lisp_Object), Lisp_Object arg,
+ bool wind_explicitly)
{
- if (specpdl_ptr == specpdl + specpdl_size)
- grow_specpdl ();
- specpdl_ptr->func = function;
- set_specpdl_symbol (Qnil);
- set_specpdl_old_value (arg);
- specpdl_ptr++;
+ record_unwind_protect_ptr_1 (function, arg, wind_explicitly);
}
-Lisp_Object
-unbind_to (ptrdiff_t count, Lisp_Object value)
+void
+record_unwind_protect (void (*function) (Lisp_Object), Lisp_Object arg)
{
- Lisp_Object quitf = Vquit_flag;
- struct gcpro gcpro1, gcpro2;
+ record_unwind_protect_1 (function, arg, true);
+}
- GCPRO2 (value, quitf);
- Vquit_flag = Qnil;
+void
+record_unwind_protect_ptr_1 (void (*function) (void *), void *arg,
+ bool wind_explicitly)
+{
+ scm_dynwind_unwind_handler (function,
+ arg,
+ (wind_explicitly
+ ? SCM_F_WIND_EXPLICITLY
+ : 0));
+}
- while (specpdl_ptr != specpdl + count)
- {
- /* Copy the binding, and decrement specpdl_ptr, before we do
- the work to unbind it. We decrement first
- so that an error in unbinding won't try to unbind
- the same entry again, and we copy the binding first
- in case more bindings are made during some of the code we run. */
-
- struct specbinding this_binding;
- this_binding = *--specpdl_ptr;
-
- if (this_binding.func != 0)
- (*this_binding.func) (this_binding.old_value);
- /* If the symbol is a list, it is really (SYMBOL WHERE
- . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
- frame. If WHERE is a buffer or frame, this indicates we
- bound a variable that had a buffer-local or frame-local
- binding. WHERE nil means that the variable had the default
- value when it was bound. CURRENT-BUFFER is the buffer that
- was current when the variable was bound. */
- else if (CONSP (this_binding.symbol))
- {
- Lisp_Object symbol, where;
-
- symbol = XCAR (this_binding.symbol);
- where = XCAR (XCDR (this_binding.symbol));
-
- if (NILP (where))
- Fset_default (symbol, this_binding.old_value);
- /* If `where' is non-nil, reset the value in the appropriate
- local binding, but only if that binding still exists. */
- else if (BUFFERP (where)
- ? !NILP (Flocal_variable_p (symbol, where))
- : !NILP (Fassq (symbol, XFRAME (where)->param_alist)))
- set_internal (symbol, this_binding.old_value, where, 1);
- }
- /* If variable has a trivial value (no forwarding), we can
- just set it. No need to check for constant symbols here,
- since that was already done by specbind. */
- else if (XSYMBOL (this_binding.symbol)->redirect == SYMBOL_PLAINVAL)
- SET_SYMBOL_VAL (XSYMBOL (this_binding.symbol),
- this_binding.old_value);
- else
- /* NOTE: we only ever come here if make_local_foo was used for
- the first time on this var within this let. */
- Fset_default (this_binding.symbol, this_binding.old_value);
+void
+record_unwind_protect_ptr (void (*function) (void *), void *arg)
+{
+ record_unwind_protect_ptr_1 (function, arg, true);
+}
+
+void
+record_unwind_protect_int_1 (void (*function) (int), int arg,
+ bool wind_explicitly)
+{
+ record_unwind_protect_ptr_1 (function, arg, wind_explicitly);
+}
+
+void
+record_unwind_protect_int (void (*function) (int), int arg)
+{
+ record_unwind_protect_int_1 (function, arg, true);
+}
+
+static void
+call_void (void *data)
+{
+ ((void (*) (void)) data) ();
+}
+
+void
+record_unwind_protect_void_1 (void (*function) (void),
+ bool wind_explicitly)
+{
+ record_unwind_protect_ptr_1 (call_void, function, wind_explicitly);
+}
+
+void
+record_unwind_protect_void (void (*function) (void))
+{
+ record_unwind_protect_void_1 (function, true);
+}
+
+static void
+unbind_once (void *ignore)
+{
+ /* Decrement specpdl_ptr before we do the work to unbind it, so
+ that an error in unbinding won't try to unbind the same entry
+ again. Take care to copy any parts of the binding needed
+ before invoking any code that can make more bindings. */
+
+ specpdl_ptr--;
+
+ switch (specpdl_ptr->kind)
+ {
+ case SPECPDL_BACKTRACE:
+ break;
+ case SPECPDL_LET:
+ { /* If variable has a trivial value (no forwarding), we can
+ just set it. No need to check for constant symbols here,
+ since that was already done by specbind. */
+ struct Lisp_Symbol *sym = XSYMBOL (specpdl_symbol (specpdl_ptr));
+ if (sym->redirect == SYMBOL_PLAINVAL)
+ {
+ SET_SYMBOL_VAL (sym, specpdl_old_value (specpdl_ptr));
+ break;
+ }
+ else
+ { /* FALLTHROUGH!!
+ NOTE: we only ever come here if make_local_foo was used for
+ the first time on this var within this let. */
+ }
+ }
+ case SPECPDL_LET_DEFAULT:
+ Fset_default (specpdl_symbol (specpdl_ptr),
+ specpdl_old_value (specpdl_ptr));
+ break;
+ case SPECPDL_LET_LOCAL:
+ {
+ Lisp_Object symbol = specpdl_symbol (specpdl_ptr);
+ Lisp_Object where = specpdl_where (specpdl_ptr);
+ Lisp_Object old_value = specpdl_old_value (specpdl_ptr);
+ eassert (BUFFERP (where));
+
+ /* If this was a local binding, reset the value in the appropriate
+ buffer, but only if that buffer's binding still exists. */
+ if (!NILP (Flocal_variable_p (symbol, where)))
+ set_internal (symbol, old_value, where, 1);
+ }
+ break;
}
+}
- if (NILP (Vquit_flag) && !NILP (quitf))
- Vquit_flag = quitf;
+void
+dynwind_begin (void)
+{
+ scm_dynwind_begin (0);
+}
- UNGCPRO;
- return value;
+void
+dynwind_end (void)
+{
+ scm_dynwind_end ();
}
DEFUN ("special-variable-p", Fspecial_variable_p, Sspecial_variable_p, 1, 1, 0,
@@ -3254,18 +3260,16 @@ DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
The debugger is entered when that frame exits, if the flag is non-nil. */)
(Lisp_Object level, Lisp_Object flag)
{
- register struct backtrace *backlist = backtrace_list;
+ union specbinding *pdl = backtrace_top ();
register EMACS_INT i;
CHECK_NUMBER (level);
- for (i = 0; backlist && i < XINT (level); i++)
- {
- backlist = backlist->next;
- }
+ for (i = 0; backtrace_p (pdl) && i < XINT (level); i++)
+ pdl = backtrace_next (pdl);
- if (backlist)
- backlist->debug_on_exit = !NILP (flag);
+ if (backtrace_p (pdl))
+ set_backtrace_debug_on_exit (pdl, !NILP (flag));
return flag;
}
@@ -3275,62 +3279,68 @@ DEFUN ("backtrace", Fbacktrace, Sbacktrace, 0, 0, "",
Output stream used is value of `standard-output'. */)
(void)
{
- register struct backtrace *backlist = backtrace_list;
- Lisp_Object tail;
+ union specbinding *pdl = backtrace_top ();
Lisp_Object tem;
- struct gcpro gcpro1;
Lisp_Object old_print_level = Vprint_level;
if (NILP (Vprint_level))
XSETFASTINT (Vprint_level, 8);
- tail = Qnil;
- GCPRO1 (tail);
-
- while (backlist)
+ while (backtrace_p (pdl))
{
- write_string (backlist->debug_on_exit ? "* " : " ", 2);
- if (backlist->nargs == UNEVALLED)
+ write_string (backtrace_debug_on_exit (pdl) ? "* " : " ", 2);
+ if (backtrace_nargs (pdl) == UNEVALLED)
{
- Fprin1 (Fcons (backlist->function, *backlist->args), Qnil);
+ Fprin1 (Fcons (backtrace_function (pdl), *backtrace_args (pdl)),
+ Qnil);
write_string ("\n", -1);
}
else
{
- tem = backlist->function;
+ tem = backtrace_function (pdl);
Fprin1 (tem, Qnil); /* This can QUIT. */
write_string ("(", -1);
- if (backlist->nargs == MANY)
- { /* FIXME: Can this happen? */
- bool later_arg = 0;
- for (tail = *backlist->args; !NILP (tail); tail = Fcdr (tail))
- {
- if (later_arg)
- write_string (" ", -1);
- Fprin1 (Fcar (tail), Qnil);
- later_arg = 1;
- }
- }
- else
- {
- ptrdiff_t i;
- for (i = 0; i < backlist->nargs; i++)
- {
- if (i) write_string (" ", -1);
- Fprin1 (backlist->args[i], Qnil);
- }
- }
+ {
+ ptrdiff_t i;
+ for (i = 0; i < backtrace_nargs (pdl); i++)
+ {
+ if (i) write_string (" ", -1);
+ Fprin1 (backtrace_args (pdl)[i], Qnil);
+ }
+ }
write_string (")\n", -1);
}
- backlist = backlist->next;
+ pdl = backtrace_next (pdl);
}
Vprint_level = old_print_level;
- UNGCPRO;
return Qnil;
}
-DEFUN ("backtrace-frame", Fbacktrace_frame, Sbacktrace_frame, 1, 1, NULL,
+static union specbinding *
+get_backtrace_frame (Lisp_Object nframes, Lisp_Object base)
+{
+ union specbinding *pdl = backtrace_top ();
+ register EMACS_INT i;
+
+ CHECK_NATNUM (nframes);
+
+ if (!NILP (base))
+ { /* Skip up to `base'. */
+ base = Findirect_function (base, Qt);
+ while (backtrace_p (pdl)
+ && !EQ (base, Findirect_function (backtrace_function (pdl), Qt)))
+ pdl = backtrace_next (pdl);
+ }
+
+ /* Find the frame requested. */
+ for (i = XFASTINT (nframes); i > 0 && backtrace_p (pdl); i--)
+ pdl = backtrace_next (pdl);
+
+ return pdl;
+}
+
+DEFUN ("backtrace-frame", Fbacktrace_frame, Sbacktrace_frame, 1, 2, NULL,
doc: /* Return the function and arguments NFRAMES up from current execution point.
If that frame has not evaluated the arguments yet (or is a special form),
the value is (nil FUNCTION ARG-FORMS...).
@@ -3339,67 +3349,261 @@ the value is (t FUNCTION ARG-VALUES...).
A &rest arg is represented as the tail of the list ARG-VALUES.
FUNCTION is whatever was supplied as car of evaluated list,
or a lambda expression for macro calls.
-If NFRAMES is more than the number of frames, the value is nil. */)
- (Lisp_Object nframes)
+If NFRAMES is more than the number of frames, the value is nil.
+If BASE is non-nil, it should be a function and NFRAMES counts from its
+nearest activation frame. */)
+ (Lisp_Object nframes, Lisp_Object base)
{
- register struct backtrace *backlist = backtrace_list;
- register EMACS_INT i;
- Lisp_Object tem;
+ union specbinding *pdl = get_backtrace_frame (nframes, base);
- CHECK_NATNUM (nframes);
-
- /* Find the frame requested. */
- for (i = 0; backlist && i < XFASTINT (nframes); i++)
- backlist = backlist->next;
-
- if (!backlist)
+ if (!backtrace_p (pdl))
return Qnil;
- if (backlist->nargs == UNEVALLED)
- return Fcons (Qnil, Fcons (backlist->function, *backlist->args));
+ if (backtrace_nargs (pdl) == UNEVALLED)
+ return Fcons (Qnil,
+ Fcons (backtrace_function (pdl), *backtrace_args (pdl)));
else
{
- if (backlist->nargs == MANY) /* FIXME: Can this happen? */
- tem = *backlist->args;
- else
- tem = Flist (backlist->nargs, backlist->args);
+ Lisp_Object tem = Flist (backtrace_nargs (pdl), backtrace_args (pdl));
- return Fcons (Qt, Fcons (backlist->function, tem));
+ return Fcons (Qt, Fcons (backtrace_function (pdl), tem));
}
}
+/* For backtrace-eval, we want to temporarily unwind the last few elements of
+ the specpdl stack, and then rewind them. We store the pre-unwind values
+ directly in the pre-existing specpdl elements (i.e. we swap the current
+ value and the old value stored in the specpdl), kind of like the inplace
+ pointer-reversal trick. As it turns out, the rewind does the same as the
+ unwind, except it starts from the other end of the specpdl stack, so we use
+ the same function for both unwind and rewind. */
+static void
+backtrace_eval_unrewind (int distance)
+{
+ union specbinding *tmp = specpdl_ptr;
+ int step = -1;
+ if (distance < 0)
+ { /* It's a rewind rather than unwind. */
+ tmp += distance - 1;
+ step = 1;
+ distance = -distance;
+ }
+
+ for (; distance > 0; distance--)
+ {
+ tmp += step;
+ /* */
+ switch (tmp->kind)
+ {
+ case SPECPDL_BACKTRACE:
+ break;
+ case SPECPDL_LET:
+ { /* If variable has a trivial value (no forwarding), we can
+ just set it. No need to check for constant symbols here,
+ since that was already done by specbind. */
+ struct Lisp_Symbol *sym = XSYMBOL (specpdl_symbol (tmp));
+ if (sym->redirect == SYMBOL_PLAINVAL)
+ {
+ Lisp_Object old_value = specpdl_old_value (tmp);
+ set_specpdl_old_value (tmp, SYMBOL_VAL (sym));
+ SET_SYMBOL_VAL (sym, old_value);
+ break;
+ }
+ else
+ { /* FALLTHROUGH!!
+ NOTE: we only ever come here if make_local_foo was used for
+ the first time on this var within this let. */
+ }
+ }
+ case SPECPDL_LET_DEFAULT:
+ {
+ Lisp_Object sym = specpdl_symbol (tmp);
+ Lisp_Object old_value = specpdl_old_value (tmp);
+ set_specpdl_old_value (tmp, Fdefault_value (sym));
+ Fset_default (sym, old_value);
+ }
+ break;
+ case SPECPDL_LET_LOCAL:
+ {
+ Lisp_Object symbol = specpdl_symbol (tmp);
+ Lisp_Object where = specpdl_where (tmp);
+ Lisp_Object old_value = specpdl_old_value (tmp);
+ eassert (BUFFERP (where));
+
+ /* If this was a local binding, reset the value in the appropriate
+ buffer, but only if that buffer's binding still exists. */
+ if (!NILP (Flocal_variable_p (symbol, where)))
+ {
+ set_specpdl_old_value
+ (tmp, Fbuffer_local_value (symbol, where));
+ set_internal (symbol, old_value, where, 1);
+ }
+ }
+ break;
+ }
+ }
+}
+
+DEFUN ("backtrace-eval", Fbacktrace_eval, Sbacktrace_eval, 2, 3, NULL,
+ doc: /* Evaluate EXP in the context of some activation frame.
+NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */)
+ (Lisp_Object exp, Lisp_Object nframes, Lisp_Object base)
+{
+ union specbinding *pdl = get_backtrace_frame (nframes, base);
+ dynwind_begin ();
+ ptrdiff_t distance = specpdl_ptr - pdl;
+ eassert (distance >= 0);
+
+ if (!backtrace_p (pdl))
+ error ("Activation frame not found!");
+
+ backtrace_eval_unrewind (distance);
+ record_unwind_protect_int (backtrace_eval_unrewind, -distance);
+
+ /* Use eval_sub rather than Feval since the main motivation behind
+ backtrace-eval is to be able to get/set the value of lexical variables
+ from the debugger. */
+ Lisp_Object tem1 = eval_sub (exp);
+ dynwind_end ();
+ return tem1;
+}
+
+DEFUN ("backtrace--locals", Fbacktrace__locals, Sbacktrace__locals, 1, 2, NULL,
+ doc: /* Return names and values of local variables of a stack frame.
+NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */)
+ (Lisp_Object nframes, Lisp_Object base)
+{
+ union specbinding *frame = get_backtrace_frame (nframes, base);
+ union specbinding *prevframe
+ = get_backtrace_frame (make_number (XFASTINT (nframes) - 1), base);
+ ptrdiff_t distance = specpdl_ptr - frame;
+ Lisp_Object result = Qnil;
+ eassert (distance >= 0);
+
+ if (!backtrace_p (prevframe))
+ error ("Activation frame not found!");
+ if (!backtrace_p (frame))
+ error ("Activation frame not found!");
+
+ /* The specpdl entries normally contain the symbol being bound along with its
+ `old_value', so it can be restored. The new value to which it is bound is
+ available in one of two places: either in the current value of the
+ variable (if it hasn't been rebound yet) or in the `old_value' slot of the
+ next specpdl entry for it.
+ `backtrace_eval_unrewind' happens to swap the role of `old_value'
+ and "new value", so we abuse it here, to fetch the new value.
+ It's ugly (we'd rather not modify global data) and a bit inefficient,
+ but it does the job for now. */
+ backtrace_eval_unrewind (distance);
+
+ /* Grab values. */
+ {
+ union specbinding *tmp = prevframe;
+ for (; tmp > frame; tmp--)
+ {
+ switch (tmp->kind)
+ {
+ case SPECPDL_LET:
+ case SPECPDL_LET_DEFAULT:
+ case SPECPDL_LET_LOCAL:
+ {
+ Lisp_Object sym = specpdl_symbol (tmp);
+ Lisp_Object val = specpdl_old_value (tmp);
+ if (EQ (sym, Qinternal_interpreter_environment))
+ {
+ Lisp_Object env = val;
+ for (; CONSP (env); env = XCDR (env))
+ {
+ Lisp_Object binding = XCAR (env);
+ if (CONSP (binding))
+ result = Fcons (Fcons (XCAR (binding),
+ XCDR (binding)),
+ result);
+ }
+ }
+ else
+ result = Fcons (Fcons (sym, val), result);
+ }
+ }
+ }
+ }
+
+ /* Restore values from specpdl to original place. */
+ backtrace_eval_unrewind (-distance);
+
+ return result;
+}
+
-#if BYTE_MARK_STACK
void
-mark_backtrace (void)
+get_backtrace (Lisp_Object array)
{
- register struct backtrace *backlist;
- ptrdiff_t i;
+ union specbinding *pdl = backtrace_next (backtrace_top ());
+ ptrdiff_t i = 0, asize = ASIZE (array);
- for (backlist = backtrace_list; backlist; backlist = backlist->next)
+ /* Copy the backtrace contents into working memory. */
+ for (; i < asize; i++)
{
- mark_object (*backlist->function);
-
- if (backlist->nargs == UNEVALLED
- || backlist->nargs == MANY) /* FIXME: Can this happen? */
- i = 1;
+ if (backtrace_p (pdl))
+ {
+ ASET (array, i, backtrace_function (pdl));
+ pdl = backtrace_next (pdl);
+ }
else
- i = backlist->nargs;
- while (i--)
- mark_object (backlist->args[i]);
+ ASET (array, i, Qnil);
}
}
-#endif
+Lisp_Object backtrace_top_function (void)
+{
+ union specbinding *pdl = backtrace_top ();
+ return (backtrace_p (pdl) ? backtrace_function (pdl) : Qnil);
+}
+
+_Noreturn SCM
+abort_to_prompt (SCM tag, SCM arglst)
+{
+ static SCM var = SCM_UNDEFINED;
+ if (SCM_UNBNDP (var))
+ var = scm_c_public_lookup ("guile", "abort-to-prompt");
+
+ scm_apply_1 (scm_variable_ref (var), tag, arglst);
+ emacs_abort ();
+}
+
+SCM
+call_with_prompt (SCM tag, SCM thunk, SCM handler)
+{
+ static SCM var = SCM_UNDEFINED;
+ if (SCM_UNBNDP (var))
+ var = scm_c_public_lookup ("guile", "call-with-prompt");
+
+ return scm_call_3 (scm_variable_ref (var), tag, thunk, handler);
+}
+
+SCM
+make_prompt_tag (void)
+{
+ static SCM var = SCM_UNDEFINED;
+ if (SCM_UNBNDP (var))
+ var = scm_c_public_lookup ("guile", "make-prompt-tag");
+
+ return scm_call_0 (scm_variable_ref (var));
+}
+
void
syms_of_eval (void)
{
+#include "eval.x"
+
DEFVAR_INT ("max-specpdl-size", max_specpdl_size,
doc: /* Limit on number of Lisp variable bindings and `unwind-protect's.
If Lisp code tries to increase the total number past this amount,
an error is signaled.
You can safely use a value considerably larger than the default value,
if that proves inconveniently small. However, if you increase it too far,
-Emacs could run out of memory trying to make the stack bigger. */);
+Emacs could run out of memory trying to make the stack bigger.
+Note that this limit may be silently increased by the debugger
+if `debug-on-error' or `debug-on-quit' is set. */);
DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth,
doc: /* Limit on depth in `eval', `apply' and `funcall' before error.
@@ -3535,47 +3739,4 @@ alist of active lexical bindings. */);
Vsignaling_function = Qnil;
inhibit_lisp_code = Qnil;
-
- defsubr (&Sor);
- defsubr (&Sand);
- defsubr (&Sif);
- defsubr (&Scond);
- defsubr (&Sprogn);
- defsubr (&Sprog1);
- defsubr (&Sprog2);
- defsubr (&Ssetq);
- defsubr (&Squote);
- defsubr (&Sfunction);
- defsubr (&Sdefvar);
- defsubr (&Sdefvaralias);
- defsubr (&Sdefconst);
- defsubr (&Smake_var_non_special);
- defsubr (&Slet);
- defsubr (&SletX);
- defsubr (&Swhile);
- defsubr (&Smacroexpand);
- defsubr (&Scatch);
- defsubr (&Sthrow);
- defsubr (&Sunwind_protect);
- defsubr (&Scondition_case);
- defsubr (&Ssignal);
- defsubr (&Sinteractive_p);
- defsubr (&Scalled_interactively_p);
- defsubr (&Scommandp);
- defsubr (&Sautoload);
- defsubr (&Sautoload_do_load);
- 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 (&Srun_hook_wrapped);
- defsubr (&Sfetch_bytecode);
- defsubr (&Sbacktrace_debug);
- defsubr (&Sbacktrace);
- defsubr (&Sbacktrace_frame);
- defsubr (&Sspecial_variable_p);
- defsubr (&Sfunctionp);
}