X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/daa3760289bd389e8c174c8d24b375cd875cd911..be857679f65f098614295fd511978c6d1a318b1e:/src/eval.c diff --git a/src/eval.c b/src/eval.c index 0e012d4500..50b8879300 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1,11 +1,11 @@ /* Evaluator for GNU Emacs Lisp interpreter. - Copyright (C) 1985, 1986, 1987, 1992 Free Software Foundation, Inc. + Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995 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) +the Free Software Foundation; either version 2, or (at your option) any later version. GNU Emacs is distributed in the hope that it will be useful, @@ -15,14 +15,13 @@ 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. */ +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ -#include "config.h" +#include #include "lisp.h" -#ifdef HAVE_X_WINDOWS -#include "xterm.h" -#endif +#include "blockinput.h" #ifndef standalone #include "commands.h" @@ -51,6 +50,24 @@ struct backtrace struct backtrace *backtrace_list; +/* This structure helps implement the `catch' and `throw' control + structure. A struct catchtag contains all the information needed + to restore the state of the interpreter after a non-local jump. + + Handlers for error conditions (represented by `struct handler' + structures) just point to a catch tag to do the cleanup required + for their jumps. + + catchtag structures are chained together in the C calling stack; + the `next' member points to the next outer catchtag. + + A call like (throw TAG VAL) searches for a catchtag whose `tag' + member is TAG, and then unbinds to it. The `val' member is used to + hold VAL while the stack is unwound; `val' is returned as the value + of the catch form. + + All the other members are concerned with restoring the interpreter + state. */ struct catchtag { Lisp_Object tag; @@ -73,6 +90,9 @@ Lisp_Object Qmocklisp_arguments, Vmocklisp_arguments, Qmocklisp; Lisp_Object Qand_rest, Qand_optional; Lisp_Object Qdebug_on_error; +/* This holds either the symbol `run-hooks' or nil. + It is nil at an early stage of startup, and when Emacs + is shutting down. */ Lisp_Object Vrun_hooks; /* Non-nil means record all fset's and provide's, to be undone @@ -111,27 +131,46 @@ Lisp_Object Vstack_trace_on_error; if an error is handled by the command loop's error handler. */ Lisp_Object Vdebug_on_error; +/* List of conditions and regexps specifying error messages which + do not enter the debugger even if Vdebug_on_errors says they should. */ +Lisp_Object Vdebug_ignored_errors; + +/* Non-nil means call the debugger even if the error will be handled. */ +Lisp_Object Vdebug_on_signal; + +/* Hook for edebug to use. */ +Lisp_Object Vsignal_hook_function; + /* 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; +/* The value of num_nonmacro_input_events as of the last time we + started to enter the debugger. If we decide to enter the debugger + again when this is still equal to num_nonmacro_input_events, then we + know that the debugger itself has an error, and we should just + signal the error instead of entering an infinite loop of debugger + invocations. */ +int when_entered_debugger; Lisp_Object Vdebugger; void specbind (), record_unwind_protect (); +Lisp_Object run_hook_with_args (); + 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)); + specpdl = (struct specbinding *) xmalloc (specpdl_size * sizeof (struct specbinding)); + specpdl_ptr = specpdl; max_specpdl_size = 600; - max_lisp_eval_depth = 200; + max_lisp_eval_depth = 300; + + Vrun_hooks = Qnil; } init_eval () @@ -143,7 +182,8 @@ init_eval () Vquit_flag = Qnil; debug_on_next_call = 0; lisp_eval_depth = 0; - entering_debugger = 0; + /* This is less than the initial value of num_nonmacro_input_events. */ + when_entered_debugger = -1; } Lisp_Object @@ -155,7 +195,7 @@ call_debugger (arg) if (specpdl_size + 40 > max_specpdl_size) max_specpdl_size = specpdl_size + 40; debug_on_next_call = 0; - entering_debugger = 1; + when_entered_debugger = num_nonmacro_input_events; return apply1 (Vdebugger, arg); } @@ -299,7 +339,7 @@ DEFUN ("progn", Fprogn, Sprogn, 0, UNEVALLED, 0, if (!EQ (Vmocklisp_arguments, Qt)) { val = make_number (0); - while (!NILP (args) && (tem = Fcar (args), XTYPE (tem) == Lisp_Symbol)) + while (!NILP (args) && (tem = Fcar (args), SYMBOLP (tem))) { QUIT; specbind (tem, val), args = Fcdr (args); @@ -357,7 +397,7 @@ whose values are discarded.") } DEFUN ("prog2", Fprog2, Sprog2, 2, UNEVALLED, 0, - "(prog1 X Y BODY...): eval X, Y and BODY sequentially; value from Y.\n\ + "(prog2 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) @@ -370,7 +410,7 @@ whose values are discarded.") val = Qnil; - if (NILP(args)) + if (NILP (args)) return Qnil; args_left = args; @@ -385,7 +425,7 @@ whose values are discarded.") Feval (Fcar (args_left)); args_left = Fcdr (args_left); } - while (!NILP(args_left)); + while (!NILP (args_left)); UNGCPRO; return val; @@ -393,8 +433,12 @@ whose values are discarded.") 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.") +The symbols SYM are variables; they are literal (not evaluated).\n\ +The values VAL are expressions; they are evaluated.\n\ +Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.\n\ +The second VAL is not computed until after the first SYM is set, and so on;\n\ +each VAL can use the new value of variables set earlier in the `setq'.\n\ +The return value of the `setq' form is the value of the last VAL.") (args) Lisp_Object args; { @@ -457,8 +501,7 @@ and input is currently coming from the keyboard (not in keyboard macro).") /* If this isn't a byte-compiled function, there may be a frame at the top for Finteractive_p itself. If so, skip it. */ fun = Findirect_function (*btp->function); - if (XTYPE (fun) == Lisp_Subr - && (struct Lisp_Subr *) XPNTR (fun) == &Sinteractive_p) + if (SUBRP (fun) && XSUBR (fun) == &Sinteractive_p) btp = btp->next; /* If we're running an Emacs 18-style byte-compiled function, there @@ -480,7 +523,7 @@ and input is currently coming from the keyboard (not in keyboard macro).") Fbytecode at the top. If this frame is for a built-in function (such as load or eval-region) return nil. */ fun = Findirect_function (*btp->function); - if (XTYPE (fun) == Lisp_Subr) + if (SUBRP (fun)) return Qnil; /* btp points to the frame of a Lisp function that called interactive-p. Return t if that function was called interactively. */ @@ -504,6 +547,7 @@ See also the function `interactive'.") if (!NILP (Vpurify_flag)) defn = Fpurecopy (defn); Ffset (fn_name, defn); + LOADHIST_ATTACH (fn_name); return fn_name; } @@ -525,6 +569,7 @@ and the result should be a form to be evaluated instead of the original.") if (!NILP (Vpurify_flag)) defn = Fpurecopy (defn); Ffset (fn_name, defn); + LOADHIST_ATTACH (fn_name); return fn_name; } @@ -543,23 +588,28 @@ If INITVALUE is missing, SYMBOL's value is not set.") (args) Lisp_Object args; { - register Lisp_Object sym, tem; + register Lisp_Object sym, tem, tail; sym = Fcar (args); - tem = Fcdr (args); - if (!NILP (tem)) + tail = Fcdr (args); + if (!NILP (Fcdr (Fcdr (tail)))) + error ("too many arguments"); + + if (!NILP (tail)) { tem = Fdefault_boundp (sym); if (NILP (tem)) Fset_default (sym, Feval (Fcar (Fcdr (args)))); } - tem = Fcar (Fcdr (Fcdr (args))); - if (!NILP (tem)) + tail = Fcdr (Fcdr (args)); + if (!NILP (Fcar (tail))) { + tem = Fcar (tail); if (!NILP (Vpurify_flag)) tem = Fpurecopy (tem); Fput (sym, Qvariable_documentation, tem); } + LOADHIST_ATTACH (sym); return sym; } @@ -583,6 +633,9 @@ it would override the user's choice.") register Lisp_Object sym, tem; sym = Fcar (args); + if (!NILP (Fcdr (Fcdr (Fcdr (args))))) + error ("too many arguments"); + Fset_default (sym, Feval (Fcar (Fcdr (args)))); tem = Fcar (Fcdr (Fcdr (args))); if (!NILP (tem)) @@ -591,6 +644,7 @@ it would override the user's choice.") tem = Fpurecopy (tem); Fput (sym, Qvariable_documentation, tem); } + LOADHIST_ATTACH (sym); return sym; } @@ -598,17 +652,26 @@ 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 \"*\"") +for the variable is `*'.") (variable) Lisp_Object variable; { Lisp_Object documentation; + if (!SYMBOLP (variable)) + return Qnil; + documentation = Fget (variable, Qvariable_documentation); - if (XTYPE (documentation) == Lisp_Int && XINT (documentation) < 0) + if (INTEGERP (documentation) && XINT (documentation) < 0) + return Qt; + if (STRINGP (documentation) + && ((unsigned char) XSTRING (documentation)->data[0] == '*')) return Qt; - if ((XTYPE (documentation) == Lisp_String) && - ((unsigned char) XSTRING (documentation)->data[0] == '*')) + /* If it is (STRING . INTEGER), a negative integer means a user variable. */ + if (CONSP (documentation) + && STRINGP (XCONS (documentation)->car) + && INTEGERP (XCONS (documentation)->cdr) + && XINT (XCONS (documentation)->cdr) < 0) return Qt; return Qnil; } @@ -633,7 +696,7 @@ Each VALUEFORM can refer to the symbols already bound by this VARLIST.") { QUIT; elt = Fcar (varlist); - if (XTYPE (elt) == Lisp_Symbol) + if (SYMBOLP (elt)) specbind (elt, Qnil); else if (! NILP (Fcdr (Fcdr (elt)))) Fsignal (Qerror, @@ -681,7 +744,7 @@ All the VALUEFORMs are evalled before any symbols are bound.") { QUIT; elt = Fcar (varlist); - if (XTYPE (elt) == Lisp_Symbol) + if (SYMBOLP (elt)) temps [argnum++] = Qnil; else if (! NILP (Fcdr (Fcdr (elt)))) Fsignal (Qerror, @@ -698,7 +761,7 @@ All the VALUEFORMs are evalled before any symbols are bound.") { elt = Fcar (varlist); tem = temps[argnum++]; - if (XTYPE (elt) == Lisp_Symbol) + if (SYMBOLP (elt)) specbind (elt, tem); else specbind (Fcar (elt), tem); @@ -722,7 +785,8 @@ until TEST returns nil.") test = Fcar (args); body = Fcdr (args); - while (tem = Feval (test), !NILP (tem)) + while (tem = Feval (test), + (!EQ (Vmocklisp_arguments, Qt) ? XINT (tem) : !NILP (tem))) { QUIT; Fprogn (body); @@ -739,74 +803,61 @@ 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; + (form, environment) + Lisp_Object form; + Lisp_Object environment; { + /* With cleanups from Hallvard Furuseth. */ 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) + if (!CONSP (form)) break; + /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */ + def = sym = XCONS (form)->car; + tem = Qnil; /* Trace symbols aliases to other symbols until we get a symbol that is not an alias. */ - while (1) + while (SYMBOLP (def)) { QUIT; - tem = Fassq (sym, env); + sym = def; + tem = Fassq (sym, environment); if (NILP (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; + if (!EQ (def, Qunbound)) + continue; } + break; } - /* Right now TEM is the result from SYM in ENV, + /* Right now TEM is the result from SYM in ENVIRONMENT, and if TEM is nil then DEF is SYM's function definition. */ if (NILP (tem)) { - /* SYM is not mentioned in ENV. + /* SYM is not mentioned in ENVIRONMENT. Look at its function definition. */ - if (EQ (def, Qunbound) - || XTYPE (def) != Lisp_Cons) + if (EQ (def, Qunbound) || !CONSP (def)) /* 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 (NILP (tem)) + tem = Fnth (make_number (4), def); + if (EQ (tem, Qt) || EQ (tem, Qmacro)) + /* Yes, load it and try again. */ + { + struct gcpro gcpro1; + GCPRO1 (form); + do_autoload (def, sym); + UNGCPRO; + continue; + } + else break; - /* Yes, load it and try again. */ - do_autoload (def, sym); - continue; } else if (!EQ (XCONS (def)->car, Qmacro)) break; @@ -818,7 +869,6 @@ definitions to shadow the loaded ones for use in file byte-compilation.") if (NILP (expander)) break; } - explicit: form = apply1 (expander, XCONS (form)->cdr); } return form; @@ -876,26 +926,41 @@ internal_catch (tag, func, arg) 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. +/* Unwind the specbind, catch, and handler stacks back to CATCH, and + jump to that CATCH, returning VALUE as the value of that catch. - At the end, restore some static info saved in CATCH. + This is the guts Fthrow and Fsignal; they differ only in the way + they choose the catch tag to throw to. A catch tag for a + condition-case form has a TAG of Qnil. - 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. */ + Before each catch is discarded, unbind all special bindings and + execute all unwind-protect clauses made above that catch. Unwind + the handler stack as we go, so that the proper handlers are in + effect for each unwind-protect clause we run. At the end, restore + some static info saved in CATCH, and longjmp to the location + specified in the + + This is used for correct unwinding in Fthrow and Fsignal. */ static void -unbind_catch (catch) +unwind_to_catch (catch, value) struct catchtag *catch; + Lisp_Object value; { register int last_time; + /* Save the value in the tag. */ + catch->val = value; + + /* Restore the polling-suppression count. */ + set_poll_suppress_count (catch->poll_suppress_count); + do { last_time = catchlist == catch; + + /* Unwind the specpdl stack, and then restore the proper set of + handlers. */ unbind_to (catchlist->pdlcount, Qnil); handlerlist = catchlist->handlerlist; catchlist = catchlist->next; @@ -905,13 +970,15 @@ unbind_catch (catch) gcprolist = catch->gcpro; backtrace_list = catch->backlist; lisp_eval_depth = catch->lisp_eval_depth; + + _longjmp (catch->jmp, 1); } 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; + (tag, value) + register Lisp_Object tag, value; { register struct catchtag *c; @@ -921,18 +988,9 @@ Both TAG and VALUE are evalled.") 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); - } + unwind_to_catch (c, value); } - tag = Fsignal (Qno_catch, Fcons (tag, Fcons (val, Qnil))); + tag = Fsignal (Qno_catch, Fcons (tag, Fcons (value, Qnil))); } } @@ -972,6 +1030,9 @@ 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\ +The car of a handler may be a list of condition names\n\ +instead of a single condition name.\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\ @@ -985,10 +1046,23 @@ See also the function `signal' for more info.") Lisp_Object val; struct catchtag c; struct handler h; - register Lisp_Object tem; + register Lisp_Object var, bodyform, handlers; + + var = Fcar (args); + bodyform = Fcar (Fcdr (args)); + handlers = Fcdr (Fcdr (args)); + CHECK_SYMBOL (var, 0); - tem = Fcar (args); - CHECK_SYMBOL (tem, 0); + for (val = handlers; ! NILP (val); val = Fcdr (val)) + { + Lisp_Object tem; + tem = Fcar (val); + if (! (NILP (tem) + || (CONSP (tem) + && (SYMBOLP (XCONS (tem)->car) + || CONSP (XCONS (tem)->car))))) + error ("Invalid condition handler", tem); + } c.tag = Qnil; c.val = Qnil; @@ -1001,35 +1075,40 @@ See also the function `signal' for more info.") if (_setjmp (c.jmp)) { if (!NILP (h.var)) - specbind (h.var, Fcdr (c.val)); - val = Fprogn (Fcdr (Fcar (c.val))); + specbind (h.var, c.val); + val = Fprogn (Fcdr (h.chosen_clause)); + + /* Note that this just undoes the binding of h.var; whoever + longjumped to us unwound the stack to c.pdlcount before + throwing. */ unbind_to (c.pdlcount, Qnil); return val; } c.next = catchlist; catchlist = &c; - h.var = Fcar (args); - h.handler = Fcdr (Fcdr (args)); - - for (val = h.handler; ! NILP (val); val = Fcdr (val)) - { - tem = Fcar (val); - if ((!NILP (tem)) && - (!CONSP (tem) || (XTYPE (XCONS (tem)->car) != Lisp_Symbol))) - error ("Invalid condition handler", tem); - } + h.var = var; + h.handler = handlers; h.next = handlerlist; - h.poll_suppress_count = poll_suppress_count; h.tag = &c; handlerlist = &h; - val = Feval (Fcar (Fcdr (args))); + val = Feval (bodyform); catchlist = c.next; handlerlist = h.next; return val; } +/* Call the function BFUN with no arguments, catching errors within it + according to HANDLERS. If there is an error, call HFUN with + one argument which is the data that describes the error: + (SIGNALNAME . DATA) + + HANDLERS can be a list of conditions to catch. + If HANDLERS is Qt, catch all errors. + If HANDLERS is Qerror, catch all errors + but allow the debugger to run if that is enabled. */ + Lisp_Object internal_condition_case (bfun, handlers, hfun) Lisp_Object (*bfun) (); @@ -1040,6 +1119,11 @@ internal_condition_case (bfun, handlers, hfun) struct catchtag c; struct handler h; + /* Since Fsignal resets this to 0, it had better be 0 now + or else we have a potential bug. */ + if (interrupt_input_blocked != 0) + abort (); + c.tag = Qnil; c.val = Qnil; c.backlist = backtrace_list; @@ -1050,13 +1134,12 @@ internal_condition_case (bfun, handlers, hfun) c.gcpro = gcprolist; if (_setjmp (c.jmp)) { - return (*hfun) (Fcdr (c.val)); + return (*hfun) (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; @@ -1067,12 +1150,51 @@ internal_condition_case (bfun, handlers, hfun) return val; } +/* Like internal_condition_case but call HFUN with ARG as its argument. */ + +Lisp_Object +internal_condition_case_1 (bfun, arg, handlers, hfun) + Lisp_Object (*bfun) (); + Lisp_Object arg; + 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) (c.val); + } + c.next = catchlist; + catchlist = &c; + h.handler = handlers; + h.var = Qnil; + h.next = handlerlist; + h.tag = &c; + handlerlist = &h; + + val = (*bfun) (arg); + catchlist = c.next; + handlerlist = h.next; + return val; +} + static Lisp_Object find_handler_clause (); DEFUN ("signal", Fsignal, Ssignal, 2, 2, 0, - "Signal an error. Args are SIGNAL-NAME, and associated DATA.\n\ + "Signal an error. Args are ERROR-SYMBOL and associated DATA.\n\ This function does not return.\n\n\ -A signal name is a symbol with an `error-conditions' property\n\ +An error symbol 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\ @@ -1080,29 +1202,36 @@ The symbol `error' should normally be one of them.\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; + (error_symbol, data) + Lisp_Object error_symbol, data; { register struct handler *allhandlers = handlerlist; Lisp_Object conditions; extern int gc_in_progress; extern int waiting_for_input; Lisp_Object debugger_value; + Lisp_Object string; quit_error_check (); immediate_quit = 0; if (gc_in_progress || waiting_for_input) abort (); +#ifdef HAVE_WINDOW_SYSTEM TOTALLY_UNBLOCK_INPUT; +#endif - conditions = Fget (sig, Qerror_conditions); + /* This hook is used by edebug. */ + if (! NILP (Vsignal_hook_function)) + Ffuncall (Vsignal_hook_function, error_symbol, data); + + conditions = Fget (error_symbol, Qerror_conditions); for (; handlerlist; handlerlist = handlerlist->next) { register Lisp_Object clause; clause = find_handler_clause (handlerlist->handler, conditions, - sig, data, &debugger_value); + error_symbol, 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. */ @@ -1112,29 +1241,43 @@ See also the function `condition-case'.") return debugger_value; #else if (EQ (clause, Qlambda)) - error ("Returning a value from an error is no longer supported"); + { + /* We can't return values to code which signaled an error, but we + can continue code which has signaled a quit. */ + if (EQ (error_symbol, Qquit)) + return Qnil; + else + error ("Cannot return from the debugger in an error"); + } #endif if (!NILP (clause)) { + Lisp_Object unwind_data; 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); + if (EQ (data, memory_signal_data)) + unwind_data = memory_signal_data; + else + unwind_data = Fcons (error_symbol, data); + h->chosen_clause = clause; + unwind_to_catch (h->tag, unwind_data); } } 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); + find_handler_clause (Qerror, conditions, error_symbol, data, &debugger_value); + if (catchlist != 0) + Fthrow (Qtop_level, Qt); + + if (! EQ (data, memory_signal_data)) + data = Fcons (error_symbol, data); + + string = Ferror_message_string (data); + fatal (XSTRING (string)->data, 0, 0); } /* Return nonzero iff LIST is a non-nil atom or @@ -1144,32 +1287,60 @@ static int wants_debugger (list, conditions) Lisp_Object list, conditions; { - static int looking = 0; - - if (looking) - { - /* We got an error while looking in LIST. */ - looking = 0; - return 1; - } - if (NILP (list)) return 0; if (! CONSP (list)) return 1; - looking = 1; - while (!NILP (conditions)) + while (CONSP (conditions)) { - Lisp_Object tem; - tem = Fmemq (XCONS (conditions)->car, list); - if (! NILP (tem)) - { - looking = 0; + Lisp_Object this, tail; + this = XCONS (conditions)->car; + for (tail = list; CONSP (tail); tail = XCONS (tail)->cdr) + if (EQ (XCONS (tail)->car, this)) return 1; - } conditions = XCONS (conditions)->cdr; } + return 0; +} + +/* Return 1 if an error with condition-symbols CONDITIONS, + and described by SIGNAL-DATA, should skip the debugger + according to debugger-ignore-errors. */ + +static int +skip_debugger (conditions, data) + Lisp_Object conditions, data; +{ + Lisp_Object tail; + int first_string = 1; + Lisp_Object error_message; + + for (tail = Vdebug_ignored_errors; CONSP (tail); + tail = XCONS (tail)->cdr) + { + if (STRINGP (XCONS (tail)->car)) + { + if (first_string) + { + error_message = Ferror_message_string (data); + first_string = 0; + } + if (fast_string_match (XCONS (tail)->car, error_message) >= 0) + return 1; + } + else + { + Lisp_Object contail; + + for (contail = conditions; CONSP (contail); + contail = XCONS (contail)->cdr) + if (EQ (XCONS (tail)->car, XCONS (contail)->car)) + return 1; + } + } + + return 0; } /* Value of Qlambda means we have called debugger and user has continued. @@ -1182,36 +1353,67 @@ find_handler_clause (handlers, conditions, sig, data, 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 */ + /* error is used similarly, but means print an error message + and run the debugger if that is enabled. */ + if (EQ (handlers, Qerror) + || !NILP (Vdebug_on_signal)) /* This says call debugger even if + there is a handler. */ { + int count = specpdl_ptr - specpdl; + int debugger_called = 0; + if (wants_debugger (Vstack_trace_on_error, conditions)) internal_with_output_to_temp_buffer ("*Backtrace*", Fbacktrace, Qnil); - if (!entering_debugger - && ((EQ (sig, Qquit) && debug_on_quit) - || wants_debugger (Vdebug_on_error, conditions))) + if ((EQ (sig, Qquit) + ? debug_on_quit + : wants_debugger (Vdebug_on_error, conditions)) + && ! skip_debugger (conditions, Fcons (sig, data)) + && when_entered_debugger < num_nonmacro_input_events) { - 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); + *debugger_value_ptr + = call_debugger (Fcons (Qerror, + Fcons (Fcons (sig, data), + Qnil))); + debugger_called = 1; + } + /* If there is no handler, return saying whether we ran the debugger. */ + if (EQ (handlers, Qerror)) + { + if (debugger_called) + return unbind_to (count, Qlambda); + return Qt; } - return Qt; } for (h = handlers; CONSP (h); h = Fcdr (h)) { - tem1 = Fcar (h); - if (!CONSP (tem1)) + Lisp_Object handler, condit; + + handler = Fcar (h); + if (!CONSP (handler)) continue; - tem = Fmemq (Fcar (tem1), conditions); - if (!NILP (tem)) - return tem1; + condit = Fcar (handler); + /* Handle a single condition name in handler HANDLER. */ + if (SYMBOLP (condit)) + { + tem = Fmemq (Fcar (handler), conditions); + if (!NILP (tem)) + return handler; + } + /* Handle a list of condition names in handler HANDLER. */ + else if (CONSP (condit)) + { + while (CONSP (condit)) + { + tem = Fmemq (Fcar (condit), conditions); + if (!NILP (tem)) + return handler; + condit = XCONS (condit)->cdr; + } + } } return Qnil; } @@ -1222,12 +1424,42 @@ find_handler_clause (handlers, conditions, sig, data, debugger_value_ptr) void error (m, a1, a2, a3) char *m; + char *a1, *a2, *a3; { char buf[200]; - sprintf (buf, m, a1, a2, a3); + int size = 200; + int mlen; + char *buffer = buf; + char *args[3]; + int allocated = 0; + Lisp_Object string; + + args[0] = a1; + args[1] = a2; + args[2] = a3; + + mlen = strlen (m); while (1) - Fsignal (Qerror, Fcons (build_string (buf), Qnil)); + { + int used = doprnt (buf, size, m, m + mlen, 3, args); + if (used < size) + break; + size *= 2; + if (allocated) + buffer = (char *) xrealloc (buffer, size); + else + { + buffer = (char *) xmalloc (size); + allocated = 1; + } + } + + string = build_string (buf); + if (allocated) + free (buffer); + + Fsignal (Qerror, Fcons (string, Qnil)); } DEFUN ("commandp", Fcommandp, Scommandp, 1, 1, 0, @@ -1258,7 +1490,7 @@ Also, a symbol satisfies `commandp' if its function definition does so.") /* Emacs primitives are interactive if their DEFUN specifies an interactive spec. */ - if (XTYPE (fun) == Lisp_Subr) + if (SUBRP (fun)) { if (XSUBR (fun)->prompt) return Qt; @@ -1269,20 +1501,19 @@ Also, a symbol satisfies `commandp' if its function definition does so.") /* 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 + else if (COMPILEDP (fun)) + return ((XVECTOR (fun)->size & PSEUDOVECTOR_SIZE_MASK) > COMPILED_INTERACTIVE ? Qt : Qnil); /* Strings and vectors are keyboard macros. */ - if (XTYPE (fun) == Lisp_String - || XTYPE (fun) == Lisp_Vector) + if (STRINGP (fun) || VECTORP (fun)) return Qt; /* Lists may represent commands. */ if (!CONSP (fun)) return Qnil; funcar = Fcar (fun); - if (XTYPE (funcar) != Lisp_Symbol) + if (!SYMBOLP (funcar)) return Fsignal (Qinvalid_function, Fcons (fun, Qnil)); if (EQ (funcar, Qlambda)) return Fassq (Qinteractive, Fcdr (Fcdr (fun))); @@ -1300,13 +1531,16 @@ DEFUN ("autoload", Fautoload, Sautoload, 2, 5, 0, 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\ +Fifth arg TYPE indicates the type of the object:\n\ + nil or omitted says FUNCTION is a function,\n\ + `keymap' says FUNCTION is really a keymap, and\n\ + `macro' or t says 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; + (function, file, docstring, interactive, type) + Lisp_Object function, file, docstring, interactive, type; { #ifdef NO_ARG_ARRAY Lisp_Object args[4]; @@ -1317,7 +1551,7 @@ this does nothing and returns nil.") /* If function is defined and not as an autoload, don't override */ if (!EQ (XSYMBOL (function)->function, Qunbound) - && !(XTYPE (XSYMBOL (function)->function) == Lisp_Cons + && !(CONSP (XSYMBOL (function)->function) && EQ (XCONS (XSYMBOL (function)->function)->car, Qautoload))) return Qnil; @@ -1325,7 +1559,7 @@ this does nothing and returns nil.") args[0] = file; args[1] = docstring; args[2] = interactive; - args[3] = macro; + args[3] = type; return Ffset (function, Fcons (Qautoload, Flist (4, &args[0]))); #else /* NO_ARG_ARRAY */ @@ -1357,29 +1591,53 @@ un_autoload (oldqueue) return Qnil; } +/* Load an autoloaded function. + FUNNAME is the symbol which is the function's name. + FUNDEF is the autoload definition (a list). */ + do_autoload (fundef, funname) Lisp_Object fundef, funname; { int count = specpdl_ptr - specpdl; - Lisp_Object fun, val; + Lisp_Object fun, val, queue, first, second; + struct gcpro gcpro1, gcpro2, gcpro3; fun = funname; CHECK_SYMBOL (funname, 0); + GCPRO3 (fun, funname, fundef); /* 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); + + /* Save the old autoloads, in case we ever do an unload. */ + queue = Vautoload_queue; + while (CONSP (queue)) + { + first = Fcar (queue); + second = Fcdr (first); + first = Fcar (first); + + /* Note: This test is subtle. The cdr of an autoload-queue entry + may be an atom if the autoload entry was generated by a defalias + or fset. */ + if (CONSP (second)) + Fput (first, Qautoload, (Fcdr (second))); + + queue = Fcdr (queue); + } + /* Once loading finishes, don't undo it. */ Vautoload_queue = Qt; unbind_to (count, Qnil); fun = Findirect_function (fun); - if (XTYPE (fun) == Lisp_Cons - && EQ (XCONS (fun)->car, Qautoload)) + if (!NILP (Fequal (fun, fundef))) error ("Autoloading failed to define function %s", XSYMBOL (funname)->name->data); + UNGCPRO; } DEFUN ("eval", Feval, Seval, 1, 1, 0, @@ -1392,15 +1650,15 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0, struct backtrace backtrace; struct gcpro gcpro1, gcpro2, gcpro3; - if (XTYPE (form) == Lisp_Symbol) + if (SYMBOLP (form)) { if (EQ (Vmocklisp_arguments, Qt)) return Fsymbol_value (form); val = Fsymbol_value (form); if (NILP (val)) - XFASTINT (val) = 0; + XSETFASTINT (val, 0); else if (EQ (val, Qt)) - XFASTINT (val) = 1; + XSETFASTINT (val, 1); return val; } if (!CONSP (form)) @@ -1441,7 +1699,7 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0, retry: fun = Findirect_function (original_fun); - if (XTYPE (fun) == Lisp_Subr) + if (SUBRP (fun)) { Lisp_Object numargs; Lisp_Object argvals[7]; @@ -1532,6 +1790,11 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0, val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2], argvals[3], argvals[4], argvals[5]); goto done; + case 7: + val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2], + argvals[3], argvals[4], argvals[5], + argvals[6]); + goto done; default: /* Someone has created a subr that takes more arguments than @@ -1541,14 +1804,14 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0, abort (); } } - if (XTYPE (fun) == Lisp_Compiled) + if (COMPILEDP (fun)) 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) + if (!SYMBOLP (funcar)) return Fsignal (Qinvalid_function, Fcons (fun, Qnil)); if (EQ (funcar, Qautoload)) { @@ -1568,9 +1831,9 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0, if (!EQ (Vmocklisp_arguments, Qt)) { if (NILP (val)) - XFASTINT (val) = 0; + XSETFASTINT (val, 0); else if (EQ (val, Qt)) - XFASTINT (val) = 1; + XSETFASTINT (val, 1); } lisp_eval_depth--; if (backtrace.debug_on_exit) @@ -1581,6 +1844,7 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0, DEFUN ("apply", Fapply, Sapply, 2, MANY, 0, "Call FUNCTION with our remaining args, using our last arg as list of args.\n\ +Then return the value FUNCTION returns.\n\ Thus, (apply '+ 1 2 '(3 4)) returns 10.") (nargs, args) int nargs; @@ -1617,7 +1881,7 @@ Thus, (apply '+ 1 2 '(3 4)) returns 10.") goto funcall; } - if (XTYPE (fun) == Lisp_Subr) + if (SUBRP (fun)) { if (numargs < XSUBR (fun)->min_args || (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs)) @@ -1658,6 +1922,231 @@ Thus, (apply '+ 1 2 '(3 4)) returns 10.") RETURN_UNGCPRO (Ffuncall (gcpro1.nvars, funcall_args)); } +/* Run hook variables in various ways. */ + +enum run_hooks_condition {to_completion, until_success, until_failure}; + +DEFUN ("run-hooks", Frun_hooks, Srun_hooks, 1, MANY, 0, + "Run each hook in HOOKS. Major mode functions use this.\n\ +Each argument should be a symbol, a hook variable.\n\ +These symbols are processed in the order specified.\n\ +If a hook symbol has a non-nil value, that value may be a function\n\ +or a list of functions to be called to run the hook.\n\ +If the value is a function, it is called with no arguments.\n\ +If it is a list, the elements are called, in order, with no arguments.\n\ +\n\ +To make a hook variable buffer-local, use `make-local-hook',\n\ +not `make-local-variable'.") + (nargs, args) + int nargs; + Lisp_Object *args; +{ + Lisp_Object hook[1]; + register int i; + + for (i = 0; i < nargs; i++) + { + hook[0] = args[i]; + run_hook_with_args (1, hook, to_completion); + } + + return Qnil; +} + +DEFUN ("run-hook-with-args", Frun_hook_with_args, + Srun_hook_with_args, 1, MANY, 0, + "Run HOOK with the specified arguments ARGS.\n\ +HOOK should be a symbol, a hook variable. If HOOK has a non-nil\n\ +value, that value may be a function or a list of functions to be\n\ +called to run the hook. If the value is a function, it is called with\n\ +the given arguments and its return value is returned. If it is a list\n\ +of functions, those functions are called, in order,\n\ +with the given arguments ARGS.\n\ +It is best not to depend on the value return by `run-hook-with-args',\n\ +as that may change.\n\ +\n\ +To make a hook variable buffer-local, use `make-local-hook',\n\ +not `make-local-variable'.") + (nargs, args) + int nargs; + Lisp_Object *args; +{ + return run_hook_with_args (nargs, args, to_completion); +} + +DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success, + Srun_hook_with_args_until_success, 1, MANY, 0, + "Run HOOK with the specified arguments ARGS.\n\ +HOOK should be a symbol, a hook variable. Its value should\n\ +be a list of functions. We call those functions, one by one,\n\ +passing arguments ARGS to each of them, until one of them\n\ +returns a non-nil value. Then we return that value.\n\ +If all the functions return nil, we return nil.\n\ +\n\ +To make a hook variable buffer-local, use `make-local-hook',\n\ +not `make-local-variable'.") + (nargs, args) + int nargs; + Lisp_Object *args; +{ + return run_hook_with_args (nargs, args, until_success); +} + +DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure, + Srun_hook_with_args_until_failure, 1, MANY, 0, + "Run HOOK with the specified arguments ARGS.\n\ +HOOK should be a symbol, a hook variable. Its value should\n\ +be a list of functions. We call those functions, one by one,\n\ +passing arguments ARGS to each of them, until one of them\n\ +returns nil. Then we return nil.\n\ +If all the functions return non-nil, we return non-nil.\n\ +\n\ +To make a hook variable buffer-local, use `make-local-hook',\n\ +not `make-local-variable'.") + (nargs, args) + int nargs; + Lisp_Object *args; +{ + return run_hook_with_args (nargs, args, until_failure); +} + +/* ARGS[0] should be a hook symbol. + Call each of the functions in the hook value, passing each of them + as arguments all the rest of ARGS (all NARGS - 1 elements). + COND specifies a condition to test after each call + to decide whether to stop. + The caller (or its caller, etc) must gcpro all of ARGS, + except that it isn't necessary to gcpro ARGS[0]. */ + +Lisp_Object +run_hook_with_args (nargs, args, cond) + int nargs; + Lisp_Object *args; + enum run_hooks_condition cond; +{ + Lisp_Object sym, val, ret; + struct gcpro gcpro1, gcpro2; + + /* If we are dying or still initializing, + don't do anything--it would probably crash if we tried. */ + if (NILP (Vrun_hooks)) + return; + + sym = args[0]; + val = find_symbol_value (sym); + ret = (cond == until_failure ? Qt : Qnil); + + if (EQ (val, Qunbound) || NILP (val)) + return ret; + else if (!CONSP (val) || EQ (XCONS (val)->car, Qlambda)) + { + args[0] = val; + return Ffuncall (nargs, args); + } + else + { + GCPRO2 (sym, val); + + for (; + CONSP (val) && ((cond == to_completion) + || (cond == until_success ? NILP (ret) + : !NILP (ret))); + val = XCONS (val)->cdr) + { + if (EQ (XCONS (val)->car, Qt)) + { + /* t indicates this hook has a local binding; + it means to run the global binding too. */ + Lisp_Object globals; + + for (globals = Fdefault_value (sym); + CONSP (globals) && ((cond == to_completion) + || (cond == until_success ? NILP (ret) + : !NILP (ret))); + globals = XCONS (globals)->cdr) + { + args[0] = XCONS (globals)->car; + /* In a global value, t should not occur. If it does, we + must ignore it to avoid an endless loop. */ + if (!EQ (args[0], Qt)) + ret = Ffuncall (nargs, args); + } + } + else + { + args[0] = XCONS (val)->car; + ret = Ffuncall (nargs, args); + } + } + + UNGCPRO; + return ret; + } +} + +/* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual + present value of that symbol. + Call each element of FUNLIST, + passing each of them the rest of ARGS. + The caller (or its caller, etc) must gcpro all of ARGS, + except that it isn't necessary to gcpro ARGS[0]. */ + +Lisp_Object +run_hook_list_with_args (funlist, nargs, args) + Lisp_Object funlist; + int nargs; + Lisp_Object *args; +{ + Lisp_Object sym; + Lisp_Object val; + struct gcpro gcpro1, gcpro2; + + sym = args[0]; + GCPRO2 (sym, val); + + for (val = funlist; CONSP (val); val = XCONS (val)->cdr) + { + if (EQ (XCONS (val)->car, Qt)) + { + /* t indicates this hook has a local binding; + it means to run the global binding too. */ + Lisp_Object globals; + + for (globals = Fdefault_value (sym); + CONSP (globals); + globals = XCONS (globals)->cdr) + { + args[0] = XCONS (globals)->car; + /* In a global value, t should not occur. If it does, we + must ignore it to avoid an endless loop. */ + if (!EQ (args[0], Qt)) + Ffuncall (nargs, args); + } + } + else + { + args[0] = XCONS (val)->car; + Ffuncall (nargs, args); + } + } + UNGCPRO; + return Qnil; +} + +/* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */ + +void +run_hook_with_args_2 (hook, arg1, arg2) + Lisp_Object hook, arg1, arg2; +{ + Lisp_Object temp[3]; + temp[0] = hook; + temp[1] = arg1; + temp[2] = arg2; + + Frun_hook_with_args (3, temp); +} + /* Apply fn to arg */ Lisp_Object apply1 (fn, arg) @@ -1693,18 +2182,18 @@ call0 (fn) RETURN_UNGCPRO (Ffuncall (1, &fn)); } -/* Call function fn with argument arg */ +/* Call function fn with 1 argument arg1 */ /* ARGSUSED */ Lisp_Object -call1 (fn, arg) - Lisp_Object fn, arg; +call1 (fn, arg1) + Lisp_Object fn, arg1; { struct gcpro gcpro1; #ifdef NO_ARG_ARRAY Lisp_Object args[2]; args[0] = fn; - args[1] = arg; + args[1] = arg1; GCPRO1 (args[0]); gcpro1.nvars = 2; RETURN_UNGCPRO (Ffuncall (2, args)); @@ -1715,18 +2204,18 @@ call1 (fn, arg) #endif /* not NO_ARG_ARRAY */ } -/* Call function fn with arguments arg, arg1 */ +/* Call function fn with 2 arguments arg1, arg2 */ /* ARGSUSED */ Lisp_Object -call2 (fn, arg, arg1) - Lisp_Object fn, arg, arg1; +call2 (fn, arg1, arg2) + Lisp_Object fn, arg1, arg2; { struct gcpro gcpro1; #ifdef NO_ARG_ARRAY Lisp_Object args[3]; args[0] = fn; - args[1] = arg; - args[2] = arg1; + args[1] = arg1; + args[2] = arg2; GCPRO1 (args[0]); gcpro1.nvars = 3; RETURN_UNGCPRO (Ffuncall (3, args)); @@ -1737,19 +2226,19 @@ call2 (fn, arg, arg1) #endif /* not NO_ARG_ARRAY */ } -/* Call function fn with arguments arg, arg1, arg2 */ +/* Call function fn with 3 arguments arg1, arg2, arg3 */ /* ARGSUSED */ Lisp_Object -call3 (fn, arg, arg1, arg2) - Lisp_Object fn, arg, arg1, arg2; +call3 (fn, arg1, arg2, arg3) + Lisp_Object fn, arg1, arg2, arg3; { struct gcpro gcpro1; #ifdef NO_ARG_ARRAY Lisp_Object args[4]; args[0] = fn; - args[1] = arg; - args[2] = arg1; - args[3] = arg2; + args[1] = arg1; + args[2] = arg2; + args[3] = arg3; GCPRO1 (args[0]); gcpro1.nvars = 4; RETURN_UNGCPRO (Ffuncall (4, args)); @@ -1760,8 +2249,84 @@ call3 (fn, arg, arg1, arg2) #endif /* not NO_ARG_ARRAY */ } +/* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */ +/* ARGSUSED */ +Lisp_Object +call4 (fn, arg1, arg2, arg3, arg4) + Lisp_Object fn, arg1, arg2, arg3, arg4; +{ + struct gcpro gcpro1; +#ifdef NO_ARG_ARRAY + Lisp_Object args[5]; + args[0] = fn; + args[1] = arg1; + args[2] = arg2; + args[3] = arg3; + args[4] = arg4; + GCPRO1 (args[0]); + gcpro1.nvars = 5; + RETURN_UNGCPRO (Ffuncall (5, args)); +#else /* not NO_ARG_ARRAY */ + GCPRO1 (fn); + gcpro1.nvars = 5; + RETURN_UNGCPRO (Ffuncall (5, &fn)); +#endif /* not NO_ARG_ARRAY */ +} + +/* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */ +/* ARGSUSED */ +Lisp_Object +call5 (fn, arg1, arg2, arg3, arg4, arg5) + Lisp_Object fn, arg1, arg2, arg3, arg4, arg5; +{ + struct gcpro gcpro1; +#ifdef NO_ARG_ARRAY + Lisp_Object args[6]; + args[0] = fn; + args[1] = arg1; + args[2] = arg2; + args[3] = arg3; + args[4] = arg4; + args[5] = arg5; + GCPRO1 (args[0]); + gcpro1.nvars = 6; + RETURN_UNGCPRO (Ffuncall (6, args)); +#else /* not NO_ARG_ARRAY */ + GCPRO1 (fn); + gcpro1.nvars = 6; + RETURN_UNGCPRO (Ffuncall (6, &fn)); +#endif /* not NO_ARG_ARRAY */ +} + +/* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */ +/* ARGSUSED */ +Lisp_Object +call6 (fn, arg1, arg2, arg3, arg4, arg5, arg6) + Lisp_Object fn, arg1, arg2, arg3, arg4, arg5, arg6; +{ + struct gcpro gcpro1; +#ifdef NO_ARG_ARRAY + Lisp_Object args[7]; + args[0] = fn; + args[1] = arg1; + args[2] = arg2; + args[3] = arg3; + args[4] = arg4; + args[5] = arg5; + args[6] = arg6; + GCPRO1 (args[0]); + gcpro1.nvars = 7; + RETURN_UNGCPRO (Ffuncall (7, args)); +#else /* not NO_ARG_ARRAY */ + GCPRO1 (fn); + gcpro1.nvars = 7; + RETURN_UNGCPRO (Ffuncall (7, &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\ +Return the value that function returns.\n\ Thus, (funcall 'cons 'x 'y) returns (x . y).") (nargs, args) int nargs; @@ -1805,12 +2370,12 @@ Thus, (funcall 'cons 'x 'y) returns (x . y).") fun = Findirect_function (fun); - if (XTYPE (fun) == Lisp_Subr) + if (SUBRP (fun)) { if (numargs < XSUBR (fun)->min_args || (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs)) { - XFASTINT (lisp_numargs) = numargs; + XSETFASTINT (lisp_numargs, numargs); return Fsignal (Qwrong_number_of_arguments, Fcons (fun, Fcons (lisp_numargs, Qnil))); } @@ -1863,6 +2428,12 @@ Thus, (funcall 'cons 'x 'y) returns (x . y).") internal_args[2], internal_args[3], internal_args[4], internal_args[5]); goto done; + case 7: + val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1], + internal_args[2], internal_args[3], + internal_args[4], internal_args[5], + internal_args[6]); + goto done; default: @@ -1872,14 +2443,14 @@ Thus, (funcall 'cons 'x 'y) returns (x . y).") abort (); } } - if (XTYPE (fun) == Lisp_Compiled) + if (COMPILEDP (fun)) 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) + if (!SYMBOLP (funcar)) return Fsignal (Qinvalid_function, Fcons (fun, Qnil)); if (EQ (funcar, Qlambda)) val = funcall_lambda (fun, numargs, args + 1); @@ -1966,11 +2537,11 @@ funcall_lambda (fun, nargs, arg_vector) specbind (Qmocklisp_arguments, Qt); /* t means NOT mocklisp! */ - XFASTINT (numargs) = nargs; + XSETFASTINT (numargs, nargs); - if (XTYPE (fun) == Lisp_Cons) + if (CONSP (fun)) syms_left = Fcar (Fcdr (fun)); - else if (XTYPE (fun) == Lisp_Compiled) + else if (COMPILEDP (fun)) syms_left = XVECTOR (fun)->contents[COMPILED_ARGLIST]; else abort (); @@ -1979,7 +2550,7 @@ funcall_lambda (fun, nargs, arg_vector) { QUIT; next = Fcar (syms_left); - while (XTYPE (next) != Lisp_Symbol) + while (!SYMBOLP (next)) next = Fsignal (Qinvalid_function, Fcons (fun, Qnil)); if (EQ (next, Qand_rest)) rest = 1; @@ -2004,14 +2575,40 @@ funcall_lambda (fun, nargs, arg_vector) if (i < nargs) return Fsignal (Qwrong_number_of_arguments, Fcons (fun, Fcons (numargs, Qnil))); - if (XTYPE (fun) == Lisp_Cons) + if (CONSP (fun)) 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]); + { + /* If we have not actually read the bytecode string + and constants vector yet, fetch them from the file. */ + if (CONSP (XVECTOR (fun)->contents[COMPILED_BYTECODE])) + Ffetch_bytecode (fun); + val = Fbyte_code (XVECTOR (fun)->contents[COMPILED_BYTECODE], + XVECTOR (fun)->contents[COMPILED_CONSTANTS], + XVECTOR (fun)->contents[COMPILED_STACK_DEPTH]); + } return unbind_to (count, val); } + +DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode, + 1, 1, 0, + "If byte-compiled OBJECT is lazy-loaded, fetch it now.") + (object) + Lisp_Object object; +{ + Lisp_Object tem; + + if (COMPILEDP (object) + && CONSP (XVECTOR (object)->contents[COMPILED_BYTECODE])) + { + tem = read_doc_string (XVECTOR (object)->contents[COMPILED_BYTECODE]); + if (!CONSP (tem)) + error ("invalid byte code"); + XVECTOR (object)->contents[COMPILED_BYTECODE] = XCONS (tem)->car; + XVECTOR (object)->contents[COMPILED_CONSTANTS] = XCONS (tem)->cdr; + } + return object; +} void grow_specpdl () @@ -2023,9 +2620,11 @@ grow_specpdl () max_specpdl_size = 400; if (specpdl_size >= max_specpdl_size) { + if (!NILP (Vdebug_on_error)) + /* Leave room for some specpdl in the debugger. */ + max_specpdl_size = specpdl_size + 100; Fsignal (Qerror, Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil)); - max_specpdl_size *= 2; } } specpdl_size *= 2; @@ -2039,7 +2638,6 @@ void specbind (symbol, value) Lisp_Object symbol, value; { - extern void store_symval_forwarding (); /* in eval.c */ Lisp_Object ovalue; CHECK_SYMBOL (symbol, 0); @@ -2048,13 +2646,12 @@ specbind (symbol, value) 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->old_value = ovalue = find_symbol_value (symbol); specpdl_ptr++; - if (XTYPE (ovalue) == Lisp_Buffer_Objfwd) + if (BUFFER_OBJFWDP (ovalue) || KBOARD_OBJFWDP (ovalue)) store_symval_forwarding (symbol, ovalue, value); else - Fset (symbol, value); + set_internal (symbol, value, 1); } void @@ -2092,7 +2689,7 @@ unbind_to (count, value) else if (NILP (specpdl_ptr->symbol)) Fprogn (specpdl_ptr->old_value); else - Fset (specpdl_ptr->symbol, specpdl_ptr->old_value); + set_internal (specpdl_ptr->symbol, specpdl_ptr->old_value, 1); } if (NILP (Vquit_flag) && quitf) Vquit_flag = Qt; @@ -2175,9 +2772,7 @@ Output stream used is value of `standard-output'.") extern Lisp_Object Vprint_level; struct gcpro gcpro1; - entering_debugger = 0; - - XFASTINT (Vprint_level) = 3; + XSETFASTINT (Vprint_level, 3); tail = Qnil; GCPRO1 (tail); @@ -2188,6 +2783,7 @@ Output stream used is value of `standard-output'.") if (backlist->nargs == UNEVALLED) { Fprin1 (Fcons (*backlist->function, *backlist->args), Qnil); + write_string ("\n", -1); } else { @@ -2212,8 +2808,8 @@ Output stream used is value of `standard-output'.") Fprin1 (backlist->args[i], Qnil); } } + write_string (")\n", -1); } - write_string (")\n", -1); backlist = backlist->next; } @@ -2223,7 +2819,7 @@ Output stream used is value of `standard-output'.") } DEFUN ("backtrace-frame", Fbacktrace_frame, Sbacktrace_frame, 1, 1, "", - "Return the function and arguments N frames up from current execution point.\n\ + "Return the function and arguments NFRAMES 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\ @@ -2231,7 +2827,7 @@ 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.") +If NFRAMES is more than the number of frames, the value is nil.") (nframes) Lisp_Object nframes; { @@ -2242,7 +2838,7 @@ If N is more than the number of frames, the value is nil.") CHECK_NATNUM (nframes, 0); /* Find the frame requested. */ - for (i = 0; i < XFASTINT (nframes); i++) + for (i = 0; backlist && i < XFASTINT (nframes); i++) backlist = backlist->next; if (!backlist) @@ -2274,13 +2870,13 @@ 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'."); +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\ +so a quit will be signaled 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; @@ -2332,10 +2928,18 @@ if one of its condition symbols appears in the list.\n\ See also variable `debug-on-quit'."); Vdebug_on_error = Qnil; + DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors, + "*List of errors for which the debugger should not be called.\n\ +Each element may be a condition-name or a regexp that matches error messages.\n\ +If any element applies to a given error, that error skips the debugger\n\ +and just returns to top level.\n\ +This overrides the variable `debug-on-error'.\n\ +It does not apply to errors handled by `condition-case'."); + Vdebug_ignored_errors = Qnil; + 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'.\n\ -A non-nil value is equivalent to a `debug-on-error' value containing `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, @@ -2350,16 +2954,26 @@ If due to `apply' or `funcall' entry, one arg, `lambda'.\n\ If due to `eval' entry, one arg, t."); Vdebugger = Qnil; + DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function, + "If non-nil, this is a function for `signal' to call.\n\ +It receives the same arguments that `signal' was given.\n\ +The Edebug package uses this to regain control."); + Vsignal_hook_function = 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; + DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal, + "*Non-nil means call the debugger regardless of condition handlers.\n\ +Note that `debug-on-error', `debug-on-quit' and friends\n\ +still determine whether to handle the particular condition."); + Vdebug_on_signal = Qnil; + + Vrun_hooks = intern ("run-hooks"); + staticpro (&Vrun_hooks); staticpro (&Vautoload_queue); Vautoload_queue = Qnil; @@ -2394,6 +3008,11 @@ Otherwise, nil (in a bare Emacs without preloaded Lisp code)."); defsubr (&Seval); defsubr (&Sapply); defsubr (&Sfuncall); + defsubr (&Srun_hooks); + defsubr (&Srun_hook_with_args); + defsubr (&Srun_hook_with_args_until_success); + defsubr (&Srun_hook_with_args_until_failure); + defsubr (&Sfetch_bytecode); defsubr (&Sbacktrace_debug); defsubr (&Sbacktrace); defsubr (&Sbacktrace_frame);