1 /* Evaluator for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1999, 2000, 2001,
3 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
20 Boston, MA 02110-1301, USA. */
25 #include "blockinput.h"
28 #include "dispextern.h"
35 /* This definition is duplicated in alloc.c and keyboard.c */
36 /* Putting it in lisp.h makes cc bomb out! */
40 struct backtrace
*next
;
41 Lisp_Object
*function
;
42 Lisp_Object
*args
; /* Points to vector of args. */
43 int nargs
; /* Length of vector.
44 If nargs is UNEVALLED, args points to slot holding
45 list of unevalled args */
47 /* Nonzero means call value of debugger when done with this operation. */
51 struct backtrace
*backtrace_list
;
53 /* This structure helps implement the `catch' and `throw' control
54 structure. A struct catchtag contains all the information needed
55 to restore the state of the interpreter after a non-local jump.
57 Handlers for error conditions (represented by `struct handler'
58 structures) just point to a catch tag to do the cleanup required
61 catchtag structures are chained together in the C calling stack;
62 the `next' member points to the next outer catchtag.
64 A call like (throw TAG VAL) searches for a catchtag whose `tag'
65 member is TAG, and then unbinds to it. The `val' member is used to
66 hold VAL while the stack is unwound; `val' is returned as the value
69 All the other members are concerned with restoring the interpreter
76 struct catchtag
*next
;
79 struct backtrace
*backlist
;
80 struct handler
*handlerlist
;
83 int poll_suppress_count
;
84 int interrupt_input_blocked
;
85 struct byte_stack
*byte_stack
;
88 struct catchtag
*catchlist
;
91 /* Count levels of GCPRO to detect failure to UNGCPRO. */
95 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
96 Lisp_Object Qinhibit_quit
, Vinhibit_quit
, Vquit_flag
;
97 Lisp_Object Qand_rest
, Qand_optional
;
98 Lisp_Object Qdebug_on_error
;
102 /* This holds either the symbol `run-hooks' or nil.
103 It is nil at an early stage of startup, and when Emacs
106 Lisp_Object Vrun_hooks
;
108 /* Non-nil means record all fset's and provide's, to be undone
109 if the file being autoloaded is not fully loaded.
110 They are recorded by being consed onto the front of Vautoload_queue:
111 (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide. */
113 Lisp_Object Vautoload_queue
;
115 /* Current number of specbindings allocated in specpdl. */
119 /* Pointer to beginning of specpdl. */
121 struct specbinding
*specpdl
;
123 /* Pointer to first unused element in specpdl. */
125 struct specbinding
*specpdl_ptr
;
127 /* Maximum size allowed for specpdl allocation */
129 EMACS_INT max_specpdl_size
;
131 /* Depth in Lisp evaluations and function calls. */
135 /* Maximum allowed depth in Lisp evaluations and function calls. */
137 EMACS_INT max_lisp_eval_depth
;
139 /* Nonzero means enter debugger before next function call */
141 int debug_on_next_call
;
143 /* Non-zero means debugger may continue. This is zero when the
144 debugger is called during redisplay, where it might not be safe to
145 continue the interrupted redisplay. */
147 int debugger_may_continue
;
149 /* List of conditions (non-nil atom means all) which cause a backtrace
150 if an error is handled by the command loop's error handler. */
152 Lisp_Object Vstack_trace_on_error
;
154 /* List of conditions (non-nil atom means all) which enter the debugger
155 if an error is handled by the command loop's error handler. */
157 Lisp_Object Vdebug_on_error
;
159 /* List of conditions and regexps specifying error messages which
160 do not enter the debugger even if Vdebug_on_error says they should. */
162 Lisp_Object Vdebug_ignored_errors
;
164 /* Non-nil means call the debugger even if the error will be handled. */
166 Lisp_Object Vdebug_on_signal
;
168 /* Hook for edebug to use. */
170 Lisp_Object Vsignal_hook_function
;
172 /* Nonzero means enter debugger if a quit signal
173 is handled by the command loop's error handler. */
177 /* The value of num_nonmacro_input_events as of the last time we
178 started to enter the debugger. If we decide to enter the debugger
179 again when this is still equal to num_nonmacro_input_events, then we
180 know that the debugger itself has an error, and we should just
181 signal the error instead of entering an infinite loop of debugger
184 int when_entered_debugger
;
186 Lisp_Object Vdebugger
;
188 /* The function from which the last `signal' was called. Set in
191 Lisp_Object Vsignaling_function
;
193 /* Set to non-zero while processing X events. Checked in Feval to
194 make sure the Lisp interpreter isn't called from a signal handler,
195 which is unsafe because the interpreter isn't reentrant. */
199 /* Function to process declarations in defmacro forms. */
201 Lisp_Object Vmacro_declaration_function
;
203 extern Lisp_Object Qrisky_local_variable
;
205 extern Lisp_Object Qfunction
;
207 static Lisp_Object funcall_lambda
P_ ((Lisp_Object
, int, Lisp_Object
*));
208 static void unwind_to_catch
P_ ((struct catchtag
*, Lisp_Object
)) NO_RETURN
;
211 /* "gcc -O3" enables automatic function inlining, which optimizes out
212 the arguments for the invocations of these functions, whereas they
213 expect these values on the stack. */
214 Lisp_Object
apply1 () __attribute__((noinline
));
215 Lisp_Object
call2 () __attribute__((noinline
));
222 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
223 specpdl_ptr
= specpdl
;
224 /* Don't forget to update docs (lispref node "Local Variables"). */
225 max_specpdl_size
= 1000;
226 max_lisp_eval_depth
= 400;
234 specpdl_ptr
= specpdl
;
239 debug_on_next_call
= 0;
244 /* This is less than the initial value of num_nonmacro_input_events. */
245 when_entered_debugger
= -1;
248 /* unwind-protect function used by call_debugger. */
251 restore_stack_limits (data
)
254 max_specpdl_size
= XINT (XCAR (data
));
255 max_lisp_eval_depth
= XINT (XCDR (data
));
259 /* Call the Lisp debugger, giving it argument ARG. */
265 int debug_while_redisplaying
;
266 int count
= SPECPDL_INDEX ();
268 int old_max
= max_specpdl_size
;
270 /* Temporarily bump up the stack limits,
271 so the debugger won't run out of stack. */
273 max_specpdl_size
+= 1;
274 record_unwind_protect (restore_stack_limits
,
275 Fcons (make_number (old_max
),
276 make_number (max_lisp_eval_depth
)));
277 max_specpdl_size
= old_max
;
279 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
280 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
282 if (SPECPDL_INDEX () + 100 > max_specpdl_size
)
283 max_specpdl_size
= SPECPDL_INDEX () + 100;
285 #ifdef HAVE_X_WINDOWS
286 if (display_hourglass_p
)
290 debug_on_next_call
= 0;
291 when_entered_debugger
= num_nonmacro_input_events
;
293 /* Resetting redisplaying_p to 0 makes sure that debug output is
294 displayed if the debugger is invoked during redisplay. */
295 debug_while_redisplaying
= redisplaying_p
;
297 specbind (intern ("debugger-may-continue"),
298 debug_while_redisplaying
? Qnil
: Qt
);
299 specbind (Qinhibit_redisplay
, Qnil
);
300 specbind (Qdebug_on_error
, Qnil
);
302 #if 0 /* Binding this prevents execution of Lisp code during
303 redisplay, which necessarily leads to display problems. */
304 specbind (Qinhibit_eval_during_redisplay
, Qt
);
307 val
= apply1 (Vdebugger
, arg
);
309 /* Interrupting redisplay and resuming it later is not safe under
310 all circumstances. So, when the debugger returns, abort the
311 interrupted redisplay by going back to the top-level. */
312 if (debug_while_redisplaying
)
315 return unbind_to (count
, val
);
319 do_debug_on_call (code
)
322 debug_on_next_call
= 0;
323 backtrace_list
->debug_on_exit
= 1;
324 call_debugger (Fcons (code
, Qnil
));
327 /* NOTE!!! Every function that can call EVAL must protect its args
328 and temporaries from garbage collection while it needs them.
329 The definition of `For' shows what you have to do. */
331 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
332 doc
: /* Eval args until one of them yields non-nil, then return that value.
333 The remaining args are not evalled at all.
334 If all args return nil, return nil.
335 usage: (or CONDITIONS...) */)
339 register Lisp_Object val
= Qnil
;
346 val
= Feval (XCAR (args
));
356 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
357 doc
: /* Eval args until one of them yields nil, then return nil.
358 The remaining args are not evalled at all.
359 If no arg yields nil, return the last arg's value.
360 usage: (and CONDITIONS...) */)
364 register Lisp_Object val
= Qt
;
371 val
= Feval (XCAR (args
));
381 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
382 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
383 Returns the value of THEN or the value of the last of the ELSE's.
384 THEN must be one expression, but ELSE... can be zero or more expressions.
385 If COND yields nil, and there are no ELSE's, the value is nil.
386 usage: (if COND THEN ELSE...) */)
390 register Lisp_Object cond
;
394 cond
= Feval (Fcar (args
));
398 return Feval (Fcar (Fcdr (args
)));
399 return Fprogn (Fcdr (Fcdr (args
)));
402 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
403 doc
: /* Try each clause until one succeeds.
404 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
405 and, if the value is non-nil, this clause succeeds:
406 then the expressions in BODY are evaluated and the last one's
407 value is the value of the cond-form.
408 If no clause succeeds, cond returns nil.
409 If a clause has one element, as in (CONDITION),
410 CONDITION's value if non-nil is returned from the cond-form.
411 usage: (cond CLAUSES...) */)
415 register Lisp_Object clause
, val
;
422 clause
= Fcar (args
);
423 val
= Feval (Fcar (clause
));
426 if (!EQ (XCDR (clause
), Qnil
))
427 val
= Fprogn (XCDR (clause
));
437 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
438 doc
: /* Eval BODY forms sequentially and return value of last one.
439 usage: (progn BODY...) */)
443 register Lisp_Object val
= Qnil
;
450 val
= Feval (XCAR (args
));
458 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
459 doc
: /* Eval FIRST and BODY sequentially; value from FIRST.
460 The value of FIRST is saved during the evaluation of the remaining args,
461 whose values are discarded.
462 usage: (prog1 FIRST BODY...) */)
467 register Lisp_Object args_left
;
468 struct gcpro gcpro1
, gcpro2
;
469 register int argnum
= 0;
481 val
= Feval (Fcar (args_left
));
483 Feval (Fcar (args_left
));
484 args_left
= Fcdr (args_left
);
486 while (!NILP(args_left
));
492 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
493 doc
: /* Eval FORM1, FORM2 and BODY sequentially; value from FORM2.
494 The value of FORM2 is saved during the evaluation of the
495 remaining args, whose values are discarded.
496 usage: (prog2 FORM1 FORM2 BODY...) */)
501 register Lisp_Object args_left
;
502 struct gcpro gcpro1
, gcpro2
;
503 register int argnum
= -1;
517 val
= Feval (Fcar (args_left
));
519 Feval (Fcar (args_left
));
520 args_left
= Fcdr (args_left
);
522 while (!NILP (args_left
));
528 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
529 doc
: /* Set each SYM to the value of its VAL.
530 The symbols SYM are variables; they are literal (not evaluated).
531 The values VAL are expressions; they are evaluated.
532 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
533 The second VAL is not computed until after the first SYM is set, and so on;
534 each VAL can use the new value of variables set earlier in the `setq'.
535 The return value of the `setq' form is the value of the last VAL.
536 usage: (setq [SYM VAL]...) */)
540 register Lisp_Object args_left
;
541 register Lisp_Object val
, sym
;
552 val
= Feval (Fcar (Fcdr (args_left
)));
553 sym
= Fcar (args_left
);
555 args_left
= Fcdr (Fcdr (args_left
));
557 while (!NILP(args_left
));
563 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
564 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
565 usage: (quote ARG) */)
569 if (!NILP (Fcdr (args
)))
570 xsignal2 (Qwrong_number_of_arguments
, Qquote
, Flength (args
));
574 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
575 doc
: /* Like `quote', but preferred for objects which are functions.
576 In byte compilation, `function' causes its argument to be compiled.
577 `quote' cannot do that.
578 usage: (function ARG) */)
582 if (!NILP (Fcdr (args
)))
583 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
588 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
589 doc
: /* Return t if the function was run directly by user input.
590 This means that the function was called with `call-interactively'
591 \(which includes being called as the binding of a key)
592 and input is currently coming from the keyboard (not in keyboard macro),
593 and Emacs is not running in batch mode (`noninteractive' is nil).
595 The only known proper use of `interactive-p' is in deciding whether to
596 display a helpful message, or how to display it. If you're thinking
597 of using it for any other purpose, it is quite likely that you're
598 making a mistake. Think: what do you want to do when the command is
599 called from a keyboard macro?
601 If you want to test whether your function was called with
602 `call-interactively', the way to do that is by adding an extra
603 optional argument, and making the `interactive' spec specify non-nil
604 unconditionally for that argument. (`p' is a good way to do this.) */)
607 return (INTERACTIVE
&& interactive_p (1)) ? Qt
: Qnil
;
611 DEFUN ("called-interactively-p", Fcalled_interactively_p
, Scalled_interactively_p
, 0, 0, 0,
612 doc
: /* Return t if the function using this was called with `call-interactively'.
613 This is used for implementing advice and other function-modifying
616 The cleanest way to test whether your function was called with
617 `call-interactively' is by adding an extra optional argument,
618 and making the `interactive' spec specify non-nil unconditionally
619 for that argument. (`p' is a good way to do this.) */)
622 return interactive_p (1) ? Qt
: Qnil
;
626 /* Return 1 if function in which this appears was called using
629 EXCLUDE_SUBRS_P non-zero means always return 0 if the function
630 called is a built-in. */
633 interactive_p (exclude_subrs_p
)
636 struct backtrace
*btp
;
639 btp
= backtrace_list
;
641 /* If this isn't a byte-compiled function, there may be a frame at
642 the top for Finteractive_p. If so, skip it. */
643 fun
= Findirect_function (*btp
->function
, Qnil
);
644 if (SUBRP (fun
) && (XSUBR (fun
) == &Sinteractive_p
645 || XSUBR (fun
) == &Scalled_interactively_p
))
648 /* If we're running an Emacs 18-style byte-compiled function, there
649 may be a frame for Fbytecode at the top level. In any version of
650 Emacs there can be Fbytecode frames for subexpressions evaluated
651 inside catch and condition-case. Skip past them.
653 If this isn't a byte-compiled function, then we may now be
654 looking at several frames for special forms. Skip past them. */
656 && (EQ (*btp
->function
, Qbytecode
)
657 || btp
->nargs
== UNEVALLED
))
660 /* btp now points at the frame of the innermost function that isn't
661 a special form, ignoring frames for Finteractive_p and/or
662 Fbytecode at the top. If this frame is for a built-in function
663 (such as load or eval-region) return nil. */
664 fun
= Findirect_function (*btp
->function
, Qnil
);
665 if (exclude_subrs_p
&& SUBRP (fun
))
668 /* btp points to the frame of a Lisp function that called interactive-p.
669 Return t if that function was called interactively. */
670 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
676 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
677 doc
: /* Define NAME as a function.
678 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
679 See also the function `interactive'.
680 usage: (defun NAME ARGLIST [DOCSTRING] BODY...) */)
684 register Lisp_Object fn_name
;
685 register Lisp_Object defn
;
687 fn_name
= Fcar (args
);
688 CHECK_SYMBOL (fn_name
);
689 defn
= Fcons (Qlambda
, Fcdr (args
));
690 if (!NILP (Vpurify_flag
))
691 defn
= Fpurecopy (defn
);
692 if (CONSP (XSYMBOL (fn_name
)->function
)
693 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
694 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
695 Ffset (fn_name
, defn
);
696 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
700 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
701 doc
: /* Define NAME as a macro.
702 The actual definition looks like
703 (macro lambda ARGLIST [DOCSTRING] [DECL] BODY...).
704 When the macro is called, as in (NAME ARGS...),
705 the function (lambda ARGLIST BODY...) is applied to
706 the list ARGS... as it appears in the expression,
707 and the result should be a form to be evaluated instead of the original.
709 DECL is a declaration, optional, which can specify how to indent
710 calls to this macro and how Edebug should handle it. It looks like this:
712 The elements can look like this:
714 Set NAME's `lisp-indent-function' property to INDENT.
717 Set NAME's `edebug-form-spec' property to DEBUG. (This is
718 equivalent to writing a `def-edebug-spec' for the macro.)
719 usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */)
723 register Lisp_Object fn_name
;
724 register Lisp_Object defn
;
725 Lisp_Object lambda_list
, doc
, tail
;
727 fn_name
= Fcar (args
);
728 CHECK_SYMBOL (fn_name
);
729 lambda_list
= Fcar (Fcdr (args
));
730 tail
= Fcdr (Fcdr (args
));
733 if (STRINGP (Fcar (tail
)))
739 while (CONSP (Fcar (tail
))
740 && EQ (Fcar (Fcar (tail
)), Qdeclare
))
742 if (!NILP (Vmacro_declaration_function
))
746 call2 (Vmacro_declaration_function
, fn_name
, Fcar (tail
));
754 tail
= Fcons (lambda_list
, tail
);
756 tail
= Fcons (lambda_list
, Fcons (doc
, tail
));
757 defn
= Fcons (Qmacro
, Fcons (Qlambda
, tail
));
759 if (!NILP (Vpurify_flag
))
760 defn
= Fpurecopy (defn
);
761 if (CONSP (XSYMBOL (fn_name
)->function
)
762 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
763 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
764 Ffset (fn_name
, defn
);
765 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
770 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
771 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
772 Aliased variables always have the same value; setting one sets the other.
773 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
774 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
775 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
777 The return value is BASE-VARIABLE. */)
778 (new_alias
, base_variable
, docstring
)
779 Lisp_Object new_alias
, base_variable
, docstring
;
781 struct Lisp_Symbol
*sym
;
783 CHECK_SYMBOL (new_alias
);
784 CHECK_SYMBOL (base_variable
);
786 if (SYMBOL_CONSTANT_P (new_alias
))
787 error ("Cannot make a constant an alias");
789 sym
= XSYMBOL (new_alias
);
790 sym
->indirect_variable
= 1;
791 sym
->value
= base_variable
;
792 sym
->constant
= SYMBOL_CONSTANT_P (base_variable
);
793 LOADHIST_ATTACH (new_alias
);
794 if (!NILP (docstring
))
795 Fput (new_alias
, Qvariable_documentation
, docstring
);
797 Fput (new_alias
, Qvariable_documentation
, Qnil
);
799 return base_variable
;
803 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
804 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
805 You are not required to define a variable in order to use it,
806 but the definition can supply documentation and an initial value
807 in a way that tags can recognize.
809 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.
810 If SYMBOL is buffer-local, its default value is what is set;
811 buffer-local values are not affected.
812 INITVALUE and DOCSTRING are optional.
813 If DOCSTRING starts with *, this variable is identified as a user option.
814 This means that M-x set-variable recognizes it.
815 See also `user-variable-p'.
816 If INITVALUE is missing, SYMBOL's value is not set.
818 If SYMBOL has a local binding, then this form affects the local
819 binding. This is usually not what you want. Thus, if you need to
820 load a file defining variables, with this form or with `defconst' or
821 `defcustom', you should always load that file _outside_ any bindings
822 for these variables. \(`defconst' and `defcustom' behave similarly in
824 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
828 register Lisp_Object sym
, tem
, tail
;
832 if (!NILP (Fcdr (Fcdr (tail
))))
833 error ("Too many arguments");
835 tem
= Fdefault_boundp (sym
);
838 if (SYMBOL_CONSTANT_P (sym
))
840 /* For upward compatibility, allow (defvar :foo (quote :foo)). */
841 Lisp_Object tem
= Fcar (tail
);
843 && EQ (XCAR (tem
), Qquote
)
844 && CONSP (XCDR (tem
))
845 && EQ (XCAR (XCDR (tem
)), sym
)))
846 error ("Constant symbol `%s' specified in defvar",
847 SDATA (SYMBOL_NAME (sym
)));
851 Fset_default (sym
, Feval (Fcar (tail
)));
853 { /* Check if there is really a global binding rather than just a let
854 binding that shadows the global unboundness of the var. */
855 volatile struct specbinding
*pdl
= specpdl_ptr
;
856 while (--pdl
>= specpdl
)
858 if (EQ (pdl
->symbol
, sym
) && !pdl
->func
859 && EQ (pdl
->old_value
, Qunbound
))
861 message_with_string ("Warning: defvar ignored because %s is let-bound",
862 SYMBOL_NAME (sym
), 1);
871 if (!NILP (Vpurify_flag
))
872 tem
= Fpurecopy (tem
);
873 Fput (sym
, Qvariable_documentation
, tem
);
875 LOADHIST_ATTACH (sym
);
878 /* Simple (defvar <var>) should not count as a definition at all.
879 It could get in the way of other definitions, and unloading this
880 package could try to make the variable unbound. */
886 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
887 doc
: /* Define SYMBOL as a constant variable.
888 The intent is that neither programs nor users should ever change this value.
889 Always sets the value of SYMBOL to the result of evalling INITVALUE.
890 If SYMBOL is buffer-local, its default value is what is set;
891 buffer-local values are not affected.
892 DOCSTRING is optional.
894 If SYMBOL has a local binding, then this form sets the local binding's
895 value. However, you should normally not make local bindings for
896 variables defined with this form.
897 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
901 register Lisp_Object sym
, tem
;
904 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
905 error ("Too many arguments");
907 tem
= Feval (Fcar (Fcdr (args
)));
908 if (!NILP (Vpurify_flag
))
909 tem
= Fpurecopy (tem
);
910 Fset_default (sym
, tem
);
911 tem
= Fcar (Fcdr (Fcdr (args
)));
914 if (!NILP (Vpurify_flag
))
915 tem
= Fpurecopy (tem
);
916 Fput (sym
, Qvariable_documentation
, tem
);
918 Fput (sym
, Qrisky_local_variable
, Qt
);
919 LOADHIST_ATTACH (sym
);
923 /* Error handler used in Fuser_variable_p. */
925 user_variable_p_eh (ignore
)
931 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
932 doc
: /* Return t if VARIABLE is intended to be set and modified by users.
933 \(The alternative is a variable used internally in a Lisp program.)
934 A variable is a user variable if
935 \(1) the first character of its documentation is `*', or
936 \(2) it is customizable (its property list contains a non-nil value
937 of `standard-value' or `custom-autoload'), or
938 \(3) it is an alias for another user variable.
939 Return nil if VARIABLE is an alias and there is a loop in the
940 chain of symbols. */)
942 Lisp_Object variable
;
944 Lisp_Object documentation
;
946 if (!SYMBOLP (variable
))
949 /* If indirect and there's an alias loop, don't check anything else. */
950 if (XSYMBOL (variable
)->indirect_variable
951 && NILP (internal_condition_case_1 (indirect_variable
, variable
,
952 Qt
, user_variable_p_eh
)))
957 documentation
= Fget (variable
, Qvariable_documentation
);
958 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
960 if (STRINGP (documentation
)
961 && ((unsigned char) SREF (documentation
, 0) == '*'))
963 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
964 if (CONSP (documentation
)
965 && STRINGP (XCAR (documentation
))
966 && INTEGERP (XCDR (documentation
))
967 && XINT (XCDR (documentation
)) < 0)
969 /* Customizable? See `custom-variable-p'. */
970 if ((!NILP (Fget (variable
, intern ("standard-value"))))
971 || (!NILP (Fget (variable
, intern ("custom-autoload")))))
974 if (!XSYMBOL (variable
)->indirect_variable
)
977 /* An indirect variable? Let's follow the chain. */
978 variable
= XSYMBOL (variable
)->value
;
982 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
983 doc
: /* Bind variables according to VARLIST then eval BODY.
984 The value of the last form in BODY is returned.
985 Each element of VARLIST is a symbol (which is bound to nil)
986 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
987 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
988 usage: (let* VARLIST BODY...) */)
992 Lisp_Object varlist
, val
, elt
;
993 int count
= SPECPDL_INDEX ();
994 struct gcpro gcpro1
, gcpro2
, gcpro3
;
996 GCPRO3 (args
, elt
, varlist
);
998 varlist
= Fcar (args
);
999 while (!NILP (varlist
))
1002 elt
= Fcar (varlist
);
1004 specbind (elt
, Qnil
);
1005 else if (! NILP (Fcdr (Fcdr (elt
))))
1006 signal_error ("`let' bindings can have only one value-form", elt
);
1009 val
= Feval (Fcar (Fcdr (elt
)));
1010 specbind (Fcar (elt
), val
);
1012 varlist
= Fcdr (varlist
);
1015 val
= Fprogn (Fcdr (args
));
1016 return unbind_to (count
, val
);
1019 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
1020 doc
: /* Bind variables according to VARLIST then eval BODY.
1021 The value of the last form in BODY is returned.
1022 Each element of VARLIST is a symbol (which is bound to nil)
1023 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
1024 All the VALUEFORMs are evalled before any symbols are bound.
1025 usage: (let VARLIST BODY...) */)
1029 Lisp_Object
*temps
, tem
;
1030 register Lisp_Object elt
, varlist
;
1031 int count
= SPECPDL_INDEX ();
1032 register int argnum
;
1033 struct gcpro gcpro1
, gcpro2
;
1035 varlist
= Fcar (args
);
1037 /* Make space to hold the values to give the bound variables */
1038 elt
= Flength (varlist
);
1039 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
1041 /* Compute the values and store them in `temps' */
1043 GCPRO2 (args
, *temps
);
1046 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
1049 elt
= Fcar (varlist
);
1051 temps
[argnum
++] = Qnil
;
1052 else if (! NILP (Fcdr (Fcdr (elt
))))
1053 signal_error ("`let' bindings can have only one value-form", elt
);
1055 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
1056 gcpro2
.nvars
= argnum
;
1060 varlist
= Fcar (args
);
1061 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
1063 elt
= Fcar (varlist
);
1064 tem
= temps
[argnum
++];
1066 specbind (elt
, tem
);
1068 specbind (Fcar (elt
), tem
);
1071 elt
= Fprogn (Fcdr (args
));
1072 return unbind_to (count
, elt
);
1075 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
1076 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
1077 The order of execution is thus TEST, BODY, TEST, BODY and so on
1078 until TEST returns nil.
1079 usage: (while TEST BODY...) */)
1083 Lisp_Object test
, body
;
1084 struct gcpro gcpro1
, gcpro2
;
1086 GCPRO2 (test
, body
);
1090 while (!NILP (Feval (test
)))
1100 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
1101 doc
: /* Return result of expanding macros at top level of FORM.
1102 If FORM is not a macro call, it is returned unchanged.
1103 Otherwise, the macro is expanded and the expansion is considered
1104 in place of FORM. When a non-macro-call results, it is returned.
1106 The second optional arg ENVIRONMENT specifies an environment of macro
1107 definitions to shadow the loaded ones for use in file byte-compilation. */)
1110 Lisp_Object environment
;
1112 /* With cleanups from Hallvard Furuseth. */
1113 register Lisp_Object expander
, sym
, def
, tem
;
1117 /* Come back here each time we expand a macro call,
1118 in case it expands into another macro call. */
1121 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1122 def
= sym
= XCAR (form
);
1124 /* Trace symbols aliases to other symbols
1125 until we get a symbol that is not an alias. */
1126 while (SYMBOLP (def
))
1130 tem
= Fassq (sym
, environment
);
1133 def
= XSYMBOL (sym
)->function
;
1134 if (!EQ (def
, Qunbound
))
1139 /* Right now TEM is the result from SYM in ENVIRONMENT,
1140 and if TEM is nil then DEF is SYM's function definition. */
1143 /* SYM is not mentioned in ENVIRONMENT.
1144 Look at its function definition. */
1145 if (EQ (def
, Qunbound
) || !CONSP (def
))
1146 /* Not defined or definition not suitable */
1148 if (EQ (XCAR (def
), Qautoload
))
1150 /* Autoloading function: will it be a macro when loaded? */
1151 tem
= Fnth (make_number (4), def
);
1152 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
1153 /* Yes, load it and try again. */
1155 struct gcpro gcpro1
;
1157 do_autoload (def
, sym
);
1164 else if (!EQ (XCAR (def
), Qmacro
))
1166 else expander
= XCDR (def
);
1170 expander
= XCDR (tem
);
1171 if (NILP (expander
))
1174 form
= apply1 (expander
, XCDR (form
));
1179 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1180 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1181 TAG is evalled to get the tag to use; it must not be nil.
1183 Then the BODY is executed.
1184 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
1185 If no throw happens, `catch' returns the value of the last BODY form.
1186 If a throw happens, it specifies the value to return from `catch'.
1187 usage: (catch TAG BODY...) */)
1191 register Lisp_Object tag
;
1192 struct gcpro gcpro1
;
1195 tag
= Feval (Fcar (args
));
1197 return internal_catch (tag
, Fprogn
, Fcdr (args
));
1200 /* Set up a catch, then call C function FUNC on argument ARG.
1201 FUNC should return a Lisp_Object.
1202 This is how catches are done from within C code. */
1205 internal_catch (tag
, func
, arg
)
1207 Lisp_Object (*func
) ();
1210 /* This structure is made part of the chain `catchlist'. */
1213 /* Fill in the components of c, and put it on the list. */
1217 c
.backlist
= backtrace_list
;
1218 c
.handlerlist
= handlerlist
;
1219 c
.lisp_eval_depth
= lisp_eval_depth
;
1220 c
.pdlcount
= SPECPDL_INDEX ();
1221 c
.poll_suppress_count
= poll_suppress_count
;
1222 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1223 c
.gcpro
= gcprolist
;
1224 c
.byte_stack
= byte_stack_list
;
1228 if (! _setjmp (c
.jmp
))
1229 c
.val
= (*func
) (arg
);
1231 /* Throw works by a longjmp that comes right here. */
1236 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1237 jump to that CATCH, returning VALUE as the value of that catch.
1239 This is the guts Fthrow and Fsignal; they differ only in the way
1240 they choose the catch tag to throw to. A catch tag for a
1241 condition-case form has a TAG of Qnil.
1243 Before each catch is discarded, unbind all special bindings and
1244 execute all unwind-protect clauses made above that catch. Unwind
1245 the handler stack as we go, so that the proper handlers are in
1246 effect for each unwind-protect clause we run. At the end, restore
1247 some static info saved in CATCH, and longjmp to the location
1250 This is used for correct unwinding in Fthrow and Fsignal. */
1253 unwind_to_catch (catch, value
)
1254 struct catchtag
*catch;
1257 register int last_time
;
1259 /* Save the value in the tag. */
1262 /* Restore certain special C variables. */
1263 set_poll_suppress_count (catch->poll_suppress_count
);
1264 UNBLOCK_INPUT_TO (catch->interrupt_input_blocked
);
1265 handling_signal
= 0;
1270 last_time
= catchlist
== catch;
1272 /* Unwind the specpdl stack, and then restore the proper set of
1274 unbind_to (catchlist
->pdlcount
, Qnil
);
1275 handlerlist
= catchlist
->handlerlist
;
1276 catchlist
= catchlist
->next
;
1278 while (! last_time
);
1281 /* If x_catch_errors was done, turn it off now.
1282 (First we give unbind_to a chance to do that.) */
1283 #if 0 /* This would disable x_catch_errors after x_connection_closed.
1284 * The catch must remain in effect during that delicate
1285 * state. --lorentey */
1286 x_fully_uncatch_errors ();
1290 byte_stack_list
= catch->byte_stack
;
1291 gcprolist
= catch->gcpro
;
1294 gcpro_level
= gcprolist
->level
+ 1;
1298 backtrace_list
= catch->backlist
;
1299 lisp_eval_depth
= catch->lisp_eval_depth
;
1301 _longjmp (catch->jmp
, 1);
1304 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1305 doc
: /* Throw to the catch for TAG and return VALUE from it.
1306 Both TAG and VALUE are evalled. */)
1308 register Lisp_Object tag
, value
;
1310 register struct catchtag
*c
;
1313 for (c
= catchlist
; c
; c
= c
->next
)
1315 if (EQ (c
->tag
, tag
))
1316 unwind_to_catch (c
, value
);
1318 xsignal2 (Qno_catch
, tag
, value
);
1322 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1323 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1324 If BODYFORM completes normally, its value is returned
1325 after executing the UNWINDFORMS.
1326 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1327 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1332 int count
= SPECPDL_INDEX ();
1334 record_unwind_protect (Fprogn
, Fcdr (args
));
1335 val
= Feval (Fcar (args
));
1336 return unbind_to (count
, val
);
1339 /* Chain of condition handlers currently in effect.
1340 The elements of this chain are contained in the stack frames
1341 of Fcondition_case and internal_condition_case.
1342 When an error is signaled (by calling Fsignal, below),
1343 this chain is searched for an element that applies. */
1345 struct handler
*handlerlist
;
1347 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1348 doc
: /* Regain control when an error is signaled.
1349 Executes BODYFORM and returns its value if no error happens.
1350 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1351 where the BODY is made of Lisp expressions.
1353 A handler is applicable to an error
1354 if CONDITION-NAME is one of the error's condition names.
1355 If an error happens, the first applicable handler is run.
1357 The car of a handler may be a list of condition names
1358 instead of a single condition name. Then it handles all of them.
1360 When a handler handles an error, control returns to the `condition-case'
1361 and it executes the handler's BODY...
1362 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA) from the error.
1363 (If VAR is nil, the handler can't access that information.)
1364 Then the value of the last BODY form is returned from the `condition-case'
1367 See also the function `signal' for more info.
1368 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1372 register Lisp_Object bodyform
, handlers
;
1373 volatile Lisp_Object var
;
1376 bodyform
= Fcar (Fcdr (args
));
1377 handlers
= Fcdr (Fcdr (args
));
1379 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1382 /* Like Fcondition_case, but the args are separate
1383 rather than passed in a list. Used by Fbyte_code. */
1386 internal_lisp_condition_case (var
, bodyform
, handlers
)
1387 volatile Lisp_Object var
;
1388 Lisp_Object bodyform
, handlers
;
1396 for (val
= handlers
; CONSP (val
); val
= XCDR (val
))
1402 && (SYMBOLP (XCAR (tem
))
1403 || CONSP (XCAR (tem
))))))
1404 error ("Invalid condition handler", tem
);
1409 c
.backlist
= backtrace_list
;
1410 c
.handlerlist
= handlerlist
;
1411 c
.lisp_eval_depth
= lisp_eval_depth
;
1412 c
.pdlcount
= SPECPDL_INDEX ();
1413 c
.poll_suppress_count
= poll_suppress_count
;
1414 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1415 c
.gcpro
= gcprolist
;
1416 c
.byte_stack
= byte_stack_list
;
1417 if (_setjmp (c
.jmp
))
1420 specbind (h
.var
, c
.val
);
1421 val
= Fprogn (Fcdr (h
.chosen_clause
));
1423 /* Note that this just undoes the binding of h.var; whoever
1424 longjumped to us unwound the stack to c.pdlcount before
1426 unbind_to (c
.pdlcount
, Qnil
);
1433 h
.handler
= handlers
;
1434 h
.next
= handlerlist
;
1438 val
= Feval (bodyform
);
1440 handlerlist
= h
.next
;
1444 /* Call the function BFUN with no arguments, catching errors within it
1445 according to HANDLERS. If there is an error, call HFUN with
1446 one argument which is the data that describes the error:
1449 HANDLERS can be a list of conditions to catch.
1450 If HANDLERS is Qt, catch all errors.
1451 If HANDLERS is Qerror, catch all errors
1452 but allow the debugger to run if that is enabled. */
1455 internal_condition_case (bfun
, handlers
, hfun
)
1456 Lisp_Object (*bfun
) ();
1457 Lisp_Object handlers
;
1458 Lisp_Object (*hfun
) ();
1464 /* Since Fsignal will close off all calls to x_catch_errors,
1465 we will get the wrong results if some are not closed now. */
1467 if (x_catching_errors ())
1473 c
.backlist
= backtrace_list
;
1474 c
.handlerlist
= handlerlist
;
1475 c
.lisp_eval_depth
= lisp_eval_depth
;
1476 c
.pdlcount
= SPECPDL_INDEX ();
1477 c
.poll_suppress_count
= poll_suppress_count
;
1478 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1479 c
.gcpro
= gcprolist
;
1480 c
.byte_stack
= byte_stack_list
;
1481 if (_setjmp (c
.jmp
))
1483 return (*hfun
) (c
.val
);
1487 h
.handler
= handlers
;
1489 h
.next
= handlerlist
;
1495 handlerlist
= h
.next
;
1499 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1502 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1503 Lisp_Object (*bfun
) ();
1505 Lisp_Object handlers
;
1506 Lisp_Object (*hfun
) ();
1512 /* Since Fsignal will close off all calls to x_catch_errors,
1513 we will get the wrong results if some are not closed now. */
1515 if (x_catching_errors ())
1521 c
.backlist
= backtrace_list
;
1522 c
.handlerlist
= handlerlist
;
1523 c
.lisp_eval_depth
= lisp_eval_depth
;
1524 c
.pdlcount
= SPECPDL_INDEX ();
1525 c
.poll_suppress_count
= poll_suppress_count
;
1526 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1527 c
.gcpro
= gcprolist
;
1528 c
.byte_stack
= byte_stack_list
;
1529 if (_setjmp (c
.jmp
))
1531 return (*hfun
) (c
.val
);
1535 h
.handler
= handlers
;
1537 h
.next
= handlerlist
;
1541 val
= (*bfun
) (arg
);
1543 handlerlist
= h
.next
;
1548 /* Like internal_condition_case but call BFUN with NARGS as first,
1549 and ARGS as second argument. */
1552 internal_condition_case_2 (bfun
, nargs
, args
, handlers
, hfun
)
1553 Lisp_Object (*bfun
) ();
1556 Lisp_Object handlers
;
1557 Lisp_Object (*hfun
) ();
1563 /* Since Fsignal will close off all calls to x_catch_errors,
1564 we will get the wrong results if some are not closed now. */
1566 if (x_catching_errors ())
1572 c
.backlist
= backtrace_list
;
1573 c
.handlerlist
= handlerlist
;
1574 c
.lisp_eval_depth
= lisp_eval_depth
;
1575 c
.pdlcount
= SPECPDL_INDEX ();
1576 c
.poll_suppress_count
= poll_suppress_count
;
1577 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1578 c
.gcpro
= gcprolist
;
1579 c
.byte_stack
= byte_stack_list
;
1580 if (_setjmp (c
.jmp
))
1582 return (*hfun
) (c
.val
);
1586 h
.handler
= handlers
;
1588 h
.next
= handlerlist
;
1592 val
= (*bfun
) (nargs
, args
);
1594 handlerlist
= h
.next
;
1599 static Lisp_Object find_handler_clause
P_ ((Lisp_Object
, Lisp_Object
,
1600 Lisp_Object
, Lisp_Object
));
1602 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1603 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1604 This function does not return.
1606 An error symbol is a symbol with an `error-conditions' property
1607 that is a list of condition names.
1608 A handler for any of those names will get to handle this signal.
1609 The symbol `error' should normally be one of them.
1611 DATA should be a list. Its elements are printed as part of the error message.
1612 See Info anchor `(elisp)Definition of signal' for some details on how this
1613 error message is constructed.
1614 If the signal is handled, DATA is made available to the handler.
1615 See also the function `condition-case'. */)
1616 (error_symbol
, data
)
1617 Lisp_Object error_symbol
, data
;
1619 /* When memory is full, ERROR-SYMBOL is nil,
1620 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1621 That is a special case--don't do this in other situations. */
1622 register struct handler
*allhandlers
= handlerlist
;
1623 Lisp_Object conditions
;
1624 extern int gc_in_progress
;
1625 extern int waiting_for_input
;
1627 Lisp_Object real_error_symbol
;
1628 struct backtrace
*bp
;
1630 immediate_quit
= handling_signal
= 0;
1632 if (gc_in_progress
|| waiting_for_input
)
1635 if (NILP (error_symbol
))
1636 real_error_symbol
= Fcar (data
);
1638 real_error_symbol
= error_symbol
;
1640 #if 0 /* rms: I don't know why this was here,
1641 but it is surely wrong for an error that is handled. */
1642 #ifdef HAVE_X_WINDOWS
1643 if (display_hourglass_p
)
1644 cancel_hourglass ();
1648 /* This hook is used by edebug. */
1649 if (! NILP (Vsignal_hook_function
)
1650 && ! NILP (error_symbol
))
1652 /* Edebug takes care of restoring these variables when it exits. */
1653 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1654 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1656 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1657 max_specpdl_size
= SPECPDL_INDEX () + 40;
1659 call2 (Vsignal_hook_function
, error_symbol
, data
);
1662 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1664 /* Remember from where signal was called. Skip over the frame for
1665 `signal' itself. If a frame for `error' follows, skip that,
1666 too. Don't do this when ERROR_SYMBOL is nil, because that
1667 is a memory-full error. */
1668 Vsignaling_function
= Qnil
;
1669 if (backtrace_list
&& !NILP (error_symbol
))
1671 bp
= backtrace_list
->next
;
1672 if (bp
&& bp
->function
&& EQ (*bp
->function
, Qerror
))
1674 if (bp
&& bp
->function
)
1675 Vsignaling_function
= *bp
->function
;
1678 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1680 register Lisp_Object clause
;
1682 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1683 error_symbol
, data
);
1685 if (EQ (clause
, Qlambda
))
1687 /* We can't return values to code which signaled an error, but we
1688 can continue code which has signaled a quit. */
1689 if (EQ (real_error_symbol
, Qquit
))
1692 error ("Cannot return from the debugger in an error");
1697 Lisp_Object unwind_data
;
1698 struct handler
*h
= handlerlist
;
1700 handlerlist
= allhandlers
;
1702 if (NILP (error_symbol
))
1705 unwind_data
= Fcons (error_symbol
, data
);
1706 h
->chosen_clause
= clause
;
1707 unwind_to_catch (h
->tag
, unwind_data
);
1711 handlerlist
= allhandlers
;
1712 /* If no handler is present now, try to run the debugger,
1713 and if that fails, throw to top level. */
1714 find_handler_clause (Qerror
, conditions
, error_symbol
, data
);
1716 Fthrow (Qtop_level
, Qt
);
1718 if (! NILP (error_symbol
))
1719 data
= Fcons (error_symbol
, data
);
1721 string
= Ferror_message_string (data
);
1722 fatal ("%s", SDATA (string
), 0);
1725 /* Internal version of Fsignal that never returns.
1726 Used for anything but Qquit (which can return from Fsignal). */
1729 xsignal (error_symbol
, data
)
1730 Lisp_Object error_symbol
, data
;
1732 Fsignal (error_symbol
, data
);
1736 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1739 xsignal0 (error_symbol
)
1740 Lisp_Object error_symbol
;
1742 xsignal (error_symbol
, Qnil
);
1746 xsignal1 (error_symbol
, arg
)
1747 Lisp_Object error_symbol
, arg
;
1749 xsignal (error_symbol
, list1 (arg
));
1753 xsignal2 (error_symbol
, arg1
, arg2
)
1754 Lisp_Object error_symbol
, arg1
, arg2
;
1756 xsignal (error_symbol
, list2 (arg1
, arg2
));
1760 xsignal3 (error_symbol
, arg1
, arg2
, arg3
)
1761 Lisp_Object error_symbol
, arg1
, arg2
, arg3
;
1763 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1766 /* Signal `error' with message S, and additional arg ARG.
1767 If ARG is not a genuine list, make it a one-element list. */
1770 signal_error (s
, arg
)
1774 Lisp_Object tortoise
, hare
;
1776 hare
= tortoise
= arg
;
1777 while (CONSP (hare
))
1784 tortoise
= XCDR (tortoise
);
1786 if (EQ (hare
, tortoise
))
1791 arg
= Fcons (arg
, Qnil
); /* Make it a list. */
1793 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1797 /* Return nonzero if LIST is a non-nil atom or
1798 a list containing one of CONDITIONS. */
1801 wants_debugger (list
, conditions
)
1802 Lisp_Object list
, conditions
;
1809 while (CONSP (conditions
))
1811 Lisp_Object
this, tail
;
1812 this = XCAR (conditions
);
1813 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1814 if (EQ (XCAR (tail
), this))
1816 conditions
= XCDR (conditions
);
1821 /* Return 1 if an error with condition-symbols CONDITIONS,
1822 and described by SIGNAL-DATA, should skip the debugger
1823 according to debugger-ignored-errors. */
1826 skip_debugger (conditions
, data
)
1827 Lisp_Object conditions
, data
;
1830 int first_string
= 1;
1831 Lisp_Object error_message
;
1833 error_message
= Qnil
;
1834 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1836 if (STRINGP (XCAR (tail
)))
1840 error_message
= Ferror_message_string (data
);
1844 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1849 Lisp_Object contail
;
1851 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1852 if (EQ (XCAR (tail
), XCAR (contail
)))
1860 /* Value of Qlambda means we have called debugger and user has continued.
1861 There are two ways to pass SIG and DATA:
1862 = SIG is the error symbol, and DATA is the rest of the data.
1863 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1864 This is for memory-full errors only.
1866 We need to increase max_specpdl_size temporarily around
1867 anything we do that can push on the specpdl, so as not to get
1868 a second error here in case we're handling specpdl overflow. */
1871 find_handler_clause (handlers
, conditions
, sig
, data
)
1872 Lisp_Object handlers
, conditions
, sig
, data
;
1874 register Lisp_Object h
;
1875 register Lisp_Object tem
;
1876 int debugger_called
= 0;
1877 int debugger_considered
= 0;
1879 /* t is used by handlers for all conditions, set up by C code. */
1880 if (EQ (handlers
, Qt
))
1883 /* Don't run the debugger for a memory-full error.
1884 (There is no room in memory to do that!) */
1886 debugger_considered
= 1;
1888 /* error is used similarly, but means print an error message
1889 and run the debugger if that is enabled. */
1890 if (EQ (handlers
, Qerror
)
1891 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1892 there is a handler. */
1894 if (!NILP (sig
) && wants_debugger (Vstack_trace_on_error
, conditions
))
1898 internal_with_output_to_temp_buffer ("*Backtrace*",
1899 (Lisp_Object (*) (Lisp_Object
)) Fbacktrace
,
1902 internal_with_output_to_temp_buffer ("*Backtrace*",
1908 if (!debugger_considered
)
1910 debugger_considered
= 1;
1911 debugger_called
= maybe_call_debugger (conditions
, sig
, data
);
1914 /* If there is no handler, return saying whether we ran the debugger. */
1915 if (EQ (handlers
, Qerror
))
1917 if (debugger_called
)
1923 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1925 Lisp_Object handler
, condit
;
1928 if (!CONSP (handler
))
1930 condit
= Fcar (handler
);
1931 /* Handle a single condition name in handler HANDLER. */
1932 if (SYMBOLP (condit
))
1934 tem
= Fmemq (Fcar (handler
), conditions
);
1938 /* Handle a list of condition names in handler HANDLER. */
1939 else if (CONSP (condit
))
1942 for (tail
= condit
; CONSP (tail
); tail
= XCDR (tail
))
1944 tem
= Fmemq (Fcar (tail
), conditions
);
1947 /* This handler is going to apply.
1948 Does it allow the debugger to run first? */
1949 if (! debugger_considered
&& !NILP (Fmemq (Qdebug
, condit
)))
1950 maybe_call_debugger (conditions
, sig
, data
);
1960 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1961 SIG and DATA describe the signal, as in find_handler_clause. */
1964 maybe_call_debugger (conditions
, sig
, data
)
1965 Lisp_Object conditions
, sig
, data
;
1967 Lisp_Object combined_data
;
1969 combined_data
= Fcons (sig
, data
);
1972 /* Don't try to run the debugger with interrupts blocked.
1973 The editing loop would return anyway. */
1975 /* Does user wants to enter debugger for this kind of error? */
1978 : wants_debugger (Vdebug_on_error
, conditions
))
1979 && ! skip_debugger (conditions
, combined_data
)
1980 /* rms: what's this for? */
1981 && when_entered_debugger
< num_nonmacro_input_events
)
1983 call_debugger (Fcons (Qerror
, Fcons (combined_data
, Qnil
)));
1990 /* dump an error message; called like printf */
1994 error (m
, a1
, a2
, a3
)
2014 int used
= doprnt (buffer
, size
, m
, m
+ mlen
, 3, args
);
2019 buffer
= (char *) xrealloc (buffer
, size
);
2022 buffer
= (char *) xmalloc (size
);
2027 string
= build_string (buffer
);
2031 xsignal1 (Qerror
, string
);
2034 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
2035 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
2036 This means it contains a description for how to read arguments to give it.
2037 The value is nil for an invalid function or a symbol with no function
2040 Interactively callable functions include strings and vectors (treated
2041 as keyboard macros), lambda-expressions that contain a top-level call
2042 to `interactive', autoload definitions made by `autoload' with non-nil
2043 fourth argument, and some of the built-in functions of Lisp.
2045 Also, a symbol satisfies `commandp' if its function definition does so.
2047 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
2048 then strings and vectors are not accepted. */)
2049 (function
, for_call_interactively
)
2050 Lisp_Object function
, for_call_interactively
;
2052 register Lisp_Object fun
;
2053 register Lisp_Object funcar
;
2054 Lisp_Object if_prop
= Qnil
;
2058 fun
= indirect_function (fun
); /* Check cycles. */
2059 if (NILP (fun
) || EQ (fun
, Qunbound
))
2062 /* Check an `interactive-form' property if present, analogous to the
2063 function-documentation property. */
2065 while (SYMBOLP (fun
))
2067 Lisp_Object tmp
= Fget (fun
, intern ("interactive-form"));
2070 fun
= Fsymbol_function (fun
);
2073 /* Emacs primitives are interactive if their DEFUN specifies an
2074 interactive spec. */
2076 return XSUBR (fun
)->intspec
? Qt
: if_prop
;
2078 /* Bytecode objects are interactive if they are long enough to
2079 have an element whose index is COMPILED_INTERACTIVE, which is
2080 where the interactive spec is stored. */
2081 else if (COMPILEDP (fun
))
2082 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
2085 /* Strings and vectors are keyboard macros. */
2086 if (STRINGP (fun
) || VECTORP (fun
))
2087 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
2089 /* Lists may represent commands. */
2092 funcar
= XCAR (fun
);
2093 if (EQ (funcar
, Qlambda
))
2094 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
2095 if (EQ (funcar
, Qautoload
))
2096 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
2102 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
2103 doc
: /* Define FUNCTION to autoload from FILE.
2104 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
2105 Third arg DOCSTRING is documentation for the function.
2106 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
2107 Fifth arg TYPE indicates the type of the object:
2108 nil or omitted says FUNCTION is a function,
2109 `keymap' says FUNCTION is really a keymap, and
2110 `macro' or t says FUNCTION is really a macro.
2111 Third through fifth args give info about the real definition.
2112 They default to nil.
2113 If FUNCTION is already defined other than as an autoload,
2114 this does nothing and returns nil. */)
2115 (function
, file
, docstring
, interactive
, type
)
2116 Lisp_Object function
, file
, docstring
, interactive
, type
;
2119 Lisp_Object args
[4];
2122 CHECK_SYMBOL (function
);
2123 CHECK_STRING (file
);
2125 /* If function is defined and not as an autoload, don't override */
2126 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
2127 && !(CONSP (XSYMBOL (function
)->function
)
2128 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
2131 if (NILP (Vpurify_flag
))
2132 /* Only add entries after dumping, because the ones before are
2133 not useful and else we get loads of them from the loaddefs.el. */
2134 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
2138 args
[1] = docstring
;
2139 args
[2] = interactive
;
2142 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
2143 #else /* NO_ARG_ARRAY */
2144 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
2145 #endif /* not NO_ARG_ARRAY */
2149 un_autoload (oldqueue
)
2150 Lisp_Object oldqueue
;
2152 register Lisp_Object queue
, first
, second
;
2154 /* Queue to unwind is current value of Vautoload_queue.
2155 oldqueue is the shadowed value to leave in Vautoload_queue. */
2156 queue
= Vautoload_queue
;
2157 Vautoload_queue
= oldqueue
;
2158 while (CONSP (queue
))
2160 first
= XCAR (queue
);
2161 second
= Fcdr (first
);
2162 first
= Fcar (first
);
2163 if (EQ (first
, make_number (0)))
2166 Ffset (first
, second
);
2167 queue
= XCDR (queue
);
2172 /* Load an autoloaded function.
2173 FUNNAME is the symbol which is the function's name.
2174 FUNDEF is the autoload definition (a list). */
2177 do_autoload (fundef
, funname
)
2178 Lisp_Object fundef
, funname
;
2180 int count
= SPECPDL_INDEX ();
2181 Lisp_Object fun
, queue
, first
, second
;
2182 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2184 /* This is to make sure that loadup.el gives a clear picture
2185 of what files are preloaded and when. */
2186 if (! NILP (Vpurify_flag
))
2187 error ("Attempt to autoload %s while preparing to dump",
2188 SDATA (SYMBOL_NAME (funname
)));
2191 CHECK_SYMBOL (funname
);
2192 GCPRO3 (fun
, funname
, fundef
);
2194 /* Preserve the match data. */
2195 record_unwind_save_match_data ();
2197 /* Value saved here is to be restored into Vautoload_queue. */
2198 record_unwind_protect (un_autoload
, Vautoload_queue
);
2199 Vautoload_queue
= Qt
;
2200 Fload (Fcar (Fcdr (fundef
)), Qnil
, Qt
, Qnil
, Qt
);
2202 /* Save the old autoloads, in case we ever do an unload. */
2203 queue
= Vautoload_queue
;
2204 while (CONSP (queue
))
2206 first
= XCAR (queue
);
2207 second
= Fcdr (first
);
2208 first
= Fcar (first
);
2210 if (SYMBOLP (first
) && CONSP (second
) && EQ (XCAR (second
), Qautoload
))
2211 Fput (first
, Qautoload
, (XCDR (second
)));
2213 queue
= XCDR (queue
);
2216 /* Once loading finishes, don't undo it. */
2217 Vautoload_queue
= Qt
;
2218 unbind_to (count
, Qnil
);
2220 fun
= Findirect_function (fun
, Qnil
);
2222 if (!NILP (Fequal (fun
, fundef
)))
2223 error ("Autoloading failed to define function %s",
2224 SDATA (SYMBOL_NAME (funname
)));
2229 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
2230 doc
: /* Evaluate FORM and return its value. */)
2234 Lisp_Object fun
, val
, original_fun
, original_args
;
2236 struct backtrace backtrace
;
2237 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2239 if (handling_signal
)
2243 return Fsymbol_value (form
);
2248 if ((consing_since_gc
> gc_cons_threshold
2249 && consing_since_gc
> gc_relative_threshold
)
2251 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2254 Fgarbage_collect ();
2258 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2260 if (max_lisp_eval_depth
< 100)
2261 max_lisp_eval_depth
= 100;
2262 if (lisp_eval_depth
> max_lisp_eval_depth
)
2263 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2266 original_fun
= Fcar (form
);
2267 original_args
= Fcdr (form
);
2269 backtrace
.next
= backtrace_list
;
2270 backtrace_list
= &backtrace
;
2271 backtrace
.function
= &original_fun
; /* This also protects them from gc */
2272 backtrace
.args
= &original_args
;
2273 backtrace
.nargs
= UNEVALLED
;
2274 backtrace
.evalargs
= 1;
2275 backtrace
.debug_on_exit
= 0;
2277 if (debug_on_next_call
)
2278 do_debug_on_call (Qt
);
2280 /* At this point, only original_fun and original_args
2281 have values that will be used below */
2284 /* Optimize for no indirection. */
2286 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2287 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2288 fun
= indirect_function (fun
);
2292 Lisp_Object numargs
;
2293 Lisp_Object argvals
[8];
2294 Lisp_Object args_left
;
2295 register int i
, maxargs
;
2297 args_left
= original_args
;
2298 numargs
= Flength (args_left
);
2302 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
2303 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2304 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2306 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2308 backtrace
.evalargs
= 0;
2309 val
= (*XSUBR (fun
)->function
) (args_left
);
2313 if (XSUBR (fun
)->max_args
== MANY
)
2315 /* Pass a vector of evaluated arguments */
2317 register int argnum
= 0;
2319 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2321 GCPRO3 (args_left
, fun
, fun
);
2325 while (!NILP (args_left
))
2327 vals
[argnum
++] = Feval (Fcar (args_left
));
2328 args_left
= Fcdr (args_left
);
2329 gcpro3
.nvars
= argnum
;
2332 backtrace
.args
= vals
;
2333 backtrace
.nargs
= XINT (numargs
);
2335 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
2340 GCPRO3 (args_left
, fun
, fun
);
2341 gcpro3
.var
= argvals
;
2344 maxargs
= XSUBR (fun
)->max_args
;
2345 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
2347 argvals
[i
] = Feval (Fcar (args_left
));
2353 backtrace
.args
= argvals
;
2354 backtrace
.nargs
= XINT (numargs
);
2359 val
= (*XSUBR (fun
)->function
) ();
2362 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
2365 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
2368 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2372 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2373 argvals
[2], argvals
[3]);
2376 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2377 argvals
[3], argvals
[4]);
2380 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2381 argvals
[3], argvals
[4], argvals
[5]);
2384 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2385 argvals
[3], argvals
[4], argvals
[5],
2390 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2391 argvals
[3], argvals
[4], argvals
[5],
2392 argvals
[6], argvals
[7]);
2396 /* Someone has created a subr that takes more arguments than
2397 is supported by this code. We need to either rewrite the
2398 subr to use a different argument protocol, or add more
2399 cases to this switch. */
2403 if (COMPILEDP (fun
))
2404 val
= apply_lambda (fun
, original_args
, 1);
2407 if (EQ (fun
, Qunbound
))
2408 xsignal1 (Qvoid_function
, original_fun
);
2410 xsignal1 (Qinvalid_function
, original_fun
);
2411 funcar
= XCAR (fun
);
2412 if (!SYMBOLP (funcar
))
2413 xsignal1 (Qinvalid_function
, original_fun
);
2414 if (EQ (funcar
, Qautoload
))
2416 do_autoload (fun
, original_fun
);
2419 if (EQ (funcar
, Qmacro
))
2420 val
= Feval (apply1 (Fcdr (fun
), original_args
));
2421 else if (EQ (funcar
, Qlambda
))
2422 val
= apply_lambda (fun
, original_args
, 1);
2424 xsignal1 (Qinvalid_function
, original_fun
);
2430 if (backtrace
.debug_on_exit
)
2431 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2432 backtrace_list
= backtrace
.next
;
2437 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
2438 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2439 Then return the value FUNCTION returns.
2440 Thus, (apply '+ 1 2 '(3 4)) returns 10.
2441 usage: (apply FUNCTION &rest ARGUMENTS) */)
2446 register int i
, numargs
;
2447 register Lisp_Object spread_arg
;
2448 register Lisp_Object
*funcall_args
;
2450 struct gcpro gcpro1
;
2454 spread_arg
= args
[nargs
- 1];
2455 CHECK_LIST (spread_arg
);
2457 numargs
= XINT (Flength (spread_arg
));
2460 return Ffuncall (nargs
- 1, args
);
2461 else if (numargs
== 1)
2463 args
[nargs
- 1] = XCAR (spread_arg
);
2464 return Ffuncall (nargs
, args
);
2467 numargs
+= nargs
- 2;
2469 /* Optimize for no indirection. */
2470 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2471 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2472 fun
= indirect_function (fun
);
2473 if (EQ (fun
, Qunbound
))
2475 /* Let funcall get the error */
2482 if (numargs
< XSUBR (fun
)->min_args
2483 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2484 goto funcall
; /* Let funcall get the error */
2485 else if (XSUBR (fun
)->max_args
> numargs
)
2487 /* Avoid making funcall cons up a yet another new vector of arguments
2488 by explicitly supplying nil's for optional values */
2489 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
2490 * sizeof (Lisp_Object
));
2491 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2492 funcall_args
[++i
] = Qnil
;
2493 GCPRO1 (*funcall_args
);
2494 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2498 /* We add 1 to numargs because funcall_args includes the
2499 function itself as well as its arguments. */
2502 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
2503 * sizeof (Lisp_Object
));
2504 GCPRO1 (*funcall_args
);
2505 gcpro1
.nvars
= 1 + numargs
;
2508 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
2509 /* Spread the last arg we got. Its first element goes in
2510 the slot that it used to occupy, hence this value of I. */
2512 while (!NILP (spread_arg
))
2514 funcall_args
[i
++] = XCAR (spread_arg
);
2515 spread_arg
= XCDR (spread_arg
);
2518 /* By convention, the caller needs to gcpro Ffuncall's args. */
2519 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
2522 /* Run hook variables in various ways. */
2524 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
2525 static Lisp_Object run_hook_with_args
P_ ((int, Lisp_Object
*,
2526 enum run_hooks_condition
));
2528 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2529 doc
: /* Run each hook in HOOKS.
2530 Each argument should be a symbol, a hook variable.
2531 These symbols are processed in the order specified.
2532 If a hook symbol has a non-nil value, that value may be a function
2533 or a list of functions to be called to run the hook.
2534 If the value is a function, it is called with no arguments.
2535 If it is a list, the elements are called, in order, with no arguments.
2537 Major modes should not use this function directly to run their mode
2538 hook; they should use `run-mode-hooks' instead.
2540 Do not use `make-local-variable' to make a hook variable buffer-local.
2541 Instead, use `add-hook' and specify t for the LOCAL argument.
2542 usage: (run-hooks &rest HOOKS) */)
2547 Lisp_Object hook
[1];
2550 for (i
= 0; i
< nargs
; i
++)
2553 run_hook_with_args (1, hook
, to_completion
);
2559 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2560 Srun_hook_with_args
, 1, MANY
, 0,
2561 doc
: /* Run HOOK with the specified arguments ARGS.
2562 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2563 value, that value may be a function or a list of functions to be
2564 called to run the hook. If the value is a function, it is called with
2565 the given arguments and its return value is returned. If it is a list
2566 of functions, those functions are called, in order,
2567 with the given arguments ARGS.
2568 It is best not to depend on the value returned by `run-hook-with-args',
2571 Do not use `make-local-variable' to make a hook variable buffer-local.
2572 Instead, use `add-hook' and specify t for the LOCAL argument.
2573 usage: (run-hook-with-args HOOK &rest ARGS) */)
2578 return run_hook_with_args (nargs
, args
, to_completion
);
2581 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2582 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2583 doc
: /* Run HOOK with the specified arguments ARGS.
2584 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2585 value, that value may be a function or a list of functions to be
2586 called to run the hook. If the value is a function, it is called with
2587 the given arguments and its return value is returned.
2588 If it is a list of functions, those functions are called, in order,
2589 with the given arguments ARGS, until one of them
2590 returns a non-nil value. Then we return that value.
2591 However, if they all return nil, we return nil.
2593 Do not use `make-local-variable' to make a hook variable buffer-local.
2594 Instead, use `add-hook' and specify t for the LOCAL argument.
2595 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2600 return run_hook_with_args (nargs
, args
, until_success
);
2603 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2604 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2605 doc
: /* Run HOOK with the specified arguments ARGS.
2606 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2607 value, that value may be a function or a list of functions to be
2608 called to run the hook. If the value is a function, it is called with
2609 the given arguments and its return value is returned.
2610 If it is a list of functions, those functions are called, in order,
2611 with the given arguments ARGS, until one of them returns nil.
2612 Then we return nil. However, if they all return non-nil, we return non-nil.
2614 Do not use `make-local-variable' to make a hook variable buffer-local.
2615 Instead, use `add-hook' and specify t for the LOCAL argument.
2616 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2621 return run_hook_with_args (nargs
, args
, until_failure
);
2624 /* ARGS[0] should be a hook symbol.
2625 Call each of the functions in the hook value, passing each of them
2626 as arguments all the rest of ARGS (all NARGS - 1 elements).
2627 COND specifies a condition to test after each call
2628 to decide whether to stop.
2629 The caller (or its caller, etc) must gcpro all of ARGS,
2630 except that it isn't necessary to gcpro ARGS[0]. */
2633 run_hook_with_args (nargs
, args
, cond
)
2636 enum run_hooks_condition cond
;
2638 Lisp_Object sym
, val
, ret
;
2639 Lisp_Object globals
;
2640 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2642 /* If we are dying or still initializing,
2643 don't do anything--it would probably crash if we tried. */
2644 if (NILP (Vrun_hooks
))
2648 val
= find_symbol_value (sym
);
2649 ret
= (cond
== until_failure
? Qt
: Qnil
);
2651 if (EQ (val
, Qunbound
) || NILP (val
))
2653 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2656 return Ffuncall (nargs
, args
);
2661 GCPRO3 (sym
, val
, globals
);
2664 CONSP (val
) && ((cond
== to_completion
)
2665 || (cond
== until_success
? NILP (ret
)
2669 if (EQ (XCAR (val
), Qt
))
2671 /* t indicates this hook has a local binding;
2672 it means to run the global binding too. */
2674 for (globals
= Fdefault_value (sym
);
2675 CONSP (globals
) && ((cond
== to_completion
)
2676 || (cond
== until_success
? NILP (ret
)
2678 globals
= XCDR (globals
))
2680 args
[0] = XCAR (globals
);
2681 /* In a global value, t should not occur. If it does, we
2682 must ignore it to avoid an endless loop. */
2683 if (!EQ (args
[0], Qt
))
2684 ret
= Ffuncall (nargs
, args
);
2689 args
[0] = XCAR (val
);
2690 ret
= Ffuncall (nargs
, args
);
2699 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2700 present value of that symbol.
2701 Call each element of FUNLIST,
2702 passing each of them the rest of ARGS.
2703 The caller (or its caller, etc) must gcpro all of ARGS,
2704 except that it isn't necessary to gcpro ARGS[0]. */
2707 run_hook_list_with_args (funlist
, nargs
, args
)
2708 Lisp_Object funlist
;
2714 Lisp_Object globals
;
2715 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2719 GCPRO3 (sym
, val
, globals
);
2721 for (val
= funlist
; CONSP (val
); val
= XCDR (val
))
2723 if (EQ (XCAR (val
), Qt
))
2725 /* t indicates this hook has a local binding;
2726 it means to run the global binding too. */
2728 for (globals
= Fdefault_value (sym
);
2730 globals
= XCDR (globals
))
2732 args
[0] = XCAR (globals
);
2733 /* In a global value, t should not occur. If it does, we
2734 must ignore it to avoid an endless loop. */
2735 if (!EQ (args
[0], Qt
))
2736 Ffuncall (nargs
, args
);
2741 args
[0] = XCAR (val
);
2742 Ffuncall (nargs
, args
);
2749 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2752 run_hook_with_args_2 (hook
, arg1
, arg2
)
2753 Lisp_Object hook
, arg1
, arg2
;
2755 Lisp_Object temp
[3];
2760 Frun_hook_with_args (3, temp
);
2763 /* Apply fn to arg */
2766 Lisp_Object fn
, arg
;
2768 struct gcpro gcpro1
;
2772 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2776 Lisp_Object args
[2];
2780 RETURN_UNGCPRO (Fapply (2, args
));
2782 #else /* not NO_ARG_ARRAY */
2783 RETURN_UNGCPRO (Fapply (2, &fn
));
2784 #endif /* not NO_ARG_ARRAY */
2787 /* Call function fn on no arguments */
2792 struct gcpro gcpro1
;
2795 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2798 /* Call function fn with 1 argument arg1 */
2802 Lisp_Object fn
, arg1
;
2804 struct gcpro gcpro1
;
2806 Lisp_Object args
[2];
2812 RETURN_UNGCPRO (Ffuncall (2, args
));
2813 #else /* not NO_ARG_ARRAY */
2816 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2817 #endif /* not NO_ARG_ARRAY */
2820 /* Call function fn with 2 arguments arg1, arg2 */
2823 call2 (fn
, arg1
, arg2
)
2824 Lisp_Object fn
, arg1
, arg2
;
2826 struct gcpro gcpro1
;
2828 Lisp_Object args
[3];
2834 RETURN_UNGCPRO (Ffuncall (3, args
));
2835 #else /* not NO_ARG_ARRAY */
2838 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2839 #endif /* not NO_ARG_ARRAY */
2842 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2845 call3 (fn
, arg1
, arg2
, arg3
)
2846 Lisp_Object fn
, arg1
, arg2
, arg3
;
2848 struct gcpro gcpro1
;
2850 Lisp_Object args
[4];
2857 RETURN_UNGCPRO (Ffuncall (4, args
));
2858 #else /* not NO_ARG_ARRAY */
2861 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2862 #endif /* not NO_ARG_ARRAY */
2865 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2868 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2869 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2871 struct gcpro gcpro1
;
2873 Lisp_Object args
[5];
2881 RETURN_UNGCPRO (Ffuncall (5, args
));
2882 #else /* not NO_ARG_ARRAY */
2885 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2886 #endif /* not NO_ARG_ARRAY */
2889 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2892 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2893 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2895 struct gcpro gcpro1
;
2897 Lisp_Object args
[6];
2906 RETURN_UNGCPRO (Ffuncall (6, args
));
2907 #else /* not NO_ARG_ARRAY */
2910 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2911 #endif /* not NO_ARG_ARRAY */
2914 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2917 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2918 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2920 struct gcpro gcpro1
;
2922 Lisp_Object args
[7];
2932 RETURN_UNGCPRO (Ffuncall (7, args
));
2933 #else /* not NO_ARG_ARRAY */
2936 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2937 #endif /* not NO_ARG_ARRAY */
2940 /* The caller should GCPRO all the elements of ARGS. */
2942 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2943 doc
: /* Call first argument as a function, passing remaining arguments to it.
2944 Return the value that function returns.
2945 Thus, (funcall 'cons 'x 'y) returns (x . y).
2946 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2951 Lisp_Object fun
, original_fun
;
2953 int numargs
= nargs
- 1;
2954 Lisp_Object lisp_numargs
;
2956 struct backtrace backtrace
;
2957 register Lisp_Object
*internal_args
;
2961 if ((consing_since_gc
> gc_cons_threshold
2962 && consing_since_gc
> gc_relative_threshold
)
2964 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2965 Fgarbage_collect ();
2967 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2969 if (max_lisp_eval_depth
< 100)
2970 max_lisp_eval_depth
= 100;
2971 if (lisp_eval_depth
> max_lisp_eval_depth
)
2972 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2975 backtrace
.next
= backtrace_list
;
2976 backtrace_list
= &backtrace
;
2977 backtrace
.function
= &args
[0];
2978 backtrace
.args
= &args
[1];
2979 backtrace
.nargs
= nargs
- 1;
2980 backtrace
.evalargs
= 0;
2981 backtrace
.debug_on_exit
= 0;
2983 if (debug_on_next_call
)
2984 do_debug_on_call (Qlambda
);
2988 original_fun
= args
[0];
2992 /* Optimize for no indirection. */
2994 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2995 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2996 fun
= indirect_function (fun
);
3000 if (numargs
< XSUBR (fun
)->min_args
3001 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
3003 XSETFASTINT (lisp_numargs
, numargs
);
3004 xsignal2 (Qwrong_number_of_arguments
, original_fun
, lisp_numargs
);
3007 if (XSUBR (fun
)->max_args
== UNEVALLED
)
3008 xsignal1 (Qinvalid_function
, original_fun
);
3010 if (XSUBR (fun
)->max_args
== MANY
)
3012 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
3016 if (XSUBR (fun
)->max_args
> numargs
)
3018 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
3019 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
3020 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
3021 internal_args
[i
] = Qnil
;
3024 internal_args
= args
+ 1;
3025 switch (XSUBR (fun
)->max_args
)
3028 val
= (*XSUBR (fun
)->function
) ();
3031 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
3034 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1]);
3037 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3041 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3042 internal_args
[2], internal_args
[3]);
3045 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3046 internal_args
[2], internal_args
[3],
3050 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3051 internal_args
[2], internal_args
[3],
3052 internal_args
[4], internal_args
[5]);
3055 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3056 internal_args
[2], internal_args
[3],
3057 internal_args
[4], internal_args
[5],
3062 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3063 internal_args
[2], internal_args
[3],
3064 internal_args
[4], internal_args
[5],
3065 internal_args
[6], internal_args
[7]);
3070 /* If a subr takes more than 8 arguments without using MANY
3071 or UNEVALLED, we need to extend this function to support it.
3072 Until this is done, there is no way to call the function. */
3076 if (COMPILEDP (fun
))
3077 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3080 if (EQ (fun
, Qunbound
))
3081 xsignal1 (Qvoid_function
, original_fun
);
3083 xsignal1 (Qinvalid_function
, original_fun
);
3084 funcar
= XCAR (fun
);
3085 if (!SYMBOLP (funcar
))
3086 xsignal1 (Qinvalid_function
, original_fun
);
3087 if (EQ (funcar
, Qlambda
))
3088 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3089 else if (EQ (funcar
, Qautoload
))
3091 do_autoload (fun
, original_fun
);
3096 xsignal1 (Qinvalid_function
, original_fun
);
3101 if (backtrace
.debug_on_exit
)
3102 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
3103 backtrace_list
= backtrace
.next
;
3108 apply_lambda (fun
, args
, eval_flag
)
3109 Lisp_Object fun
, args
;
3112 Lisp_Object args_left
;
3113 Lisp_Object numargs
;
3114 register Lisp_Object
*arg_vector
;
3115 struct gcpro gcpro1
, gcpro2
, gcpro3
;
3117 register Lisp_Object tem
;
3119 numargs
= Flength (args
);
3120 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
3123 GCPRO3 (*arg_vector
, args_left
, fun
);
3126 for (i
= 0; i
< XINT (numargs
);)
3128 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
3129 if (eval_flag
) tem
= Feval (tem
);
3130 arg_vector
[i
++] = tem
;
3138 backtrace_list
->args
= arg_vector
;
3139 backtrace_list
->nargs
= i
;
3141 backtrace_list
->evalargs
= 0;
3142 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
3144 /* Do the debug-on-exit now, while arg_vector still exists. */
3145 if (backtrace_list
->debug_on_exit
)
3146 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
3147 /* Don't do it again when we return to eval. */
3148 backtrace_list
->debug_on_exit
= 0;
3152 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
3153 and return the result of evaluation.
3154 FUN must be either a lambda-expression or a compiled-code object. */
3157 funcall_lambda (fun
, nargs
, arg_vector
)
3160 register Lisp_Object
*arg_vector
;
3162 Lisp_Object val
, syms_left
, next
;
3163 int count
= SPECPDL_INDEX ();
3164 int i
, optional
, rest
;
3168 syms_left
= XCDR (fun
);
3169 if (CONSP (syms_left
))
3170 syms_left
= XCAR (syms_left
);
3172 xsignal1 (Qinvalid_function
, fun
);
3174 else if (COMPILEDP (fun
))
3175 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3179 i
= optional
= rest
= 0;
3180 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3184 next
= XCAR (syms_left
);
3185 if (!SYMBOLP (next
))
3186 xsignal1 (Qinvalid_function
, fun
);
3188 if (EQ (next
, Qand_rest
))
3190 else if (EQ (next
, Qand_optional
))
3194 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
3198 specbind (next
, arg_vector
[i
++]);
3200 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3202 specbind (next
, Qnil
);
3205 if (!NILP (syms_left
))
3206 xsignal1 (Qinvalid_function
, fun
);
3208 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3211 val
= Fprogn (XCDR (XCDR (fun
)));
3214 /* If we have not actually read the bytecode string
3215 and constants vector yet, fetch them from the file. */
3216 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3217 Ffetch_bytecode (fun
);
3218 val
= Fbyte_code (AREF (fun
, COMPILED_BYTECODE
),
3219 AREF (fun
, COMPILED_CONSTANTS
),
3220 AREF (fun
, COMPILED_STACK_DEPTH
));
3223 return unbind_to (count
, val
);
3226 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3228 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3234 if (COMPILEDP (object
) && CONSP (AREF (object
, COMPILED_BYTECODE
)))
3236 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3239 tem
= AREF (object
, COMPILED_BYTECODE
);
3240 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3241 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3243 error ("Invalid byte code");
3245 AREF (object
, COMPILED_BYTECODE
) = XCAR (tem
);
3246 AREF (object
, COMPILED_CONSTANTS
) = XCDR (tem
);
3254 register int count
= SPECPDL_INDEX ();
3255 if (specpdl_size
>= max_specpdl_size
)
3257 if (max_specpdl_size
< 400)
3258 max_specpdl_size
= 400;
3259 if (specpdl_size
>= max_specpdl_size
)
3260 signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil
);
3263 if (specpdl_size
> max_specpdl_size
)
3264 specpdl_size
= max_specpdl_size
;
3265 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
3266 specpdl_ptr
= specpdl
+ count
;
3270 specbind (symbol
, value
)
3271 Lisp_Object symbol
, value
;
3274 Lisp_Object valcontents
;
3276 CHECK_SYMBOL (symbol
);
3277 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3280 /* The most common case is that of a non-constant symbol with a
3281 trivial value. Make that as fast as we can. */
3282 valcontents
= SYMBOL_VALUE (symbol
);
3283 if (!MISCP (valcontents
) && !SYMBOL_CONSTANT_P (symbol
))
3285 specpdl_ptr
->symbol
= symbol
;
3286 specpdl_ptr
->old_value
= valcontents
;
3287 specpdl_ptr
->func
= NULL
;
3289 SET_SYMBOL_VALUE (symbol
, value
);
3293 Lisp_Object valcontents
;
3295 ovalue
= find_symbol_value (symbol
);
3296 specpdl_ptr
->func
= 0;
3297 specpdl_ptr
->old_value
= ovalue
;
3299 valcontents
= XSYMBOL (symbol
)->value
;
3301 if (BUFFER_LOCAL_VALUEP (valcontents
)
3302 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
3303 || BUFFER_OBJFWDP (valcontents
))
3305 Lisp_Object where
, current_buffer
;
3307 current_buffer
= Fcurrent_buffer ();
3309 /* For a local variable, record both the symbol and which
3310 buffer's or frame's value we are saving. */
3311 if (!NILP (Flocal_variable_p (symbol
, Qnil
)))
3312 where
= current_buffer
;
3313 else if (!BUFFER_OBJFWDP (valcontents
)
3314 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
3315 where
= XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
3319 /* We're not using the `unused' slot in the specbinding
3320 structure because this would mean we have to do more
3321 work for simple variables. */
3322 specpdl_ptr
->symbol
= Fcons (symbol
, Fcons (where
, current_buffer
));
3324 /* If SYMBOL is a per-buffer variable which doesn't have a
3325 buffer-local value here, make the `let' change the global
3326 value by changing the value of SYMBOL in all buffers not
3327 having their own value. This is consistent with what
3328 happens with other buffer-local variables. */
3330 && BUFFER_OBJFWDP (valcontents
))
3333 Fset_default (symbol
, value
);
3338 specpdl_ptr
->symbol
= symbol
;
3341 if (BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
))
3342 store_symval_forwarding (symbol
, ovalue
, value
, NULL
);
3344 set_internal (symbol
, value
, 0, 1);
3349 record_unwind_protect (function
, arg
)
3350 Lisp_Object (*function
) P_ ((Lisp_Object
));
3353 eassert (!handling_signal
);
3355 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3357 specpdl_ptr
->func
= function
;
3358 specpdl_ptr
->symbol
= Qnil
;
3359 specpdl_ptr
->old_value
= arg
;
3364 unbind_to (count
, value
)
3368 Lisp_Object quitf
= Vquit_flag
;
3369 struct gcpro gcpro1
, gcpro2
;
3371 GCPRO2 (value
, quitf
);
3374 while (specpdl_ptr
!= specpdl
+ count
)
3376 /* Copy the binding, and decrement specpdl_ptr, before we do
3377 the work to unbind it. We decrement first
3378 so that an error in unbinding won't try to unbind
3379 the same entry again, and we copy the binding first
3380 in case more bindings are made during some of the code we run. */
3382 struct specbinding this_binding
;
3383 this_binding
= *--specpdl_ptr
;
3385 if (this_binding
.func
!= 0)
3386 (*this_binding
.func
) (this_binding
.old_value
);
3387 /* If the symbol is a list, it is really (SYMBOL WHERE
3388 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3389 frame. If WHERE is a buffer or frame, this indicates we
3390 bound a variable that had a buffer-local or frame-local
3391 binding. WHERE nil means that the variable had the default
3392 value when it was bound. CURRENT-BUFFER is the buffer that
3393 was current when the variable was bound. */
3394 else if (CONSP (this_binding
.symbol
))
3396 Lisp_Object symbol
, where
;
3398 symbol
= XCAR (this_binding
.symbol
);
3399 where
= XCAR (XCDR (this_binding
.symbol
));
3402 Fset_default (symbol
, this_binding
.old_value
);
3403 else if (BUFFERP (where
))
3404 set_internal (symbol
, this_binding
.old_value
, XBUFFER (where
), 1);
3406 set_internal (symbol
, this_binding
.old_value
, NULL
, 1);
3410 /* If variable has a trivial value (no forwarding), we can
3411 just set it. No need to check for constant symbols here,
3412 since that was already done by specbind. */
3413 if (!MISCP (SYMBOL_VALUE (this_binding
.symbol
)))
3414 SET_SYMBOL_VALUE (this_binding
.symbol
, this_binding
.old_value
);
3416 set_internal (this_binding
.symbol
, this_binding
.old_value
, 0, 1);
3420 if (NILP (Vquit_flag
) && !NILP (quitf
))
3427 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3428 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3429 The debugger is entered when that frame exits, if the flag is non-nil. */)
3431 Lisp_Object level
, flag
;
3433 register struct backtrace
*backlist
= backtrace_list
;
3436 CHECK_NUMBER (level
);
3438 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
3440 backlist
= backlist
->next
;
3444 backlist
->debug_on_exit
= !NILP (flag
);
3449 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3450 doc
: /* Print a trace of Lisp function calls currently active.
3451 Output stream used is value of `standard-output'. */)
3454 register struct backtrace
*backlist
= backtrace_list
;
3458 extern Lisp_Object Vprint_level
;
3459 struct gcpro gcpro1
;
3461 XSETFASTINT (Vprint_level
, 3);
3468 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
3469 if (backlist
->nargs
== UNEVALLED
)
3471 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
3472 write_string ("\n", -1);
3476 tem
= *backlist
->function
;
3477 Fprin1 (tem
, Qnil
); /* This can QUIT */
3478 write_string ("(", -1);
3479 if (backlist
->nargs
== MANY
)
3481 for (tail
= *backlist
->args
, i
= 0;
3483 tail
= Fcdr (tail
), i
++)
3485 if (i
) write_string (" ", -1);
3486 Fprin1 (Fcar (tail
), Qnil
);
3491 for (i
= 0; i
< backlist
->nargs
; i
++)
3493 if (i
) write_string (" ", -1);
3494 Fprin1 (backlist
->args
[i
], Qnil
);
3497 write_string (")\n", -1);
3499 backlist
= backlist
->next
;
3502 Vprint_level
= Qnil
;
3507 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, NULL
,
3508 doc
: /* Return the function and arguments NFRAMES up from current execution point.
3509 If that frame has not evaluated the arguments yet (or is a special form),
3510 the value is (nil FUNCTION ARG-FORMS...).
3511 If that frame has evaluated its arguments and called its function already,
3512 the value is (t FUNCTION ARG-VALUES...).
3513 A &rest arg is represented as the tail of the list ARG-VALUES.
3514 FUNCTION is whatever was supplied as car of evaluated list,
3515 or a lambda expression for macro calls.
3516 If NFRAMES is more than the number of frames, the value is nil. */)
3518 Lisp_Object nframes
;
3520 register struct backtrace
*backlist
= backtrace_list
;
3524 CHECK_NATNUM (nframes
);
3526 /* Find the frame requested. */
3527 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3528 backlist
= backlist
->next
;
3532 if (backlist
->nargs
== UNEVALLED
)
3533 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3536 if (backlist
->nargs
== MANY
)
3537 tem
= *backlist
->args
;
3539 tem
= Flist (backlist
->nargs
, backlist
->args
);
3541 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3549 register struct backtrace
*backlist
;
3552 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3554 mark_object (*backlist
->function
);
3556 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3559 i
= backlist
->nargs
- 1;
3561 mark_object (backlist
->args
[i
]);
3568 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
3569 doc
: /* *Limit on number of Lisp variable bindings and `unwind-protect's.
3570 If Lisp code tries to increase the total number past this amount,
3571 an error is signaled.
3572 You can safely use a value considerably larger than the default value,
3573 if that proves inconveniently small. However, if you increase it too far,
3574 Emacs could run out of memory trying to make the stack bigger. */);
3576 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
3577 doc
: /* *Limit on depth in `eval', `apply' and `funcall' before error.
3579 This limit serves to catch infinite recursions for you before they cause
3580 actual stack overflow in C, which would be fatal for Emacs.
3581 You can safely make it considerably larger than its default value,
3582 if that proves inconveniently small. However, if you increase it too far,
3583 Emacs could overflow the real C stack, and crash. */);
3585 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
3586 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3587 If the value is t, that means do an ordinary quit.
3588 If the value equals `throw-on-input', that means quit by throwing
3589 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3590 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3591 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3594 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
3595 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3596 Note that `quit-flag' will still be set by typing C-g,
3597 so a quit will be signaled as soon as `inhibit-quit' is nil.
3598 To prevent this happening, set `quit-flag' to nil
3599 before making `inhibit-quit' nil. */);
3600 Vinhibit_quit
= Qnil
;
3602 Qinhibit_quit
= intern ("inhibit-quit");
3603 staticpro (&Qinhibit_quit
);
3605 Qautoload
= intern ("autoload");
3606 staticpro (&Qautoload
);
3608 Qdebug_on_error
= intern ("debug-on-error");
3609 staticpro (&Qdebug_on_error
);
3611 Qmacro
= intern ("macro");
3612 staticpro (&Qmacro
);
3614 Qdeclare
= intern ("declare");
3615 staticpro (&Qdeclare
);
3617 /* Note that the process handling also uses Qexit, but we don't want
3618 to staticpro it twice, so we just do it here. */
3619 Qexit
= intern ("exit");
3622 Qinteractive
= intern ("interactive");
3623 staticpro (&Qinteractive
);
3625 Qcommandp
= intern ("commandp");
3626 staticpro (&Qcommandp
);
3628 Qdefun
= intern ("defun");
3629 staticpro (&Qdefun
);
3631 Qand_rest
= intern ("&rest");
3632 staticpro (&Qand_rest
);
3634 Qand_optional
= intern ("&optional");
3635 staticpro (&Qand_optional
);
3637 Qdebug
= intern ("debug");
3638 staticpro (&Qdebug
);
3640 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
3641 doc
: /* *Non-nil means errors display a backtrace buffer.
3642 More precisely, this happens for any error that is handled
3643 by the editor command loop.
3644 If the value is a list, an error only means to display a backtrace
3645 if one of its condition symbols appears in the list. */);
3646 Vstack_trace_on_error
= Qnil
;
3648 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
3649 doc
: /* *Non-nil means enter debugger if an error is signaled.
3650 Does not apply to errors handled by `condition-case' or those
3651 matched by `debug-ignored-errors'.
3652 If the value is a list, an error only means to enter the debugger
3653 if one of its condition symbols appears in the list.
3654 When you evaluate an expression interactively, this variable
3655 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3656 See also variable `debug-on-quit'. */);
3657 Vdebug_on_error
= Qnil
;
3659 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
3660 doc
: /* *List of errors for which the debugger should not be called.
3661 Each element may be a condition-name or a regexp that matches error messages.
3662 If any element applies to a given error, that error skips the debugger
3663 and just returns to top level.
3664 This overrides the variable `debug-on-error'.
3665 It does not apply to errors handled by `condition-case'. */);
3666 Vdebug_ignored_errors
= Qnil
;
3668 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
3669 doc
: /* *Non-nil means enter debugger if quit is signaled (C-g, for example).
3670 Does not apply if quit is handled by a `condition-case'. */);
3673 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
3674 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3676 DEFVAR_BOOL ("debugger-may-continue", &debugger_may_continue
,
3677 doc
: /* Non-nil means debugger may continue execution.
3678 This is nil when the debugger is called under circumstances where it
3679 might not be safe to continue. */);
3680 debugger_may_continue
= 1;
3682 DEFVAR_LISP ("debugger", &Vdebugger
,
3683 doc
: /* Function to call to invoke debugger.
3684 If due to frame exit, args are `exit' and the value being returned;
3685 this function's value will be returned instead of that.
3686 If due to error, args are `error' and a list of the args to `signal'.
3687 If due to `apply' or `funcall' entry, one arg, `lambda'.
3688 If due to `eval' entry, one arg, t. */);
3691 DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function
,
3692 doc
: /* If non-nil, this is a function for `signal' to call.
3693 It receives the same arguments that `signal' was given.
3694 The Edebug package uses this to regain control. */);
3695 Vsignal_hook_function
= Qnil
;
3697 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal
,
3698 doc
: /* *Non-nil means call the debugger regardless of condition handlers.
3699 Note that `debug-on-error', `debug-on-quit' and friends
3700 still determine whether to handle the particular condition. */);
3701 Vdebug_on_signal
= Qnil
;
3703 DEFVAR_LISP ("macro-declaration-function", &Vmacro_declaration_function
,
3704 doc
: /* Function to process declarations in a macro definition.
3705 The function will be called with two args MACRO and DECL.
3706 MACRO is the name of the macro being defined.
3707 DECL is a list `(declare ...)' containing the declarations.
3708 The value the function returns is not used. */);
3709 Vmacro_declaration_function
= Qnil
;
3711 Vrun_hooks
= intern ("run-hooks");
3712 staticpro (&Vrun_hooks
);
3714 staticpro (&Vautoload_queue
);
3715 Vautoload_queue
= Qnil
;
3716 staticpro (&Vsignaling_function
);
3717 Vsignaling_function
= Qnil
;
3728 defsubr (&Sfunction
);
3730 defsubr (&Sdefmacro
);
3732 defsubr (&Sdefvaralias
);
3733 defsubr (&Sdefconst
);
3734 defsubr (&Suser_variable_p
);
3738 defsubr (&Smacroexpand
);
3741 defsubr (&Sunwind_protect
);
3742 defsubr (&Scondition_case
);
3744 defsubr (&Sinteractive_p
);
3745 defsubr (&Scalled_interactively_p
);
3746 defsubr (&Scommandp
);
3747 defsubr (&Sautoload
);
3750 defsubr (&Sfuncall
);
3751 defsubr (&Srun_hooks
);
3752 defsubr (&Srun_hook_with_args
);
3753 defsubr (&Srun_hook_with_args_until_success
);
3754 defsubr (&Srun_hook_with_args_until_failure
);
3755 defsubr (&Sfetch_bytecode
);
3756 defsubr (&Sbacktrace_debug
);
3757 defsubr (&Sbacktrace
);
3758 defsubr (&Sbacktrace_frame
);
3761 /* arch-tag: 014a07aa-33ab-4a8f-a3d2-ee8a4a9ff7fb
3762 (do not change this comment) */