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.
1360 When a handler handles an error,
1361 control returns to the condition-case and the handler BODY... is executed
1362 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).
1363 VAR may be nil; then you do not get access to the signal information.
1365 The value of the last BODY form is returned from the condition-case.
1366 See also the function `signal' for more info.
1367 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1371 register Lisp_Object bodyform
, handlers
;
1372 volatile Lisp_Object var
;
1375 bodyform
= Fcar (Fcdr (args
));
1376 handlers
= Fcdr (Fcdr (args
));
1378 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1381 /* Like Fcondition_case, but the args are separate
1382 rather than passed in a list. Used by Fbyte_code. */
1385 internal_lisp_condition_case (var
, bodyform
, handlers
)
1386 volatile Lisp_Object var
;
1387 Lisp_Object bodyform
, handlers
;
1395 for (val
= handlers
; CONSP (val
); val
= XCDR (val
))
1401 && (SYMBOLP (XCAR (tem
))
1402 || CONSP (XCAR (tem
))))))
1403 error ("Invalid condition handler", tem
);
1408 c
.backlist
= backtrace_list
;
1409 c
.handlerlist
= handlerlist
;
1410 c
.lisp_eval_depth
= lisp_eval_depth
;
1411 c
.pdlcount
= SPECPDL_INDEX ();
1412 c
.poll_suppress_count
= poll_suppress_count
;
1413 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1414 c
.gcpro
= gcprolist
;
1415 c
.byte_stack
= byte_stack_list
;
1416 if (_setjmp (c
.jmp
))
1419 specbind (h
.var
, c
.val
);
1420 val
= Fprogn (Fcdr (h
.chosen_clause
));
1422 /* Note that this just undoes the binding of h.var; whoever
1423 longjumped to us unwound the stack to c.pdlcount before
1425 unbind_to (c
.pdlcount
, Qnil
);
1432 h
.handler
= handlers
;
1433 h
.next
= handlerlist
;
1437 val
= Feval (bodyform
);
1439 handlerlist
= h
.next
;
1443 /* Call the function BFUN with no arguments, catching errors within it
1444 according to HANDLERS. If there is an error, call HFUN with
1445 one argument which is the data that describes the error:
1448 HANDLERS can be a list of conditions to catch.
1449 If HANDLERS is Qt, catch all errors.
1450 If HANDLERS is Qerror, catch all errors
1451 but allow the debugger to run if that is enabled. */
1454 internal_condition_case (bfun
, handlers
, hfun
)
1455 Lisp_Object (*bfun
) ();
1456 Lisp_Object handlers
;
1457 Lisp_Object (*hfun
) ();
1463 /* Since Fsignal will close off all calls to x_catch_errors,
1464 we will get the wrong results if some are not closed now. */
1465 #if 0 /* Fsignal doesn't do that anymore. --lorentey */
1467 if (x_catching_errors ())
1474 c
.backlist
= backtrace_list
;
1475 c
.handlerlist
= handlerlist
;
1476 c
.lisp_eval_depth
= lisp_eval_depth
;
1477 c
.pdlcount
= SPECPDL_INDEX ();
1478 c
.poll_suppress_count
= poll_suppress_count
;
1479 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1480 c
.gcpro
= gcprolist
;
1481 c
.byte_stack
= byte_stack_list
;
1482 if (_setjmp (c
.jmp
))
1484 return (*hfun
) (c
.val
);
1488 h
.handler
= handlers
;
1490 h
.next
= handlerlist
;
1496 handlerlist
= h
.next
;
1500 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1503 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1504 Lisp_Object (*bfun
) ();
1506 Lisp_Object handlers
;
1507 Lisp_Object (*hfun
) ();
1513 /* Since Fsignal will close off all calls to x_catch_errors,
1514 we will get the wrong results if some are not closed now. */
1515 #if 0 /* Fsignal doesn't do that anymore. --lorentey */
1517 if (x_catching_errors ())
1524 c
.backlist
= backtrace_list
;
1525 c
.handlerlist
= handlerlist
;
1526 c
.lisp_eval_depth
= lisp_eval_depth
;
1527 c
.pdlcount
= SPECPDL_INDEX ();
1528 c
.poll_suppress_count
= poll_suppress_count
;
1529 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1530 c
.gcpro
= gcprolist
;
1531 c
.byte_stack
= byte_stack_list
;
1532 if (_setjmp (c
.jmp
))
1534 return (*hfun
) (c
.val
);
1538 h
.handler
= handlers
;
1540 h
.next
= handlerlist
;
1544 val
= (*bfun
) (arg
);
1546 handlerlist
= h
.next
;
1551 /* Like internal_condition_case but call BFUN with NARGS as first,
1552 and ARGS as second argument. */
1555 internal_condition_case_2 (bfun
, nargs
, args
, handlers
, hfun
)
1556 Lisp_Object (*bfun
) ();
1559 Lisp_Object handlers
;
1560 Lisp_Object (*hfun
) ();
1566 /* Since Fsignal will close off all calls to x_catch_errors,
1567 we will get the wrong results if some are not closed now. */
1568 #if 0 /* Fsignal doesn't do that anymore. --lorentey */
1570 if (x_catching_errors ())
1577 c
.backlist
= backtrace_list
;
1578 c
.handlerlist
= handlerlist
;
1579 c
.lisp_eval_depth
= lisp_eval_depth
;
1580 c
.pdlcount
= SPECPDL_INDEX ();
1581 c
.poll_suppress_count
= poll_suppress_count
;
1582 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1583 c
.gcpro
= gcprolist
;
1584 c
.byte_stack
= byte_stack_list
;
1585 if (_setjmp (c
.jmp
))
1587 return (*hfun
) (c
.val
);
1591 h
.handler
= handlers
;
1593 h
.next
= handlerlist
;
1597 val
= (*bfun
) (nargs
, args
);
1599 handlerlist
= h
.next
;
1604 static Lisp_Object find_handler_clause
P_ ((Lisp_Object
, Lisp_Object
,
1605 Lisp_Object
, Lisp_Object
));
1607 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1608 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1609 This function does not return.
1611 An error symbol is a symbol with an `error-conditions' property
1612 that is a list of condition names.
1613 A handler for any of those names will get to handle this signal.
1614 The symbol `error' should normally be one of them.
1616 DATA should be a list. Its elements are printed as part of the error message.
1617 See Info anchor `(elisp)Definition of signal' for some details on how this
1618 error message is constructed.
1619 If the signal is handled, DATA is made available to the handler.
1620 See also the function `condition-case'. */)
1621 (error_symbol
, data
)
1622 Lisp_Object error_symbol
, data
;
1624 /* When memory is full, ERROR-SYMBOL is nil,
1625 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1626 That is a special case--don't do this in other situations. */
1627 register struct handler
*allhandlers
= handlerlist
;
1628 Lisp_Object conditions
;
1629 extern int gc_in_progress
;
1630 extern int waiting_for_input
;
1632 Lisp_Object real_error_symbol
;
1633 struct backtrace
*bp
;
1635 immediate_quit
= handling_signal
= 0;
1637 if (gc_in_progress
|| waiting_for_input
)
1640 if (NILP (error_symbol
))
1641 real_error_symbol
= Fcar (data
);
1643 real_error_symbol
= error_symbol
;
1645 #if 0 /* rms: I don't know why this was here,
1646 but it is surely wrong for an error that is handled. */
1647 #ifdef HAVE_X_WINDOWS
1648 if (display_hourglass_p
)
1649 cancel_hourglass ();
1653 /* This hook is used by edebug. */
1654 if (! NILP (Vsignal_hook_function
)
1655 && ! NILP (error_symbol
))
1657 /* Edebug takes care of restoring these variables when it exits. */
1658 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1659 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1661 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1662 max_specpdl_size
= SPECPDL_INDEX () + 40;
1664 call2 (Vsignal_hook_function
, error_symbol
, data
);
1667 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1669 /* Remember from where signal was called. Skip over the frame for
1670 `signal' itself. If a frame for `error' follows, skip that,
1671 too. Don't do this when ERROR_SYMBOL is nil, because that
1672 is a memory-full error. */
1673 Vsignaling_function
= Qnil
;
1674 if (backtrace_list
&& !NILP (error_symbol
))
1676 bp
= backtrace_list
->next
;
1677 if (bp
&& bp
->function
&& EQ (*bp
->function
, Qerror
))
1679 if (bp
&& bp
->function
)
1680 Vsignaling_function
= *bp
->function
;
1683 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1685 register Lisp_Object clause
;
1687 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1688 error_symbol
, data
);
1690 if (EQ (clause
, Qlambda
))
1692 /* We can't return values to code which signaled an error, but we
1693 can continue code which has signaled a quit. */
1694 if (EQ (real_error_symbol
, Qquit
))
1697 error ("Cannot return from the debugger in an error");
1702 Lisp_Object unwind_data
;
1703 struct handler
*h
= handlerlist
;
1705 handlerlist
= allhandlers
;
1707 if (NILP (error_symbol
))
1710 unwind_data
= Fcons (error_symbol
, data
);
1711 h
->chosen_clause
= clause
;
1712 unwind_to_catch (h
->tag
, unwind_data
);
1716 handlerlist
= allhandlers
;
1717 /* If no handler is present now, try to run the debugger,
1718 and if that fails, throw to top level. */
1719 find_handler_clause (Qerror
, conditions
, error_symbol
, data
);
1721 Fthrow (Qtop_level
, Qt
);
1723 if (! NILP (error_symbol
))
1724 data
= Fcons (error_symbol
, data
);
1726 string
= Ferror_message_string (data
);
1727 fatal ("%s", SDATA (string
), 0);
1730 /* Internal version of Fsignal that never returns.
1731 Used for anything but Qquit (which can return from Fsignal). */
1734 xsignal (error_symbol
, data
)
1735 Lisp_Object error_symbol
, data
;
1737 Fsignal (error_symbol
, data
);
1741 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1744 xsignal0 (error_symbol
)
1745 Lisp_Object error_symbol
;
1747 xsignal (error_symbol
, Qnil
);
1751 xsignal1 (error_symbol
, arg
)
1752 Lisp_Object error_symbol
, arg
;
1754 xsignal (error_symbol
, list1 (arg
));
1758 xsignal2 (error_symbol
, arg1
, arg2
)
1759 Lisp_Object error_symbol
, arg1
, arg2
;
1761 xsignal (error_symbol
, list2 (arg1
, arg2
));
1765 xsignal3 (error_symbol
, arg1
, arg2
, arg3
)
1766 Lisp_Object error_symbol
, arg1
, arg2
, arg3
;
1768 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1771 /* Signal `error' with message S, and additional arg ARG.
1772 If ARG is not a genuine list, make it a one-element list. */
1775 signal_error (s
, arg
)
1779 Lisp_Object tortoise
, hare
;
1781 hare
= tortoise
= arg
;
1782 while (CONSP (hare
))
1789 tortoise
= XCDR (tortoise
);
1791 if (EQ (hare
, tortoise
))
1796 arg
= Fcons (arg
, Qnil
); /* Make it a list. */
1798 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1802 /* Return nonzero if LIST is a non-nil atom or
1803 a list containing one of CONDITIONS. */
1806 wants_debugger (list
, conditions
)
1807 Lisp_Object list
, conditions
;
1814 while (CONSP (conditions
))
1816 Lisp_Object
this, tail
;
1817 this = XCAR (conditions
);
1818 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1819 if (EQ (XCAR (tail
), this))
1821 conditions
= XCDR (conditions
);
1826 /* Return 1 if an error with condition-symbols CONDITIONS,
1827 and described by SIGNAL-DATA, should skip the debugger
1828 according to debugger-ignored-errors. */
1831 skip_debugger (conditions
, data
)
1832 Lisp_Object conditions
, data
;
1835 int first_string
= 1;
1836 Lisp_Object error_message
;
1838 error_message
= Qnil
;
1839 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1841 if (STRINGP (XCAR (tail
)))
1845 error_message
= Ferror_message_string (data
);
1849 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1854 Lisp_Object contail
;
1856 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1857 if (EQ (XCAR (tail
), XCAR (contail
)))
1865 /* Value of Qlambda means we have called debugger and user has continued.
1866 There are two ways to pass SIG and DATA:
1867 = SIG is the error symbol, and DATA is the rest of the data.
1868 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1869 This is for memory-full errors only.
1871 We need to increase max_specpdl_size temporarily around
1872 anything we do that can push on the specpdl, so as not to get
1873 a second error here in case we're handling specpdl overflow. */
1876 find_handler_clause (handlers
, conditions
, sig
, data
)
1877 Lisp_Object handlers
, conditions
, sig
, data
;
1879 register Lisp_Object h
;
1880 register Lisp_Object tem
;
1881 int debugger_called
= 0;
1882 int debugger_considered
= 0;
1884 /* t is used by handlers for all conditions, set up by C code. */
1885 if (EQ (handlers
, Qt
))
1888 /* Don't run the debugger for a memory-full error.
1889 (There is no room in memory to do that!) */
1891 debugger_considered
= 1;
1893 /* error is used similarly, but means print an error message
1894 and run the debugger if that is enabled. */
1895 if (EQ (handlers
, Qerror
)
1896 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1897 there is a handler. */
1899 if (!NILP (sig
) && wants_debugger (Vstack_trace_on_error
, conditions
))
1903 internal_with_output_to_temp_buffer ("*Backtrace*",
1904 (Lisp_Object (*) (Lisp_Object
)) Fbacktrace
,
1907 internal_with_output_to_temp_buffer ("*Backtrace*",
1913 if (!debugger_considered
)
1915 debugger_considered
= 1;
1916 debugger_called
= maybe_call_debugger (conditions
, sig
, data
);
1919 /* If there is no handler, return saying whether we ran the debugger. */
1920 if (EQ (handlers
, Qerror
))
1922 if (debugger_called
)
1928 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1930 Lisp_Object handler
, condit
;
1933 if (!CONSP (handler
))
1935 condit
= Fcar (handler
);
1936 /* Handle a single condition name in handler HANDLER. */
1937 if (SYMBOLP (condit
))
1939 tem
= Fmemq (Fcar (handler
), conditions
);
1943 /* Handle a list of condition names in handler HANDLER. */
1944 else if (CONSP (condit
))
1947 for (tail
= condit
; CONSP (tail
); tail
= XCDR (tail
))
1949 tem
= Fmemq (Fcar (tail
), conditions
);
1952 /* This handler is going to apply.
1953 Does it allow the debugger to run first? */
1954 if (! debugger_considered
&& !NILP (Fmemq (Qdebug
, condit
)))
1955 maybe_call_debugger (conditions
, sig
, data
);
1965 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1966 SIG and DATA describe the signal, as in find_handler_clause. */
1969 maybe_call_debugger (conditions
, sig
, data
)
1970 Lisp_Object conditions
, sig
, data
;
1972 Lisp_Object combined_data
;
1974 combined_data
= Fcons (sig
, data
);
1977 /* Don't try to run the debugger with interrupts blocked.
1978 The editing loop would return anyway. */
1980 /* Does user wants to enter debugger for this kind of error? */
1983 : wants_debugger (Vdebug_on_error
, conditions
))
1984 && ! skip_debugger (conditions
, combined_data
)
1985 /* rms: what's this for? */
1986 && when_entered_debugger
< num_nonmacro_input_events
)
1988 call_debugger (Fcons (Qerror
, Fcons (combined_data
, Qnil
)));
1995 /* dump an error message; called like printf */
1999 error (m
, a1
, a2
, a3
)
2019 int used
= doprnt (buffer
, size
, m
, m
+ mlen
, 3, args
);
2024 buffer
= (char *) xrealloc (buffer
, size
);
2027 buffer
= (char *) xmalloc (size
);
2032 string
= build_string (buffer
);
2036 xsignal1 (Qerror
, string
);
2039 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
2040 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
2041 This means it contains a description for how to read arguments to give it.
2042 The value is nil for an invalid function or a symbol with no function
2045 Interactively callable functions include strings and vectors (treated
2046 as keyboard macros), lambda-expressions that contain a top-level call
2047 to `interactive', autoload definitions made by `autoload' with non-nil
2048 fourth argument, and some of the built-in functions of Lisp.
2050 Also, a symbol satisfies `commandp' if its function definition does so.
2052 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
2053 then strings and vectors are not accepted. */)
2054 (function
, for_call_interactively
)
2055 Lisp_Object function
, for_call_interactively
;
2057 register Lisp_Object fun
;
2058 register Lisp_Object funcar
;
2059 Lisp_Object if_prop
= Qnil
;
2063 fun
= indirect_function (fun
); /* Check cycles. */
2064 if (NILP (fun
) || EQ (fun
, Qunbound
))
2067 /* Check an `interactive-form' property if present, analogous to the
2068 function-documentation property. */
2070 while (SYMBOLP (fun
))
2072 Lisp_Object tmp
= Fget (fun
, intern ("interactive-form"));
2075 fun
= Fsymbol_function (fun
);
2078 /* Emacs primitives are interactive if their DEFUN specifies an
2079 interactive spec. */
2081 return XSUBR (fun
)->prompt
? Qt
: if_prop
;
2083 /* Bytecode objects are interactive if they are long enough to
2084 have an element whose index is COMPILED_INTERACTIVE, which is
2085 where the interactive spec is stored. */
2086 else if (COMPILEDP (fun
))
2087 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
2090 /* Strings and vectors are keyboard macros. */
2091 if (STRINGP (fun
) || VECTORP (fun
))
2092 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
2094 /* Lists may represent commands. */
2097 funcar
= XCAR (fun
);
2098 if (EQ (funcar
, Qlambda
))
2099 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
2100 if (EQ (funcar
, Qautoload
))
2101 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
2107 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
2108 doc
: /* Define FUNCTION to autoload from FILE.
2109 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
2110 Third arg DOCSTRING is documentation for the function.
2111 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
2112 Fifth arg TYPE indicates the type of the object:
2113 nil or omitted says FUNCTION is a function,
2114 `keymap' says FUNCTION is really a keymap, and
2115 `macro' or t says FUNCTION is really a macro.
2116 Third through fifth args give info about the real definition.
2117 They default to nil.
2118 If FUNCTION is already defined other than as an autoload,
2119 this does nothing and returns nil. */)
2120 (function
, file
, docstring
, interactive
, type
)
2121 Lisp_Object function
, file
, docstring
, interactive
, type
;
2124 Lisp_Object args
[4];
2127 CHECK_SYMBOL (function
);
2128 CHECK_STRING (file
);
2130 /* If function is defined and not as an autoload, don't override */
2131 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
2132 && !(CONSP (XSYMBOL (function
)->function
)
2133 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
2136 if (NILP (Vpurify_flag
))
2137 /* Only add entries after dumping, because the ones before are
2138 not useful and else we get loads of them from the loaddefs.el. */
2139 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
2143 args
[1] = docstring
;
2144 args
[2] = interactive
;
2147 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
2148 #else /* NO_ARG_ARRAY */
2149 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
2150 #endif /* not NO_ARG_ARRAY */
2154 un_autoload (oldqueue
)
2155 Lisp_Object oldqueue
;
2157 register Lisp_Object queue
, first
, second
;
2159 /* Queue to unwind is current value of Vautoload_queue.
2160 oldqueue is the shadowed value to leave in Vautoload_queue. */
2161 queue
= Vautoload_queue
;
2162 Vautoload_queue
= oldqueue
;
2163 while (CONSP (queue
))
2165 first
= XCAR (queue
);
2166 second
= Fcdr (first
);
2167 first
= Fcar (first
);
2168 if (EQ (first
, make_number (0)))
2171 Ffset (first
, second
);
2172 queue
= XCDR (queue
);
2177 /* Load an autoloaded function.
2178 FUNNAME is the symbol which is the function's name.
2179 FUNDEF is the autoload definition (a list). */
2182 do_autoload (fundef
, funname
)
2183 Lisp_Object fundef
, funname
;
2185 int count
= SPECPDL_INDEX ();
2186 Lisp_Object fun
, queue
, first
, second
;
2187 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2189 /* This is to make sure that loadup.el gives a clear picture
2190 of what files are preloaded and when. */
2191 if (! NILP (Vpurify_flag
))
2192 error ("Attempt to autoload %s while preparing to dump",
2193 SDATA (SYMBOL_NAME (funname
)));
2196 CHECK_SYMBOL (funname
);
2197 GCPRO3 (fun
, funname
, fundef
);
2199 /* Preserve the match data. */
2200 record_unwind_save_match_data ();
2202 /* Value saved here is to be restored into Vautoload_queue. */
2203 record_unwind_protect (un_autoload
, Vautoload_queue
);
2204 Vautoload_queue
= Qt
;
2205 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
, Qt
);
2207 /* Save the old autoloads, in case we ever do an unload. */
2208 queue
= Vautoload_queue
;
2209 while (CONSP (queue
))
2211 first
= XCAR (queue
);
2212 second
= Fcdr (first
);
2213 first
= Fcar (first
);
2215 if (SYMBOLP (first
) && CONSP (second
) && EQ (XCAR (second
), Qautoload
))
2216 Fput (first
, Qautoload
, (XCDR (second
)));
2218 queue
= XCDR (queue
);
2221 /* Once loading finishes, don't undo it. */
2222 Vautoload_queue
= Qt
;
2223 unbind_to (count
, Qnil
);
2225 fun
= Findirect_function (fun
, Qnil
);
2227 if (!NILP (Fequal (fun
, fundef
)))
2228 error ("Autoloading failed to define function %s",
2229 SDATA (SYMBOL_NAME (funname
)));
2234 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
2235 doc
: /* Evaluate FORM and return its value. */)
2239 Lisp_Object fun
, val
, original_fun
, original_args
;
2241 struct backtrace backtrace
;
2242 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2244 if (handling_signal
)
2248 return Fsymbol_value (form
);
2253 if ((consing_since_gc
> gc_cons_threshold
2254 && consing_since_gc
> gc_relative_threshold
)
2256 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2259 Fgarbage_collect ();
2263 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2265 if (max_lisp_eval_depth
< 100)
2266 max_lisp_eval_depth
= 100;
2267 if (lisp_eval_depth
> max_lisp_eval_depth
)
2268 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2271 original_fun
= Fcar (form
);
2272 original_args
= Fcdr (form
);
2274 backtrace
.next
= backtrace_list
;
2275 backtrace_list
= &backtrace
;
2276 backtrace
.function
= &original_fun
; /* This also protects them from gc */
2277 backtrace
.args
= &original_args
;
2278 backtrace
.nargs
= UNEVALLED
;
2279 backtrace
.evalargs
= 1;
2280 backtrace
.debug_on_exit
= 0;
2282 if (debug_on_next_call
)
2283 do_debug_on_call (Qt
);
2285 /* At this point, only original_fun and original_args
2286 have values that will be used below */
2289 /* Optimize for no indirection. */
2291 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2292 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2293 fun
= indirect_function (fun
);
2297 Lisp_Object numargs
;
2298 Lisp_Object argvals
[8];
2299 Lisp_Object args_left
;
2300 register int i
, maxargs
;
2302 args_left
= original_args
;
2303 numargs
= Flength (args_left
);
2307 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
2308 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2309 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2311 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2313 backtrace
.evalargs
= 0;
2314 val
= (*XSUBR (fun
)->function
) (args_left
);
2318 if (XSUBR (fun
)->max_args
== MANY
)
2320 /* Pass a vector of evaluated arguments */
2322 register int argnum
= 0;
2324 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2326 GCPRO3 (args_left
, fun
, fun
);
2330 while (!NILP (args_left
))
2332 vals
[argnum
++] = Feval (Fcar (args_left
));
2333 args_left
= Fcdr (args_left
);
2334 gcpro3
.nvars
= argnum
;
2337 backtrace
.args
= vals
;
2338 backtrace
.nargs
= XINT (numargs
);
2340 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
2345 GCPRO3 (args_left
, fun
, fun
);
2346 gcpro3
.var
= argvals
;
2349 maxargs
= XSUBR (fun
)->max_args
;
2350 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
2352 argvals
[i
] = Feval (Fcar (args_left
));
2358 backtrace
.args
= argvals
;
2359 backtrace
.nargs
= XINT (numargs
);
2364 val
= (*XSUBR (fun
)->function
) ();
2367 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
2370 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
2373 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2377 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2378 argvals
[2], argvals
[3]);
2381 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2382 argvals
[3], argvals
[4]);
2385 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2386 argvals
[3], argvals
[4], argvals
[5]);
2389 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2390 argvals
[3], argvals
[4], argvals
[5],
2395 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2396 argvals
[3], argvals
[4], argvals
[5],
2397 argvals
[6], argvals
[7]);
2401 /* Someone has created a subr that takes more arguments than
2402 is supported by this code. We need to either rewrite the
2403 subr to use a different argument protocol, or add more
2404 cases to this switch. */
2408 if (COMPILEDP (fun
))
2409 val
= apply_lambda (fun
, original_args
, 1);
2412 if (EQ (fun
, Qunbound
))
2413 xsignal1 (Qvoid_function
, original_fun
);
2415 xsignal1 (Qinvalid_function
, original_fun
);
2416 funcar
= XCAR (fun
);
2417 if (!SYMBOLP (funcar
))
2418 xsignal1 (Qinvalid_function
, original_fun
);
2419 if (EQ (funcar
, Qautoload
))
2421 do_autoload (fun
, original_fun
);
2424 if (EQ (funcar
, Qmacro
))
2425 val
= Feval (apply1 (Fcdr (fun
), original_args
));
2426 else if (EQ (funcar
, Qlambda
))
2427 val
= apply_lambda (fun
, original_args
, 1);
2429 xsignal1 (Qinvalid_function
, original_fun
);
2435 if (backtrace
.debug_on_exit
)
2436 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2437 backtrace_list
= backtrace
.next
;
2442 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
2443 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2444 Then return the value FUNCTION returns.
2445 Thus, (apply '+ 1 2 '(3 4)) returns 10.
2446 usage: (apply FUNCTION &rest ARGUMENTS) */)
2451 register int i
, numargs
;
2452 register Lisp_Object spread_arg
;
2453 register Lisp_Object
*funcall_args
;
2455 struct gcpro gcpro1
;
2459 spread_arg
= args
[nargs
- 1];
2460 CHECK_LIST (spread_arg
);
2462 numargs
= XINT (Flength (spread_arg
));
2465 return Ffuncall (nargs
- 1, args
);
2466 else if (numargs
== 1)
2468 args
[nargs
- 1] = XCAR (spread_arg
);
2469 return Ffuncall (nargs
, args
);
2472 numargs
+= nargs
- 2;
2474 /* Optimize for no indirection. */
2475 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2476 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2477 fun
= indirect_function (fun
);
2478 if (EQ (fun
, Qunbound
))
2480 /* Let funcall get the error */
2487 if (numargs
< XSUBR (fun
)->min_args
2488 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2489 goto funcall
; /* Let funcall get the error */
2490 else if (XSUBR (fun
)->max_args
> numargs
)
2492 /* Avoid making funcall cons up a yet another new vector of arguments
2493 by explicitly supplying nil's for optional values */
2494 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
2495 * sizeof (Lisp_Object
));
2496 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2497 funcall_args
[++i
] = Qnil
;
2498 GCPRO1 (*funcall_args
);
2499 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2503 /* We add 1 to numargs because funcall_args includes the
2504 function itself as well as its arguments. */
2507 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
2508 * sizeof (Lisp_Object
));
2509 GCPRO1 (*funcall_args
);
2510 gcpro1
.nvars
= 1 + numargs
;
2513 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
2514 /* Spread the last arg we got. Its first element goes in
2515 the slot that it used to occupy, hence this value of I. */
2517 while (!NILP (spread_arg
))
2519 funcall_args
[i
++] = XCAR (spread_arg
);
2520 spread_arg
= XCDR (spread_arg
);
2523 /* By convention, the caller needs to gcpro Ffuncall's args. */
2524 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
2527 /* Run hook variables in various ways. */
2529 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
2530 static Lisp_Object run_hook_with_args
P_ ((int, Lisp_Object
*,
2531 enum run_hooks_condition
));
2533 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2534 doc
: /* Run each hook in HOOKS.
2535 Each argument should be a symbol, a hook variable.
2536 These symbols are processed in the order specified.
2537 If a hook symbol has a non-nil value, that value may be a function
2538 or a list of functions to be called to run the hook.
2539 If the value is a function, it is called with no arguments.
2540 If it is a list, the elements are called, in order, with no arguments.
2542 Major modes should not use this function directly to run their mode
2543 hook; they should use `run-mode-hooks' instead.
2545 Do not use `make-local-variable' to make a hook variable buffer-local.
2546 Instead, use `add-hook' and specify t for the LOCAL argument.
2547 usage: (run-hooks &rest HOOKS) */)
2552 Lisp_Object hook
[1];
2555 for (i
= 0; i
< nargs
; i
++)
2558 run_hook_with_args (1, hook
, to_completion
);
2564 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2565 Srun_hook_with_args
, 1, MANY
, 0,
2566 doc
: /* Run HOOK with the specified arguments ARGS.
2567 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2568 value, that value may be a function or a list of functions to be
2569 called to run the hook. If the value is a function, it is called with
2570 the given arguments and its return value is returned. If it is a list
2571 of functions, those functions are called, in order,
2572 with the given arguments ARGS.
2573 It is best not to depend on the value returned by `run-hook-with-args',
2576 Do not use `make-local-variable' to make a hook variable buffer-local.
2577 Instead, use `add-hook' and specify t for the LOCAL argument.
2578 usage: (run-hook-with-args HOOK &rest ARGS) */)
2583 return run_hook_with_args (nargs
, args
, to_completion
);
2586 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2587 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2588 doc
: /* Run HOOK with the specified arguments ARGS.
2589 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2590 value, that value may be a function or a list of functions to be
2591 called to run the hook. If the value is a function, it is called with
2592 the given arguments and its return value is returned.
2593 If it is a list of functions, those functions are called, in order,
2594 with the given arguments ARGS, until one of them
2595 returns a non-nil value. Then we return that value.
2596 However, if they all return nil, we return nil.
2598 Do not use `make-local-variable' to make a hook variable buffer-local.
2599 Instead, use `add-hook' and specify t for the LOCAL argument.
2600 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2605 return run_hook_with_args (nargs
, args
, until_success
);
2608 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2609 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2610 doc
: /* Run HOOK with the specified arguments ARGS.
2611 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2612 value, that value may be a function or a list of functions to be
2613 called to run the hook. If the value is a function, it is called with
2614 the given arguments and its return value is returned.
2615 If it is a list of functions, those functions are called, in order,
2616 with the given arguments ARGS, until one of them returns nil.
2617 Then we return nil. However, if they all return non-nil, we return non-nil.
2619 Do not use `make-local-variable' to make a hook variable buffer-local.
2620 Instead, use `add-hook' and specify t for the LOCAL argument.
2621 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2626 return run_hook_with_args (nargs
, args
, until_failure
);
2629 /* ARGS[0] should be a hook symbol.
2630 Call each of the functions in the hook value, passing each of them
2631 as arguments all the rest of ARGS (all NARGS - 1 elements).
2632 COND specifies a condition to test after each call
2633 to decide whether to stop.
2634 The caller (or its caller, etc) must gcpro all of ARGS,
2635 except that it isn't necessary to gcpro ARGS[0]. */
2638 run_hook_with_args (nargs
, args
, cond
)
2641 enum run_hooks_condition cond
;
2643 Lisp_Object sym
, val
, ret
;
2644 Lisp_Object globals
;
2645 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2647 /* If we are dying or still initializing,
2648 don't do anything--it would probably crash if we tried. */
2649 if (NILP (Vrun_hooks
))
2653 val
= find_symbol_value (sym
);
2654 ret
= (cond
== until_failure
? Qt
: Qnil
);
2656 if (EQ (val
, Qunbound
) || NILP (val
))
2658 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2661 return Ffuncall (nargs
, args
);
2666 GCPRO3 (sym
, val
, globals
);
2669 CONSP (val
) && ((cond
== to_completion
)
2670 || (cond
== until_success
? NILP (ret
)
2674 if (EQ (XCAR (val
), Qt
))
2676 /* t indicates this hook has a local binding;
2677 it means to run the global binding too. */
2679 for (globals
= Fdefault_value (sym
);
2680 CONSP (globals
) && ((cond
== to_completion
)
2681 || (cond
== until_success
? NILP (ret
)
2683 globals
= XCDR (globals
))
2685 args
[0] = XCAR (globals
);
2686 /* In a global value, t should not occur. If it does, we
2687 must ignore it to avoid an endless loop. */
2688 if (!EQ (args
[0], Qt
))
2689 ret
= Ffuncall (nargs
, args
);
2694 args
[0] = XCAR (val
);
2695 ret
= Ffuncall (nargs
, args
);
2704 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2705 present value of that symbol.
2706 Call each element of FUNLIST,
2707 passing each of them the rest of ARGS.
2708 The caller (or its caller, etc) must gcpro all of ARGS,
2709 except that it isn't necessary to gcpro ARGS[0]. */
2712 run_hook_list_with_args (funlist
, nargs
, args
)
2713 Lisp_Object funlist
;
2719 Lisp_Object globals
;
2720 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2724 GCPRO3 (sym
, val
, globals
);
2726 for (val
= funlist
; CONSP (val
); val
= XCDR (val
))
2728 if (EQ (XCAR (val
), Qt
))
2730 /* t indicates this hook has a local binding;
2731 it means to run the global binding too. */
2733 for (globals
= Fdefault_value (sym
);
2735 globals
= XCDR (globals
))
2737 args
[0] = XCAR (globals
);
2738 /* In a global value, t should not occur. If it does, we
2739 must ignore it to avoid an endless loop. */
2740 if (!EQ (args
[0], Qt
))
2741 Ffuncall (nargs
, args
);
2746 args
[0] = XCAR (val
);
2747 Ffuncall (nargs
, args
);
2754 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2757 run_hook_with_args_2 (hook
, arg1
, arg2
)
2758 Lisp_Object hook
, arg1
, arg2
;
2760 Lisp_Object temp
[3];
2765 Frun_hook_with_args (3, temp
);
2768 /* Apply fn to arg */
2771 Lisp_Object fn
, arg
;
2773 struct gcpro gcpro1
;
2777 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2781 Lisp_Object args
[2];
2785 RETURN_UNGCPRO (Fapply (2, args
));
2787 #else /* not NO_ARG_ARRAY */
2788 RETURN_UNGCPRO (Fapply (2, &fn
));
2789 #endif /* not NO_ARG_ARRAY */
2792 /* Call function fn on no arguments */
2797 struct gcpro gcpro1
;
2800 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2803 /* Call function fn with 1 argument arg1 */
2807 Lisp_Object fn
, arg1
;
2809 struct gcpro gcpro1
;
2811 Lisp_Object args
[2];
2817 RETURN_UNGCPRO (Ffuncall (2, args
));
2818 #else /* not NO_ARG_ARRAY */
2821 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2822 #endif /* not NO_ARG_ARRAY */
2825 /* Call function fn with 2 arguments arg1, arg2 */
2828 call2 (fn
, arg1
, arg2
)
2829 Lisp_Object fn
, arg1
, arg2
;
2831 struct gcpro gcpro1
;
2833 Lisp_Object args
[3];
2839 RETURN_UNGCPRO (Ffuncall (3, args
));
2840 #else /* not NO_ARG_ARRAY */
2843 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2844 #endif /* not NO_ARG_ARRAY */
2847 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2850 call3 (fn
, arg1
, arg2
, arg3
)
2851 Lisp_Object fn
, arg1
, arg2
, arg3
;
2853 struct gcpro gcpro1
;
2855 Lisp_Object args
[4];
2862 RETURN_UNGCPRO (Ffuncall (4, args
));
2863 #else /* not NO_ARG_ARRAY */
2866 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2867 #endif /* not NO_ARG_ARRAY */
2870 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2873 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2874 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2876 struct gcpro gcpro1
;
2878 Lisp_Object args
[5];
2886 RETURN_UNGCPRO (Ffuncall (5, args
));
2887 #else /* not NO_ARG_ARRAY */
2890 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2891 #endif /* not NO_ARG_ARRAY */
2894 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2897 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2898 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2900 struct gcpro gcpro1
;
2902 Lisp_Object args
[6];
2911 RETURN_UNGCPRO (Ffuncall (6, args
));
2912 #else /* not NO_ARG_ARRAY */
2915 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2916 #endif /* not NO_ARG_ARRAY */
2919 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2922 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2923 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2925 struct gcpro gcpro1
;
2927 Lisp_Object args
[7];
2937 RETURN_UNGCPRO (Ffuncall (7, args
));
2938 #else /* not NO_ARG_ARRAY */
2941 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2942 #endif /* not NO_ARG_ARRAY */
2945 /* The caller should GCPRO all the elements of ARGS. */
2947 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2948 doc
: /* Call first argument as a function, passing remaining arguments to it.
2949 Return the value that function returns.
2950 Thus, (funcall 'cons 'x 'y) returns (x . y).
2951 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2956 Lisp_Object fun
, original_fun
;
2958 int numargs
= nargs
- 1;
2959 Lisp_Object lisp_numargs
;
2961 struct backtrace backtrace
;
2962 register Lisp_Object
*internal_args
;
2966 if ((consing_since_gc
> gc_cons_threshold
2967 && consing_since_gc
> gc_relative_threshold
)
2969 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2970 Fgarbage_collect ();
2972 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2974 if (max_lisp_eval_depth
< 100)
2975 max_lisp_eval_depth
= 100;
2976 if (lisp_eval_depth
> max_lisp_eval_depth
)
2977 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2980 backtrace
.next
= backtrace_list
;
2981 backtrace_list
= &backtrace
;
2982 backtrace
.function
= &args
[0];
2983 backtrace
.args
= &args
[1];
2984 backtrace
.nargs
= nargs
- 1;
2985 backtrace
.evalargs
= 0;
2986 backtrace
.debug_on_exit
= 0;
2988 if (debug_on_next_call
)
2989 do_debug_on_call (Qlambda
);
2993 original_fun
= args
[0];
2997 /* Optimize for no indirection. */
2999 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
3000 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
3001 fun
= indirect_function (fun
);
3005 if (numargs
< XSUBR (fun
)->min_args
3006 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
3008 XSETFASTINT (lisp_numargs
, numargs
);
3009 xsignal2 (Qwrong_number_of_arguments
, original_fun
, lisp_numargs
);
3012 if (XSUBR (fun
)->max_args
== UNEVALLED
)
3013 xsignal1 (Qinvalid_function
, original_fun
);
3015 if (XSUBR (fun
)->max_args
== MANY
)
3017 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
3021 if (XSUBR (fun
)->max_args
> numargs
)
3023 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
3024 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
3025 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
3026 internal_args
[i
] = Qnil
;
3029 internal_args
= args
+ 1;
3030 switch (XSUBR (fun
)->max_args
)
3033 val
= (*XSUBR (fun
)->function
) ();
3036 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
3039 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1]);
3042 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3046 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3047 internal_args
[2], internal_args
[3]);
3050 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3051 internal_args
[2], internal_args
[3],
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]);
3060 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3061 internal_args
[2], internal_args
[3],
3062 internal_args
[4], internal_args
[5],
3067 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3068 internal_args
[2], internal_args
[3],
3069 internal_args
[4], internal_args
[5],
3070 internal_args
[6], internal_args
[7]);
3075 /* If a subr takes more than 8 arguments without using MANY
3076 or UNEVALLED, we need to extend this function to support it.
3077 Until this is done, there is no way to call the function. */
3081 if (COMPILEDP (fun
))
3082 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3085 if (EQ (fun
, Qunbound
))
3086 xsignal1 (Qvoid_function
, original_fun
);
3088 xsignal1 (Qinvalid_function
, original_fun
);
3089 funcar
= XCAR (fun
);
3090 if (!SYMBOLP (funcar
))
3091 xsignal1 (Qinvalid_function
, original_fun
);
3092 if (EQ (funcar
, Qlambda
))
3093 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3094 else if (EQ (funcar
, Qautoload
))
3096 do_autoload (fun
, original_fun
);
3101 xsignal1 (Qinvalid_function
, original_fun
);
3106 if (backtrace
.debug_on_exit
)
3107 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
3108 backtrace_list
= backtrace
.next
;
3113 apply_lambda (fun
, args
, eval_flag
)
3114 Lisp_Object fun
, args
;
3117 Lisp_Object args_left
;
3118 Lisp_Object numargs
;
3119 register Lisp_Object
*arg_vector
;
3120 struct gcpro gcpro1
, gcpro2
, gcpro3
;
3122 register Lisp_Object tem
;
3124 numargs
= Flength (args
);
3125 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
3128 GCPRO3 (*arg_vector
, args_left
, fun
);
3131 for (i
= 0; i
< XINT (numargs
);)
3133 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
3134 if (eval_flag
) tem
= Feval (tem
);
3135 arg_vector
[i
++] = tem
;
3143 backtrace_list
->args
= arg_vector
;
3144 backtrace_list
->nargs
= i
;
3146 backtrace_list
->evalargs
= 0;
3147 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
3149 /* Do the debug-on-exit now, while arg_vector still exists. */
3150 if (backtrace_list
->debug_on_exit
)
3151 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
3152 /* Don't do it again when we return to eval. */
3153 backtrace_list
->debug_on_exit
= 0;
3157 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
3158 and return the result of evaluation.
3159 FUN must be either a lambda-expression or a compiled-code object. */
3162 funcall_lambda (fun
, nargs
, arg_vector
)
3165 register Lisp_Object
*arg_vector
;
3167 Lisp_Object val
, syms_left
, next
;
3168 int count
= SPECPDL_INDEX ();
3169 int i
, optional
, rest
;
3173 syms_left
= XCDR (fun
);
3174 if (CONSP (syms_left
))
3175 syms_left
= XCAR (syms_left
);
3177 xsignal1 (Qinvalid_function
, fun
);
3179 else if (COMPILEDP (fun
))
3180 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3184 i
= optional
= rest
= 0;
3185 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3189 next
= XCAR (syms_left
);
3190 if (!SYMBOLP (next
))
3191 xsignal1 (Qinvalid_function
, fun
);
3193 if (EQ (next
, Qand_rest
))
3195 else if (EQ (next
, Qand_optional
))
3199 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
3203 specbind (next
, arg_vector
[i
++]);
3205 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3207 specbind (next
, Qnil
);
3210 if (!NILP (syms_left
))
3211 xsignal1 (Qinvalid_function
, fun
);
3213 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3216 val
= Fprogn (XCDR (XCDR (fun
)));
3219 /* If we have not actually read the bytecode string
3220 and constants vector yet, fetch them from the file. */
3221 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3222 Ffetch_bytecode (fun
);
3223 val
= Fbyte_code (AREF (fun
, COMPILED_BYTECODE
),
3224 AREF (fun
, COMPILED_CONSTANTS
),
3225 AREF (fun
, COMPILED_STACK_DEPTH
));
3228 return unbind_to (count
, val
);
3231 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3233 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3239 if (COMPILEDP (object
) && CONSP (AREF (object
, COMPILED_BYTECODE
)))
3241 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3244 tem
= AREF (object
, COMPILED_BYTECODE
);
3245 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3246 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3248 error ("Invalid byte code");
3250 AREF (object
, COMPILED_BYTECODE
) = XCAR (tem
);
3251 AREF (object
, COMPILED_CONSTANTS
) = XCDR (tem
);
3259 register int count
= SPECPDL_INDEX ();
3260 if (specpdl_size
>= max_specpdl_size
)
3262 if (max_specpdl_size
< 400)
3263 max_specpdl_size
= 400;
3264 if (specpdl_size
>= max_specpdl_size
)
3265 signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil
);
3268 if (specpdl_size
> max_specpdl_size
)
3269 specpdl_size
= max_specpdl_size
;
3270 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
3271 specpdl_ptr
= specpdl
+ count
;
3275 specbind (symbol
, value
)
3276 Lisp_Object symbol
, value
;
3279 Lisp_Object valcontents
;
3281 CHECK_SYMBOL (symbol
);
3282 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3285 /* The most common case is that of a non-constant symbol with a
3286 trivial value. Make that as fast as we can. */
3287 valcontents
= SYMBOL_VALUE (symbol
);
3288 if (!MISCP (valcontents
) && !SYMBOL_CONSTANT_P (symbol
))
3290 specpdl_ptr
->symbol
= symbol
;
3291 specpdl_ptr
->old_value
= valcontents
;
3292 specpdl_ptr
->func
= NULL
;
3294 SET_SYMBOL_VALUE (symbol
, value
);
3298 Lisp_Object valcontents
;
3300 ovalue
= find_symbol_value (symbol
);
3301 specpdl_ptr
->func
= 0;
3302 specpdl_ptr
->old_value
= ovalue
;
3304 valcontents
= XSYMBOL (symbol
)->value
;
3306 if (BUFFER_LOCAL_VALUEP (valcontents
)
3307 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
3308 || BUFFER_OBJFWDP (valcontents
))
3310 Lisp_Object where
, current_buffer
;
3312 current_buffer
= Fcurrent_buffer ();
3314 /* For a local variable, record both the symbol and which
3315 buffer's or frame's value we are saving. */
3316 if (!NILP (Flocal_variable_p (symbol
, Qnil
)))
3317 where
= current_buffer
;
3318 else if (!BUFFER_OBJFWDP (valcontents
)
3319 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
3320 where
= XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
3324 /* We're not using the `unused' slot in the specbinding
3325 structure because this would mean we have to do more
3326 work for simple variables. */
3327 specpdl_ptr
->symbol
= Fcons (symbol
, Fcons (where
, current_buffer
));
3329 /* If SYMBOL is a per-buffer variable which doesn't have a
3330 buffer-local value here, make the `let' change the global
3331 value by changing the value of SYMBOL in all buffers not
3332 having their own value. This is consistent with what
3333 happens with other buffer-local variables. */
3335 && BUFFER_OBJFWDP (valcontents
))
3338 Fset_default (symbol
, value
);
3343 specpdl_ptr
->symbol
= symbol
;
3346 if (BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
))
3347 store_symval_forwarding (symbol
, ovalue
, value
, NULL
);
3349 set_internal (symbol
, value
, 0, 1);
3354 record_unwind_protect (function
, arg
)
3355 Lisp_Object (*function
) P_ ((Lisp_Object
));
3358 eassert (!handling_signal
);
3360 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3362 specpdl_ptr
->func
= function
;
3363 specpdl_ptr
->symbol
= Qnil
;
3364 specpdl_ptr
->old_value
= arg
;
3369 unbind_to (count
, value
)
3373 Lisp_Object quitf
= Vquit_flag
;
3374 struct gcpro gcpro1
, gcpro2
;
3376 GCPRO2 (value
, quitf
);
3379 while (specpdl_ptr
!= specpdl
+ count
)
3381 /* Copy the binding, and decrement specpdl_ptr, before we do
3382 the work to unbind it. We decrement first
3383 so that an error in unbinding won't try to unbind
3384 the same entry again, and we copy the binding first
3385 in case more bindings are made during some of the code we run. */
3387 struct specbinding this_binding
;
3388 this_binding
= *--specpdl_ptr
;
3390 if (this_binding
.func
!= 0)
3391 (*this_binding
.func
) (this_binding
.old_value
);
3392 /* If the symbol is a list, it is really (SYMBOL WHERE
3393 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3394 frame. If WHERE is a buffer or frame, this indicates we
3395 bound a variable that had a buffer-local or frame-local
3396 binding. WHERE nil means that the variable had the default
3397 value when it was bound. CURRENT-BUFFER is the buffer that
3398 was current when the variable was bound. */
3399 else if (CONSP (this_binding
.symbol
))
3401 Lisp_Object symbol
, where
;
3403 symbol
= XCAR (this_binding
.symbol
);
3404 where
= XCAR (XCDR (this_binding
.symbol
));
3407 Fset_default (symbol
, this_binding
.old_value
);
3408 else if (BUFFERP (where
))
3409 set_internal (symbol
, this_binding
.old_value
, XBUFFER (where
), 1);
3411 set_internal (symbol
, this_binding
.old_value
, NULL
, 1);
3415 /* If variable has a trivial value (no forwarding), we can
3416 just set it. No need to check for constant symbols here,
3417 since that was already done by specbind. */
3418 if (!MISCP (SYMBOL_VALUE (this_binding
.symbol
)))
3419 SET_SYMBOL_VALUE (this_binding
.symbol
, this_binding
.old_value
);
3421 set_internal (this_binding
.symbol
, this_binding
.old_value
, 0, 1);
3425 if (NILP (Vquit_flag
) && !NILP (quitf
))
3432 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3433 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3434 The debugger is entered when that frame exits, if the flag is non-nil. */)
3436 Lisp_Object level
, flag
;
3438 register struct backtrace
*backlist
= backtrace_list
;
3441 CHECK_NUMBER (level
);
3443 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
3445 backlist
= backlist
->next
;
3449 backlist
->debug_on_exit
= !NILP (flag
);
3454 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3455 doc
: /* Print a trace of Lisp function calls currently active.
3456 Output stream used is value of `standard-output'. */)
3459 register struct backtrace
*backlist
= backtrace_list
;
3463 extern Lisp_Object Vprint_level
;
3464 struct gcpro gcpro1
;
3466 XSETFASTINT (Vprint_level
, 3);
3473 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
3474 if (backlist
->nargs
== UNEVALLED
)
3476 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
3477 write_string ("\n", -1);
3481 tem
= *backlist
->function
;
3482 Fprin1 (tem
, Qnil
); /* This can QUIT */
3483 write_string ("(", -1);
3484 if (backlist
->nargs
== MANY
)
3486 for (tail
= *backlist
->args
, i
= 0;
3488 tail
= Fcdr (tail
), i
++)
3490 if (i
) write_string (" ", -1);
3491 Fprin1 (Fcar (tail
), Qnil
);
3496 for (i
= 0; i
< backlist
->nargs
; i
++)
3498 if (i
) write_string (" ", -1);
3499 Fprin1 (backlist
->args
[i
], Qnil
);
3502 write_string (")\n", -1);
3504 backlist
= backlist
->next
;
3507 Vprint_level
= Qnil
;
3512 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, NULL
,
3513 doc
: /* Return the function and arguments NFRAMES up from current execution point.
3514 If that frame has not evaluated the arguments yet (or is a special form),
3515 the value is (nil FUNCTION ARG-FORMS...).
3516 If that frame has evaluated its arguments and called its function already,
3517 the value is (t FUNCTION ARG-VALUES...).
3518 A &rest arg is represented as the tail of the list ARG-VALUES.
3519 FUNCTION is whatever was supplied as car of evaluated list,
3520 or a lambda expression for macro calls.
3521 If NFRAMES is more than the number of frames, the value is nil. */)
3523 Lisp_Object nframes
;
3525 register struct backtrace
*backlist
= backtrace_list
;
3529 CHECK_NATNUM (nframes
);
3531 /* Find the frame requested. */
3532 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3533 backlist
= backlist
->next
;
3537 if (backlist
->nargs
== UNEVALLED
)
3538 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3541 if (backlist
->nargs
== MANY
)
3542 tem
= *backlist
->args
;
3544 tem
= Flist (backlist
->nargs
, backlist
->args
);
3546 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3554 register struct backtrace
*backlist
;
3557 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3559 mark_object (*backlist
->function
);
3561 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3564 i
= backlist
->nargs
- 1;
3566 mark_object (backlist
->args
[i
]);
3573 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
3574 doc
: /* *Limit on number of Lisp variable bindings and `unwind-protect's.
3575 If Lisp code tries to increase the total number past this amount,
3576 an error is signaled.
3577 You can safely use a value considerably larger than the default value,
3578 if that proves inconveniently small. However, if you increase it too far,
3579 Emacs could run out of memory trying to make the stack bigger. */);
3581 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
3582 doc
: /* *Limit on depth in `eval', `apply' and `funcall' before error.
3584 This limit serves to catch infinite recursions for you before they cause
3585 actual stack overflow in C, which would be fatal for Emacs.
3586 You can safely make it considerably larger than its default value,
3587 if that proves inconveniently small. However, if you increase it too far,
3588 Emacs could overflow the real C stack, and crash. */);
3590 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
3591 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3592 If the value is t, that means do an ordinary quit.
3593 If the value equals `throw-on-input', that means quit by throwing
3594 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3595 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3596 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3599 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
3600 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3601 Note that `quit-flag' will still be set by typing C-g,
3602 so a quit will be signaled as soon as `inhibit-quit' is nil.
3603 To prevent this happening, set `quit-flag' to nil
3604 before making `inhibit-quit' nil. */);
3605 Vinhibit_quit
= Qnil
;
3607 Qinhibit_quit
= intern ("inhibit-quit");
3608 staticpro (&Qinhibit_quit
);
3610 Qautoload
= intern ("autoload");
3611 staticpro (&Qautoload
);
3613 Qdebug_on_error
= intern ("debug-on-error");
3614 staticpro (&Qdebug_on_error
);
3616 Qmacro
= intern ("macro");
3617 staticpro (&Qmacro
);
3619 Qdeclare
= intern ("declare");
3620 staticpro (&Qdeclare
);
3622 /* Note that the process handling also uses Qexit, but we don't want
3623 to staticpro it twice, so we just do it here. */
3624 Qexit
= intern ("exit");
3627 Qinteractive
= intern ("interactive");
3628 staticpro (&Qinteractive
);
3630 Qcommandp
= intern ("commandp");
3631 staticpro (&Qcommandp
);
3633 Qdefun
= intern ("defun");
3634 staticpro (&Qdefun
);
3636 Qand_rest
= intern ("&rest");
3637 staticpro (&Qand_rest
);
3639 Qand_optional
= intern ("&optional");
3640 staticpro (&Qand_optional
);
3642 Qdebug
= intern ("debug");
3643 staticpro (&Qdebug
);
3645 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
3646 doc
: /* *Non-nil means errors display a backtrace buffer.
3647 More precisely, this happens for any error that is handled
3648 by the editor command loop.
3649 If the value is a list, an error only means to display a backtrace
3650 if one of its condition symbols appears in the list. */);
3651 Vstack_trace_on_error
= Qnil
;
3653 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
3654 doc
: /* *Non-nil means enter debugger if an error is signaled.
3655 Does not apply to errors handled by `condition-case' or those
3656 matched by `debug-ignored-errors'.
3657 If the value is a list, an error only means to enter the debugger
3658 if one of its condition symbols appears in the list.
3659 When you evaluate an expression interactively, this variable
3660 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3661 See also variable `debug-on-quit'. */);
3662 Vdebug_on_error
= Qnil
;
3664 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
3665 doc
: /* *List of errors for which the debugger should not be called.
3666 Each element may be a condition-name or a regexp that matches error messages.
3667 If any element applies to a given error, that error skips the debugger
3668 and just returns to top level.
3669 This overrides the variable `debug-on-error'.
3670 It does not apply to errors handled by `condition-case'. */);
3671 Vdebug_ignored_errors
= Qnil
;
3673 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
3674 doc
: /* *Non-nil means enter debugger if quit is signaled (C-g, for example).
3675 Does not apply if quit is handled by a `condition-case'. */);
3678 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
3679 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3681 DEFVAR_BOOL ("debugger-may-continue", &debugger_may_continue
,
3682 doc
: /* Non-nil means debugger may continue execution.
3683 This is nil when the debugger is called under circumstances where it
3684 might not be safe to continue. */);
3685 debugger_may_continue
= 1;
3687 DEFVAR_LISP ("debugger", &Vdebugger
,
3688 doc
: /* Function to call to invoke debugger.
3689 If due to frame exit, args are `exit' and the value being returned;
3690 this function's value will be returned instead of that.
3691 If due to error, args are `error' and a list of the args to `signal'.
3692 If due to `apply' or `funcall' entry, one arg, `lambda'.
3693 If due to `eval' entry, one arg, t. */);
3696 DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function
,
3697 doc
: /* If non-nil, this is a function for `signal' to call.
3698 It receives the same arguments that `signal' was given.
3699 The Edebug package uses this to regain control. */);
3700 Vsignal_hook_function
= Qnil
;
3702 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal
,
3703 doc
: /* *Non-nil means call the debugger regardless of condition handlers.
3704 Note that `debug-on-error', `debug-on-quit' and friends
3705 still determine whether to handle the particular condition. */);
3706 Vdebug_on_signal
= Qnil
;
3708 DEFVAR_LISP ("macro-declaration-function", &Vmacro_declaration_function
,
3709 doc
: /* Function to process declarations in a macro definition.
3710 The function will be called with two args MACRO and DECL.
3711 MACRO is the name of the macro being defined.
3712 DECL is a list `(declare ...)' containing the declarations.
3713 The value the function returns is not used. */);
3714 Vmacro_declaration_function
= Qnil
;
3716 Vrun_hooks
= intern ("run-hooks");
3717 staticpro (&Vrun_hooks
);
3719 staticpro (&Vautoload_queue
);
3720 Vautoload_queue
= Qnil
;
3721 staticpro (&Vsignaling_function
);
3722 Vsignaling_function
= Qnil
;
3733 defsubr (&Sfunction
);
3735 defsubr (&Sdefmacro
);
3737 defsubr (&Sdefvaralias
);
3738 defsubr (&Sdefconst
);
3739 defsubr (&Suser_variable_p
);
3743 defsubr (&Smacroexpand
);
3746 defsubr (&Sunwind_protect
);
3747 defsubr (&Scondition_case
);
3749 defsubr (&Sinteractive_p
);
3750 defsubr (&Scalled_interactively_p
);
3751 defsubr (&Scommandp
);
3752 defsubr (&Sautoload
);
3755 defsubr (&Sfuncall
);
3756 defsubr (&Srun_hooks
);
3757 defsubr (&Srun_hook_with_args
);
3758 defsubr (&Srun_hook_with_args_until_success
);
3759 defsubr (&Srun_hook_with_args_until_failure
);
3760 defsubr (&Sfetch_bytecode
);
3761 defsubr (&Sbacktrace_debug
);
3762 defsubr (&Sbacktrace
);
3763 defsubr (&Sbacktrace_frame
);
3766 /* arch-tag: 014a07aa-33ab-4a8f-a3d2-ee8a4a9ff7fb
3767 (do not change this comment) */