# HG changeset patch # User Jim Blandy # Date 674417948 0 # Node ID ce09dc5838904fc08c7ab72d831a3575cab1b64d # Parent d548f961975172c8f28eef3524ed70f1083fa01b Initial revision diff -r d548f9619751 -r ce09dc583890 src/eval.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/eval.c Thu May 16 18:19:08 1991 +0000 @@ -0,0 +1,2332 @@ +/* Evaluator for GNU Emacs Lisp interpreter. + Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 1, or (at your option) +any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs; see the file COPYING. If not, write to +the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ + + +#include "config.h" +#include "lisp.h" +#ifdef HAVE_X_WINDOWS +#include "xterm.h" +#endif + +#ifndef standalone +#include "commands.h" +#else +#define INTERACTIVE 1 +#endif + +#include + +/* This definition is duplicated in alloc.c and keyboard.c */ +/* Putting it in lisp.h makes cc bomb out! */ + +struct backtrace + { + struct backtrace *next; + Lisp_Object *function; + Lisp_Object *args; /* Points to vector of args. */ + int nargs; /* length of vector */ + /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */ + char evalargs; + /* Nonzero means call value of debugger when done with this operation. */ + char debug_on_exit; + }; + +struct backtrace *backtrace_list; + +struct catchtag + { + Lisp_Object tag; + Lisp_Object val; + struct catchtag *next; + struct gcpro *gcpro; + jmp_buf jmp; + struct backtrace *backlist; + struct handler *handlerlist; + int lisp_eval_depth; + int pdlcount; + int poll_suppress_count; + }; + +struct catchtag *catchlist; + +Lisp_Object Qautoload, Qmacro, Qexit, Qinteractive, Qcommandp, Qdefun; +Lisp_Object Vquit_flag, Vinhibit_quit; +Lisp_Object Qmocklisp_arguments, Vmocklisp_arguments, Qmocklisp; +Lisp_Object Qand_rest, Qand_optional; +Lisp_Object Qdebug_on_error; + +Lisp_Object Vrun_hooks; + +/* Non-nil means record all fset's and provide's, to be undone + if the file being autoloaded is not fully loaded. + They are recorded by being consed onto the front of Vautoload_queue: + (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */ + +Lisp_Object Vautoload_queue; + +/* Current number of specbindings allocated in specpdl. */ +int specpdl_size; + +/* Pointer to beginning of specpdl. */ +struct specbinding *specpdl; + +/* Pointer to first unused element in specpdl. */ +struct specbinding *specpdl_ptr; + +/* Maximum size allowed for specpdl allocation */ +int max_specpdl_size; + +/* Depth in Lisp evaluations and function calls. */ +int lisp_eval_depth; + +/* Maximum allowed depth in Lisp evaluations and function calls. */ +int max_lisp_eval_depth; + +/* Nonzero means enter debugger before next function call */ +int debug_on_next_call; + +/* Nonzero means display a backtrace if an error + is handled by the command loop's error handler. */ +int stack_trace_on_error; + +/* Nonzero means enter debugger if an error + is handled by the command loop's error handler. */ +int debug_on_error; + +/* Nonzero means enter debugger if a quit signal + is handled by the command loop's error handler. */ +int debug_on_quit; + +/* Nonzero means we are trying to enter the debugger. + This is to prevent recursive attempts. */ +int entering_debugger; + +Lisp_Object Vdebugger; + +void specbind (), record_unwind_protect (); + +Lisp_Object funcall_lambda (); +extern Lisp_Object ml_apply (); /* Apply a mocklisp function to unevaluated argument list */ + +init_eval_once () +{ + specpdl_size = 50; + specpdl = (struct specbinding *) malloc (specpdl_size * sizeof (struct specbinding)); + max_specpdl_size = 600; + max_lisp_eval_depth = 200; +} + +init_eval () +{ + specpdl_ptr = specpdl; + catchlist = 0; + handlerlist = 0; + backtrace_list = 0; + Vquit_flag = Qnil; + debug_on_next_call = 0; + lisp_eval_depth = 0; + entering_debugger = 0; +} + +Lisp_Object +call_debugger (arg) + Lisp_Object arg; +{ + if (lisp_eval_depth + 20 > max_lisp_eval_depth) + max_lisp_eval_depth = lisp_eval_depth + 20; + if (specpdl_size + 40 > max_specpdl_size) + max_specpdl_size = specpdl_size + 40; + debug_on_next_call = 0; + entering_debugger = 1; + return apply1 (Vdebugger, arg); +} + +do_debug_on_call (code) + Lisp_Object code; +{ + debug_on_next_call = 0; + backtrace_list->debug_on_exit = 1; + call_debugger (Fcons (code, Qnil)); +} + +/* 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, + "Eval args until one of them yields non-nil, then return that value.\n\ +The remaining args are not evalled at all.\n\ +If all args return nil, return nil.") + (args) + Lisp_Object args; +{ + register Lisp_Object val; + Lisp_Object args_left; + struct gcpro gcpro1; + + if (NULL(args)) + return Qnil; + + args_left = args; + GCPRO1 (args_left); + + do + { + val = Feval (Fcar (args_left)); + if (!NULL (val)) + break; + args_left = Fcdr (args_left); + } + while (!NULL(args_left)); + + UNGCPRO; + return val; +} + +DEFUN ("and", Fand, Sand, 0, UNEVALLED, 0, + "Eval args until one of them yields nil, then return nil.\n\ +The remaining args are not evalled at all.\n\ +If no arg yields nil, return the last arg's value.") + (args) + Lisp_Object args; +{ + register Lisp_Object val; + Lisp_Object args_left; + struct gcpro gcpro1; + + if (NULL(args)) + return Qt; + + args_left = args; + GCPRO1 (args_left); + + do + { + val = Feval (Fcar (args_left)); + if (NULL (val)) + break; + args_left = Fcdr (args_left); + } + while (!NULL(args_left)); + + UNGCPRO; + return val; +} + +DEFUN ("if", Fif, Sif, 2, UNEVALLED, 0, + "(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...\n\ +Returns the value of THEN or the value of the last of the ELSE's.\n\ +THEN must be one expression, but ELSE... can be zero or more expressions.\n\ +If COND yields nil, and there are no ELSE's, the value is nil.") + (args) + Lisp_Object args; +{ + register Lisp_Object cond; + struct gcpro gcpro1; + + GCPRO1 (args); + cond = Feval (Fcar (args)); + UNGCPRO; + + if (!NULL (cond)) + return Feval (Fcar (Fcdr (args))); + return Fprogn (Fcdr (Fcdr (args))); +} + +DEFUN ("cond", Fcond, Scond, 0, UNEVALLED, 0, + "(cond CLAUSES...): try each clause until one succeeds.\n\ +Each clause looks like (CONDITION BODY...). CONDITION is evaluated\n\ +and, if the value is non-nil, this clause succeeds:\n\ +then the expressions in BODY are evaluated and the last one's\n\ +value is the value of the cond-form.\n\ +If no clause succeeds, cond returns nil.\n\ +If a clause has one element, as in (CONDITION),\n\ +CONDITION's value if non-nil is returned from the cond-form.") + (args) + Lisp_Object args; +{ + register Lisp_Object clause, val; + struct gcpro gcpro1; + + val = Qnil; + GCPRO1 (args); + while (!NULL (args)) + { + clause = Fcar (args); + val = Feval (Fcar (clause)); + if (!NULL (val)) + { + if (!EQ (XCONS (clause)->cdr, Qnil)) + val = Fprogn (XCONS (clause)->cdr); + break; + } + args = XCONS (args)->cdr; + } + UNGCPRO; + + return val; +} + +DEFUN ("progn", Fprogn, Sprogn, 0, UNEVALLED, 0, + "(progn BODY...): eval BODY forms sequentially and return value of last one.") + (args) + Lisp_Object args; +{ + register Lisp_Object val, tem; + Lisp_Object args_left; + struct gcpro gcpro1; + + /* In Mocklisp code, symbols at the front of the progn arglist + are to be bound to zero. */ + if (!EQ (Vmocklisp_arguments, Qt)) + { + val = make_number (0); + while (!NULL (args) && (tem = Fcar (args), XTYPE (tem) == Lisp_Symbol)) + { + QUIT; + specbind (tem, val), args = Fcdr (args); + } + } + + if (NULL(args)) + return Qnil; + + args_left = args; + GCPRO1 (args_left); + + do + { + val = Feval (Fcar (args_left)); + args_left = Fcdr (args_left); + } + while (!NULL(args_left)); + + UNGCPRO; + return val; +} + +DEFUN ("prog1", Fprog1, Sprog1, 1, UNEVALLED, 0, + "(prog1 FIRST BODY...): eval FIRST and BODY sequentially; value from FIRST.\n\ +The value of FIRST is saved during the evaluation of the remaining args,\n\ +whose values are discarded.") + (args) + Lisp_Object args; +{ + Lisp_Object val; + register Lisp_Object args_left; + struct gcpro gcpro1, gcpro2; + register int argnum = 0; + + if (NULL(args)) + return Qnil; + + args_left = args; + val = Qnil; + GCPRO2 (args, val); + + do + { + if (!(argnum++)) + val = Feval (Fcar (args_left)); + else + Feval (Fcar (args_left)); + args_left = Fcdr (args_left); + } + while (!NULL(args_left)); + + UNGCPRO; + return val; +} + +DEFUN ("prog2", Fprog2, Sprog2, 2, UNEVALLED, 0, + "(prog1 X Y BODY...): eval X, Y and BODY sequentially; value from Y.\n\ +The value of Y is saved during the evaluation of the remaining args,\n\ +whose values are discarded.") + (args) + Lisp_Object args; +{ + Lisp_Object val; + register Lisp_Object args_left; + struct gcpro gcpro1, gcpro2; + register int argnum = -1; + + val = Qnil; + + if (NULL(args)) + return Qnil; + + args_left = args; + val = Qnil; + GCPRO2 (args, val); + + do + { + if (!(argnum++)) + val = Feval (Fcar (args_left)); + else + Feval (Fcar (args_left)); + args_left = Fcdr (args_left); + } + while (!NULL(args_left)); + + UNGCPRO; + return val; +} + +DEFUN ("setq", Fsetq, Ssetq, 0, UNEVALLED, 0, + "(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.\n\ +The SYMs are not evaluated. Thus (setq x y) sets x to the value of y.\n\ +Each SYM is set before the next VAL is computed.") + (args) + Lisp_Object args; +{ + register Lisp_Object args_left; + register Lisp_Object val, sym; + struct gcpro gcpro1; + + if (NULL(args)) + return Qnil; + + args_left = args; + GCPRO1 (args); + + do + { + val = Feval (Fcar (Fcdr (args_left))); + sym = Fcar (args_left); + Fset (sym, val); + args_left = Fcdr (Fcdr (args_left)); + } + while (!NULL(args_left)); + + UNGCPRO; + return val; +} + +DEFUN ("quote", Fquote, Squote, 1, UNEVALLED, 0, + "Return the argument, without evaluating it. `(quote x)' yields `x'.") + (args) + Lisp_Object args; +{ + return Fcar (args); +} + +DEFUN ("function", Ffunction, Sfunction, 1, UNEVALLED, 0, + "Like `quote', but preferred for objects which are functions.\n\ +In byte compilation, `function' causes its argument to be compiled.\n\ +`quote' cannot do that.") + (args) + Lisp_Object args; +{ + return Fcar (args); +} + +DEFUN ("interactive-p", Finteractive_p, Sinteractive_p, 0, 0, 0, + "Return t if function in which this appears was called interactively.\n\ +This means that the function was called with call-interactively (which\n\ +includes being called as the binding of a key)\n\ +and input is currently coming from the keyboard (not in keyboard macro).") + () +{ + register struct backtrace *btp; + register Lisp_Object fun; + + if (!INTERACTIVE) + return Qnil; + + /* Unless the object was compiled, skip the frame of interactive-p itself + (if interpreted) or the frame of byte-code (if called from + compiled function). */ + btp = backtrace_list; + if (! XTYPE (*btp->function) == Lisp_Compiled) + btp = btp->next; + for (; + btp && (btp->nargs == UNEVALLED + || EQ (*btp->function, Qbytecode)); + btp = btp->next) + {} + /* btp now points at the frame of the innermost function + that DOES eval its args. + If it is a built-in function (such as load or eval-region) + return nil. */ + fun = *btp->function; + while (XTYPE (fun) == Lisp_Symbol) + { + QUIT; + fun = Fsymbol_function (fun); + } + if (XTYPE (fun) == Lisp_Subr) + return Qnil; + /* btp points to the frame of a Lisp function that called interactive-p. + Return t if that function was called interactively. */ + if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively)) + return Qt; + return Qnil; +} + +DEFUN ("defun", Fdefun, Sdefun, 2, UNEVALLED, 0, + "(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.\n\ +The definition is (lambda ARGLIST [DOCSTRING] BODY...).\n\ +See also the function `interactive'.") + (args) + Lisp_Object args; +{ + register Lisp_Object fn_name; + register Lisp_Object defn; + + fn_name = Fcar (args); + defn = Fcons (Qlambda, Fcdr (args)); + if (!NULL (Vpurify_flag)) + defn = Fpurecopy (defn); + Ffset (fn_name, defn); + return fn_name; +} + +DEFUN ("defmacro", Fdefmacro, Sdefmacro, 2, UNEVALLED, 0, + "(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.\n\ +The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).\n\ +When the macro is called, as in (NAME ARGS...),\n\ +the function (lambda ARGLIST BODY...) is applied to\n\ +the list ARGS... as it appears in the expression,\n\ +and the result should be a form to be evaluated instead of the original.") + (args) + Lisp_Object args; +{ + register Lisp_Object fn_name; + register Lisp_Object defn; + + fn_name = Fcar (args); + defn = Fcons (Qmacro, Fcons (Qlambda, Fcdr (args))); + if (!NULL (Vpurify_flag)) + defn = Fpurecopy (defn); + Ffset (fn_name, defn); + return fn_name; +} + +DEFUN ("defvar", Fdefvar, Sdefvar, 1, UNEVALLED, 0, + "(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.\n\ +You are not required to define a variable in order to use it,\n\ +but the definition can supply documentation and an initial value\n\ +in a way that tags can recognize.\n\n\ +INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.\n\ +If SYMBOL is buffer-local, its default value is initialized in this way.\n\ +INITVALUE and DOCSTRING are optional.\n\ +If DOCSTRING starts with *, this variable is identified as a user option.\n\ + This means that M-x set-variable and M-x edit-options recognize it.\n\ +If INITVALUE is missing, SYMBOL's value is not set.") + (args) + Lisp_Object args; +{ + register Lisp_Object sym, tem; + + sym = Fcar (args); + tem = Fcdr (args); + if (!NULL (tem)) + { + tem = Fdefault_boundp (sym); + if (NULL (tem)) + Fset_default (sym, Feval (Fcar (Fcdr (args)))); + } + tem = Fcar (Fcdr (Fcdr (args))); + if (!NULL (tem)) + { + if (!NULL (Vpurify_flag)) + tem = Fpurecopy (tem); + Fput (sym, Qvariable_documentation, tem); + } + return sym; +} + +DEFUN ("defconst", Fdefconst, Sdefconst, 2, UNEVALLED, 0, + "(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant variable.\n\ +The intent is that programs do not change this value, but users may.\n\ +Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\ +If SYMBOL is buffer-local, its default value is initialized in this way.\n\ +DOCSTRING is optional.\n\ +If DOCSTRING starts with *, this variable is identified as a user option.\n\ + This means that M-x set-variable and M-x edit-options recognize it.\n\n\ +Note: do not use `defconst' for user options in libraries that are not\n\ +normally loaded, since it is useful for users to be able to specify\n\ +their own values for such variables before loading the library.\n\ +Since `defconst' unconditionally assigns the variable,\n\ +it would override the user's choice.") + (args) + Lisp_Object args; +{ + register Lisp_Object sym, tem; + + sym = Fcar (args); + Fset_default (sym, Feval (Fcar (Fcdr (args)))); + tem = Fcar (Fcdr (Fcdr (args))); + if (!NULL (tem)) + { + if (!NULL (Vpurify_flag)) + tem = Fpurecopy (tem); + Fput (sym, Qvariable_documentation, tem); + } + return sym; +} + +DEFUN ("user-variable-p", Fuser_variable_p, Suser_variable_p, 1, 1, 0, + "Returns t if VARIABLE is intended to be set and modified by users.\n\ +\(The alternative is a variable used internally in a Lisp program.)\n\ +Determined by whether the first character of the documentation\n\ +for the variable is \"*\"") + (variable) + Lisp_Object variable; +{ + Lisp_Object documentation; + + documentation = Fget (variable, Qvariable_documentation); + if (XTYPE (documentation) == Lisp_Int && XINT (documentation) < 0) + return Qt; + if ((XTYPE (documentation) == Lisp_String) && + ((unsigned char) XSTRING (documentation)->data[0] == '*')) + return Qt; + return Qnil; +} + +DEFUN ("let*", FletX, SletX, 1, UNEVALLED, 0, + "(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\ +The value of the last form in BODY is returned.\n\ +Each element of VARLIST is a symbol (which is bound to nil)\n\ +or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\ +Each VALUEFORM can refer to the symbols already bound by this VARLIST.") + (args) + Lisp_Object args; +{ + Lisp_Object varlist, val, elt; + int count = specpdl_ptr - specpdl; + struct gcpro gcpro1, gcpro2, gcpro3; + + GCPRO3 (args, elt, varlist); + + varlist = Fcar (args); + while (!NULL (varlist)) + { + QUIT; + elt = Fcar (varlist); + if (XTYPE (elt) == Lisp_Symbol) + specbind (elt, Qnil); + else + { + val = Feval (Fcar (Fcdr (elt))); + specbind (Fcar (elt), val); + } + varlist = Fcdr (varlist); + } + UNGCPRO; + val = Fprogn (Fcdr (args)); + return unbind_to (count, val); +} + +DEFUN ("let", Flet, Slet, 1, UNEVALLED, 0, + "(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\ +The value of the last form in BODY is returned.\n\ +Each element of VARLIST is a symbol (which is bound to nil)\n\ +or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\ +All the VALUEFORMs are evalled before any symbols are bound.") + (args) + Lisp_Object args; +{ + Lisp_Object *temps, tem; + register Lisp_Object elt, varlist; + int count = specpdl_ptr - specpdl; + register int argnum; + struct gcpro gcpro1, gcpro2; + + varlist = Fcar (args); + + /* Make space to hold the values to give the bound variables */ + elt = Flength (varlist); + temps = (Lisp_Object *) alloca (XFASTINT (elt) * sizeof (Lisp_Object)); + + /* Compute the values and store them in `temps' */ + + GCPRO2 (args, *temps); + gcpro2.nvars = 0; + + for (argnum = 0; !NULL (varlist); varlist = Fcdr (varlist)) + { + QUIT; + elt = Fcar (varlist); + if (XTYPE (elt) == Lisp_Symbol) + temps [argnum++] = Qnil; + else + temps [argnum++] = Feval (Fcar (Fcdr (elt))); + gcpro2.nvars = argnum; + } + UNGCPRO; + + varlist = Fcar (args); + for (argnum = 0; !NULL (varlist); varlist = Fcdr (varlist)) + { + elt = Fcar (varlist); + tem = temps[argnum++]; + if (XTYPE (elt) == Lisp_Symbol) + specbind (elt, tem); + else + specbind (Fcar (elt), tem); + } + + elt = Fprogn (Fcdr (args)); + return unbind_to (count, elt); +} + +DEFUN ("while", Fwhile, Swhile, 1, UNEVALLED, 0, + "(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.\n\ +The order of execution is thus TEST, BODY, TEST, BODY and so on\n\ +until TEST returns nil.") + (args) + Lisp_Object args; +{ + Lisp_Object test, body, tem; + struct gcpro gcpro1, gcpro2; + + GCPRO2 (test, body); + + test = Fcar (args); + body = Fcdr (args); + while (tem = Feval (test), !NULL (tem)) + { + QUIT; + Fprogn (body); + } + + UNGCPRO; + return Qnil; +} + +DEFUN ("macroexpand", Fmacroexpand, Smacroexpand, 1, 2, 0, + "Return result of expanding macros at top level of FORM.\n\ +If FORM is not a macro call, it is returned unchanged.\n\ +Otherwise, the macro is expanded and the expansion is considered\n\ +in place of FORM. When a non-macro-call results, it is returned.\n\n\ +The second optional arg ENVIRONMENT species an environment of macro\n\ +definitions to shadow the loaded ones for use in file byte-compilation.") + (form, env) + register Lisp_Object form; + Lisp_Object env; +{ + register Lisp_Object expander, sym, def, tem; + + while (1) + { + /* Come back here each time we expand a macro call, + in case it expands into another macro call. */ + if (XTYPE (form) != Lisp_Cons) + break; + sym = XCONS (form)->car; + /* Detect ((macro lambda ...) ...) */ + if (XTYPE (sym) == Lisp_Cons + && EQ (XCONS (sym)->car, Qmacro)) + { + expander = XCONS (sym)->cdr; + goto explicit; + } + if (XTYPE (sym) != Lisp_Symbol) + break; + /* Trace symbols aliases to other symbols + until we get a symbol that is not an alias. */ + while (1) + { + QUIT; + tem = Fassq (sym, env); + if (NULL (tem)) + { + def = XSYMBOL (sym)->function; + if (XTYPE (def) == Lisp_Symbol && !EQ (def, Qunbound)) + sym = def; + else + break; + } + else + { +#if 0 /* This is turned off because it caused an element (foo . bar) + to have the effect of defining foo as an alias for the macro bar. + That is inconsistent; bar should be a function to expand foo. */ + if (XTYPE (tem) == Lisp_Cons + && XTYPE (XCONS (tem)->cdr) == Lisp_Symbol) + sym = XCONS (tem)->cdr; + else +#endif + break; + } + } + /* Right now TEM is the result from SYM in ENV, + and if TEM is nil then DEF is SYM's function definition. */ + if (NULL (tem)) + { + /* SYM is not mentioned in ENV. + Look at its function definition. */ + if (EQ (def, Qunbound) + || XTYPE (def) != Lisp_Cons) + /* Not defined or definition not suitable */ + break; + if (EQ (XCONS (def)->car, Qautoload)) + { + /* Autoloading function: will it be a macro when loaded? */ + tem = Fcar (Fnthcdr (make_number (4), def)); + if (NULL (tem)) + break; + /* Yes, load it and try again. */ + do_autoload (def, sym); + continue; + } + else if (!EQ (XCONS (def)->car, Qmacro)) + break; + else expander = XCONS (def)->cdr; + } + else + { + expander = XCONS (tem)->cdr; + if (NULL (expander)) + break; + } + explicit: + form = apply1 (expander, XCONS (form)->cdr); + } + return form; +} + +DEFUN ("catch", Fcatch, Scatch, 1, UNEVALLED, 0, + "(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.\n\ +TAG is evalled to get the tag to use. Then the BODY is executed.\n\ +Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.\n\ +If no throw happens, `catch' returns the value of the last BODY form.\n\ +If a throw happens, it specifies the value to return from `catch'.") + (args) + Lisp_Object args; +{ + register Lisp_Object tag; + struct gcpro gcpro1; + + GCPRO1 (args); + tag = Feval (Fcar (args)); + UNGCPRO; + return internal_catch (tag, Fprogn, Fcdr (args)); +} + +/* 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. */ + +Lisp_Object +internal_catch (tag, func, arg) + Lisp_Object tag; + Lisp_Object (*func) (); + Lisp_Object arg; +{ + /* This structure is made part of the chain `catchlist'. */ + struct catchtag c; + + /* Fill in the components of c, and put it on the list. */ + c.next = catchlist; + c.tag = tag; + c.val = Qnil; + c.backlist = backtrace_list; + c.handlerlist = handlerlist; + c.lisp_eval_depth = lisp_eval_depth; + c.pdlcount = specpdl_ptr - specpdl; + c.poll_suppress_count = poll_suppress_count; + c.gcpro = gcprolist; + catchlist = &c; + + /* Call FUNC. */ + if (! _setjmp (c.jmp)) + c.val = (*func) (arg); + + /* Throw works by a longjmp that comes right here. */ + catchlist = c.next; + return c.val; +} + +/* Discard from the catchlist all catch tags back through CATCH. + Before each catch is discarded, unbind all special bindings + made within that catch. Also, when discarding a catch that + corresponds to a condition handler, discard that handler. + + At the end, restore some static info saved in CATCH. + + This is used for correct unwinding in Fthrow and Fsignal, + before doing the longjmp that actually destroys the stack frames + in which these handlers and catches reside. */ + +static void +unbind_catch (catch) + struct catchtag *catch; +{ + register int last_time; + + do + { + last_time = catchlist == catch; + unbind_to (catchlist->pdlcount, Qnil); + handlerlist = catchlist->handlerlist; + catchlist = catchlist->next; + } + while (! last_time); + + gcprolist = catch->gcpro; + backtrace_list = catch->backlist; + lisp_eval_depth = catch->lisp_eval_depth; +} + +DEFUN ("throw", Fthrow, Sthrow, 2, 2, 0, + "(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.\n\ +Both TAG and VALUE are evalled.") + (tag, val) + register Lisp_Object tag, val; +{ + register struct catchtag *c; + + while (1) + { + if (!NULL (tag)) + for (c = catchlist; c; c = c->next) + { + if (EQ (c->tag, tag)) + { + /* Restore the polling-suppression count. */ + if (c->poll_suppress_count > poll_suppress_count) + abort (); + while (c->poll_suppress_count < poll_suppress_count) + start_polling (); + c->val = val; + unbind_catch (c); + _longjmp (c->jmp, 1); + } + } + tag = Fsignal (Qno_catch, Fcons (tag, Fcons (val, Qnil))); + } +} + + +DEFUN ("unwind-protect", Funwind_protect, Sunwind_protect, 1, UNEVALLED, 0, + "Do BODYFORM, protecting with UNWINDFORMS.\n\ +Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).\n\ +If BODYFORM completes normally, its value is returned\n\ +after executing the UNWINDFORMS.\n\ +If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.") + (args) + Lisp_Object args; +{ + Lisp_Object val; + int count = specpdl_ptr - specpdl; + + record_unwind_protect (0, Fcdr (args)); + val = Feval (Fcar (args)); + return unbind_to (count, val); +} + +/* Chain of condition handlers currently in effect. + The elements of this chain are contained in the stack frames + of Fcondition_case and internal_condition_case. + When an error is signaled (by calling Fsignal, below), + this chain is searched for an element that applies. */ + +struct handler *handlerlist; + +DEFUN ("condition-case", Fcondition_case, Scondition_case, 2, UNEVALLED, 0, + "Regain control when an error is signaled.\n\ +Usage looks like (condition-case VAR BODYFORM HANDLERS...).\n\ +executes BODYFORM and returns its value if no error happens.\n\ +Each element of HANDLERS looks like (CONDITION-NAME BODY...)\n\ +where the BODY is made of Lisp expressions.\n\n\ +A handler is applicable to an error\n\ +if CONDITION-NAME is one of the error's condition names.\n\ +If an error happens, the first applicable handler is run.\n\ +\n\ +When a handler handles an error,\n\ +control returns to the condition-case and the handler BODY... is executed\n\ +with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\ +VAR may be nil; then you do not get access to the signal information.\n\ +\n\ +The value of the last BODY form is returned from the condition-case.\n\ +See also the function `signal' for more info.") + (args) + Lisp_Object args; +{ + Lisp_Object val; + struct catchtag c; + struct handler h; + register Lisp_Object tem; + + tem = Fcar (args); + CHECK_SYMBOL (tem, 0); + + c.tag = Qnil; + c.val = Qnil; + c.backlist = backtrace_list; + c.handlerlist = handlerlist; + c.lisp_eval_depth = lisp_eval_depth; + c.pdlcount = specpdl_ptr - specpdl; + c.poll_suppress_count = poll_suppress_count; + c.gcpro = gcprolist; + if (_setjmp (c.jmp)) + { + if (!NULL (h.var)) + specbind (h.var, Fcdr (c.val)); + val = Fprogn (Fcdr (Fcar (c.val))); + unbind_to (c.pdlcount, Qnil); + return val; + } + c.next = catchlist; + catchlist = &c; + h.var = Fcar (args); + h.handler = Fcdr (Fcdr (args)); + + for (val = h.handler; ! NULL (val); val = Fcdr (val)) + { + tem = Fcar (val); + if ((!NULL (tem)) && + (!CONSP (tem) || (XTYPE (XCONS (tem)->car) != Lisp_Symbol))) + error ("Invalid condition handler", tem); + } + + h.next = handlerlist; + h.poll_suppress_count = poll_suppress_count; + h.tag = &c; + handlerlist = &h; + + val = Feval (Fcar (Fcdr (args))); + catchlist = c.next; + handlerlist = h.next; + return val; +} + +Lisp_Object +internal_condition_case (bfun, handlers, hfun) + Lisp_Object (*bfun) (); + Lisp_Object handlers; + Lisp_Object (*hfun) (); +{ + Lisp_Object val; + struct catchtag c; + struct handler h; + + c.tag = Qnil; + c.val = Qnil; + c.backlist = backtrace_list; + c.handlerlist = handlerlist; + c.lisp_eval_depth = lisp_eval_depth; + c.pdlcount = specpdl_ptr - specpdl; + c.poll_suppress_count = poll_suppress_count; + c.gcpro = gcprolist; + if (_setjmp (c.jmp)) + { + return (*hfun) (Fcdr (c.val)); + } + c.next = catchlist; + catchlist = &c; + h.handler = handlers; + h.var = Qnil; + h.poll_suppress_count = poll_suppress_count; + h.next = handlerlist; + h.tag = &c; + handlerlist = &h; + + val = (*bfun) (); + catchlist = c.next; + handlerlist = h.next; + return val; +} + +static Lisp_Object find_handler_clause (); + +DEFUN ("signal", Fsignal, Ssignal, 2, 2, 0, + "Signal an error. Args are SIGNAL-NAME, and associated DATA.\n\ +This function does not return.\n\n\ +A signal name is a symbol with an `error-conditions' property\n\ +that is a list of condition names.\n\ +A handler for any of those names will get to handle this signal.\n\ +The symbol `error' should normally be one of them.\n\ +\n\ +DATA should be a list. Its elements are printed as part of the error message.\n\ +If the signal is handled, DATA is made available to the handler.\n\ +See also the function `condition-case'.") + (sig, data) + Lisp_Object sig, data; +{ + register struct handler *allhandlers = handlerlist; + Lisp_Object conditions; + extern int gc_in_progress; + extern int waiting_for_input; + Lisp_Object debugger_value; + + quit_error_check (); + immediate_quit = 0; + if (gc_in_progress || waiting_for_input) + abort (); + + TOTALLY_UNBLOCK_INPUT; + + conditions = Fget (sig, Qerror_conditions); + + for (; handlerlist; handlerlist = handlerlist->next) + { + register Lisp_Object clause; + clause = find_handler_clause (handlerlist->handler, conditions, + sig, data, &debugger_value); + +#if 0 /* Most callers are not prepared to handle gc if this returns. + So, since this feature is not very useful, take it out. */ + /* If have called debugger and user wants to continue, + just return nil. */ + if (EQ (clause, Qlambda)) + return debugger_value; +#else + if (EQ (clause, Qlambda)) + error ("Returning a value from an error is no longer supported"); +#endif + + if (!NULL (clause)) + { + struct handler *h = handlerlist; + /* Restore the polling-suppression count. */ + if (h->poll_suppress_count > poll_suppress_count) + abort (); + while (h->poll_suppress_count < poll_suppress_count) + start_polling (); + handlerlist = allhandlers; + unbind_catch (h->tag); + h->tag->val = Fcons (clause, Fcons (sig, data)); + _longjmp (h->tag->jmp, 1); + } + } + + handlerlist = allhandlers; + /* If no handler is present now, try to run the debugger, + and if that fails, throw to top level. */ + find_handler_clause (Qerror, conditions, sig, data, &debugger_value); + Fthrow (Qtop_level, Qt); +} + +/* Value of Qlambda means we have called debugger and + user has continued. Store value returned fromdebugger + into *debugger_value_ptr */ + +static Lisp_Object +find_handler_clause (handlers, conditions, sig, data, debugger_value_ptr) + Lisp_Object handlers, conditions, sig, data; + Lisp_Object *debugger_value_ptr; +{ + register Lisp_Object h; + register Lisp_Object tem; + register Lisp_Object tem1; + + if (EQ (handlers, Qt)) /* t is used by handlers for all conditions, set up by C code. */ + return Qt; + if (EQ (handlers, Qerror)) /* error is used similarly, but means display a backtrace too */ + { + if (stack_trace_on_error) + internal_with_output_to_temp_buffer ("*Backtrace*", Fbacktrace, Qnil); + if (!entering_debugger + && EQ (sig, Qquit) ? debug_on_quit : debug_on_error) + { + int count = specpdl_ptr - specpdl; + specbind (Qdebug_on_error, Qnil); + *debugger_value_ptr = + call_debugger (Fcons (Qerror, + Fcons (Fcons (sig, data), + Qnil))); + return unbind_to (count, Qlambda); + } + return Qt; + } + for (h = handlers; CONSP (h); h = Fcdr (h)) + { + tem1 = Fcar (h); + if (!CONSP (tem1)) + continue; + tem = Fmemq (Fcar (tem1), conditions); + if (!NULL (tem)) + return tem1; + } + return Qnil; +} + +/* dump an error message; called like printf */ + +/* VARARGS 1 */ +void +error (m, a1, a2, a3) + char *m; +{ + char buf[200]; + sprintf (buf, m, a1, a2, a3); + + while (1) + Fsignal (Qerror, Fcons (build_string (buf), Qnil)); +} + +DEFUN ("commandp", Fcommandp, Scommandp, 1, 1, 0, + "T if FUNCTION makes provisions for interactive calling.\n\ +This means it contains a description for how to read arguments to give it.\n\ +The value is nil for an invalid function or a symbol with no function\n\ +definition.\n\ +\n\ +Interactively callable functions include strings and vectors (treated\n\ +as keyboard macros), lambda-expressions that contain a top-level call\n\ +to `interactive', autoload definitions made by `autoload' with non-nil\n\ +fourth argument, and some of the built-in functions of Lisp.\n\ +\n\ +Also, a symbol satisfies `commandp' if its function definition does so.") + (function) + Lisp_Object function; +{ + register Lisp_Object fun; + register Lisp_Object funcar; + register Lisp_Object tem; + register int i = 0; + + fun = function; + + /* Dereference symbols, but avoid infinte loops. Eech. */ + while (XTYPE (fun) == Lisp_Symbol) + { + if (++i > 10) return Qnil; + tem = Ffboundp (fun); + if (NULL (tem)) return Qnil; + fun = Fsymbol_function (fun); + } + + /* Emacs primitives are interactive if their DEFUN specifies an + interactive spec. */ + if (XTYPE (fun) == Lisp_Subr) + { + if (XSUBR (fun)->prompt) + return Qt; + else + return Qnil; + } + + /* 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. */ + else if (XTYPE (fun) == Lisp_Compiled) + return (XVECTOR (fun)->size > COMPILED_INTERACTIVE + ? Qt : Qnil); + + /* Strings and vectors are keyboard macros. */ + if (XTYPE (fun) == Lisp_String + || XTYPE (fun) == Lisp_Vector) + return Qt; + + /* Lists may represent commands. */ + if (!CONSP (fun)) + return Qnil; + funcar = Fcar (fun); + if (XTYPE (funcar) != Lisp_Symbol) + return Fsignal (Qinvalid_function, Fcons (fun, Qnil)); + if (EQ (funcar, Qlambda)) + return Fassq (Qinteractive, Fcdr (Fcdr (fun))); + if (EQ (funcar, Qmocklisp)) + return Qt; /* All mocklisp functions can be called interactively */ + if (EQ (funcar, Qautoload)) + return Fcar (Fcdr (Fcdr (Fcdr (fun)))); + else + return Qnil; +} + +/* ARGSUSED */ +DEFUN ("autoload", Fautoload, Sautoload, 2, 5, 0, + "Define FUNCTION to autoload from FILE.\n\ +FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\ +Third arg DOCSTRING is documentation for the function.\n\ +Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\ +Fifth arg MACRO if non-nil says the function is really a macro.\n\ +Third through fifth args give info about the real definition.\n\ +They default to nil.\n\ +If FUNCTION is already defined other than as an autoload,\n\ +this does nothing and returns nil.") + (function, file, docstring, interactive, macro) + Lisp_Object function, file, docstring, interactive, macro; +{ +#ifdef NO_ARG_ARRAY + Lisp_Object args[4]; +#endif + + CHECK_SYMBOL (function, 0); + CHECK_STRING (file, 1); + + /* If function is defined and not as an autoload, don't override */ + if (!EQ (XSYMBOL (function)->function, Qunbound) + && !(XTYPE (XSYMBOL (function)->function) == Lisp_Cons + && EQ (XCONS (XSYMBOL (function)->function)->car, Qautoload))) + return Qnil; + +#ifdef NO_ARG_ARRAY + args[0] = file; + args[1] = docstring; + args[2] = interactive; + args[3] = macro; + + return Ffset (function, Fcons (Qautoload, Flist (4, &args[0]))); +#else /* NO_ARG_ARRAY */ + return Ffset (function, Fcons (Qautoload, Flist (4, &file))); +#endif /* not NO_ARG_ARRAY */ +} + +Lisp_Object +un_autoload (oldqueue) + Lisp_Object oldqueue; +{ + register Lisp_Object queue, first, second; + + /* Queue to unwind is current value of Vautoload_queue. + oldqueue is the shadowed value to leave in Vautoload_queue. */ + queue = Vautoload_queue; + Vautoload_queue = oldqueue; + while (CONSP (queue)) + { + first = Fcar (queue); + second = Fcdr (first); + first = Fcar (first); + if (EQ (second, Qnil)) + Vfeatures = first; + else + Ffset (first, second); + queue = Fcdr (queue); + } + return Qnil; +} + +do_autoload (fundef, funname) + Lisp_Object fundef, funname; +{ + int count = specpdl_ptr - specpdl; + Lisp_Object fun, val; + + fun = funname; + CHECK_SYMBOL (funname, 0); + + /* Value saved here is to be restored into Vautoload_queue */ + record_unwind_protect (un_autoload, Vautoload_queue); + Vautoload_queue = Qt; + Fload (Fcar (Fcdr (fundef)), Qnil, noninteractive ? Qt : Qnil, Qnil); + /* Once loading finishes, don't undo it. */ + Vautoload_queue = Qt; + unbind_to (count, Qnil); + + while (XTYPE (fun) == Lisp_Symbol) + { + QUIT; + val = XSYMBOL (fun)->function; + if (EQ (val, Qunbound)) + Fsymbol_function (fun); /* Get the right kind of error! */ + fun = val; + } + if (XTYPE (fun) == Lisp_Cons + && EQ (XCONS (fun)->car, Qautoload)) + error ("Autoloading failed to define function %s", + XSYMBOL (funname)->name->data); +} + +DEFUN ("eval", Feval, Seval, 1, 1, 0, + "Evaluate FORM and return its value.") + (form) + Lisp_Object form; +{ + Lisp_Object fun, val, original_fun, original_args; + Lisp_Object funcar; + struct backtrace backtrace; + struct gcpro gcpro1, gcpro2, gcpro3; + + if (XTYPE (form) == Lisp_Symbol) + { + if (EQ (Vmocklisp_arguments, Qt)) + return Fsymbol_value (form); + val = Fsymbol_value (form); + if (NULL (val)) + XFASTINT (val) = 0; + else if (EQ (val, Qt)) + XFASTINT (val) = 1; + return val; + } + if (!CONSP (form)) + return form; + + QUIT; + if (consing_since_gc > gc_cons_threshold) + { + GCPRO1 (form); + Fgarbage_collect (); + 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 = Fcar (form); + original_args = Fcdr (form); + + backtrace.next = backtrace_list; + backtrace_list = &backtrace; + backtrace.function = &original_fun; /* This also protects them from gc */ + backtrace.args = &original_args; + backtrace.nargs = UNEVALLED; + backtrace.evalargs = 1; + backtrace.debug_on_exit = 0; + + 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: + fun = original_fun; + while (XTYPE (fun) == Lisp_Symbol) + { + QUIT; + val = XSYMBOL (fun)->function; + if (EQ (val, Qunbound)) + Fsymbol_function (fun); /* Get the right kind of error! */ + fun = val; + } + + if (XTYPE (fun) == Lisp_Subr) + { + Lisp_Object numargs; + Lisp_Object argvals[7]; + Lisp_Object args_left; + register int i, maxargs; + + args_left = original_args; + numargs = Flength (args_left); + + if (XINT (numargs) < XSUBR (fun)->min_args || + (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < XINT (numargs))) + return Fsignal (Qwrong_number_of_arguments, Fcons (fun, Fcons (numargs, Qnil))); + + if (XSUBR (fun)->max_args == UNEVALLED) + { + backtrace.evalargs = 0; + val = (*XSUBR (fun)->function) (args_left); + goto done; + } + + if (XSUBR (fun)->max_args == MANY) + { + /* Pass a vector of evaluated arguments */ + Lisp_Object *vals; + register int argnum = 0; + + vals = (Lisp_Object *) alloca (XINT (numargs) * sizeof (Lisp_Object)); + + GCPRO3 (args_left, fun, fun); + gcpro3.var = vals; + gcpro3.nvars = 0; + + while (!NULL (args_left)) + { + vals[argnum++] = Feval (Fcar (args_left)); + args_left = Fcdr (args_left); + gcpro3.nvars = argnum; + } + UNGCPRO; + + backtrace.args = vals; + backtrace.nargs = XINT (numargs); + + val = (*XSUBR (fun)->function) (XINT (numargs), vals); + goto done; + } + + 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] = Feval (Fcar (args_left)); + gcpro3.nvars = ++i; + } + + UNGCPRO; + + backtrace.args = argvals; + backtrace.nargs = XINT (numargs); + + switch (i) + { + case 0: + val = (*XSUBR (fun)->function) (); + goto done; + case 1: + val = (*XSUBR (fun)->function) (argvals[0]); + goto done; + case 2: + val = (*XSUBR (fun)->function) (argvals[0], argvals[1]); + goto done; + case 3: + val = (*XSUBR (fun)->function) (argvals[0], argvals[1], + argvals[2]); + goto done; + case 4: + val = (*XSUBR (fun)->function) (argvals[0], argvals[1], + argvals[2], argvals[3]); + goto done; + case 5: + val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2], + argvals[3], argvals[4]); + goto done; + case 6: + val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2], + argvals[3], argvals[4], argvals[5]); + goto done; + + default: + error ("Ffuncall doesn't handle that number of arguments."); + goto done; + } + } + if (XTYPE (fun) == Lisp_Compiled) + val = apply_lambda (fun, original_args, 1); + else + { + if (!CONSP (fun)) + return Fsignal (Qinvalid_function, Fcons (fun, Qnil)); + funcar = Fcar (fun); + if (XTYPE (funcar) != Lisp_Symbol) + return Fsignal (Qinvalid_function, Fcons (fun, Qnil)); + if (EQ (funcar, Qautoload)) + { + do_autoload (fun, original_fun); + goto retry; + } + if (EQ (funcar, Qmacro)) + val = Feval (apply1 (Fcdr (fun), original_args)); + else if (EQ (funcar, Qlambda)) + val = apply_lambda (fun, original_args, 1); + else if (EQ (funcar, Qmocklisp)) + val = ml_apply (fun, original_args); + else + return Fsignal (Qinvalid_function, Fcons (fun, Qnil)); + } + done: + if (!EQ (Vmocklisp_arguments, Qt)) + { + if (NULL (val)) + XFASTINT (val) = 0; + else if (EQ (val, Qt)) + XFASTINT (val) = 1; + } + lisp_eval_depth--; + if (backtrace.debug_on_exit) + val = call_debugger (Fcons (Qexit, Fcons (val, Qnil))); + backtrace_list = backtrace.next; + return val; +} + +DEFUN ("apply", Fapply, Sapply, 2, MANY, 0, + "Call FUNCTION with our remaining args, using our last arg as list of args.\n\ +Thus, (apply '+ 1 2 '(3 4)) returns 10.") + (nargs, args) + int nargs; + Lisp_Object *args; +{ + register int i, numargs; + register Lisp_Object spread_arg; + register Lisp_Object *funcall_args; + struct gcpro gcpro1; + Lisp_Object fun; + + fun = args [0]; + funcall_args = 0; + spread_arg = args [nargs - 1]; + CHECK_LIST (spread_arg, nargs); + + numargs = XINT (Flength (spread_arg)); + + if (numargs == 0) + return Ffuncall (nargs - 1, args); + else if (numargs == 1) + { + args [nargs - 1] = XCONS (spread_arg)->car; + return Ffuncall (nargs, args); + } + + numargs = nargs - 2 + numargs; + + while (XTYPE (fun) == Lisp_Symbol) + { + QUIT; + fun = XSYMBOL (fun)->function; + if (EQ (fun, Qunbound)) + { + /* Let funcall get the error */ + fun = args[0]; + goto funcall; + } + } + + if (XTYPE (fun) == Lisp_Subr) + { + 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 > numargs) + { + /* Avoid making funcall cons up a yet another new vector of arguments + by explicitly supplying nil's for optional values */ + funcall_args = (Lisp_Object *) alloca ((1 + XSUBR (fun)->max_args) + * sizeof (Lisp_Object)); + for (i = numargs; i < XSUBR (fun)->max_args;) + funcall_args[++i] = Qnil; + } + } + funcall: + /* We add 1 to numargs because funcall_args includes the + function itself as well as its arguments. */ + if (!funcall_args) + funcall_args = (Lisp_Object *) alloca ((1 + numargs) + * sizeof (Lisp_Object)); + bcopy (args, funcall_args, nargs * sizeof (Lisp_Object)); + /* Spread the last arg we got. Its first element goes in + the slot that it used to occupy, hence this value of I. */ + i = nargs - 1; + while (!NULL (spread_arg)) + { + funcall_args [i++] = XCONS (spread_arg)->car; + spread_arg = XCONS (spread_arg)->cdr; + } + + GCPRO1 (*funcall_args); + gcpro1.nvars = numargs + 1; + { + Lisp_Object val = Ffuncall (numargs + 1, funcall_args); + UNGCPRO; + return val; + } +} + +/* Apply fn to arg */ +Lisp_Object +apply1 (fn, arg) + Lisp_Object fn, arg; +{ + if (NULL (arg)) + return Ffuncall (1, &fn); +#ifdef NO_ARG_ARRAY + { + Lisp_Object args[2]; + args[0] = fn; + args[1] = arg; + return Fapply (2, args); + } +#else /* not NO_ARG_ARRAY */ + return Fapply (2, &fn); +#endif /* not NO_ARG_ARRAY */ +} + +/* Call function fn on no arguments */ +Lisp_Object +call0 (fn) + Lisp_Object fn; +{ + return Ffuncall (1, &fn); +} + +/* Call function fn with argument arg */ +/* ARGSUSED */ +Lisp_Object +call1 (fn, arg) + Lisp_Object fn, arg; +{ +#ifdef NO_ARG_ARRAY + Lisp_Object args[2]; + args[0] = fn; + args[1] = arg; + return Ffuncall (2, args); +#else /* not NO_ARG_ARRAY */ + return Ffuncall (2, &fn); +#endif /* not NO_ARG_ARRAY */ +} + +/* Call function fn with arguments arg, arg1 */ +/* ARGSUSED */ +Lisp_Object +call2 (fn, arg, arg1) + Lisp_Object fn, arg, arg1; +{ +#ifdef NO_ARG_ARRAY + Lisp_Object args[3]; + args[0] = fn; + args[1] = arg; + args[2] = arg1; + return Ffuncall (3, args); +#else /* not NO_ARG_ARRAY */ + return Ffuncall (3, &fn); +#endif /* not NO_ARG_ARRAY */ +} + +/* Call function fn with arguments arg, arg1, arg2 */ +/* ARGSUSED */ +Lisp_Object +call3 (fn, arg, arg1, arg2) + Lisp_Object fn, arg, arg1, arg2; +{ +#ifdef NO_ARG_ARRAY + Lisp_Object args[4]; + args[0] = fn; + args[1] = arg; + args[2] = arg1; + args[3] = arg2; + return Ffuncall (4, args); +#else /* not NO_ARG_ARRAY */ + return Ffuncall (4, &fn); +#endif /* not NO_ARG_ARRAY */ +} + +DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0, + "Call first argument as a function, passing remaining arguments to it.\n\ +Thus, (funcall 'cons 'x 'y) returns (x . y).") + (nargs, args) + int nargs; + Lisp_Object *args; +{ + Lisp_Object fun; + Lisp_Object funcar; + int numargs = nargs - 1; + Lisp_Object lisp_numargs; + Lisp_Object val; + struct backtrace backtrace; + register Lisp_Object *internal_args; + register int i; + + QUIT; + if (consing_since_gc > gc_cons_threshold) + Fgarbage_collect (); + + + 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"); + } + + backtrace.next = backtrace_list; + backtrace_list = &backtrace; + backtrace.function = &args[0]; + backtrace.args = &args[1]; + backtrace.nargs = nargs - 1; + backtrace.evalargs = 0; + backtrace.debug_on_exit = 0; + + if (debug_on_next_call) + do_debug_on_call (Qlambda); + + retry: + + fun = args[0]; + while (XTYPE (fun) == Lisp_Symbol) + { + QUIT; + val = XSYMBOL (fun)->function; + if (EQ (val, Qunbound)) + Fsymbol_function (fun); /* Get the right kind of error! */ + fun = val; + } + + if (XTYPE (fun) == Lisp_Subr) + { + if (numargs < XSUBR (fun)->min_args + || (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs)) + { + XFASTINT (lisp_numargs) = numargs; + return Fsignal (Qwrong_number_of_arguments, Fcons (fun, Fcons (lisp_numargs, Qnil))); + } + + if (XSUBR (fun)->max_args == UNEVALLED) + return Fsignal (Qinvalid_function, Fcons (fun, Qnil)); + + if (XSUBR (fun)->max_args == MANY) + { + val = (*XSUBR (fun)->function) (numargs, args + 1); + goto done; + } + + if (XSUBR (fun)->max_args > numargs) + { + internal_args = (Lisp_Object *) alloca (XSUBR (fun)->max_args * sizeof (Lisp_Object)); + bcopy (args + 1, internal_args, numargs * sizeof (Lisp_Object)); + 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) (); + goto done; + case 1: + val = (*XSUBR (fun)->function) (internal_args[0]); + goto done; + case 2: + val = (*XSUBR (fun)->function) (internal_args[0], + internal_args[1]); + goto done; + case 3: + val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1], + internal_args[2]); + goto done; + case 4: + val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1], + internal_args[2], + internal_args[3]); + goto done; + case 5: + val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1], + internal_args[2], internal_args[3], + internal_args[4]); + goto done; + case 6: + val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1], + internal_args[2], internal_args[3], + internal_args[4], internal_args[5]); + goto done; + + default: + error ("funcall: this number of args not handled."); + } + } + if (XTYPE (fun) == Lisp_Compiled) + val = funcall_lambda (fun, numargs, args + 1); + else + { + if (!CONSP (fun)) + return Fsignal (Qinvalid_function, Fcons (fun, Qnil)); + funcar = Fcar (fun); + if (XTYPE (funcar) != Lisp_Symbol) + return Fsignal (Qinvalid_function, Fcons (fun, Qnil)); + if (EQ (funcar, Qlambda)) + val = funcall_lambda (fun, numargs, args + 1); + else if (EQ (funcar, Qmocklisp)) + val = ml_apply (fun, Flist (numargs, args + 1)); + else if (EQ (funcar, Qautoload)) + { + do_autoload (fun, args[0]); + goto retry; + } + else + return Fsignal (Qinvalid_function, Fcons (fun, Qnil)); + } + done: + lisp_eval_depth--; + if (backtrace.debug_on_exit) + val = call_debugger (Fcons (Qexit, Fcons (val, Qnil))); + backtrace_list = backtrace.next; + return val; +} + +Lisp_Object +apply_lambda (fun, args, eval_flag) + Lisp_Object fun, args; + int eval_flag; +{ + Lisp_Object args_left; + Lisp_Object numargs; + register Lisp_Object *arg_vector; + struct gcpro gcpro1, gcpro2, gcpro3; + register int i; + register Lisp_Object tem; + + numargs = Flength (args); + arg_vector = (Lisp_Object *) alloca (XINT (numargs) * sizeof (Lisp_Object)); + args_left = args; + + GCPRO3 (*arg_vector, args_left, fun); + gcpro1.nvars = 0; + + for (i = 0; i < XINT (numargs);) + { + tem = Fcar (args_left), args_left = Fcdr (args_left); + if (eval_flag) tem = Feval (tem); + arg_vector[i++] = tem; + gcpro1.nvars = i; + } + + UNGCPRO; + + if (eval_flag) + { + backtrace_list->args = arg_vector; + backtrace_list->nargs = i; + } + backtrace_list->evalargs = 0; + tem = funcall_lambda (fun, XINT (numargs), arg_vector); + + /* Do the debug-on-exit now, while arg_vector still exists. */ + if (backtrace_list->debug_on_exit) + tem = call_debugger (Fcons (Qexit, Fcons (tem, Qnil))); + /* Don't do it again when we return to eval. */ + backtrace_list->debug_on_exit = 0; + return tem; +} + +/* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR + and return the result of evaluation. + FUN must be either a lambda-expression or a compiled-code object. */ + +Lisp_Object +funcall_lambda (fun, nargs, arg_vector) + Lisp_Object fun; + int nargs; + register Lisp_Object *arg_vector; +{ + Lisp_Object val, tem; + register Lisp_Object syms_left; + Lisp_Object numargs; + register Lisp_Object next; + int count = specpdl_ptr - specpdl; + register int i; + int optional = 0, rest = 0; + + specbind (Qmocklisp_arguments, Qt); /* t means NOT mocklisp! */ + + XFASTINT (numargs) = nargs; + + if (XTYPE (fun) == Lisp_Cons) + syms_left = Fcar (Fcdr (fun)); + else if (XTYPE (fun) == Lisp_Compiled) + syms_left = XVECTOR (fun)->contents[COMPILED_ARGLIST]; + else abort (); + + i = 0; + for (; !NULL (syms_left); syms_left = Fcdr (syms_left)) + { + QUIT; + next = Fcar (syms_left); + if (EQ (next, Qand_rest)) + rest = 1; + else if (EQ (next, Qand_optional)) + optional = 1; + else if (rest) + { + specbind (Fcar (syms_left), Flist (nargs - i, &arg_vector[i])); + i = nargs; + } + else if (i < nargs) + { + tem = arg_vector[i++]; + specbind (next, tem); + } + else if (!optional) + return Fsignal (Qwrong_number_of_arguments, Fcons (fun, Fcons (numargs, Qnil))); + else + specbind (next, Qnil); + } + + if (i < nargs) + return Fsignal (Qwrong_number_of_arguments, Fcons (fun, Fcons (numargs, Qnil))); + + if (XTYPE (fun) == Lisp_Cons) + val = Fprogn (Fcdr (Fcdr (fun))); + else + val = Fbyte_code (XVECTOR (fun)->contents[COMPILED_BYTECODE], + XVECTOR (fun)->contents[COMPILED_CONSTANTS], + XVECTOR (fun)->contents[COMPILED_STACK_DEPTH]); + return unbind_to (count, val); +} + +void +grow_specpdl () +{ + register int count = specpdl_ptr - specpdl; + if (specpdl_size >= max_specpdl_size) + { + if (max_specpdl_size < 400) + max_specpdl_size = 400; + if (specpdl_size >= max_specpdl_size) + { + Fsignal (Qerror, + Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil)); + max_specpdl_size *= 2; + } + } + specpdl_size *= 2; + if (specpdl_size > max_specpdl_size) + specpdl_size = max_specpdl_size; + specpdl = (struct specbinding *) xrealloc (specpdl, specpdl_size * sizeof (struct specbinding)); + specpdl_ptr = specpdl + count; +} + +void +specbind (symbol, value) + Lisp_Object symbol, value; +{ + extern void store_symval_forwarding (); /* in eval.c */ + Lisp_Object ovalue; + + if (specpdl_ptr == specpdl + specpdl_size) + grow_specpdl (); + specpdl_ptr->symbol = symbol; + specpdl_ptr->func = 0; + ovalue = XSYMBOL (symbol)->value; + specpdl_ptr->old_value = EQ (ovalue, Qunbound) ? Qunbound : Fsymbol_value (symbol); + specpdl_ptr++; + if (XTYPE (ovalue) == Lisp_Buffer_Objfwd) + store_symval_forwarding (symbol, ovalue, value); + else + Fset (symbol, value); +} + +void +record_unwind_protect (function, arg) + Lisp_Object (*function)(); + Lisp_Object arg; +{ + if (specpdl_ptr == specpdl + specpdl_size) + grow_specpdl (); + specpdl_ptr->func = function; + specpdl_ptr->symbol = Qnil; + specpdl_ptr->old_value = arg; + specpdl_ptr++; +} + +Lisp_Object +unbind_to (count, value) + int count; + Lisp_Object value; +{ + int quitf = !NULL (Vquit_flag); + struct gcpro gcpro1; + + GCPRO1 (value); + + Vquit_flag = Qnil; + + while (specpdl_ptr != specpdl + count) + { + --specpdl_ptr; + if (specpdl_ptr->func != 0) + (*specpdl_ptr->func) (specpdl_ptr->old_value); + /* Note that a "binding" of nil is really an unwind protect, + so in that case the "old value" is a list of forms to evaluate. */ + else if (NULL (specpdl_ptr->symbol)) + Fprogn (specpdl_ptr->old_value); + else + Fset (specpdl_ptr->symbol, specpdl_ptr->old_value); + } + if (NULL (Vquit_flag) && quitf) Vquit_flag = Qt; + + UNGCPRO; + + return value; +} + +#if 0 + +/* Get the value of symbol's global binding, even if that binding + is not now dynamically visible. */ + +Lisp_Object +top_level_value (symbol) + Lisp_Object symbol; +{ + register struct specbinding *ptr = specpdl; + + CHECK_SYMBOL (symbol, 0); + for (; ptr != specpdl_ptr; ptr++) + { + if (EQ (ptr->symbol, symbol)) + return ptr->old_value; + } + return Fsymbol_value (symbol); +} + +Lisp_Object +top_level_set (symbol, newval) + Lisp_Object symbol, newval; +{ + register struct specbinding *ptr = specpdl; + + CHECK_SYMBOL (symbol, 0); + for (; ptr != specpdl_ptr; ptr++) + { + if (EQ (ptr->symbol, symbol)) + { + ptr->old_value = newval; + return newval; + } + } + return Fset (symbol, newval); +} + +#endif /* 0 */ + +DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0, + "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\ +The debugger is entered when that frame exits, if the flag is non-nil.") + (level, flag) + Lisp_Object level, flag; +{ + register struct backtrace *backlist = backtrace_list; + register int i; + + CHECK_NUMBER (level, 0); + + for (i = 0; backlist && i < XINT (level); i++) + { + backlist = backlist->next; + } + + if (backlist) + backlist->debug_on_exit = !NULL (flag); + + return flag; +} + +DEFUN ("backtrace", Fbacktrace, Sbacktrace, 0, 0, "", + "Print a trace of Lisp function calls currently active.\n\ +Output stream used is value of `standard-output'.") + () +{ + register struct backtrace *backlist = backtrace_list; + register int i; + Lisp_Object tail; + Lisp_Object tem; + extern Lisp_Object Vprint_level; + struct gcpro gcpro1; + + entering_debugger = 0; + + XFASTINT (Vprint_level) = 3; + + tail = Qnil; + GCPRO1 (tail); + + while (backlist) + { + write_string (backlist->debug_on_exit ? "* " : " ", 2); + if (backlist->nargs == UNEVALLED) + { + Fprin1 (Fcons (*backlist->function, *backlist->args), Qnil); + } + else + { + tem = *backlist->function; + Fprin1 (tem, Qnil); /* This can QUIT */ + write_string ("(", -1); + if (backlist->nargs == MANY) + { + for (tail = *backlist->args, i = 0; + !NULL (tail); + tail = Fcdr (tail), i++) + { + if (i) write_string (" ", -1); + Fprin1 (Fcar (tail), Qnil); + } + } + else + { + for (i = 0; i < backlist->nargs; i++) + { + if (i) write_string (" ", -1); + Fprin1 (backlist->args[i], Qnil); + } + } + } + write_string (")\n", -1); + backlist = backlist->next; + } + + Vprint_level = Qnil; + UNGCPRO; + return Qnil; +} + +DEFUN ("backtrace-frame", Fbacktrace_frame, Sbacktrace_frame, 1, 1, "", + "Return the function and arguments N frames up from current execution point.\n\ +If that frame has not evaluated the arguments yet (or is a special form),\n\ +the value is (nil FUNCTION ARG-FORMS...).\n\ +If that frame has evaluated its arguments and called its function already,\n\ +the value is (t FUNCTION ARG-VALUES...).\n\ +A &rest arg is represented as the tail of the list ARG-VALUES.\n\ +FUNCTION is whatever was supplied as car of evaluated list,\n\ +or a lambda expression for macro calls.\n\ +If N is more than the number of frames, the value is nil.") + (nframes) + Lisp_Object nframes; +{ + register struct backtrace *backlist = backtrace_list; + register int i; + Lisp_Object tem; + + CHECK_NATNUM (nframes, 0); + + /* Find the frame requested. */ + for (i = 0; i < XFASTINT (nframes); i++) + backlist = backlist->next; + + if (!backlist) + return Qnil; + if (backlist->nargs == UNEVALLED) + return Fcons (Qnil, Fcons (*backlist->function, *backlist->args)); + else + { + if (backlist->nargs == MANY) + tem = *backlist->args; + else + tem = Flist (backlist->nargs, backlist->args); + + return Fcons (Qt, Fcons (*backlist->function, tem)); + } +} + +syms_of_eval () +{ + DEFVAR_INT ("max-specpdl-size", &max_specpdl_size, + "Limit on number of Lisp variable bindings & unwind-protects before error."); + + DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth, + "Limit on depth in `eval', `apply' and `funcall' before error.\n\ +This limit is to catch infinite recursions for you before they cause\n\ +actual stack overflow in C, which would be fatal for Emacs.\n\ +You can safely make it considerably larger than its default value,\n\ +if that proves inconveniently small."); + + DEFVAR_LISP ("quit-flag", &Vquit_flag, + "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\ +Typing C-G sets `quit-flag' non-nil, regardless of `inhibit-quit'."); + Vquit_flag = Qnil; + + DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit, + "Non-nil inhibits C-g quitting from happening immediately.\n\ +Note that `quit-flag' will still be set by typing C-g,\n\ +so a quit will be signalled as soon as `inhibit-quit' is nil.\n\ +To prevent this happening, set `quit-flag' to nil\n\ +before making `inhibit-quit' nil."); + Vinhibit_quit = Qnil; + + Qautoload = intern ("autoload"); + staticpro (&Qautoload); + + Qdebug_on_error = intern ("debug-on-error"); + staticpro (&Qdebug_on_error); + + Qmacro = intern ("macro"); + staticpro (&Qmacro); + + /* Note that the process handling also uses Qexit, but we don't want + to staticpro it twice, so we just do it here. */ + Qexit = intern ("exit"); + staticpro (&Qexit); + + Qinteractive = intern ("interactive"); + staticpro (&Qinteractive); + + Qcommandp = intern ("commandp"); + staticpro (&Qcommandp); + + Qdefun = intern ("defun"); + staticpro (&Qdefun); + + Qand_rest = intern ("&rest"); + staticpro (&Qand_rest); + + Qand_optional = intern ("&optional"); + staticpro (&Qand_optional); + + DEFVAR_BOOL ("stack-trace-on-error", &stack_trace_on_error, + "*Non-nil means automatically display a backtrace buffer\n\ +after any error that is handled by the editor command loop."); + stack_trace_on_error = 0; + + DEFVAR_BOOL ("debug-on-error", &debug_on_error, + "*Non-nil means enter debugger if an error is signaled.\n\ +Does not apply to errors handled by `condition-case'.\n\ +See also variable `debug-on-quit'."); + debug_on_error = 0; + + DEFVAR_BOOL ("debug-on-quit", &debug_on_quit, + "*Non-nil means enter debugger if quit is signaled (C-G, for example).\n\ +Does not apply if quit is handled by a `condition-case'."); + debug_on_quit = 0; + + DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call, + "Non-nil means enter debugger before next `eval', `apply' or `funcall'."); + + DEFVAR_LISP ("debugger", &Vdebugger, + "Function to call to invoke debugger.\n\ +If due to frame exit, args are `exit' and the value being returned;\n\ + this function's value will be returned instead of that.\n\ +If due to error, args are `error' and a list of the args to `signal'.\n\ +If due to `apply' or `funcall' entry, one arg, `lambda'.\n\ +If due to `eval' entry, one arg, t."); + Vdebugger = Qnil; + + Qmocklisp_arguments = intern ("mocklisp-arguments"); + staticpro (&Qmocklisp_arguments); + DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments, + "While in a mocklisp function, the list of its unevaluated args."); + Vmocklisp_arguments = Qt; + + DEFVAR_LISP ("run-hooks", &Vrun_hooks, + "Set to the function `run-hooks', if that function has been defined.\n\ +Otherwise, nil (in a bare Emacs without preloaded Lisp code)."); + Vrun_hooks = Qnil; + + staticpro (&Vautoload_queue); + Vautoload_queue = Qnil; + + defsubr (&Sor); + defsubr (&Sand); + defsubr (&Sif); + defsubr (&Scond); + defsubr (&Sprogn); + defsubr (&Sprog1); + defsubr (&Sprog2); + defsubr (&Ssetq); + defsubr (&Squote); + defsubr (&Sfunction); + defsubr (&Sdefun); + defsubr (&Sdefmacro); + defsubr (&Sdefvar); + defsubr (&Sdefconst); + defsubr (&Suser_variable_p); + defsubr (&Slet); + defsubr (&SletX); + defsubr (&Swhile); + defsubr (&Smacroexpand); + defsubr (&Scatch); + defsubr (&Sthrow); + defsubr (&Sunwind_protect); + defsubr (&Scondition_case); + defsubr (&Ssignal); + defsubr (&Sinteractive_p); + defsubr (&Scommandp); + defsubr (&Sautoload); + defsubr (&Seval); + defsubr (&Sapply); + defsubr (&Sfuncall); + defsubr (&Sbacktrace_debug); + defsubr (&Sbacktrace); + defsubr (&Sbacktrace_frame); +}