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;
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)
{
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;
call_debugger (list1 (code));
}
\f
-/* 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...) */)
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);
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.
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");
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);
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 <var>) 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,
(Lisp_Object symbol)
{
CHECK_SYMBOL (symbol);
- XSYMBOL (symbol)->declared_special = 0;
+ SET_SYMBOL_DECLARED_SPECIAL (XSYMBOL (symbol), 0);
return Qnil;
}
\f
-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.
return form;
}
\f
-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.
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
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;
}
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);
}
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;
-}
\f
-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...)
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
}
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
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
return scm_c_values (args, nargs);
}
\f
-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;
-}
-\f
-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;
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
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);
+ //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. */
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 ();
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;
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;
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);
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;
{ /* 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;
(Lisp_Object symbol)
{
CHECK_SYMBOL (symbol);
- return XSYMBOL (symbol)->declared_special ? Qt : Qnil;
+ return SYMBOL_DECLARED_SPECIAL (XSYMBOL (symbol)) ? Qt : Qnil;
}
\f
{ /* 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)
+ sym_t sym = XSYMBOL (specpdl_symbol (tmp));
+ if (SYMBOL_REDIRECT (sym) == SYMBOL_PLAINVAL)
{
Lisp_Object old_value = specpdl_old_value (tmp);
set_specpdl_old_value (tmp, SYMBOL_VAL (sym));
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");
HCoop / bpt / emacs.git / blobdiff