diff options
Diffstat (limited to 'src/eval.c')
| -rw-r--r-- | src/eval.c | 190 |
1 files changed, 111 insertions, 79 deletions
diff --git a/src/eval.c b/src/eval.c index 2a5b631f1c9..fbb3a7aad34 100644 --- a/src/eval.c +++ b/src/eval.c @@ -203,6 +203,8 @@ Lisp_Object Vmacro_declaration_function; extern Lisp_Object Qrisky_local_variable; +extern Lisp_Object Qfunction; + static Lisp_Object funcall_lambda P_ ((Lisp_Object, int, Lisp_Object*)); static void unwind_to_catch P_ ((struct catchtag *, Lisp_Object)) NO_RETURN; @@ -540,7 +542,7 @@ usage: (setq [SYM VAL]...) */) register Lisp_Object val, sym; struct gcpro gcpro1; - if (NILP(args)) + if (NILP (args)) return Qnil; args_left = args; @@ -565,6 +567,8 @@ usage: (quote ARG) */) (args) Lisp_Object args; { + if (!NILP (Fcdr (args))) + xsignal2 (Qwrong_number_of_arguments, Qquote, Flength (args)); return Fcar (args); } @@ -576,6 +580,8 @@ usage: (function ARG) */) (args) Lisp_Object args; { + if (!NILP (Fcdr (args))) + xsignal2 (Qwrong_number_of_arguments, Qfunction, Flength (args)); return Fcar (args); } @@ -1038,10 +1044,10 @@ usage: (let VARLIST BODY...) */) GCPRO2 (args, *temps); gcpro2.nvars = 0; - for (argnum = 0; !NILP (varlist); varlist = Fcdr (varlist)) + for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist)) { QUIT; - elt = Fcar (varlist); + elt = XCAR (varlist); if (SYMBOLP (elt)) temps [argnum++] = Qnil; else if (! NILP (Fcdr (Fcdr (elt)))) @@ -1053,9 +1059,9 @@ usage: (let VARLIST BODY...) */) UNGCPRO; varlist = Fcar (args); - for (argnum = 0; !NILP (varlist); varlist = Fcdr (varlist)) + for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist)) { - elt = Fcar (varlist); + elt = XCAR (varlist); tem = temps[argnum++]; if (SYMBOLP (elt)) specbind (elt, tem); @@ -1275,8 +1281,12 @@ unwind_to_catch (catch, value) #if HAVE_X_WINDOWS /* If x_catch_errors was done, turn it off now. (First we give unbind_to a chance to do that.) */ +#if 0 /* This would disable x_catch_errors after x_connection_closed. + * The catch must remain in effect during that delicate + * state. --lorentey */ x_fully_uncatch_errors (); #endif +#endif byte_stack_list = catch->byte_stack; gcprolist = catch->gcpro; @@ -1588,8 +1598,7 @@ internal_condition_case_2 (bfun, nargs, args, handlers, hfun) static Lisp_Object find_handler_clause P_ ((Lisp_Object, Lisp_Object, - Lisp_Object, Lisp_Object, - Lisp_Object *)); + Lisp_Object, Lisp_Object)); DEFUN ("signal", Fsignal, Ssignal, 2, 2, 0, doc: /* Signal an error. Args are ERROR-SYMBOL and associated DATA. @@ -1615,7 +1624,6 @@ See also the function `condition-case'. */) Lisp_Object conditions; extern int gc_in_progress; extern int waiting_for_input; - Lisp_Object debugger_value; Lisp_Object string; Lisp_Object real_error_symbol; struct backtrace *bp; @@ -1673,7 +1681,7 @@ See also the function `condition-case'. */) register Lisp_Object clause; clause = find_handler_clause (handlerlist->handler, conditions, - error_symbol, data, &debugger_value); + error_symbol, data); if (EQ (clause, Qlambda)) { @@ -1704,7 +1712,7 @@ See also the function `condition-case'. */) 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, error_symbol, data, &debugger_value); + find_handler_clause (Qerror, conditions, error_symbol, data); if (catchlist != 0) Fthrow (Qtop_level, Qt); @@ -1856,75 +1864,54 @@ skip_debugger (conditions, data) = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA). This is for memory-full errors only. - Store value returned from debugger into *DEBUGGER_VALUE_PTR. - We need to increase max_specpdl_size temporarily around anything we do that can push on the specpdl, so as not to get a second error here in case we're handling specpdl overflow. */ static Lisp_Object -find_handler_clause (handlers, conditions, sig, data, debugger_value_ptr) +find_handler_clause (handlers, conditions, sig, data) Lisp_Object handlers, conditions, sig, data; - Lisp_Object *debugger_value_ptr; { register Lisp_Object h; register Lisp_Object tem; + int debugger_called = 0; + int debugger_considered = 0; - if (EQ (handlers, Qt)) /* t is used by handlers for all conditions, set up by C code. */ + /* t is used by handlers for all conditions, set up by C code. */ + if (EQ (handlers, Qt)) return Qt; + + /* Don't run the debugger for a memory-full error. + (There is no room in memory to do that!) */ + if (NILP (sig)) + debugger_considered = 1; + /* 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 debugger_called = 0; - Lisp_Object sig_symbol, combined_data; - /* This is set to 1 if we are handling a memory-full error, - because these must not run the debugger. - (There is no room in memory to do that!) */ - int no_debugger = 0; - - if (NILP (sig)) - { - combined_data = data; - sig_symbol = Fcar (data); - no_debugger = 1; - } - else - { - combined_data = Fcons (sig, data); - sig_symbol = sig; - } - - if (wants_debugger (Vstack_trace_on_error, conditions)) + if (!NILP (sig) && wants_debugger (Vstack_trace_on_error, conditions)) { max_specpdl_size++; -#ifdef PROTOTYPES + #ifdef PROTOTYPES internal_with_output_to_temp_buffer ("*Backtrace*", (Lisp_Object (*) (Lisp_Object)) Fbacktrace, Qnil); -#else + #else internal_with_output_to_temp_buffer ("*Backtrace*", Fbacktrace, Qnil); -#endif + #endif max_specpdl_size--; } - if (! no_debugger - /* Don't try to run the debugger with interrupts blocked. - The editing loop would return anyway. */ - && ! INPUT_BLOCKED_P - && (EQ (sig_symbol, Qquit) - ? debug_on_quit - : wants_debugger (Vdebug_on_error, conditions)) - && ! skip_debugger (conditions, combined_data) - && when_entered_debugger < num_nonmacro_input_events) + + if (!debugger_considered) { - *debugger_value_ptr - = call_debugger (Fcons (Qerror, - Fcons (combined_data, Qnil))); - debugger_called = 1; + debugger_considered = 1; + debugger_called = maybe_call_debugger (conditions, sig, data); } + /* If there is no handler, return saying whether we ran the debugger. */ if (EQ (handlers, Qerror)) { @@ -1933,6 +1920,7 @@ find_handler_clause (handlers, conditions, sig, data, debugger_value_ptr) return Qt; } } + for (h = handlers; CONSP (h); h = Fcdr (h)) { Lisp_Object handler, condit; @@ -1951,18 +1939,55 @@ find_handler_clause (handlers, conditions, sig, data, debugger_value_ptr) /* Handle a list of condition names in handler HANDLER. */ else if (CONSP (condit)) { - while (CONSP (condit)) + Lisp_Object tail; + for (tail = condit; CONSP (tail); tail = XCDR (tail)) { - tem = Fmemq (Fcar (condit), conditions); + tem = Fmemq (Fcar (tail), conditions); if (!NILP (tem)) - return handler; - condit = XCDR (condit); + { + /* This handler is going to apply. + Does it allow the debugger to run first? */ + if (! debugger_considered && !NILP (Fmemq (Qdebug, condit))) + maybe_call_debugger (conditions, sig, data); + return handler; + } } } } + return Qnil; } +/* Call the debugger if calling it is currently enabled for CONDITIONS. + SIG and DATA describe the signal, as in find_handler_clause. */ + +int +maybe_call_debugger (conditions, sig, data) + Lisp_Object conditions, sig, data; +{ + Lisp_Object combined_data; + + combined_data = Fcons (sig, data); + + if ( + /* Don't try to run the debugger with interrupts blocked. + The editing loop would return anyway. */ + ! INPUT_BLOCKED_P + /* Does user wants to enter debugger for this kind of error? */ + && (EQ (sig, Qquit) + ? debug_on_quit + : wants_debugger (Vdebug_on_error, conditions)) + && ! skip_debugger (conditions, combined_data) + /* rms: what's this for? */ + && when_entered_debugger < num_nonmacro_input_events) + { + call_debugger (Fcons (Qerror, Fcons (combined_data, Qnil))); + return 1; + } + + return 0; +} + /* dump an error message; called like printf */ /* VARARGS 1 */ @@ -2027,42 +2052,49 @@ then strings and vectors are not accepted. */) { register Lisp_Object fun; register Lisp_Object funcar; + Lisp_Object if_prop = Qnil; fun = function; - fun = indirect_function (fun); - if (EQ (fun, Qunbound)) + fun = indirect_function (fun); /* Check cycles. */ + if (NILP (fun) || EQ (fun, Qunbound)) return Qnil; + /* Check an `interactive-form' property if present, analogous to the + function-documentation property. */ + fun = function; + while (SYMBOLP (fun)) + { + Lisp_Object tmp = Fget (fun, intern ("interactive-form")); + if (!NILP (tmp)) + if_prop = Qt; + fun = Fsymbol_function (fun); + } + /* Emacs primitives are interactive if their DEFUN specifies an interactive spec. */ if (SUBRP (fun)) - { - if (XSUBR (fun)->prompt) - return Qt; - else - return Qnil; - } + return XSUBR (fun)->intspec ? Qt : if_prop; /* 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 (COMPILEDP (fun)) return ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_INTERACTIVE - ? Qt : Qnil); + ? Qt : if_prop); /* Strings and vectors are keyboard macros. */ - if (NILP (for_call_interactively) && (STRINGP (fun) || VECTORP (fun))) - return Qt; + if (STRINGP (fun) || VECTORP (fun)) + return (NILP (for_call_interactively) ? Qt : Qnil); /* Lists may represent commands. */ if (!CONSP (fun)) return Qnil; funcar = XCAR (fun); if (EQ (funcar, Qlambda)) - return Fassq (Qinteractive, Fcdr (XCDR (fun))); + return !NILP (Fassq (Qinteractive, Fcdr (XCDR (fun)))) ? Qt : if_prop; if (EQ (funcar, Qautoload)) - return Fcar (Fcdr (Fcdr (XCDR (fun)))); + return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun))))) ? Qt : if_prop; else return Qnil; } @@ -2173,7 +2205,7 @@ do_autoload (fundef, funname) The 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, Qt); + Fload (Fcar (Fcdr (fundef)), Qnil, Qt, Qnil, Qt); /* Once loading finishes, don't undo it. */ Vautoload_queue = Qt; @@ -3232,7 +3264,6 @@ void specbind (symbol, value) Lisp_Object symbol, value; { - Lisp_Object ovalue; Lisp_Object valcontents; CHECK_SYMBOL (symbol); @@ -3252,16 +3283,13 @@ specbind (symbol, value) } else { - Lisp_Object valcontents; - - ovalue = find_symbol_value (symbol); + Lisp_Object ovalue = find_symbol_value (symbol); specpdl_ptr->func = 0; specpdl_ptr->old_value = ovalue; valcontents = XSYMBOL (symbol)->value; if (BUFFER_LOCAL_VALUEP (valcontents) - || SOME_BUFFER_LOCAL_VALUEP (valcontents) || BUFFER_OBJFWDP (valcontents)) { Lisp_Object where, current_buffer; @@ -3272,7 +3300,7 @@ specbind (symbol, value) buffer's or frame's value we are saving. */ if (!NILP (Flocal_variable_p (symbol, Qnil))) where = current_buffer; - else if (!BUFFER_OBJFWDP (valcontents) + else if (BUFFER_LOCAL_VALUEP (valcontents) && XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame) where = XBUFFER_LOCAL_VALUE (valcontents)->frame; else @@ -3300,10 +3328,14 @@ specbind (symbol, value) specpdl_ptr->symbol = symbol; specpdl_ptr++; - if (BUFFER_OBJFWDP (ovalue) || KBOARD_OBJFWDP (ovalue)) - store_symval_forwarding (symbol, ovalue, value, NULL); - else - set_internal (symbol, value, 0, 1); + /* We used to do + if (BUFFER_OBJFWDP (ovalue) || KBOARD_OBJFWDP (ovalue)) + store_symval_forwarding (symbol, ovalue, value, NULL); + else + but ovalue comes from find_symbol_value which should never return + such an internal value. */ + eassert (!(BUFFER_OBJFWDP (ovalue) || KBOARD_OBJFWDP (ovalue))); + set_internal (symbol, value, 0, 1); } } |