X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/4fc5845fe896177307f553d8af0d48834206c060..5615dcc03b721ea3a4d619fe8c6f9a4232193c3d:/src/eval.c diff --git a/src/eval.c b/src/eval.c index f625258229..86ee384896 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1,6 +1,6 @@ /* Evaluator for GNU Emacs Lisp interpreter. Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1999, 2000, 2001, - 2002, 2004, 2005 Free Software Foundation, Inc. + 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -103,7 +103,7 @@ Lisp_Object Vrun_hooks; /* Non-nil means record all fset's and provide's, to be undone if the file being autoloaded is not fully loaded. They are recorded by being consed onto the front of Vautoload_queue: - (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */ + (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide. */ Lisp_Object Vautoload_queue; @@ -117,7 +117,7 @@ struct specbinding *specpdl; /* Pointer to first unused element in specpdl. */ -volatile struct specbinding *specpdl_ptr; +struct specbinding *specpdl_ptr; /* Maximum size allowed for specpdl allocation */ @@ -235,6 +235,7 @@ restore_stack_limits (data) { max_specpdl_size = XINT (XCAR (data)); max_lisp_eval_depth = XINT (XCDR (data)); + return Qnil; } /* Call the Lisp debugger, giving it argument ARG. */ @@ -471,10 +472,10 @@ usage: (prog1 FIRST BODY...) */) } DEFUN ("prog2", Fprog2, Sprog2, 2, UNEVALLED, 0, - doc: /* Eval X, Y and BODY sequentially; value from Y. -The value of Y is saved during the evaluation of the remaining args, -whose values are discarded. -usage: (prog2 X Y BODY...) */) + doc: /* Eval FORM1, FORM2 and BODY sequentially; value from FORM2. +The value of FORM2 is saved during the evaluation of the +remaining args, whose values are discarded. +usage: (prog2 FORM1 FORM2 BODY...) */) (args) Lisp_Object args; { @@ -564,8 +565,8 @@ usage: (function ARG) */) DEFUN ("interactive-p", Finteractive_p, Sinteractive_p, 0, 0, 0, doc: /* Return t if the function was run directly by user input. -This means that the function was called with call-interactively (which -includes being called as the binding of a key) +This means that the function was called with `call-interactively' +\(which includes being called as the binding of a key) and input is currently coming from the keyboard (not in keyboard macro), and Emacs is not running in batch mode (`noninteractive' is nil). @@ -586,14 +587,14 @@ unconditionally for that argument. (`p' is a good way to do this.) */) DEFUN ("called-interactively-p", Fcalled_interactively_p, Scalled_interactively_p, 0, 0, 0, - doc: /* Return t if the function using this was called with call-interactively. + doc: /* Return t if the function using this was called with `call-interactively'. This is used for implementing advice and other function-modifying features of Emacs. The cleanest way to test whether your function was called with -`call-interactively', the way to do that is by adding an extra -optional argument, and making the `interactive' spec specify non-nil -unconditionally for that argument. (`p' is a good way to do this.) */) +`call-interactively' is by adding an extra optional argument, +and making the `interactive' spec specify non-nil unconditionally +for that argument. (`p' is a good way to do this.) */) () { return interactive_p (1) ? Qt : Qnil; @@ -617,7 +618,7 @@ interactive_p (exclude_subrs_p) /* If this isn't a byte-compiled function, there may be a frame at the top for Finteractive_p. If so, skip it. */ - fun = Findirect_function (*btp->function); + fun = Findirect_function (*btp->function, Qnil); if (SUBRP (fun) && (XSUBR (fun) == &Sinteractive_p || XSUBR (fun) == &Scalled_interactively_p)) btp = btp->next; @@ -638,7 +639,7 @@ interactive_p (exclude_subrs_p) a special form, ignoring frames for Finteractive_p and/or 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); + fun = Findirect_function (*btp->function, Qnil); if (exclude_subrs_p && SUBRP (fun)) return 0; @@ -779,7 +780,7 @@ The return value is BASE-VARIABLE. */) DEFUN ("defvar", Fdefvar, Sdefvar, 1, UNEVALLED, 0, - doc: /* Define SYMBOL as a variable. + doc: /* Define SYMBOL as a variable, and return SYMBOL. You are not required to define a variable in order to use it, but the definition can supply documentation and an initial value in a way that tags can recognize. @@ -806,10 +807,6 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */) register Lisp_Object sym, tem, tail; sym = Fcar (args); - if (SYMBOL_CONSTANT_P (sym)) - error ("Constant symbol `%s' specified in defvar", - SDATA (SYMBOL_NAME (sym))); - tail = Fcdr (args); if (!NILP (Fcdr (Fcdr (tail)))) error ("Too many arguments"); @@ -817,6 +814,18 @@ usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */) tem = Fdefault_boundp (sym); if (!NILP (tail)) { + if (SYMBOL_CONSTANT_P (sym)) + { + /* For upward compatibility, allow (defvar :foo (quote :foo)). */ + Lisp_Object tem = Fcar (tail); + if (! (CONSP (tem) + && EQ (XCAR (tem), Qquote) + && CONSP (XCDR (tem)) + && EQ (XCAR (XCDR (tem)), sym))) + error ("Constant symbol `%s' specified in defvar", + SDATA (SYMBOL_NAME (sym))); + } + if (NILP (tem)) Fset_default (sym, Feval (Fcar (tail))); else @@ -1250,6 +1259,12 @@ unwind_to_catch (catch, value) } while (! last_time); +#if HAVE_X_WINDOWS + /* If x_catch_errors was done, turn it off now. + (First we give unbind_to a chance to do that.) */ + x_fully_uncatch_errors (); +#endif + byte_stack_list = catch->byte_stack; gcprolist = catch->gcpro; #ifdef DEBUG_GCPRO @@ -1334,15 +1349,28 @@ usage: (condition-case VAR BODYFORM &rest HANDLERS) */) (args) Lisp_Object args; { - Lisp_Object val; - struct catchtag c; - struct handler h; register Lisp_Object bodyform, handlers; volatile Lisp_Object var; var = Fcar (args); bodyform = Fcar (Fcdr (args)); handlers = Fcdr (Fcdr (args)); + + return internal_lisp_condition_case (var, bodyform, handlers); +} + +/* Like Fcondition_case, but the args are separate + rather than passed in a list. Used by Fbyte_code. */ + +Lisp_Object +internal_lisp_condition_case (var, bodyform, handlers) + volatile Lisp_Object var; + Lisp_Object bodyform, handlers; +{ + Lisp_Object val; + struct catchtag c; + struct handler h; + CHECK_SYMBOL (var); for (val = handlers; CONSP (val); val = XCDR (val)) @@ -1413,8 +1441,10 @@ internal_condition_case (bfun, handlers, hfun) struct catchtag c; struct handler h; -#if 0 /* We now handle interrupt_input_blocked properly. - What we still do not handle is exiting a signal handler. */ + /* Since Fsignal will close off all calls to x_catch_errors, + we will get the wrong results if some are not closed now. */ +#if HAVE_X_WINDOWS + if (x_catching_errors ()) abort (); #endif @@ -1459,6 +1489,13 @@ internal_condition_case_1 (bfun, arg, handlers, hfun) struct catchtag c; struct handler h; + /* Since Fsignal will close off all calls to x_catch_errors, + we will get the wrong results if some are not closed now. */ +#if HAVE_X_WINDOWS + if (x_catching_errors ()) + abort (); +#endif + c.tag = Qnil; c.val = Qnil; c.backlist = backtrace_list; @@ -1503,6 +1540,13 @@ internal_condition_case_2 (bfun, nargs, args, handlers, hfun) struct catchtag c; struct handler h; + /* Since Fsignal will close off all calls to x_catch_errors, + we will get the wrong results if some are not closed now. */ +#if HAVE_X_WINDOWS + if (x_catching_errors ()) + abort (); +#endif + c.tag = Qnil; c.val = Qnil; c.backlist = backtrace_list; @@ -2000,8 +2044,8 @@ un_autoload (oldqueue) first = XCAR (queue); second = Fcdr (first); first = Fcar (first); - if (EQ (second, Qnil)) - Vfeatures = first; + if (EQ (first, make_number (0))) + Vfeatures = second; else Ffset (first, second); queue = XCDR (queue); @@ -2047,7 +2091,7 @@ do_autoload (fundef, funname) second = Fcdr (first); first = Fcar (first); - if (CONSP (second) && EQ (XCAR (second), Qautoload)) + if (SYMBOLP (first) && CONSP (second) && EQ (XCAR (second), Qautoload)) Fput (first, Qautoload, (XCDR (second))); queue = XCDR (queue); @@ -2057,7 +2101,7 @@ do_autoload (fundef, funname) Vautoload_queue = Qt; unbind_to (count, Qnil); - fun = Findirect_function (fun); + fun = Findirect_function (fun, Qnil); if (!NILP (Fequal (fun, fundef))) error ("Autoloading failed to define function %s", @@ -2085,7 +2129,10 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0, return form; QUIT; - if (consing_since_gc > gc_cons_threshold) + if ((consing_since_gc > gc_cons_threshold + && consing_since_gc > gc_relative_threshold) + || + (!NILP (Vmemory_full) && consing_since_gc > memory_full_cons_threshold)) { GCPRO1 (form); Fgarbage_collect (); @@ -2117,7 +2164,7 @@ DEFUN ("eval", Feval, Seval, 1, 1, 0, /* At this point, only original_fun and original_args have values that will be used below */ retry: - fun = Findirect_function (original_fun); + fun = Findirect_function (original_fun, Qnil); if (SUBRP (fun)) { @@ -2785,7 +2832,10 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) register int i; QUIT; - if (consing_since_gc > gc_cons_threshold) + if ((consing_since_gc > gc_cons_threshold + && consing_since_gc > gc_relative_threshold) + || + (!NILP (Vmemory_full) && consing_since_gc > memory_full_cons_threshold)) Fgarbage_collect (); if (++lisp_eval_depth > max_lisp_eval_depth) @@ -2813,7 +2863,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) fun = args[0]; - fun = Findirect_function (fun); + fun = Findirect_function (fun, Qnil); if (SUBRP (fun)) { @@ -2851,8 +2901,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) val = (*XSUBR (fun)->function) (internal_args[0]); goto done; case 2: - val = (*XSUBR (fun)->function) (internal_args[0], - internal_args[1]); + val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1]); goto done; case 3: val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1], @@ -2860,8 +2909,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) goto done; case 4: val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1], - internal_args[2], - internal_args[3]); + internal_args[2], internal_args[3]); goto done; case 5: val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1], @@ -3173,6 +3221,8 @@ record_unwind_protect (function, arg) Lisp_Object (*function) P_ ((Lisp_Object)); Lisp_Object arg; { + eassert (!handling_signal); + if (specpdl_ptr == specpdl + specpdl_size) grow_specpdl (); specpdl_ptr->func = function; @@ -3387,7 +3437,7 @@ void syms_of_eval () { DEFVAR_INT ("max-specpdl-size", &max_specpdl_size, - doc: /* *Limit on number of Lisp variable bindings & unwind-protects. + doc: /* *Limit on number of Lisp variable bindings and `unwind-protect's. If Lisp code tries to increase the total number past this amount, an error is signaled. You can safely use a value considerably larger than the default value, @@ -3484,10 +3534,8 @@ It does not apply to errors handled by `condition-case'. */); Vdebug_ignored_errors = Qnil; DEFVAR_BOOL ("debug-on-quit", &debug_on_quit, - doc: /* *Non-nil means enter debugger if quit is signaled (C-g, for example). -Does not apply if quit is handled by a `condition-case'. -When you evaluate an expression interactively, this variable -is temporarily non-nil if `eval-expression-debug-on-quit' is non-nil. */); + doc: /* *Non-nil means enter debugger if quit is signaled (C-g, for example). +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,