X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/c400516ab1d827d08225ffb3e1bc1969c73cc45e..bc203f9e4311ddb2c6ea12c14ae2dc2f463591c1:/src/eval.c
diff --git a/src/eval.c b/src/eval.c
index 7d54ddb18f..8e60e8e30f 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -27,6 +27,9 @@ along with GNU Emacs. If not, see . */
#include "commands.h"
#include "keyboard.h"
#include "dispextern.h"
+#include "guile.h"
+
+static void unbind_once (void *ignore);
/* Chain of condition and catch handlers currently in effect. */
@@ -70,6 +73,10 @@ ptrdiff_t specpdl_size;
union specbinding *specpdl;
+/* Pointer to the dummy entry before the specpdl. */
+
+union specbinding *specpdl_base;
+
/* Pointer to first unused element in specpdl. */
union specbinding *specpdl_ptr;
@@ -98,13 +105,6 @@ 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 Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args);
@@ -136,119 +136,69 @@ specpdl_where (union specbinding *pdl)
return pdl->let.where;
}
-static Lisp_Object
-specpdl_arg (union specbinding *pdl)
-{
- eassert (pdl->kind == SPECPDL_UNWIND);
- return pdl->unwind.arg;
-}
-
-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)
+struct handler *
+make_catch_handler (Lisp_Object tag)
{
- eassert (pdl->kind == SPECPDL_BACKTRACE);
- pdl->bt.args = args;
+ 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->interrupt_input_blocked = interrupt_input_blocked;
+ c->ptag = make_prompt_tag ();
+ return c;
}
-static void
-set_backtrace_nargs (union specbinding *pdl, ptrdiff_t n)
+struct handler *
+make_condition_handler (Lisp_Object tag)
{
- eassert (pdl->kind == SPECPDL_BACKTRACE);
- pdl->bt.nargs = n;
-}
-
-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 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 *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->interrupt_input_blocked = interrupt_input_blocked;
+ c->ptag = make_prompt_tag ();
+ return c;
}
+static Lisp_Object eval_fn;
+static Lisp_Object funcall_fn;
void
init_eval_once (void)
{
enum { size = 50 };
union specbinding *pdlvec = xmalloc ((size + 1) * sizeof *specpdl);
+ specpdl_base = pdlvec;
specpdl_size = size;
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;
+ max_specpdl_size = 10000; /* 1000 is not enough for CEDET's c-by.el. */
+ max_lisp_eval_depth = 10000;
Vrun_hooks = Qnil;
+
+ eval_fn = scm_c_public_ref ("language elisp runtime", "eval-elisp");
+ funcall_fn = scm_c_public_ref ("elisp-functions", "funcall");
+
+ //scm_set_smob_apply (lisp_vectorlike_tag, apply_lambda, 0, 0, 1);
}
-static struct handler handlerlist_sentinel;
+static struct handler *handlerlist_sentinel;
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. */
- struct handler *c;
- handlerlist = handlerlist_sentinel.nextfree = &handlerlist_sentinel;
- PUSH_HANDLER (c, Qunbound, CATCHER);
- eassert (c == &handlerlist_sentinel);
- handlerlist_sentinel.nextfree = NULL;
- handlerlist_sentinel.next = NULL;
- }
+ handlerlist_sentinel = make_catch_handler (Qunbound);
+ handlerlist = handlerlist_sentinel;
Vquit_flag = Qnil;
debug_on_next_call = 0;
lisp_eval_depth = 0;
@@ -276,27 +226,15 @@ 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 (max_specpdl_size, count);
+ EMACS_INT old_max = max_specpdl_size;
if (lisp_eval_depth + 40 > max_lisp_eval_depth)
max_lisp_eval_depth = lisp_eval_depth + 40;
- /* While debugging Bug#16603, previous value of 100 was found
- too small to avoid specpdl overflow in the debugger itself. */
- if (max_specpdl_size - 200 < count)
- max_specpdl_size = count + 200;
-
- if (old_max == count)
- {
- /* We can enter the debugger due to specpdl overflow (Bug#16603). */
- specpdl_ptr--;
- grow_specpdl ();
- }
-
/* Restore limits after leaving the debugger. */
record_unwind_protect (restore_stack_limits,
Fcons (make_number (old_max),
@@ -332,126 +270,12 @@ call_debugger (Lisp_Object arg)
if (debug_while_redisplaying)
Ftop_level ();
- return unbind_to (count, val);
-}
-
-static void
-do_debug_on_call (Lisp_Object code)
-{
- debug_on_next_call = 0;
- set_backtrace_debug_on_exit (specpdl_ptr - 1, true);
- call_debugger (list1 (code));
-}
-
-/* NOTE!!! Every function that can call EVAL must protect its args
- and temporaries from garbage collection while it needs them.
- The definition of `For' shows what you have to do. */
-
-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)
-{
- register Lisp_Object val = Qnil;
- struct gcpro gcpro1;
-
- GCPRO1 (args);
-
- while (CONSP (args))
- {
- val = eval_sub (XCAR (args));
- if (!NILP (val))
- break;
- args = XCDR (args);
- }
-
- UNGCPRO;
- 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)
-{
- register Lisp_Object val = Qt;
- struct gcpro gcpro1;
-
- GCPRO1 (args);
-
- while (CONSP (args))
- {
- val = eval_sub (XCAR (args));
- if (NILP (val))
- break;
- args = XCDR (args);
- }
-
- UNGCPRO;
- 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;
- struct gcpro gcpro1;
-
- GCPRO1 (args);
- cond = eval_sub (XCAR (args));
- UNGCPRO;
-
- if (!NILP (cond))
- return eval_sub (Fcar (XCDR (args)));
- return Fprogn (XCDR (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;
- struct gcpro gcpro1;
-
- GCPRO1 (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);
- }
- UNGCPRO;
-
+ dynwind_end ();
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)
+
+static Lisp_Object
+Fprogn (Lisp_Object body)
{
Lisp_Object val = Qnil;
struct gcpro gcpro1;
@@ -477,113 +301,8 @@ 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,
-whose values are discarded.
-usage: (prog1 FIRST BODY...) */)
- (Lisp_Object args)
-{
- Lisp_Object val;
- Lisp_Object args_left;
- struct gcpro gcpro1, gcpro2;
-
- args_left = args;
- val = args;
- GCPRO2 (args, val);
-
- val = eval_sub (XCAR (args_left));
- while (CONSP (args_left = XCDR (args_left)))
- eval_sub (XCAR (args_left));
-
- UNGCPRO;
- return val;
-}
-
-DEFUN ("prog2", Fprog2, Sprog2, 2, UNEVALLED, 0,
- doc: /* Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
-The value of FORM2 is saved during the evaluation of the
-remaining args, whose values are discarded.
-usage: (prog2 FORM1 FORM2 BODY...) */)
- (Lisp_Object args)
-{
- struct gcpro gcpro1;
-
- GCPRO1 (args);
- eval_sub (XCAR (args));
- UNGCPRO;
- return Fprog1 (XCDR (args));
-}
-
-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, sym, lex_binding;
-
- val = args;
- if (CONSP (args))
- {
- Lisp_Object args_left = args;
- struct gcpro gcpro1;
- GCPRO1 (args);
-
- 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));
-
- UNGCPRO;
- }
-
- 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 (CONSP (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 compiled.
-`quote' cannot do that.
-usage: (function ARG) */)
- (Lisp_Object args)
+Lisp_Object
+Ffunction (Lisp_Object args)
{
Lisp_Object quoted = XCAR (args);
@@ -602,7 +321,6 @@ usage: (function ARG) */)
return quoted;
}
-
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.
@@ -614,18 +332,18 @@ then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
The return value is BASE-VARIABLE. */)
(Lisp_Object new_alias, Lisp_Object base_variable, Lisp_Object docstring)
{
- struct Lisp_Symbol *sym;
+ sym_t sym;
CHECK_SYMBOL (new_alias);
CHECK_SYMBOL (base_variable);
sym = XSYMBOL (new_alias);
- if (sym->constant)
+ if (SYMBOL_CONSTANT (sym))
/* Not sure why, but why not? */
error ("Cannot make a constant an alias");
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_FORWARDED:
error ("Cannot make an internal variable an alias");
@@ -649,11 +367,11 @@ The return value is BASE-VARIABLE. */)
error ("Don't know how to make a let-bound variable an alias");
}
- sym->declared_special = 1;
- XSYMBOL (base_variable)->declared_special = 1;
- sym->redirect = SYMBOL_VARALIAS;
+ SET_SYMBOL_DECLARED_SPECIAL (sym, 1);
+ SET_SYMBOL_DECLARED_SPECIAL (XSYMBOL (base_variable), 1);
+ SET_SYMBOL_REDIRECT (sym, SYMBOL_VARALIAS);
SET_SYMBOL_ALIAS (sym, XSYMBOL (base_variable));
- sym->constant = SYMBOL_CONSTANT_P (base_variable);
+ SET_SYMBOL_CONSTANT (sym, SYMBOL_CONSTANT_P (base_variable));
LOADHIST_ATTACH (new_alias);
/* Even if docstring is nil: remove old docstring. */
Fput (new_alias, Qvariable_documentation, docstring);
@@ -707,127 +425,6 @@ DEFUN ("set-default-toplevel-value", Fset_default_toplevel_value,
return Qnil;
}
-DEFUN ("defvar", Fdefvar, Sdefvar, 1, UNEVALLED, 0,
- doc: /* Define SYMBOL as a variable, and return SYMBOL.
-You are not required to define a variable in order to use it, but
-defining it lets you supply an initial value and documentation, which
-can be referred to by the Emacs help facilities and other programming
-tools. The `defvar' form also declares the variable as \"special\",
-so that it is always dynamically bound even if `lexical-binding' is t.
-
-The optional argument INITVALUE is evaluated, and used to set SYMBOL,
-only if SYMBOL's value is void. If SYMBOL is buffer-local, its
-default value is what is set; buffer-local values are not affected.
-If INITVALUE is missing, SYMBOL's value is not set.
-
-If SYMBOL has a local binding, then this form affects the local
-binding. This is usually not what you want. Thus, if you need to
-load a file defining variables, with this form or with `defconst' or
-`defcustom', you should always load that file _outside_ any bindings
-for these variables. \(`defconst' and `defcustom' behave similarly in
-this respect.)
-
-The optional argument DOCSTRING is a documentation string for the
-variable.
-
-To define a user option, use `defcustom' instead of `defvar'.
-usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
- (Lisp_Object args)
-{
- Lisp_Object sym, tem, tail;
-
- sym = XCAR (args);
- tail = XCDR (args);
-
- 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 (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. */
- union specbinding *binding = default_toplevel_binding (sym);
- if (binding && EQ (specpdl_old_value (binding), Qunbound))
- {
- set_specpdl_old_value (binding, eval_sub (XCAR (tail)));
- }
- }
- tail = XCDR (tail);
- tem = Fcar (tail);
- if (!NILP (tem))
- {
- if (!NILP (Vpurify_flag))
- tem = Fpurecopy (tem);
- Fput (sym, Qvariable_documentation, tem);
- }
- LOADHIST_ATTACH (sym);
- }
- else if (!NILP (Vinternal_interpreter_environment)
- && !XSYMBOL (sym)->declared_special)
- /* 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);
- else
- {
- /* Simple (defvar ) should not count as a definition at all.
- It could get in the way of other definitions, and unloading this
- package could try to make the variable unbound. */
- }
-
- return sym;
-}
-
-DEFUN ("defconst", Fdefconst, Sdefconst, 2, UNEVALLED, 0,
- doc: /* Define SYMBOL as a constant variable.
-This declares that neither programs nor users should ever change the
-value. This constancy is not actually enforced by Emacs Lisp, but
-SYMBOL is marked as a special variable so that it is never lexically
-bound.
-
-The `defconst' form always sets the value of SYMBOL to the result of
-evalling INITVALUE. If SYMBOL is buffer-local, its default value is
-what is set; buffer-local values are not affected. If SYMBOL has a
-local binding, then this form sets the local binding's value.
-However, you should normally not make local bindings for variables
-defined with this form.
-
-The optional DOCSTRING specifies the variable's documentation string.
-usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
- (Lisp_Object args)
-{
- Lisp_Object sym, tem;
-
- sym = XCAR (args);
- if (CONSP (Fcdr (XCDR (XCDR (args)))))
- error ("Too many arguments");
-
- tem = eval_sub (Fcar (XCDR (args)));
- if (!NILP (Vpurify_flag))
- tem = Fpurecopy (tem);
- Fset_default (sym, tem);
- XSYMBOL (sym)->declared_special = 1;
- tem = Fcar (XCDR (XCDR (args)));
- if (!NILP (tem))
- {
- if (!NILP (Vpurify_flag))
- tem = Fpurecopy (tem);
- Fput (sym, Qvariable_documentation, tem);
- }
- Fput (sym, Qrisky_local_variable, Qt);
- LOADHIST_ATTACH (sym);
- return sym;
-}
-
/* Make SYMBOL lexically scoped. */
DEFUN ("internal-make-var-non-special", Fmake_var_non_special,
Smake_var_non_special, 1, 1, 0,
@@ -835,168 +432,11 @@ DEFUN ("internal-make-var-non-special", Fmake_var_non_special,
(Lisp_Object symbol)
{
CHECK_SYMBOL (symbol);
- XSYMBOL (symbol)->declared_special = 0;
+ SET_SYMBOL_DECLARED_SPECIAL (XSYMBOL (symbol), 0);
return Qnil;
}
-DEFUN ("let*", FletX, SletX, 1, UNEVALLED, 0,
- doc: /* Bind variables according to VARLIST then eval BODY.
-The value of the last form in BODY is returned.
-Each element of VARLIST is a symbol (which is bound to nil)
-or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
-Each VALUEFORM can refer to the symbols already bound by this VARLIST.
-usage: (let* VARLIST BODY...) */)
- (Lisp_Object args)
-{
- Lisp_Object varlist, var, val, elt, lexenv;
- ptrdiff_t count = SPECPDL_INDEX ();
- struct gcpro gcpro1, gcpro2, gcpro3;
-
- GCPRO3 (args, elt, varlist);
-
- lexenv = Vinternal_interpreter_environment;
-
- varlist = XCAR (args);
- while (CONSP (varlist))
- {
- QUIT;
-
- elt = XCAR (varlist);
- if (SYMBOLP (elt))
- {
- var = elt;
- val = Qnil;
- }
- else if (! NILP (Fcdr (Fcdr (elt))))
- signal_error ("`let' bindings can have only one value-form", elt);
- else
- {
- var = Fcar (elt);
- val = eval_sub (Fcar (Fcdr (elt)));
- }
-
- if (!NILP (lexenv) && SYMBOLP (var)
- && !XSYMBOL (var)->declared_special
- && NILP (Fmemq (var, Vinternal_interpreter_environment)))
- /* Lexically bind VAR by adding it to the interpreter's binding
- alist. */
- {
- Lisp_Object newenv
- = Fcons (Fcons (var, val), Vinternal_interpreter_environment);
- if (EQ (Vinternal_interpreter_environment, lexenv))
- /* Save the old lexical environment on the specpdl stack,
- but only for the first lexical binding, since we'll never
- need to revert to one of the intermediate ones. */
- specbind (Qinternal_interpreter_environment, newenv);
- else
- Vinternal_interpreter_environment = newenv;
- }
- else
- specbind (var, val);
-
- varlist = XCDR (varlist);
- }
- UNGCPRO;
- val = Fprogn (XCDR (args));
- return unbind_to (count, val);
-}
-
-DEFUN ("let", Flet, Slet, 1, UNEVALLED, 0,
- doc: /* Bind variables according to VARLIST then eval BODY.
-The value of the last form in BODY is returned.
-Each element of VARLIST is a symbol (which is bound to nil)
-or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
-All the VALUEFORMs are evalled before any symbols are bound.
-usage: (let VARLIST BODY...) */)
- (Lisp_Object args)
-{
- Lisp_Object *temps, tem, lexenv;
- register Lisp_Object elt, varlist;
- ptrdiff_t count = SPECPDL_INDEX ();
- ptrdiff_t argnum;
- struct gcpro gcpro1, gcpro2;
- USE_SAFE_ALLOCA;
-
- varlist = XCAR (args);
-
- /* Make space to hold the values to give the bound variables. */
- elt = Flength (varlist);
- SAFE_ALLOCA_LISP (temps, XFASTINT (elt));
-
- /* Compute the values and store them in `temps'. */
-
- GCPRO2 (args, *temps);
- gcpro2.nvars = 0;
-
- for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist))
- {
- QUIT;
- elt = XCAR (varlist);
- if (SYMBOLP (elt))
- temps [argnum++] = Qnil;
- else if (! NILP (Fcdr (Fcdr (elt))))
- signal_error ("`let' bindings can have only one value-form", elt);
- else
- temps [argnum++] = eval_sub (Fcar (Fcdr (elt)));
- gcpro2.nvars = argnum;
- }
- UNGCPRO;
-
- lexenv = Vinternal_interpreter_environment;
-
- varlist = XCAR (args);
- for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist))
- {
- Lisp_Object var;
-
- elt = XCAR (varlist);
- var = SYMBOLP (elt) ? elt : Fcar (elt);
- tem = temps[argnum++];
-
- if (!NILP (lexenv) && SYMBOLP (var)
- && !XSYMBOL (var)->declared_special
- && NILP (Fmemq (var, Vinternal_interpreter_environment)))
- /* Lexically bind VAR by adding it to the lexenv alist. */
- lexenv = Fcons (Fcons (var, tem), lexenv);
- else
- /* Dynamically bind VAR. */
- specbind (var, tem);
- }
-
- if (!EQ (lexenv, Vinternal_interpreter_environment))
- /* Instantiate a new lexical environment. */
- specbind (Qinternal_interpreter_environment, lexenv);
-
- elt = Fprogn (XCDR (args));
- SAFE_FREE ();
- return unbind_to (count, elt);
-}
-
-DEFUN ("while", Fwhile, Swhile, 1, UNEVALLED, 0,
- doc: /* If TEST yields non-nil, eval BODY... and repeat.
-The order of execution is thus TEST, BODY, TEST, BODY and so on
-until TEST returns nil.
-usage: (while TEST BODY...) */)
- (Lisp_Object args)
-{
- Lisp_Object test, body;
- struct gcpro gcpro1, gcpro2;
-
- GCPRO2 (test, body);
-
- test = XCAR (args);
- body = XCDR (args);
- while (!NILP (eval_sub (test)))
- {
- QUIT;
- Fprogn (body);
- }
-
- UNGCPRO;
- return Qnil;
-}
-
DEFUN ("macroexpand", Fmacroexpand, Smacroexpand, 1, 2, 0,
doc: /* Return result of expanding macros at top level of FORM.
If FORM is not a macro call, it is returned unchanged.
@@ -1028,7 +468,7 @@ definitions to shadow the loaded ones for use in file byte-compilation. */)
tem = Fassq (sym, environment);
if (NILP (tem))
{
- def = XSYMBOL (sym)->function;
+ def = SYMBOL_FUNCTION (sym);
if (!NILP (def))
continue;
}
@@ -1068,7 +508,7 @@ definitions to shadow the loaded ones for use in file byte-compilation. */)
return form;
}
-DEFUN ("catch", Fcatch, Scatch, 1, UNEVALLED, 0,
+DEFUN ("call-with-catch", Fcatch, Scatch, 2, 2, 0,
doc: /* Eval BODY allowing nonlocal exits using `throw'.
TAG is evalled to get the tag to use; it must not be nil.
@@ -1077,15 +517,9 @@ Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
If no throw happens, `catch' returns the value of the last BODY form.
If a throw happens, it specifies the value to return from `catch'.
usage: (catch TAG BODY...) */)
- (Lisp_Object args)
+ (Lisp_Object tag, Lisp_Object thunk)
{
- register Lisp_Object tag;
- struct gcpro gcpro1;
-
- GCPRO1 (args);
- tag = eval_sub (XCAR (args));
- UNGCPRO;
- return internal_catch (tag, Fprogn, XCDR (args));
+ return internal_catch (tag, call0, thunk);
}
/* Assert that E is true, as a comment only. Use this instead of
@@ -1094,6 +528,127 @@ usage: (catch TAG BODY...) */)
#define clobbered_eassert(E) ((void) 0)
+static void
+set_handlerlist (void *data)
+{
+ handlerlist = data;
+}
+
+static void
+restore_handler (void *data)
+{
+ struct handler *c = data;
+ 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 0
+ if (!NILP (Vinternal_interpreter_environment))
+ specbind (Qinternal_interpreter_environment,
+ Fcons (Fcons (var, val),
+ Vinternal_interpreter_environment));
+ else
+#endif
+ 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. */
@@ -1101,27 +656,14 @@ usage: (catch TAG BODY...) */)
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 handler *c;
-
- /* Fill in the components of c, and put it on the list. */
- PUSH_HANDLER (c, tag, CATCHER);
-
- /* Call FUNC. */
- if (! sys_setjmp (c->jmp))
- {
- Lisp_Object val = (*func) (arg);
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return val;
- }
- else
- { /* Throw works by a longjmp that comes right here. */
- Lisp_Object val = handlerlist->val;
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return 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
@@ -1140,42 +682,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 handler *catch, Lisp_Object value)
{
- bool last_time;
-
- eassert (catch->next);
-
- /* 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
- {
- /* Unwind the specpdl stack, and then restore the proper set of
- handlers. */
- unbind_to (handlerlist->pdlcount, Qnil);
- last_time = handlerlist == catch;
- if (! last_time)
- handlerlist = handlerlist->next;
- }
- while (! last_time);
-
- eassert (handlerlist == catch);
-
- byte_stack_list = catch->byte_stack;
- gcprolist = catch->gcpro;
-#ifdef DEBUG_GCPRO
- gcpro_level = gcprolist ? gcprolist->level + 1 : 0;
-#endif
- 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,
@@ -1193,25 +705,8 @@ Both TAG and VALUE are evalled. */)
}
xsignal2 (Qno_catch, tag, value);
}
-
-
-DEFUN ("unwind-protect", Funwind_protect, Sunwind_protect, 1, UNEVALLED, 0,
- doc: /* Do BODYFORM, protecting with UNWINDFORMS.
-If BODYFORM completes normally, its value is returned
-after executing the UNWINDFORMS.
-If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
-usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
- (Lisp_Object args)
-{
- Lisp_Object val;
- ptrdiff_t count = SPECPDL_INDEX ();
-
- record_unwind_protect (unwind_body, XCDR (args));
- val = eval_sub (XCAR (args));
- return unbind_to (count, val);
-}
-DEFUN ("condition-case", Fcondition_case, Scondition_case, 2, UNEVALLED, 0,
+DEFUN ("call-with-handler", Fcall_with_handler, Scall_with_handler, 4, 4, 0,
doc: /* Regain control when an error is signaled.
Executes BODYFORM and returns its value if no error happens.
Each element of HANDLERS looks like (CONDITION-NAME BODY...)
@@ -1237,13 +732,43 @@ expression.
See also the function `signal' for more info.
usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
- (Lisp_Object args)
+ (Lisp_Object var,
+ Lisp_Object conditions,
+ Lisp_Object hthunk,
+ Lisp_Object thunk)
{
- Lisp_Object var = XCAR (args);
- Lisp_Object bodyform = XCAR (XCDR (args));
- Lisp_Object handlers = XCDR (XCDR (args));
+ return internal_lisp_condition_case (var,
+ list2 (intern ("funcall"), thunk),
+ list1 (list2 (conditions, list2 (intern ("funcall"), hthunk))));
+}
- 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
@@ -1256,14 +781,12 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform,
Lisp_Object val;
struct handler *c;
struct handler *oldhandlerlist = handlerlist;
- int clausenb = 0;
CHECK_SYMBOL (var);
for (val = handlers; CONSP (val); val = XCDR (val))
{
Lisp_Object tem = XCAR (val);
- clausenb++;
if (! (NILP (tem)
|| (CONSP (tem)
&& (SYMBOLP (XCAR (tem))
@@ -1272,52 +795,7 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform,
SDATA (Fprin1_to_string (tem, Qt)));
}
- { /* The first clause is the one that should be checked first, so it should
- be added to handlerlist last. So we build in `clauses' a table that
- contains `handlers' but in reverse order. */
- Lisp_Object *clauses = alloca (clausenb * sizeof (Lisp_Object *));
- Lisp_Object *volatile clauses_volatile = clauses;
- int i = clausenb;
- for (val = handlers; CONSP (val); val = XCDR (val))
- clauses[--i] = XCAR (val);
- for (i = 0; i < clausenb; i++)
- {
- Lisp_Object clause = clauses[i];
- Lisp_Object condition = XCAR (clause);
- if (!CONSP (condition))
- condition = Fcons (condition, Qnil);
- PUSH_HANDLER (c, condition, CONDITION_CASE);
- if (sys_setjmp (c->jmp))
- {
- ptrdiff_t count = SPECPDL_INDEX ();
- Lisp_Object val = handlerlist->val;
- Lisp_Object *chosen_clause = clauses_volatile;
- for (c = handlerlist->next; c != oldhandlerlist; c = c->next)
- chosen_clause++;
- handlerlist = oldhandlerlist;
- if (!NILP (var))
- {
- if (!NILP (Vinternal_interpreter_environment))
- specbind (Qinternal_interpreter_environment,
- Fcons (Fcons (var, val),
- Vinternal_interpreter_environment));
- else
- specbind (var, val);
- }
- val = Fprogn (XCDR (*chosen_clause));
- /* Note that this just undoes the binding of var; whoever
- longjumped to us unwound the stack to c.pdlcount before
- throwing. */
- if (!NILP (var))
- unbind_to (count, Qnil);
- return val;
- }
- }
- }
-
- val = eval_sub (bodyform);
- handlerlist = oldhandlerlist;
- return val;
+ return ilcc1 (var, bodyform, Freverse (handlers));
}
/* Call the function BFUN with no arguments, catching errors within it
@@ -1335,21 +813,12 @@ internal_condition_case (Lisp_Object (*bfun) (void), Lisp_Object handlers,
Lisp_Object (*hfun) (Lisp_Object))
{
Lisp_Object val;
- struct handler *c;
-
- PUSH_HANDLER (c, handlers, CONDITION_CASE);
- if (sys_setjmp (c->jmp))
- {
- Lisp_Object val = handlerlist->val;
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return (*hfun) (val);
- }
+ struct handler *c = make_condition_handler (handlers);
- val = (*bfun) ();
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return val;
+ 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. */
@@ -1359,21 +828,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 handler *c;
+ struct handler *c = make_condition_handler (handlers);
- PUSH_HANDLER (c, handlers, CONDITION_CASE);
- if (sys_setjmp (c->jmp))
- {
- Lisp_Object val = handlerlist->val;
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return (*hfun) (val);
- }
-
- val = (*bfun) (arg);
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return val;
+ 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
@@ -1387,21 +850,15 @@ internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object),
Lisp_Object (*hfun) (Lisp_Object))
{
Lisp_Object val;
- struct handler *c;
-
- PUSH_HANDLER (c, handlers, CONDITION_CASE);
- if (sys_setjmp (c->jmp))
- {
- Lisp_Object val = handlerlist->val;
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return (*hfun) (val);
- }
-
- val = (*bfun) (arg1, arg2);
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->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,
@@ -1417,21 +874,17 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *),
Lisp_Object *args))
{
Lisp_Object val;
- struct handler *c;
-
- PUSH_HANDLER (c, handlers, CONDITION_CASE);
- if (sys_setjmp (c->jmp))
- {
- Lisp_Object val = handlerlist->val;
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return (*hfun) (val, nargs, args);
- }
+ struct handler *c = make_condition_handler (handlers);
- val = (*bfun) (nargs, args);
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return val;
+ 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));
}
@@ -1478,8 +931,7 @@ See also the function `condition-case'. */)
struct handler *h;
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,
@@ -1506,20 +958,6 @@ See also the function `condition-case'. */)
conditions = Fget (real_error_symbol, Qerror_conditions);
- /* Remember from where signal was called. Skip over the frame for
- `signal' itself. If a frame for `error' follows, skip that,
- too. Don't do this when ERROR_SYMBOL is nil, because that
- is a memory-full error. */
- Vsignaling_function = Qnil;
- if (!NILP (error_symbol))
- {
- 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)
{
if (h->type != CONDITION_CASE)
@@ -1560,7 +998,7 @@ See also the function `condition-case'. */)
}
else
{
- if (handlerlist != &handlerlist_sentinel)
+ 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. */
@@ -1826,11 +1264,10 @@ 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_pair (scm_assq (Qinteractive_form,
+ scm_procedure_properties (fun)))
+ ? 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. */
@@ -1876,16 +1313,10 @@ this does nothing and returns nil. */)
CHECK_STRING (file);
/* If function is defined and not as an autoload, don't override. */
- if (!NILP (XSYMBOL (function)->function)
- && !AUTOLOADP (XSYMBOL (function)->function))
+ if (!NILP (SYMBOL_FUNCTION (function))
+ && !AUTOLOADP (SYMBOL_FUNCTION (function)))
return Qnil;
- if (!NILP (Vpurify_flag) && 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 (XHASH (function));
return Fdefalias (function,
list5 (Qautoload, file, docstring, interactive, type),
Qnil);
@@ -1925,24 +1356,28 @@ 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
of what files are preloaded and when. */
- if (! NILP (Vpurify_flag))
+ /*if (! NILP (Vpurify_flag))
error ("Attempt to autoload %s while preparing to dump",
- SDATA (SYMBOL_NAME (funname)));
+ SDATA (SYMBOL_NAME (funname)));*/
CHECK_SYMBOL (funname);
GCPRO3 (funname, fundef, macro_only);
@@ -1966,7 +1401,7 @@ it is defines a macro. */)
/* Once loading finishes, don't undo it. */
Vautoload_queue = Qt;
- unbind_to (count, Qnil);
+ dynwind_end ();
UNGCPRO;
@@ -1992,10 +1427,12 @@ 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,
CONSP (lexical) || NILP (lexical) ? lexical : list1 (Qt));
- return unbind_to (count, eval_sub (form));
+ Lisp_Object tem0 = eval_sub (form);
+ dynwind_end ();
+ return tem0;
}
/* Grow the specpdl stack by one entry.
@@ -2025,253 +1462,70 @@ grow_specpdl (void)
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 ();
-}
-
-/* Eval a sub-expression of the current expression (i.e. in the same
- lexical scope). */
-Lisp_Object
-eval_sub (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);
- }
-
- if (!CONSP (form))
- return form;
-
- QUIT;
-
- GCPRO1 (form);
- maybe_gc ();
- UNGCPRO;
-
- if (++lisp_eval_depth > max_lisp_eval_depth)
- {
- if (max_lisp_eval_depth < 100)
- max_lisp_eval_depth = 100;
- if (lisp_eval_depth > max_lisp_eval_depth)
- error ("Lisp nesting exceeds `max-lisp-eval-depth'");
- }
-
- original_fun = XCAR (form);
- original_args = XCDR (form);
-
- /* This also protects them from gc. */
- record_in_backtrace (original_fun, &original_args, UNEVALLED);
-
- if (debug_on_next_call)
- do_debug_on_call (Qt);
-
- /* At this point, only original_fun and original_args
- have values that will be used below. */
- retry:
-
- /* Optimize for no indirection. */
- fun = original_fun;
- if (!SYMBOLP (fun))
- fun = Ffunction (Fcons (fun, Qnil));
- else if (!NILP (fun) && (fun = XSYMBOL (fun)->function, SYMBOLP (fun)))
- fun = indirect_function (fun);
-
- if (SUBRP (fun))
- {
- Lisp_Object numargs;
- Lisp_Object argvals[8];
- Lisp_Object args_left;
- register int i, maxargs;
-
- args_left = original_args;
- numargs = Flength (args_left);
-
- 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;
- }
-
- set_backtrace_args (specpdl_ptr - 1, vals);
- set_backtrace_nargs (specpdl_ptr - 1, 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;
-
- set_backtrace_args (specpdl_ptr - 1, argvals);
- set_backtrace_nargs (specpdl_ptr - 1, 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 ();
- }
- }
- }
- else if (COMPILEDP (fun))
- val = apply_lambda (fun, original_args);
- else
- {
- if (NILP (fun))
- xsignal1 (Qvoid_function, original_fun);
- if (!CONSP (fun))
- xsignal1 (Qinvalid_function, original_fun);
- funcar = XCAR (fun);
- if (!SYMBOLP (funcar))
- xsignal1 (Qinvalid_function, original_fun);
- if (EQ (funcar, Qautoload))
- {
- Fautoload_do_load (fun, original_fun, Qnil);
- goto retry;
- }
- if (EQ (funcar, Qmacro))
- {
- ptrdiff_t count = SPECPDL_INDEX ();
- Lisp_Object exp;
- /* Bind lexical-binding during expansion of the macro, so the
- macro can know reliably if the code it outputs will be
- interpreted using lexical-binding or not. */
- specbind (Qlexical_binding,
- NILP (Vinternal_interpreter_environment) ? Qnil : Qt);
- exp = apply1 (Fcdr (fun), original_args);
- unbind_to (count, Qnil);
- val = eval_sub (exp);
+ Qnil);
}
- else if (EQ (funcar, Qlambda)
- || EQ (funcar, Qclosure))
- val = apply_lambda (fun, original_args);
- else
- xsignal1 (Qinvalid_function, original_fun);
+ pdlvec = xpalloc (pdlvec, &pdlvecsize, 1, max_size + 1, sizeof *specpdl);
+ specpdl_base = pdlvec;
+ specpdl = pdlvec + 1;
+ specpdl_size = pdlvecsize - 1;
+ specpdl_ptr = specpdl + count;
}
- check_cons_list ();
+}
- lisp_eval_depth--;
- if (backtrace_debug_on_exit (specpdl_ptr - 1))
- val = call_debugger (list2 (Qexit, val));
- specpdl_ptr--;
+static void
+set_lisp_eval_depth (void *data)
+{
+ EMACS_INT n = (EMACS_INT) data;
+ lisp_eval_depth = n;
+}
- return val;
+/* Eval a sub-expression of the current expression (i.e. in the same
+ lexical scope). */
+static Lisp_Object
+eval_sub_1 (Lisp_Object form)
+{
+ QUIT;
+ return scm_call_1 (eval_fn, form);
+}
+
+Lisp_Object
+eval_sub (Lisp_Object form)
+{
+ return scm_c_value_ref (eval_sub_1 (form), 0);
}
-DEFUN ("apply", Fapply, Sapply, 1, MANY, 0,
- doc: /* Call FUNCTION with our remaining args, using our last arg as list of args.
-Then return the value FUNCTION returns.
-Thus, (apply '+ 1 2 '(3 4)) returns 10.
-usage: (apply FUNCTION &rest ARGUMENTS) */)
+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);
+}
+
+Lisp_Object
+Fapply (ptrdiff_t nargs, Lisp_Object *args)
{
ptrdiff_t i;
EMACS_INT numargs;
@@ -2300,32 +1554,14 @@ usage: (apply FUNCTION &rest ARGUMENTS) */)
/* Optimize for no indirection. */
if (SYMBOLP (fun) && !NILP (fun)
- && (fun = XSYMBOL (fun)->function, SYMBOLP (fun)))
+ && (fun = SYMBOL_FUNCTION (fun), SYMBOLP (fun)))
fun = indirect_function (fun);
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)
@@ -2573,14 +1809,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);
}
}
@@ -2591,7 +1827,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. */
@@ -2606,7 +1842,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. */
@@ -2621,7 +1857,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. */
@@ -2637,7 +1873,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. */
@@ -2655,7 +1891,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. */
@@ -2674,7 +1910,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. */
@@ -2694,7 +1930,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. */
@@ -2715,7 +1951,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. */
@@ -2729,161 +1965,16 @@ DEFUN ("functionp", Ffunctionp, Sfunctionp, 1, 1, 0,
return Qnil;
}
-DEFUN ("funcall", Ffuncall, 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).
-usage: (funcall FUNCTION &rest ARGUMENTS) */)
- (ptrdiff_t nargs, Lisp_Object *args)
+static Lisp_Object
+Ffuncall1 (ptrdiff_t nargs, Lisp_Object *args)
{
- Lisp_Object fun, original_fun;
- Lisp_Object funcar;
- ptrdiff_t numargs = nargs - 1;
- Lisp_Object lisp_numargs;
- Lisp_Object val;
- register Lisp_Object *internal_args;
- ptrdiff_t i;
-
- QUIT;
-
- if (++lisp_eval_depth > max_lisp_eval_depth)
- {
- if (max_lisp_eval_depth < 100)
- max_lisp_eval_depth = 100;
- if (lisp_eval_depth > max_lisp_eval_depth)
- error ("Lisp nesting exceeds `max-lisp-eval-depth'");
- }
-
- /* 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 ();
-
- 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) && !NILP (fun)
- && (fun = XSYMBOL (fun)->function, SYMBOLP (fun)))
- fun = indirect_function (fun);
-
- if (SUBRP (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);
+ return scm_call_n (funcall_fn, args, nargs);
+}
- 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 ();
- }
- }
- }
- else if (COMPILEDP (fun))
- val = funcall_lambda (fun, numargs, args + 1);
- else
- {
- if (NILP (fun))
- xsignal1 (Qvoid_function, original_fun);
- if (!CONSP (fun))
- xsignal1 (Qinvalid_function, original_fun);
- funcar = XCAR (fun);
- if (!SYMBOLP (funcar))
- xsignal1 (Qinvalid_function, original_fun);
- if (EQ (funcar, Qlambda)
- || EQ (funcar, Qclosure))
- val = funcall_lambda (fun, numargs, args + 1);
- 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 (specpdl_ptr - 1))
- val = call_debugger (list2 (Qexit, val));
- specpdl_ptr--;
- return val;
+Lisp_Object
+Ffuncall (ptrdiff_t nargs, Lisp_Object *args)
+{
+ return scm_c_value_ref (Ffuncall1 (nargs, args), 0);
}
static Lisp_Object
@@ -2907,24 +1998,14 @@ apply_lambda (Lisp_Object fun, Lisp_Object args)
for (i = 0; i < numargs; )
{
tem = Fcar (args_left), args_left = Fcdr (args_left);
- tem = eval_sub (tem);
arg_vector[i++] = tem;
gcpro1.nvars = i;
}
UNGCPRO;
- 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_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;
}
@@ -2938,7 +2019,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;
@@ -2958,31 +2039,6 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
else
xsignal1 (Qinvalid_function, fun);
}
- else if (COMPILEDP (fun))
- {
- syms_left = AREF (fun, COMPILED_ARGLIST);
- if (INTEGERP (syms_left))
- /* A byte-code object with a non-nil `push args' slot means we
- shouldn't bind any arguments, instead just call the byte-code
- interpreter directly; it will push arguments as necessary.
-
- Byte-code objects with either a non-existent, or a nil value for
- the `push args' slot (the default), have dynamically-bound
- arguments, and use the argument-binding code below instead (as do
- all interpreted functions, even lexically bound ones). */
- {
- /* If we have not actually read the bytecode string
- and constants vector yet, fetch them from the file. */
- if (CONSP (AREF (fun, COMPILED_BYTECODE)))
- Ffetch_bytecode (fun);
- return exec_byte_code (AREF (fun, COMPILED_BYTECODE),
- AREF (fun, COMPILED_CONSTANTS),
- AREF (fun, COMPILED_STACK_DEPTH),
- syms_left,
- nargs, arg_vector);
- }
- lexenv = Qnil;
- }
else
emacs_abort ();
@@ -3033,21 +2089,10 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
/* Instantiate a new lexical environment. */
specbind (Qinternal_interpreter_environment, lexenv);
- if (CONSP (fun))
- val = Fprogn (XCDR (XCDR (fun)));
- else
- {
- /* If we have not actually read the bytecode string
- and constants vector yet, fetch them from the file. */
- if (CONSP (AREF (fun, COMPILED_BYTECODE)))
- Ffetch_bytecode (fun);
- val = exec_byte_code (AREF (fun, COMPILED_BYTECODE),
- AREF (fun, COMPILED_CONSTANTS),
- AREF (fun, COMPILED_STACK_DEPTH),
- Qnil, 0, 0);
- }
+ val = Fprogn (XCDR (XCDR (fun)));
- return unbind_to (count, val);
+ dynwind_end ();
+ return val;
}
DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode,
@@ -3078,7 +2123,7 @@ DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode,
which was made in the buffer that is now current. */
bool
-let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol)
+let_shadows_buffer_binding_p (sym_t symbol)
{
union specbinding *p;
Lisp_Object buf = Fcurrent_buffer ();
@@ -3086,8 +2131,8 @@ let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol)
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);
+ sym_t let_bound_symbol = XSYMBOL (specpdl_symbol (p));
+ eassert (SYMBOL_REDIRECT (let_bound_symbol) != SYMBOL_VARALIAS);
if (symbol == let_bound_symbol
&& EQ (specpdl_where (p), buf))
return 1;
@@ -3123,13 +2168,13 @@ let_shadows_global_binding_p (Lisp_Object symbol)
void
specbind (Lisp_Object symbol, Lisp_Object value)
{
- struct Lisp_Symbol *sym;
+ sym_t sym;
CHECK_SYMBOL (symbol);
sym = XSYMBOL (symbol);
start:
- switch (sym->redirect)
+ switch (SYMBOL_REDIRECT (sym))
{
case SYMBOL_VARALIAS:
sym = indirect_variable (sym); XSETSYMBOL (symbol, sym); goto start;
@@ -3140,7 +2185,7 @@ specbind (Lisp_Object symbol, Lisp_Object value)
specpdl_ptr->let.symbol = symbol;
specpdl_ptr->let.old_value = SYMBOL_VAL (sym);
grow_specpdl ();
- if (!sym->constant)
+ if (! SYMBOL_CONSTANT (sym))
SET_SYMBOL_VAL (sym, value);
else
set_internal (symbol, value, Qnil, 1);
@@ -3156,10 +2201,10 @@ specbind (Lisp_Object symbol, Lisp_Object value)
specpdl_ptr->let.old_value = ovalue;
specpdl_ptr->let.where = Fcurrent_buffer ();
- eassert (sym->redirect != SYMBOL_LOCALIZED
+ eassert (SYMBOL_REDIRECT (sym) != SYMBOL_LOCALIZED
|| (EQ (SYMBOL_BLV (sym)->where, Fcurrent_buffer ())));
- if (sym->redirect == SYMBOL_LOCALIZED)
+ if (SYMBOL_REDIRECT (sym) == SYMBOL_LOCALIZED)
{
if (!blv_found (SYMBOL_BLV (sym)))
specpdl_ptr->let.kind = SPECPDL_LET_DEFAULT;
@@ -3176,7 +2221,7 @@ specbind (Lisp_Object symbol, Lisp_Object value)
specpdl_ptr->let.kind = SPECPDL_LET_DEFAULT;
grow_specpdl ();
Fset_default (symbol, value);
- return;
+ goto done;
}
}
else
@@ -3188,170 +2233,133 @@ specbind (Lisp_Object symbol, Lisp_Object value)
}
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 (void (*function) (Lisp_Object), Lisp_Object arg)
+record_unwind_protect_1 (void (*function) (Lisp_Object), Lisp_Object arg,
+ bool wind_explicitly)
{
- specpdl_ptr->unwind.kind = SPECPDL_UNWIND;
- specpdl_ptr->unwind.func = function;
- specpdl_ptr->unwind.arg = arg;
- grow_specpdl ();
+ record_unwind_protect_ptr_1 (function, arg, wind_explicitly);
}
void
-record_unwind_protect_ptr (void (*function) (void *), void *arg)
+record_unwind_protect (void (*function) (Lisp_Object), Lisp_Object arg)
{
- specpdl_ptr->unwind_ptr.kind = SPECPDL_UNWIND_PTR;
- specpdl_ptr->unwind_ptr.func = function;
- specpdl_ptr->unwind_ptr.arg = arg;
- grow_specpdl ();
+ record_unwind_protect_1 (function, arg, true);
}
void
-record_unwind_protect_int (void (*function) (int), int arg)
+record_unwind_protect_ptr_1 (void (*function) (void *), void *arg,
+ bool wind_explicitly)
{
- specpdl_ptr->unwind_int.kind = SPECPDL_UNWIND_INT;
- specpdl_ptr->unwind_int.func = function;
- specpdl_ptr->unwind_int.arg = arg;
- grow_specpdl ();
+ scm_dynwind_unwind_handler (function,
+ arg,
+ (wind_explicitly
+ ? SCM_F_WIND_EXPLICITLY
+ : 0));
}
void
-record_unwind_protect_void (void (*function) (void))
+record_unwind_protect_ptr (void (*function) (void *), void *arg)
{
- specpdl_ptr->unwind_void.kind = SPECPDL_UNWIND_VOID;
- specpdl_ptr->unwind_void.func = function;
- grow_specpdl ();
+ record_unwind_protect_ptr_1 (function, arg, true);
}
-static void
-do_nothing (void)
-{}
-
-/* Push an unwind-protect entry that does nothing, so that
- set_unwind_protect_ptr can overwrite it later. */
-
void
-record_unwind_protect_nothing (void)
+record_unwind_protect_int_1 (void (*function) (int), int arg,
+ bool wind_explicitly)
{
- record_unwind_protect_void (do_nothing);
+ record_unwind_protect_ptr_1 (function, arg, wind_explicitly);
}
-/* Clear the unwind-protect entry COUNT, so that it does nothing.
- It need not be at the top of the stack. */
-
void
-clear_unwind_protect (ptrdiff_t count)
+record_unwind_protect_int (void (*function) (int), int arg)
{
- union specbinding *p = specpdl + count;
- p->unwind_void.kind = SPECPDL_UNWIND_VOID;
- p->unwind_void.func = do_nothing;
+ record_unwind_protect_int_1 (function, arg, true);
}
-/* Set the unwind-protect entry COUNT so that it invokes FUNC (ARG).
- It need not be at the top of the stack. Discard the entry's
- previous value without invoking it. */
+static void
+call_void (void *data)
+{
+ ((void (*) (void)) data) ();
+}
void
-set_unwind_protect (ptrdiff_t count, void (*func) (Lisp_Object),
- Lisp_Object arg)
+record_unwind_protect_void_1 (void (*function) (void),
+ bool wind_explicitly)
{
- union specbinding *p = specpdl + count;
- p->unwind.kind = SPECPDL_UNWIND;
- p->unwind.func = func;
- p->unwind.arg = arg;
+ record_unwind_protect_ptr_1 (call_void, function, wind_explicitly);
}
void
-set_unwind_protect_ptr (ptrdiff_t count, void (*func) (void *), void *arg)
+record_unwind_protect_void (void (*function) (void))
{
- union specbinding *p = specpdl + count;
- p->unwind_ptr.kind = SPECPDL_UNWIND_PTR;
- p->unwind_ptr.func = func;
- p->unwind_ptr.arg = arg;
+ record_unwind_protect_void_1 (function, true);
}
-/* Pop and execute entries from the unwind-protect stack until the
- depth COUNT is reached. Return VALUE. */
-
-Lisp_Object
-unbind_to (ptrdiff_t count, Lisp_Object value)
+static void
+unbind_once (void *ignore)
{
- Lisp_Object quitf = Vquit_flag;
- struct gcpro gcpro1, gcpro2;
-
- GCPRO2 (value, quitf);
- Vquit_flag = Qnil;
+ /* 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. */
- while (specpdl_ptr != specpdl + count)
- {
- /* 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--;
+ specpdl_ptr--;
- switch (specpdl_ptr->kind)
- {
- case SPECPDL_UNWIND:
- specpdl_ptr->unwind.func (specpdl_ptr->unwind.arg);
- break;
- case SPECPDL_UNWIND_PTR:
- specpdl_ptr->unwind_ptr.func (specpdl_ptr->unwind_ptr.arg);
- break;
- case SPECPDL_UNWIND_INT:
- specpdl_ptr->unwind_int.func (specpdl_ptr->unwind_int.arg);
- break;
- case SPECPDL_UNWIND_VOID:
- specpdl_ptr->unwind_void.func ();
- break;
- 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;
- }
+ switch (specpdl_ptr->kind)
+ {
+ 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. */
+ sym_t sym = XSYMBOL (specpdl_symbol (specpdl_ptr));
+ if (SYMBOL_REDIRECT (sym) == 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,
@@ -3361,357 +2369,45 @@ context where binding is lexical by default. */)
(Lisp_Object symbol)
{
CHECK_SYMBOL (symbol);
- return XSYMBOL (symbol)->declared_special ? Qt : Qnil;
+ return SYMBOL_DECLARED_SPECIAL (XSYMBOL (symbol)) ? Qt : Qnil;
}
-
-DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
- doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
-The debugger is entered when that frame exits, if the flag is non-nil. */)
- (Lisp_Object level, Lisp_Object flag)
-{
- union specbinding *pdl = backtrace_top ();
- register EMACS_INT i;
-
- CHECK_NUMBER (level);
-
- for (i = 0; backtrace_p (pdl) && i < XINT (level); i++)
- pdl = backtrace_next (pdl);
-
- if (backtrace_p (pdl))
- set_backtrace_debug_on_exit (pdl, !NILP (flag));
-
- return flag;
-}
-
-DEFUN ("backtrace", Fbacktrace, Sbacktrace, 0, 0, "",
- doc: /* Print a trace of Lisp function calls currently active.
-Output stream used is value of `standard-output'. */)
- (void)
+_Noreturn SCM
+abort_to_prompt (SCM tag, SCM arglst)
{
- union specbinding *pdl = backtrace_top ();
- Lisp_Object tem;
- Lisp_Object old_print_level = Vprint_level;
-
- if (NILP (Vprint_level))
- XSETFASTINT (Vprint_level, 8);
-
- while (backtrace_p (pdl))
- {
- write_string (backtrace_debug_on_exit (pdl) ? "* " : " ", 2);
- if (backtrace_nargs (pdl) == UNEVALLED)
- {
- Fprin1 (Fcons (backtrace_function (pdl), *backtrace_args (pdl)),
- Qnil);
- write_string ("\n", -1);
- }
- else
- {
- tem = backtrace_function (pdl);
- Fprin1 (tem, Qnil); /* This can QUIT. */
- write_string ("(", -1);
- {
- 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);
- }
- pdl = backtrace_next (pdl);
- }
+ static SCM var = SCM_UNDEFINED;
+ if (SCM_UNBNDP (var))
+ var = scm_c_public_lookup ("guile", "abort-to-prompt");
- Vprint_level = old_print_level;
- return Qnil;
+ scm_apply_1 (scm_variable_ref (var), tag, arglst);
+ emacs_abort ();
}
-static union specbinding *
-get_backtrace_frame (Lisp_Object nframes, Lisp_Object base)
+SCM
+call_with_prompt (SCM tag, SCM thunk, SCM handler)
{
- 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);
- }
+ static SCM var = SCM_UNDEFINED;
+ if (SCM_UNBNDP (var))
+ var = scm_c_public_lookup ("guile", "call-with-prompt");
- /* Find the frame requested. */
- for (i = XFASTINT (nframes); i > 0 && backtrace_p (pdl); i--)
- pdl = backtrace_next (pdl);
-
- return pdl;
+ return scm_call_3 (scm_variable_ref (var), tag, thunk, handler);
}
-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...).
-If that frame has evaluated its arguments and called its function already,
-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.
-If BASE is non-nil, it should be a function and NFRAMES counts from its
-nearest activation frame. */)
- (Lisp_Object nframes, Lisp_Object base)
+SCM
+make_prompt_tag (void)
{
- union specbinding *pdl = get_backtrace_frame (nframes, base);
-
- if (!backtrace_p (pdl))
- return Qnil;
- if (backtrace_nargs (pdl) == UNEVALLED)
- return Fcons (Qnil,
- Fcons (backtrace_function (pdl), *backtrace_args (pdl)));
- else
- {
- Lisp_Object tem = Flist (backtrace_nargs (pdl), backtrace_args (pdl));
-
- 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)
- {
- /* FIXME: Ideally we'd like to "temporarily unwind" (some of) those
- unwind_protect, but the problem is that we don't know how to
- rewind them afterwards. */
- case SPECPDL_UNWIND:
- case SPECPDL_UNWIND_PTR:
- case SPECPDL_UNWIND_INT:
- case SPECPDL_UNWIND_VOID:
- 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;
- }
- }
-}
+ static SCM var = SCM_UNDEFINED;
+ if (SCM_UNBNDP (var))
+ var = scm_c_public_lookup ("guile", "make-prompt-tag");
-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);
- ptrdiff_t count = SPECPDL_INDEX ();
- 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. */
- return unbind_to (count, eval_sub (exp));
-}
-
-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;
+ return scm_call_0 (scm_variable_ref (var));
}
-
-void
-mark_specpdl (void)
-{
- union specbinding *pdl;
- for (pdl = specpdl; pdl != specpdl_ptr; pdl++)
- {
- switch (pdl->kind)
- {
- case SPECPDL_UNWIND:
- mark_object (specpdl_arg (pdl));
- break;
-
- case SPECPDL_BACKTRACE:
- {
- ptrdiff_t nargs = backtrace_nargs (pdl);
- mark_object (backtrace_function (pdl));
- if (nargs == UNEVALLED)
- nargs = 1;
- while (nargs--)
- mark_object (backtrace_args (pdl)[nargs]);
- }
- break;
-
- case SPECPDL_LET_DEFAULT:
- case SPECPDL_LET_LOCAL:
- mark_object (specpdl_where (pdl));
- /* Fall through. */
- case SPECPDL_LET:
- mark_object (specpdl_symbol (pdl));
- mark_object (specpdl_old_value (pdl));
- break;
- }
- }
-}
-
-void
-get_backtrace (Lisp_Object array)
-{
- union specbinding *pdl = backtrace_next (backtrace_top ());
- ptrdiff_t i = 0, asize = ASIZE (array);
-
- /* Copy the backtrace contents into working memory. */
- for (; i < asize; i++)
- {
- if (backtrace_p (pdl))
- {
- ASET (array, i, backtrace_function (pdl));
- pdl = backtrace_next (pdl);
- }
- else
- ASET (array, i, Qnil);
- }
-}
-
-Lisp_Object backtrace_top_function (void)
-{
- union specbinding *pdl = backtrace_top ();
- return (backtrace_p (pdl) ? backtrace_function (pdl) : Qnil);
-}
-
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,
@@ -3846,7 +2542,7 @@ alist of active lexical bindings. */);
Vinternal_interpreter_environment = Qnil;
/* Don't export this variable to Elisp, so no one can mess with it
(Just imagine if someone makes it buffer-local). */
- Funintern (Qinternal_interpreter_environment, Qnil);
+ //Funintern (Qinternal_interpreter_environment, Qnil);
DEFSYM (Vrun_hooks, "run-hooks");
@@ -3856,49 +2552,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 (&Sdefault_toplevel_value);
- defsubr (&Sset_default_toplevel_value);
- 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 (&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 (&Sbacktrace_eval);
- defsubr (&Sbacktrace__locals);
- defsubr (&Sspecial_variable_p);
- defsubr (&Sfunctionp);
}