X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/19411656ce2ada9b559362b71a7bff56a1095a96..bc203f9e4311ddb2c6ea12c14ae2dc2f463591c1:/src/eval.c diff --git a/src/eval.c b/src/eval.c index b34e692f85..8e60e8e30f 100644 --- a/src/eval.c +++ b/src/eval.c @@ -73,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; @@ -101,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); @@ -139,81 +136,6 @@ specpdl_where (union specbinding *pdl) 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_backtrace_nargs (union specbinding *pdl, ptrdiff_t n) -{ - 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 * make_catch_handler (Lisp_Object tag) { @@ -225,7 +147,6 @@ make_catch_handler (Lisp_Object tag) 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; @@ -242,24 +163,32 @@ make_condition_handler (Lisp_Object tag) 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; } +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; @@ -344,124 +273,9 @@ call_debugger (Lisp_Object arg) dynwind_end (); return 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; - - 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; @@ -487,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); @@ -612,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. @@ -624,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"); @@ -659,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); @@ -717,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, @@ -845,170 +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; - dynwind_begin (); - 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)); - dynwind_end (); - return 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; - dynwind_begin (); - 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 (); - dynwind_end (); - return 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. @@ -1080,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. @@ -1089,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 @@ -1116,7 +538,6 @@ 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; } @@ -1214,11 +635,13 @@ icc_lisp_handler (void *data, Lisp_Object k, Lisp_Object val) 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); @@ -1282,26 +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; - dynwind_begin (); - - 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, +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...) @@ -1327,13 +732,14 @@ 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, bodyform, handlers); + return internal_lisp_condition_case (var, + list2 (intern ("funcall"), thunk), + list1 (list2 (conditions, list2 (intern ("funcall"), hthunk)))); } static Lisp_Object @@ -1552,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) @@ -1873,7 +1265,8 @@ then strings and vectors are not accepted. */) } if (scm_is_true (scm_procedure_p (fun))) - return (scm_is_true (scm_procedure_property (fun, Qinteractive_form)) + 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 @@ -1982,9 +1375,9 @@ it is defines a macro. */) /* 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); @@ -2072,25 +1465,13 @@ grow_specpdl (void) Qnil); } pdlvec = xpalloc (pdlvec, &pdlvecsize, 1, max_size + 1, sizeof *specpdl); + specpdl_base = pdlvec; 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) { @@ -2103,130 +1484,8 @@ set_lisp_eval_depth (void *data) 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); - } - - if (!CONSP (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) - { - 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 = SYMBOL_FUNCTION (fun), SYMBOLP (fun))) - fun = indirect_function (fun); - - if (scm_is_true (scm_procedure_p (fun))) - { - Lisp_Object args_left = original_args; - Lisp_Object nargs = Flength (args_left); - Lisp_Object *args; - size_t argnum = 0; - - SAFE_ALLOCA_LISP (args, XINT (nargs)); - - 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 (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)) - { - 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 - interpreted using lexical-binding or not. */ - specbind (Qlexical_binding, - NILP (Vinternal_interpreter_environment) ? Qnil : Qt); - exp = apply1 (Fcdr (fun), original_args); - dynwind_end (); - val = eval_sub (exp); - } - else if (EQ (funcar, Qlambda) - || EQ (funcar, Qclosure)) - val = apply_lambda (fun, original_args); - else - xsignal1 (Qinvalid_function, original_fun); - } - - if (backtrace_debug_on_exit (specpdl_ptr - 1)) - val = call_debugger (list2 (Qexit, val)); - scm_dynwind_end (); - - return val; + return scm_call_1 (eval_fn, form); } Lisp_Object @@ -2265,24 +1524,8 @@ DEFUN ("values", Fvalues, Svalues, 0, MANY, 0, 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; -} - -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) */) - (ptrdiff_t nargs, Lisp_Object *args) +Lisp_Object +Fapply (ptrdiff_t nargs, Lisp_Object *args) { ptrdiff_t i; EMACS_INT numargs; @@ -2722,85 +1965,10 @@ DEFUN ("functionp", Ffunctionp, Sfunctionp, 1, 1, 0, return Qnil; } -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). -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; - - 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) - 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); - - original_fun = args[0]; - - retry: - - /* Optimize for no indirection. */ - fun = original_fun; - if (SYMBOLP (fun) && !NILP (fun) - && (fun = SYMBOL_FUNCTION (fun), SYMBOLP (fun))) - fun = indirect_function (fun); - - if (scm_is_true (scm_procedure_p (fun))) - { - val = scm_call_n (fun, args + 1, numargs); - } - 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); - goto retry; - } - else - xsignal1 (Qinvalid_function, original_fun); - } - if (backtrace_debug_on_exit (specpdl_ptr - 1)) - val = call_debugger (list2 (Qexit, val)); - scm_dynwind_end (); - return val; + return scm_call_n (funcall_fn, args, nargs); } Lisp_Object @@ -2830,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; } @@ -2881,32 +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); - dynwind_end (); - 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 (); @@ -2957,19 +2089,7 @@ 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))); dynwind_end (); return val; @@ -3003,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 (); @@ -3011,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; @@ -3048,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; @@ -3065,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); @@ -3081,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; @@ -3194,14 +2314,12 @@ unbind_once (void *ignore) 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) + sym_t sym = XSYMBOL (specpdl_symbol (specpdl_ptr)); + if (SYMBOL_REDIRECT (sym) == SYMBOL_PLAINVAL) { SET_SYMBOL_VAL (sym, specpdl_old_value (specpdl_ptr)); break; @@ -3251,312 +2369,7 @@ context where binding is lexical by default. */) (Lisp_Object symbol) { CHECK_SYMBOL (symbol); - return XSYMBOL (symbol)->declared_special ? 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) -{ - 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); - } - - Vprint_level = old_print_level; - return Qnil; -} - -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...). -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) -{ - 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) - { - 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; -} - - -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); + return SYMBOL_DECLARED_SPECIAL (XSYMBOL (symbol)) ? Qt : Qnil; } _Noreturn SCM @@ -3729,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");