X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/9125da08de041b85d03a24c78be43e29eee9b128..be857679f65f098614295fd511978c6d1a318b1e:/src/eval.c diff --git a/src/eval.c b/src/eval.c index ea608d35a7..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, 1993 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,7 +15,8 @@ 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 @@ -89,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 @@ -127,13 +131,23 @@ 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; -/* The value of num_nonmacro_input_chars as of the last time we +/* 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_chars, then we + 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. */ @@ -143,15 +157,20 @@ 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 () @@ -163,7 +182,8 @@ init_eval () Vquit_flag = Qnil; debug_on_next_call = 0; lisp_eval_depth = 0; - when_entered_debugger = 0; + /* This is less than the initial value of num_nonmacro_input_events. */ + when_entered_debugger = -1; } Lisp_Object @@ -175,7 +195,7 @@ call_debugger (arg) if (specpdl_size + 40 > max_specpdl_size) max_specpdl_size = specpdl_size + 40; debug_on_next_call = 0; - when_entered_debugger = num_nonmacro_input_chars; + when_entered_debugger = num_nonmacro_input_events; return apply1 (Vdebugger, arg); } @@ -319,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); @@ -377,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) @@ -390,7 +410,7 @@ whose values are discarded.") val = Qnil; - if (NILP(args)) + if (NILP (args)) return Qnil; args_left = args; @@ -405,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; @@ -413,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; { @@ -477,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 @@ -500,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. */ @@ -565,19 +588,23 @@ 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); @@ -606,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)) @@ -622,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; } @@ -657,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, @@ -705,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, @@ -722,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); @@ -764,9 +803,9 @@ 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; @@ -775,18 +814,18 @@ definitions to shadow the loaded ones for use in file byte-compilation.") { /* Come back here each time we expand a macro call, in case it expands into another macro call. */ - if (XTYPE (form) != Lisp_Cons) + 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 (XTYPE (def) == Lisp_Symbol) + while (SYMBOLP (def)) { QUIT; sym = def; - tem = Fassq (sym, env); + tem = Fassq (sym, environment); if (NILP (tem)) { def = XSYMBOL (sym)->function; @@ -795,14 +834,13 @@ definitions to shadow the loaded ones for use in file byte-compilation.") } 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)) @@ -812,7 +850,10 @@ definitions to shadow the loaded ones for use in file byte-compilation.") 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 @@ -936,8 +977,8 @@ unwind_to_catch (catch, value) 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; @@ -947,9 +988,9 @@ Both TAG and VALUE are evalled.") for (c = catchlist; c; c = c->next) { if (EQ (c->tag, tag)) - unwind_to_catch (c, val); + unwind_to_catch (c, value); } - tag = Fsignal (Qno_catch, Fcons (tag, Fcons (val, Qnil))); + tag = Fsignal (Qno_catch, Fcons (tag, Fcons (value, Qnil))); } } @@ -1058,6 +1099,16 @@ See also the function `signal' for more info.") 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) (); @@ -1068,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; @@ -1094,6 +1150,8 @@ 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) (); @@ -1152,16 +1210,21 @@ See also the function `condition-case'.") 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_X_WINDOWS +#ifdef HAVE_WINDOW_SYSTEM TOTALLY_UNBLOCK_INPUT; #endif + /* 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) @@ -1179,8 +1242,8 @@ See also the function `condition-case'.") #else if (EQ (clause, Qlambda)) { - /* We can't return values to code which signalled an error, but we - can continue code which has signalled a quit. */ + /* 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 @@ -1194,7 +1257,7 @@ See also the function `condition-case'.") struct handler *h = handlerlist; handlerlist = allhandlers; - if (data == memory_signal_data) + if (EQ (data, memory_signal_data)) unwind_data = memory_signal_data; else unwind_data = Fcons (error_symbol, data); @@ -1207,7 +1270,14 @@ See also the function `condition-case'.") /* If no handler is present now, try to run the debugger, and if that fails, throw to top level. */ find_handler_clause (Qerror, conditions, error_symbol, data, &debugger_value); - Fthrow (Qtop_level, Qt); + 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 @@ -1234,6 +1304,45 @@ wants_debugger (list, conditions) 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. Store value returned from debugger into *DEBUGGER_VALUE_PTR. */ @@ -1247,24 +1356,37 @@ find_handler_clause (handlers, conditions, sig, data, debugger_value_ptr) 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 ((EQ (sig, Qquit) ? debug_on_quit : wants_debugger (Vdebug_on_error, conditions)) - && when_entered_debugger < num_nonmacro_input_chars) + && ! 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)) { @@ -1326,7 +1448,11 @@ error (m, a1, a2, a3) size *= 2; if (allocated) buffer = (char *) xrealloc (buffer, size); - buffer = (char *) xmalloc (size); + else + { + buffer = (char *) xmalloc (size); + allocated = 1; + } } string = build_string (buf); @@ -1364,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; @@ -1375,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))); @@ -1426,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; @@ -1466,14 +1591,20 @@ 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, 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); @@ -1506,6 +1637,7 @@ do_autoload (fundef, funname) if (!NILP (Fequal (fun, fundef))) error ("Autoloading failed to define function %s", XSYMBOL (funname)->name->data); + UNGCPRO; } DEFUN ("eval", Feval, Seval, 1, 1, 0, @@ -1518,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)) @@ -1567,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]; @@ -1672,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)) { @@ -1699,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) @@ -1712,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; @@ -1748,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)) @@ -1789,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) @@ -1968,6 +2326,7 @@ call6 (fn, arg1, arg2, arg3, arg4, arg5, arg6) 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; @@ -2011,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))); } @@ -2084,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); @@ -2178,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 (); @@ -2191,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; @@ -2216,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 () @@ -2253,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); @@ -2262,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 @@ -2306,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; @@ -2389,7 +2772,7 @@ Output stream used is value of `standard-output'.") extern Lisp_Object Vprint_level; struct gcpro gcpro1; - XFASTINT (Vprint_level) = 3; + XSETFASTINT (Vprint_level, 3); tail = Qnil; GCPRO1 (tail); @@ -2400,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 { @@ -2424,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; } @@ -2435,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\ @@ -2443,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; { @@ -2454,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) @@ -2486,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; @@ -2544,8 +2928,17 @@ 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\ + "*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; @@ -2561,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; @@ -2605,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);