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 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 2, 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"
31 /* This definition is duplicated in alloc.c and keyboard.c */
32 /* Putting it in lisp.h makes cc bomb out! */
36 struct backtrace
*next
;
37 Lisp_Object
*function
;
38 Lisp_Object
*args
; /* Points to vector of args. */
39 int nargs
; /* Length of vector.
40 If nargs is UNEVALLED, args points to slot holding
41 list of unevalled args */
43 /* Nonzero means call value of debugger when done with this operation. */
47 struct backtrace
*backtrace_list
;
49 /* This structure helps implement the `catch' and `throw' control
50 structure. A struct catchtag contains all the information needed
51 to restore the state of the interpreter after a non-local jump.
53 Handlers for error conditions (represented by `struct handler'
54 structures) just point to a catch tag to do the cleanup required
57 catchtag structures are chained together in the C calling stack;
58 the `next' member points to the next outer catchtag.
60 A call like (throw TAG VAL) searches for a catchtag whose `tag'
61 member is TAG, and then unbinds to it. The `val' member is used to
62 hold VAL while the stack is unwound; `val' is returned as the value
65 All the other members are concerned with restoring the interpreter
72 struct catchtag
*next
;
75 struct backtrace
*backlist
;
76 struct handler
*handlerlist
;
79 int poll_suppress_count
;
80 int interrupt_input_blocked
;
81 struct byte_stack
*byte_stack
;
84 struct catchtag
*catchlist
;
87 /* Count levels of GCPRO to detect failure to UNGCPRO. */
91 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
92 Lisp_Object Qinhibit_quit
, Vinhibit_quit
, Vquit_flag
;
93 Lisp_Object Qand_rest
, Qand_optional
;
94 Lisp_Object Qdebug_on_error
;
97 /* This holds either the symbol `run-hooks' or nil.
98 It is nil at an early stage of startup, and when Emacs
101 Lisp_Object Vrun_hooks
;
103 /* Non-nil means record all fset's and provide's, to be undone
104 if the file being autoloaded is not fully loaded.
105 They are recorded by being consed onto the front of Vautoload_queue:
106 (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide. */
108 Lisp_Object Vautoload_queue
;
110 /* Current number of specbindings allocated in specpdl. */
114 /* Pointer to beginning of specpdl. */
116 struct specbinding
*specpdl
;
118 /* Pointer to first unused element in specpdl. */
120 struct specbinding
*specpdl_ptr
;
122 /* Maximum size allowed for specpdl allocation */
124 EMACS_INT max_specpdl_size
;
126 /* Depth in Lisp evaluations and function calls. */
130 /* Maximum allowed depth in Lisp evaluations and function calls. */
132 EMACS_INT max_lisp_eval_depth
;
134 /* Nonzero means enter debugger before next function call */
136 int debug_on_next_call
;
138 /* Non-zero means debugger may continue. This is zero when the
139 debugger is called during redisplay, where it might not be safe to
140 continue the interrupted redisplay. */
142 int debugger_may_continue
;
144 /* List of conditions (non-nil atom means all) which cause a backtrace
145 if an error is handled by the command loop's error handler. */
147 Lisp_Object Vstack_trace_on_error
;
149 /* List of conditions (non-nil atom means all) which enter the debugger
150 if an error is handled by the command loop's error handler. */
152 Lisp_Object Vdebug_on_error
;
154 /* List of conditions and regexps specifying error messages which
155 do not enter the debugger even if Vdebug_on_error says they should. */
157 Lisp_Object Vdebug_ignored_errors
;
159 /* Non-nil means call the debugger even if the error will be handled. */
161 Lisp_Object Vdebug_on_signal
;
163 /* Hook for edebug to use. */
165 Lisp_Object Vsignal_hook_function
;
167 /* Nonzero means enter debugger if a quit signal
168 is handled by the command loop's error handler. */
172 /* The value of num_nonmacro_input_events as of the last time we
173 started to enter the debugger. If we decide to enter the debugger
174 again when this is still equal to num_nonmacro_input_events, then we
175 know that the debugger itself has an error, and we should just
176 signal the error instead of entering an infinite loop of debugger
179 int when_entered_debugger
;
181 Lisp_Object Vdebugger
;
183 /* The function from which the last `signal' was called. Set in
186 Lisp_Object Vsignaling_function
;
188 /* Set to non-zero while processing X events. Checked in Feval to
189 make sure the Lisp interpreter isn't called from a signal handler,
190 which is unsafe because the interpreter isn't reentrant. */
194 /* Function to process declarations in defmacro forms. */
196 Lisp_Object Vmacro_declaration_function
;
198 extern Lisp_Object Qrisky_local_variable
;
200 static Lisp_Object funcall_lambda
P_ ((Lisp_Object
, int, Lisp_Object
*));
201 static void unwind_to_catch
P_ ((struct catchtag
*, Lisp_Object
)) NO_RETURN
;
207 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
208 specpdl_ptr
= specpdl
;
209 /* Don't forget to update docs (lispref node "Local Variables"). */
210 max_specpdl_size
= 1000;
211 max_lisp_eval_depth
= 300;
219 specpdl_ptr
= specpdl
;
224 debug_on_next_call
= 0;
229 /* This is less than the initial value of num_nonmacro_input_events. */
230 when_entered_debugger
= -1;
233 /* unwind-protect function used by call_debugger. */
236 restore_stack_limits (data
)
239 max_specpdl_size
= XINT (XCAR (data
));
240 max_lisp_eval_depth
= XINT (XCDR (data
));
244 /* Call the Lisp debugger, giving it argument ARG. */
250 int debug_while_redisplaying
;
251 int count
= SPECPDL_INDEX ();
253 int old_max
= max_specpdl_size
;
255 /* Temporarily bump up the stack limits,
256 so the debugger won't run out of stack. */
258 max_specpdl_size
+= 1;
259 record_unwind_protect (restore_stack_limits
,
260 Fcons (make_number (old_max
),
261 make_number (max_lisp_eval_depth
)));
262 max_specpdl_size
= old_max
;
264 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
265 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
267 if (SPECPDL_INDEX () + 100 > max_specpdl_size
)
268 max_specpdl_size
= SPECPDL_INDEX () + 100;
270 #ifdef HAVE_X_WINDOWS
271 if (display_hourglass_p
)
275 debug_on_next_call
= 0;
276 when_entered_debugger
= num_nonmacro_input_events
;
278 /* Resetting redisplaying_p to 0 makes sure that debug output is
279 displayed if the debugger is invoked during redisplay. */
280 debug_while_redisplaying
= redisplaying_p
;
282 specbind (intern ("debugger-may-continue"),
283 debug_while_redisplaying
? Qnil
: Qt
);
284 specbind (Qinhibit_redisplay
, Qnil
);
285 specbind (Qdebug_on_error
, Qnil
);
287 #if 0 /* Binding this prevents execution of Lisp code during
288 redisplay, which necessarily leads to display problems. */
289 specbind (Qinhibit_eval_during_redisplay
, Qt
);
292 val
= apply1 (Vdebugger
, arg
);
294 /* Interrupting redisplay and resuming it later is not safe under
295 all circumstances. So, when the debugger returns, abort the
296 interrupted redisplay by going back to the top-level. */
297 if (debug_while_redisplaying
)
300 return unbind_to (count
, val
);
304 do_debug_on_call (code
)
307 debug_on_next_call
= 0;
308 backtrace_list
->debug_on_exit
= 1;
309 call_debugger (Fcons (code
, Qnil
));
312 /* NOTE!!! Every function that can call EVAL must protect its args
313 and temporaries from garbage collection while it needs them.
314 The definition of `For' shows what you have to do. */
316 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
317 doc
: /* Eval args until one of them yields non-nil, then return that value.
318 The remaining args are not evalled at all.
319 If all args return nil, return nil.
320 usage: (or CONDITIONS ...) */)
324 register Lisp_Object val
= Qnil
;
331 val
= Feval (XCAR (args
));
341 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
342 doc
: /* Eval args until one of them yields nil, then return nil.
343 The remaining args are not evalled at all.
344 If no arg yields nil, return the last arg's value.
345 usage: (and CONDITIONS ...) */)
349 register Lisp_Object val
= Qt
;
356 val
= Feval (XCAR (args
));
366 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
367 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
368 Returns the value of THEN or the value of the last of the ELSE's.
369 THEN must be one expression, but ELSE... can be zero or more expressions.
370 If COND yields nil, and there are no ELSE's, the value is nil.
371 usage: (if COND THEN ELSE...) */)
375 register Lisp_Object cond
;
379 cond
= Feval (Fcar (args
));
383 return Feval (Fcar (Fcdr (args
)));
384 return Fprogn (Fcdr (Fcdr (args
)));
387 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
388 doc
: /* Try each clause until one succeeds.
389 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
390 and, if the value is non-nil, this clause succeeds:
391 then the expressions in BODY are evaluated and the last one's
392 value is the value of the cond-form.
393 If no clause succeeds, cond returns nil.
394 If a clause has one element, as in (CONDITION),
395 CONDITION's value if non-nil is returned from the cond-form.
396 usage: (cond CLAUSES...) */)
400 register Lisp_Object clause
, val
;
407 clause
= Fcar (args
);
408 val
= Feval (Fcar (clause
));
411 if (!EQ (XCDR (clause
), Qnil
))
412 val
= Fprogn (XCDR (clause
));
422 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
423 doc
: /* Eval BODY forms sequentially and return value of last one.
424 usage: (progn BODY ...) */)
428 register Lisp_Object val
= Qnil
;
435 val
= Feval (XCAR (args
));
443 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
444 doc
: /* Eval FIRST and BODY sequentially; value from FIRST.
445 The value of FIRST is saved during the evaluation of the remaining args,
446 whose values are discarded.
447 usage: (prog1 FIRST BODY...) */)
452 register Lisp_Object args_left
;
453 struct gcpro gcpro1
, gcpro2
;
454 register int argnum
= 0;
466 val
= Feval (Fcar (args_left
));
468 Feval (Fcar (args_left
));
469 args_left
= Fcdr (args_left
);
471 while (!NILP(args_left
));
477 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
478 doc
: /* Eval FORM1, FORM2 and BODY sequentially; value from FORM2.
479 The value of FORM2 is saved during the evaluation of the
480 remaining args, whose values are discarded.
481 usage: (prog2 FORM1 FORM2 BODY...) */)
486 register Lisp_Object args_left
;
487 struct gcpro gcpro1
, gcpro2
;
488 register int argnum
= -1;
502 val
= Feval (Fcar (args_left
));
504 Feval (Fcar (args_left
));
505 args_left
= Fcdr (args_left
);
507 while (!NILP (args_left
));
513 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
514 doc
: /* Set each SYM to the value of its VAL.
515 The symbols SYM are variables; they are literal (not evaluated).
516 The values VAL are expressions; they are evaluated.
517 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
518 The second VAL is not computed until after the first SYM is set, and so on;
519 each VAL can use the new value of variables set earlier in the `setq'.
520 The return value of the `setq' form is the value of the last VAL.
521 usage: (setq SYM VAL SYM VAL ...) */)
525 register Lisp_Object args_left
;
526 register Lisp_Object val
, sym
;
537 val
= Feval (Fcar (Fcdr (args_left
)));
538 sym
= Fcar (args_left
);
540 args_left
= Fcdr (Fcdr (args_left
));
542 while (!NILP(args_left
));
548 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
549 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
550 usage: (quote ARG) */)
557 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
558 doc
: /* Like `quote', but preferred for objects which are functions.
559 In byte compilation, `function' causes its argument to be compiled.
560 `quote' cannot do that.
561 usage: (function ARG) */)
569 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
570 doc
: /* Return t if the function was run directly by user input.
571 This means that the function was called with `call-interactively'
572 \(which includes being called as the binding of a key)
573 and input is currently coming from the keyboard (not in keyboard macro),
574 and Emacs is not running in batch mode (`noninteractive' is nil).
576 The only known proper use of `interactive-p' is in deciding whether to
577 display a helpful message, or how to display it. If you're thinking
578 of using it for any other purpose, it is quite likely that you're
579 making a mistake. Think: what do you want to do when the command is
580 called from a keyboard macro?
582 If you want to test whether your function was called with
583 `call-interactively', the way to do that is by adding an extra
584 optional argument, and making the `interactive' spec specify non-nil
585 unconditionally for that argument. (`p' is a good way to do this.) */)
588 return (INTERACTIVE
&& interactive_p (1)) ? Qt
: Qnil
;
592 DEFUN ("called-interactively-p", Fcalled_interactively_p
, Scalled_interactively_p
, 0, 0, 0,
593 doc
: /* Return t if the function using this was called with `call-interactively'.
594 This is used for implementing advice and other function-modifying
597 The cleanest way to test whether your function was called with
598 `call-interactively' is by adding an extra optional argument,
599 and making the `interactive' spec specify non-nil unconditionally
600 for that argument. (`p' is a good way to do this.) */)
603 return interactive_p (1) ? Qt
: Qnil
;
607 /* Return 1 if function in which this appears was called using
610 EXCLUDE_SUBRS_P non-zero means always return 0 if the function
611 called is a built-in. */
614 interactive_p (exclude_subrs_p
)
617 struct backtrace
*btp
;
620 btp
= backtrace_list
;
622 /* If this isn't a byte-compiled function, there may be a frame at
623 the top for Finteractive_p. If so, skip it. */
624 fun
= Findirect_function (*btp
->function
, Qnil
);
625 if (SUBRP (fun
) && (XSUBR (fun
) == &Sinteractive_p
626 || XSUBR (fun
) == &Scalled_interactively_p
))
629 /* If we're running an Emacs 18-style byte-compiled function, there
630 may be a frame for Fbytecode at the top level. In any version of
631 Emacs there can be Fbytecode frames for subexpressions evaluated
632 inside catch and condition-case. Skip past them.
634 If this isn't a byte-compiled function, then we may now be
635 looking at several frames for special forms. Skip past them. */
637 && (EQ (*btp
->function
, Qbytecode
)
638 || btp
->nargs
== UNEVALLED
))
641 /* btp now points at the frame of the innermost function that isn't
642 a special form, ignoring frames for Finteractive_p and/or
643 Fbytecode at the top. If this frame is for a built-in function
644 (such as load or eval-region) return nil. */
645 fun
= Findirect_function (*btp
->function
, Qnil
);
646 if (exclude_subrs_p
&& SUBRP (fun
))
649 /* btp points to the frame of a Lisp function that called interactive-p.
650 Return t if that function was called interactively. */
651 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
657 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
658 doc
: /* Define NAME as a function.
659 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
660 See also the function `interactive'.
661 usage: (defun NAME ARGLIST [DOCSTRING] BODY...) */)
665 register Lisp_Object fn_name
;
666 register Lisp_Object defn
;
668 fn_name
= Fcar (args
);
669 CHECK_SYMBOL (fn_name
);
670 defn
= Fcons (Qlambda
, Fcdr (args
));
671 if (!NILP (Vpurify_flag
))
672 defn
= Fpurecopy (defn
);
673 if (CONSP (XSYMBOL (fn_name
)->function
)
674 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
675 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
676 Ffset (fn_name
, defn
);
677 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
681 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
682 doc
: /* Define NAME as a macro.
683 The actual definition looks like
684 (macro lambda ARGLIST [DOCSTRING] [DECL] BODY...).
685 When the macro is called, as in (NAME ARGS...),
686 the function (lambda ARGLIST BODY...) is applied to
687 the list ARGS... as it appears in the expression,
688 and the result should be a form to be evaluated instead of the original.
690 DECL is a declaration, optional, which can specify how to indent
691 calls to this macro and how Edebug should handle it. It looks like this:
693 The elements can look like this:
695 Set NAME's `lisp-indent-function' property to INDENT.
698 Set NAME's `edebug-form-spec' property to DEBUG. (This is
699 equivalent to writing a `def-edebug-spec' for the macro.)
700 usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */)
704 register Lisp_Object fn_name
;
705 register Lisp_Object defn
;
706 Lisp_Object lambda_list
, doc
, tail
;
708 fn_name
= Fcar (args
);
709 CHECK_SYMBOL (fn_name
);
710 lambda_list
= Fcar (Fcdr (args
));
711 tail
= Fcdr (Fcdr (args
));
714 if (STRINGP (Fcar (tail
)))
720 while (CONSP (Fcar (tail
))
721 && EQ (Fcar (Fcar (tail
)), Qdeclare
))
723 if (!NILP (Vmacro_declaration_function
))
727 call2 (Vmacro_declaration_function
, fn_name
, Fcar (tail
));
735 tail
= Fcons (lambda_list
, tail
);
737 tail
= Fcons (lambda_list
, Fcons (doc
, tail
));
738 defn
= Fcons (Qmacro
, Fcons (Qlambda
, tail
));
740 if (!NILP (Vpurify_flag
))
741 defn
= Fpurecopy (defn
);
742 if (CONSP (XSYMBOL (fn_name
)->function
)
743 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
744 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
745 Ffset (fn_name
, defn
);
746 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
751 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
752 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
753 Aliased variables always have the same value; setting one sets the other.
754 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
755 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
756 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
758 The return value is BASE-VARIABLE. */)
759 (new_alias
, base_variable
, docstring
)
760 Lisp_Object new_alias
, base_variable
, docstring
;
762 struct Lisp_Symbol
*sym
;
764 CHECK_SYMBOL (new_alias
);
765 CHECK_SYMBOL (base_variable
);
767 if (SYMBOL_CONSTANT_P (new_alias
))
768 error ("Cannot make a constant an alias");
770 sym
= XSYMBOL (new_alias
);
771 sym
->indirect_variable
= 1;
772 sym
->value
= base_variable
;
773 sym
->constant
= SYMBOL_CONSTANT_P (base_variable
);
774 LOADHIST_ATTACH (new_alias
);
775 if (!NILP (docstring
))
776 Fput (new_alias
, Qvariable_documentation
, docstring
);
778 Fput (new_alias
, Qvariable_documentation
, Qnil
);
780 return base_variable
;
784 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
785 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
786 You are not required to define a variable in order to use it,
787 but the definition can supply documentation and an initial value
788 in a way that tags can recognize.
790 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.
791 If SYMBOL is buffer-local, its default value is what is set;
792 buffer-local values are not affected.
793 INITVALUE and DOCSTRING are optional.
794 If DOCSTRING starts with *, this variable is identified as a user option.
795 This means that M-x set-variable recognizes it.
796 See also `user-variable-p'.
797 If INITVALUE is missing, SYMBOL's value is not set.
799 If SYMBOL has a local binding, then this form affects the local
800 binding. This is usually not what you want. Thus, if you need to
801 load a file defining variables, with this form or with `defconst' or
802 `defcustom', you should always load that file _outside_ any bindings
803 for these variables. \(`defconst' and `defcustom' behave similarly in
805 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
809 register Lisp_Object sym
, tem
, tail
;
813 if (!NILP (Fcdr (Fcdr (tail
))))
814 error ("Too many arguments");
816 tem
= Fdefault_boundp (sym
);
819 if (SYMBOL_CONSTANT_P (sym
))
821 /* For upward compatibility, allow (defvar :foo (quote :foo)). */
822 Lisp_Object tem
= Fcar (tail
);
824 && EQ (XCAR (tem
), Qquote
)
825 && CONSP (XCDR (tem
))
826 && EQ (XCAR (XCDR (tem
)), sym
)))
827 error ("Constant symbol `%s' specified in defvar",
828 SDATA (SYMBOL_NAME (sym
)));
832 Fset_default (sym
, Feval (Fcar (tail
)));
834 { /* Check if there is really a global binding rather than just a let
835 binding that shadows the global unboundness of the var. */
836 volatile struct specbinding
*pdl
= specpdl_ptr
;
837 while (--pdl
>= specpdl
)
839 if (EQ (pdl
->symbol
, sym
) && !pdl
->func
840 && EQ (pdl
->old_value
, Qunbound
))
842 message_with_string ("Warning: defvar ignored because %s is let-bound",
843 SYMBOL_NAME (sym
), 1);
852 if (!NILP (Vpurify_flag
))
853 tem
= Fpurecopy (tem
);
854 Fput (sym
, Qvariable_documentation
, tem
);
856 LOADHIST_ATTACH (sym
);
859 /* Simple (defvar <var>) should not count as a definition at all.
860 It could get in the way of other definitions, and unloading this
861 package could try to make the variable unbound. */
867 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
868 doc
: /* Define SYMBOL as a constant variable.
869 The intent is that neither programs nor users should ever change this value.
870 Always sets the value of SYMBOL to the result of evalling INITVALUE.
871 If SYMBOL is buffer-local, its default value is what is set;
872 buffer-local values are not affected.
873 DOCSTRING is optional.
875 If SYMBOL has a local binding, then this form sets the local binding's
876 value. However, you should normally not make local bindings for
877 variables defined with this form.
878 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
882 register Lisp_Object sym
, tem
;
885 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
886 error ("Too many arguments");
888 tem
= Feval (Fcar (Fcdr (args
)));
889 if (!NILP (Vpurify_flag
))
890 tem
= Fpurecopy (tem
);
891 Fset_default (sym
, tem
);
892 tem
= Fcar (Fcdr (Fcdr (args
)));
895 if (!NILP (Vpurify_flag
))
896 tem
= Fpurecopy (tem
);
897 Fput (sym
, Qvariable_documentation
, tem
);
899 Fput (sym
, Qrisky_local_variable
, Qt
);
900 LOADHIST_ATTACH (sym
);
904 /* Error handler used in Fuser_variable_p. */
906 user_variable_p_eh (ignore
)
912 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
913 doc
: /* Return t if VARIABLE is intended to be set and modified by users.
914 \(The alternative is a variable used internally in a Lisp program.)
915 A variable is a user variable if
916 \(1) the first character of its documentation is `*', or
917 \(2) it is customizable (its property list contains a non-nil value
918 of `standard-value' or `custom-autoload'), or
919 \(3) it is an alias for another user variable.
920 Return nil if VARIABLE is an alias and there is a loop in the
921 chain of symbols. */)
923 Lisp_Object variable
;
925 Lisp_Object documentation
;
927 if (!SYMBOLP (variable
))
930 /* If indirect and there's an alias loop, don't check anything else. */
931 if (XSYMBOL (variable
)->indirect_variable
932 && NILP (internal_condition_case_1 (indirect_variable
, variable
,
933 Qt
, user_variable_p_eh
)))
938 documentation
= Fget (variable
, Qvariable_documentation
);
939 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
941 if (STRINGP (documentation
)
942 && ((unsigned char) SREF (documentation
, 0) == '*'))
944 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
945 if (CONSP (documentation
)
946 && STRINGP (XCAR (documentation
))
947 && INTEGERP (XCDR (documentation
))
948 && XINT (XCDR (documentation
)) < 0)
950 /* Customizable? See `custom-variable-p'. */
951 if ((!NILP (Fget (variable
, intern ("standard-value"))))
952 || (!NILP (Fget (variable
, intern ("custom-autoload")))))
955 if (!XSYMBOL (variable
)->indirect_variable
)
958 /* An indirect variable? Let's follow the chain. */
959 variable
= XSYMBOL (variable
)->value
;
963 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
964 doc
: /* Bind variables according to VARLIST then eval BODY.
965 The value of the last form in BODY is returned.
966 Each element of VARLIST is a symbol (which is bound to nil)
967 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
968 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
969 usage: (let* VARLIST BODY...) */)
973 Lisp_Object varlist
, val
, elt
;
974 int count
= SPECPDL_INDEX ();
975 struct gcpro gcpro1
, gcpro2
, gcpro3
;
977 GCPRO3 (args
, elt
, varlist
);
979 varlist
= Fcar (args
);
980 while (!NILP (varlist
))
983 elt
= Fcar (varlist
);
985 specbind (elt
, Qnil
);
986 else if (! NILP (Fcdr (Fcdr (elt
))))
987 signal_error ("`let' bindings can have only one value-form", elt
);
990 val
= Feval (Fcar (Fcdr (elt
)));
991 specbind (Fcar (elt
), val
);
993 varlist
= Fcdr (varlist
);
996 val
= Fprogn (Fcdr (args
));
997 return unbind_to (count
, val
);
1000 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
1001 doc
: /* Bind variables according to VARLIST then eval BODY.
1002 The value of the last form in BODY is returned.
1003 Each element of VARLIST is a symbol (which is bound to nil)
1004 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
1005 All the VALUEFORMs are evalled before any symbols are bound.
1006 usage: (let VARLIST BODY...) */)
1010 Lisp_Object
*temps
, tem
;
1011 register Lisp_Object elt
, varlist
;
1012 int count
= SPECPDL_INDEX ();
1013 register int argnum
;
1014 struct gcpro gcpro1
, gcpro2
;
1016 varlist
= Fcar (args
);
1018 /* Make space to hold the values to give the bound variables */
1019 elt
= Flength (varlist
);
1020 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
1022 /* Compute the values and store them in `temps' */
1024 GCPRO2 (args
, *temps
);
1027 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
1030 elt
= Fcar (varlist
);
1032 temps
[argnum
++] = Qnil
;
1033 else if (! NILP (Fcdr (Fcdr (elt
))))
1034 signal_error ("`let' bindings can have only one value-form", elt
);
1036 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
1037 gcpro2
.nvars
= argnum
;
1041 varlist
= Fcar (args
);
1042 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
1044 elt
= Fcar (varlist
);
1045 tem
= temps
[argnum
++];
1047 specbind (elt
, tem
);
1049 specbind (Fcar (elt
), tem
);
1052 elt
= Fprogn (Fcdr (args
));
1053 return unbind_to (count
, elt
);
1056 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
1057 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
1058 The order of execution is thus TEST, BODY, TEST, BODY and so on
1059 until TEST returns nil.
1060 usage: (while TEST BODY...) */)
1064 Lisp_Object test
, body
;
1065 struct gcpro gcpro1
, gcpro2
;
1067 GCPRO2 (test
, body
);
1071 while (!NILP (Feval (test
)))
1081 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
1082 doc
: /* Return result of expanding macros at top level of FORM.
1083 If FORM is not a macro call, it is returned unchanged.
1084 Otherwise, the macro is expanded and the expansion is considered
1085 in place of FORM. When a non-macro-call results, it is returned.
1087 The second optional arg ENVIRONMENT specifies an environment of macro
1088 definitions to shadow the loaded ones for use in file byte-compilation. */)
1091 Lisp_Object environment
;
1093 /* With cleanups from Hallvard Furuseth. */
1094 register Lisp_Object expander
, sym
, def
, tem
;
1098 /* Come back here each time we expand a macro call,
1099 in case it expands into another macro call. */
1102 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1103 def
= sym
= XCAR (form
);
1105 /* Trace symbols aliases to other symbols
1106 until we get a symbol that is not an alias. */
1107 while (SYMBOLP (def
))
1111 tem
= Fassq (sym
, environment
);
1114 def
= XSYMBOL (sym
)->function
;
1115 if (!EQ (def
, Qunbound
))
1120 /* Right now TEM is the result from SYM in ENVIRONMENT,
1121 and if TEM is nil then DEF is SYM's function definition. */
1124 /* SYM is not mentioned in ENVIRONMENT.
1125 Look at its function definition. */
1126 if (EQ (def
, Qunbound
) || !CONSP (def
))
1127 /* Not defined or definition not suitable */
1129 if (EQ (XCAR (def
), Qautoload
))
1131 /* Autoloading function: will it be a macro when loaded? */
1132 tem
= Fnth (make_number (4), def
);
1133 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
1134 /* Yes, load it and try again. */
1136 struct gcpro gcpro1
;
1138 do_autoload (def
, sym
);
1145 else if (!EQ (XCAR (def
), Qmacro
))
1147 else expander
= XCDR (def
);
1151 expander
= XCDR (tem
);
1152 if (NILP (expander
))
1155 form
= apply1 (expander
, XCDR (form
));
1160 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1161 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1162 TAG is evalled to get the tag to use; it must not be nil.
1164 Then the BODY is executed.
1165 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.
1166 If no throw happens, `catch' returns the value of the last BODY form.
1167 If a throw happens, it specifies the value to return from `catch'.
1168 usage: (catch TAG BODY...) */)
1172 register Lisp_Object tag
;
1173 struct gcpro gcpro1
;
1176 tag
= Feval (Fcar (args
));
1178 return internal_catch (tag
, Fprogn
, Fcdr (args
));
1181 /* Set up a catch, then call C function FUNC on argument ARG.
1182 FUNC should return a Lisp_Object.
1183 This is how catches are done from within C code. */
1186 internal_catch (tag
, func
, arg
)
1188 Lisp_Object (*func
) ();
1191 /* This structure is made part of the chain `catchlist'. */
1194 /* Fill in the components of c, and put it on the list. */
1198 c
.backlist
= backtrace_list
;
1199 c
.handlerlist
= handlerlist
;
1200 c
.lisp_eval_depth
= lisp_eval_depth
;
1201 c
.pdlcount
= SPECPDL_INDEX ();
1202 c
.poll_suppress_count
= poll_suppress_count
;
1203 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1204 c
.gcpro
= gcprolist
;
1205 c
.byte_stack
= byte_stack_list
;
1209 if (! _setjmp (c
.jmp
))
1210 c
.val
= (*func
) (arg
);
1212 /* Throw works by a longjmp that comes right here. */
1217 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1218 jump to that CATCH, returning VALUE as the value of that catch.
1220 This is the guts Fthrow and Fsignal; they differ only in the way
1221 they choose the catch tag to throw to. A catch tag for a
1222 condition-case form has a TAG of Qnil.
1224 Before each catch is discarded, unbind all special bindings and
1225 execute all unwind-protect clauses made above that catch. Unwind
1226 the handler stack as we go, so that the proper handlers are in
1227 effect for each unwind-protect clause we run. At the end, restore
1228 some static info saved in CATCH, and longjmp to the location
1231 This is used for correct unwinding in Fthrow and Fsignal. */
1234 unwind_to_catch (catch, value
)
1235 struct catchtag
*catch;
1238 register int last_time
;
1240 /* Save the value in the tag. */
1243 /* Restore certain special C variables. */
1244 set_poll_suppress_count (catch->poll_suppress_count
);
1245 UNBLOCK_INPUT_TO (catch->interrupt_input_blocked
);
1246 handling_signal
= 0;
1251 last_time
= catchlist
== catch;
1253 /* Unwind the specpdl stack, and then restore the proper set of
1255 unbind_to (catchlist
->pdlcount
, Qnil
);
1256 handlerlist
= catchlist
->handlerlist
;
1257 catchlist
= catchlist
->next
;
1259 while (! last_time
);
1262 /* If x_catch_errors was done, turn it off now.
1263 (First we give unbind_to a chance to do that.) */
1264 x_fully_uncatch_errors ();
1267 byte_stack_list
= catch->byte_stack
;
1268 gcprolist
= catch->gcpro
;
1271 gcpro_level
= gcprolist
->level
+ 1;
1275 backtrace_list
= catch->backlist
;
1276 lisp_eval_depth
= catch->lisp_eval_depth
;
1278 _longjmp (catch->jmp
, 1);
1281 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1282 doc
: /* Throw to the catch for TAG and return VALUE from it.
1283 Both TAG and VALUE are evalled. */)
1285 register Lisp_Object tag
, value
;
1287 register struct catchtag
*c
;
1290 for (c
= catchlist
; c
; c
= c
->next
)
1292 if (EQ (c
->tag
, tag
))
1293 unwind_to_catch (c
, value
);
1295 xsignal2 (Qno_catch
, tag
, value
);
1299 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1300 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1301 If BODYFORM completes normally, its value is returned
1302 after executing the UNWINDFORMS.
1303 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1304 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1309 int count
= SPECPDL_INDEX ();
1311 record_unwind_protect (Fprogn
, Fcdr (args
));
1312 val
= Feval (Fcar (args
));
1313 return unbind_to (count
, val
);
1316 /* Chain of condition handlers currently in effect.
1317 The elements of this chain are contained in the stack frames
1318 of Fcondition_case and internal_condition_case.
1319 When an error is signaled (by calling Fsignal, below),
1320 this chain is searched for an element that applies. */
1322 struct handler
*handlerlist
;
1324 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1325 doc
: /* Regain control when an error is signaled.
1326 Executes BODYFORM and returns its value if no error happens.
1327 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1328 where the BODY is made of Lisp expressions.
1330 A handler is applicable to an error
1331 if CONDITION-NAME is one of the error's condition names.
1332 If an error happens, the first applicable handler is run.
1334 The car of a handler may be a list of condition names
1335 instead of a single condition name.
1337 When a handler handles an error,
1338 control returns to the condition-case and the handler BODY... is executed
1339 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).
1340 VAR may be nil; then you do not get access to the signal information.
1342 The value of the last BODY form is returned from the condition-case.
1343 See also the function `signal' for more info.
1344 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1348 register Lisp_Object bodyform
, handlers
;
1349 volatile Lisp_Object var
;
1352 bodyform
= Fcar (Fcdr (args
));
1353 handlers
= Fcdr (Fcdr (args
));
1355 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1358 /* Like Fcondition_case, but the args are separate
1359 rather than passed in a list. Used by Fbyte_code. */
1362 internal_lisp_condition_case (var
, bodyform
, handlers
)
1363 volatile Lisp_Object var
;
1364 Lisp_Object bodyform
, handlers
;
1372 for (val
= handlers
; CONSP (val
); val
= XCDR (val
))
1378 && (SYMBOLP (XCAR (tem
))
1379 || CONSP (XCAR (tem
))))))
1380 error ("Invalid condition handler", tem
);
1385 c
.backlist
= backtrace_list
;
1386 c
.handlerlist
= handlerlist
;
1387 c
.lisp_eval_depth
= lisp_eval_depth
;
1388 c
.pdlcount
= SPECPDL_INDEX ();
1389 c
.poll_suppress_count
= poll_suppress_count
;
1390 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1391 c
.gcpro
= gcprolist
;
1392 c
.byte_stack
= byte_stack_list
;
1393 if (_setjmp (c
.jmp
))
1396 specbind (h
.var
, c
.val
);
1397 val
= Fprogn (Fcdr (h
.chosen_clause
));
1399 /* Note that this just undoes the binding of h.var; whoever
1400 longjumped to us unwound the stack to c.pdlcount before
1402 unbind_to (c
.pdlcount
, Qnil
);
1409 h
.handler
= handlers
;
1410 h
.next
= handlerlist
;
1414 val
= Feval (bodyform
);
1416 handlerlist
= h
.next
;
1420 /* Call the function BFUN with no arguments, catching errors within it
1421 according to HANDLERS. If there is an error, call HFUN with
1422 one argument which is the data that describes the error:
1425 HANDLERS can be a list of conditions to catch.
1426 If HANDLERS is Qt, catch all errors.
1427 If HANDLERS is Qerror, catch all errors
1428 but allow the debugger to run if that is enabled. */
1431 internal_condition_case (bfun
, handlers
, hfun
)
1432 Lisp_Object (*bfun
) ();
1433 Lisp_Object handlers
;
1434 Lisp_Object (*hfun
) ();
1440 /* Since Fsignal will close off all calls to x_catch_errors,
1441 we will get the wrong results if some are not closed now. */
1443 if (x_catching_errors ())
1449 c
.backlist
= backtrace_list
;
1450 c
.handlerlist
= handlerlist
;
1451 c
.lisp_eval_depth
= lisp_eval_depth
;
1452 c
.pdlcount
= SPECPDL_INDEX ();
1453 c
.poll_suppress_count
= poll_suppress_count
;
1454 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1455 c
.gcpro
= gcprolist
;
1456 c
.byte_stack
= byte_stack_list
;
1457 if (_setjmp (c
.jmp
))
1459 return (*hfun
) (c
.val
);
1463 h
.handler
= handlers
;
1465 h
.next
= handlerlist
;
1471 handlerlist
= h
.next
;
1475 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1478 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1479 Lisp_Object (*bfun
) ();
1481 Lisp_Object handlers
;
1482 Lisp_Object (*hfun
) ();
1488 /* Since Fsignal will close off all calls to x_catch_errors,
1489 we will get the wrong results if some are not closed now. */
1491 if (x_catching_errors ())
1497 c
.backlist
= backtrace_list
;
1498 c
.handlerlist
= handlerlist
;
1499 c
.lisp_eval_depth
= lisp_eval_depth
;
1500 c
.pdlcount
= SPECPDL_INDEX ();
1501 c
.poll_suppress_count
= poll_suppress_count
;
1502 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1503 c
.gcpro
= gcprolist
;
1504 c
.byte_stack
= byte_stack_list
;
1505 if (_setjmp (c
.jmp
))
1507 return (*hfun
) (c
.val
);
1511 h
.handler
= handlers
;
1513 h
.next
= handlerlist
;
1517 val
= (*bfun
) (arg
);
1519 handlerlist
= h
.next
;
1524 /* Like internal_condition_case but call BFUN with NARGS as first,
1525 and ARGS as second argument. */
1528 internal_condition_case_2 (bfun
, nargs
, args
, handlers
, hfun
)
1529 Lisp_Object (*bfun
) ();
1532 Lisp_Object handlers
;
1533 Lisp_Object (*hfun
) ();
1539 /* Since Fsignal will close off all calls to x_catch_errors,
1540 we will get the wrong results if some are not closed now. */
1542 if (x_catching_errors ())
1548 c
.backlist
= backtrace_list
;
1549 c
.handlerlist
= handlerlist
;
1550 c
.lisp_eval_depth
= lisp_eval_depth
;
1551 c
.pdlcount
= SPECPDL_INDEX ();
1552 c
.poll_suppress_count
= poll_suppress_count
;
1553 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1554 c
.gcpro
= gcprolist
;
1555 c
.byte_stack
= byte_stack_list
;
1556 if (_setjmp (c
.jmp
))
1558 return (*hfun
) (c
.val
);
1562 h
.handler
= handlers
;
1564 h
.next
= handlerlist
;
1568 val
= (*bfun
) (nargs
, args
);
1570 handlerlist
= h
.next
;
1575 static Lisp_Object find_handler_clause
P_ ((Lisp_Object
, Lisp_Object
,
1576 Lisp_Object
, Lisp_Object
,
1579 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1580 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1581 This function does not return.
1583 An error symbol is a symbol with an `error-conditions' property
1584 that is a list of condition names.
1585 A handler for any of those names will get to handle this signal.
1586 The symbol `error' should normally be one of them.
1588 DATA should be a list. Its elements are printed as part of the error message.
1589 See Info anchor `(elisp)Definition of signal' for some details on how this
1590 error message is constructed.
1591 If the signal is handled, DATA is made available to the handler.
1592 See also the function `condition-case'. */)
1593 (error_symbol
, data
)
1594 Lisp_Object error_symbol
, data
;
1596 /* When memory is full, ERROR-SYMBOL is nil,
1597 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1598 That is a special case--don't do this in other situations. */
1599 register struct handler
*allhandlers
= handlerlist
;
1600 Lisp_Object conditions
;
1601 extern int gc_in_progress
;
1602 extern int waiting_for_input
;
1603 Lisp_Object debugger_value
;
1605 Lisp_Object real_error_symbol
;
1606 struct backtrace
*bp
;
1608 immediate_quit
= handling_signal
= 0;
1610 if (gc_in_progress
|| waiting_for_input
)
1613 if (NILP (error_symbol
))
1614 real_error_symbol
= Fcar (data
);
1616 real_error_symbol
= error_symbol
;
1618 #if 0 /* rms: I don't know why this was here,
1619 but it is surely wrong for an error that is handled. */
1620 #ifdef HAVE_X_WINDOWS
1621 if (display_hourglass_p
)
1622 cancel_hourglass ();
1626 /* This hook is used by edebug. */
1627 if (! NILP (Vsignal_hook_function
)
1628 && ! NILP (error_symbol
))
1630 /* Edebug takes care of restoring these variables when it exits. */
1631 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1632 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1634 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1635 max_specpdl_size
= SPECPDL_INDEX () + 40;
1637 call2 (Vsignal_hook_function
, error_symbol
, data
);
1640 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1642 /* Remember from where signal was called. Skip over the frame for
1643 `signal' itself. If a frame for `error' follows, skip that,
1644 too. Don't do this when ERROR_SYMBOL is nil, because that
1645 is a memory-full error. */
1646 Vsignaling_function
= Qnil
;
1647 if (backtrace_list
&& !NILP (error_symbol
))
1649 bp
= backtrace_list
->next
;
1650 if (bp
&& bp
->function
&& EQ (*bp
->function
, Qerror
))
1652 if (bp
&& bp
->function
)
1653 Vsignaling_function
= *bp
->function
;
1656 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1658 register Lisp_Object clause
;
1660 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1661 error_symbol
, data
, &debugger_value
);
1663 if (EQ (clause
, Qlambda
))
1665 /* We can't return values to code which signaled an error, but we
1666 can continue code which has signaled a quit. */
1667 if (EQ (real_error_symbol
, Qquit
))
1670 error ("Cannot return from the debugger in an error");
1675 Lisp_Object unwind_data
;
1676 struct handler
*h
= handlerlist
;
1678 handlerlist
= allhandlers
;
1680 if (NILP (error_symbol
))
1683 unwind_data
= Fcons (error_symbol
, data
);
1684 h
->chosen_clause
= clause
;
1685 unwind_to_catch (h
->tag
, unwind_data
);
1689 handlerlist
= allhandlers
;
1690 /* If no handler is present now, try to run the debugger,
1691 and if that fails, throw to top level. */
1692 find_handler_clause (Qerror
, conditions
, error_symbol
, data
, &debugger_value
);
1694 Fthrow (Qtop_level
, Qt
);
1696 if (! NILP (error_symbol
))
1697 data
= Fcons (error_symbol
, data
);
1699 string
= Ferror_message_string (data
);
1700 fatal ("%s", SDATA (string
), 0);
1703 /* Internal version of Fsignal that never returns.
1704 Used for anything but Qquit (which can return from Fsignal). */
1707 xsignal (error_symbol
, data
)
1708 Lisp_Object error_symbol
, data
;
1710 Fsignal (error_symbol
, data
);
1714 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1717 xsignal0 (error_symbol
)
1718 Lisp_Object error_symbol
;
1720 xsignal (error_symbol
, Qnil
);
1724 xsignal1 (error_symbol
, arg
)
1725 Lisp_Object error_symbol
, arg
;
1727 xsignal (error_symbol
, list1 (arg
));
1731 xsignal2 (error_symbol
, arg1
, arg2
)
1732 Lisp_Object error_symbol
, arg1
, arg2
;
1734 xsignal (error_symbol
, list2 (arg1
, arg2
));
1738 xsignal3 (error_symbol
, arg1
, arg2
, arg3
)
1739 Lisp_Object error_symbol
, arg1
, arg2
, arg3
;
1741 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1744 /* Signal `error' with message S, and additional arg ARG.
1745 If ARG is not a genuine list, make it a one-element list. */
1748 signal_error (s
, arg
)
1752 Lisp_Object tortoise
, hare
;
1754 hare
= tortoise
= arg
;
1755 while (CONSP (hare
))
1762 tortoise
= XCDR (tortoise
);
1764 if (EQ (hare
, tortoise
))
1769 arg
= Fcons (arg
, Qnil
); /* Make it a list. */
1771 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1775 /* Return nonzero iff LIST is a non-nil atom or
1776 a list containing one of CONDITIONS. */
1779 wants_debugger (list
, conditions
)
1780 Lisp_Object list
, conditions
;
1787 while (CONSP (conditions
))
1789 Lisp_Object
this, tail
;
1790 this = XCAR (conditions
);
1791 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1792 if (EQ (XCAR (tail
), this))
1794 conditions
= XCDR (conditions
);
1799 /* Return 1 if an error with condition-symbols CONDITIONS,
1800 and described by SIGNAL-DATA, should skip the debugger
1801 according to debugger-ignored-errors. */
1804 skip_debugger (conditions
, data
)
1805 Lisp_Object conditions
, data
;
1808 int first_string
= 1;
1809 Lisp_Object error_message
;
1811 error_message
= Qnil
;
1812 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1814 if (STRINGP (XCAR (tail
)))
1818 error_message
= Ferror_message_string (data
);
1822 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1827 Lisp_Object contail
;
1829 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1830 if (EQ (XCAR (tail
), XCAR (contail
)))
1838 /* Value of Qlambda means we have called debugger and user has continued.
1839 There are two ways to pass SIG and DATA:
1840 = SIG is the error symbol, and DATA is the rest of the data.
1841 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1842 This is for memory-full errors only.
1844 Store value returned from debugger into *DEBUGGER_VALUE_PTR.
1846 We need to increase max_specpdl_size temporarily around
1847 anything we do that can push on the specpdl, so as not to get
1848 a second error here in case we're handling specpdl overflow. */
1851 find_handler_clause (handlers
, conditions
, sig
, data
, debugger_value_ptr
)
1852 Lisp_Object handlers
, conditions
, sig
, data
;
1853 Lisp_Object
*debugger_value_ptr
;
1855 register Lisp_Object h
;
1856 register Lisp_Object tem
;
1858 if (EQ (handlers
, Qt
)) /* t is used by handlers for all conditions, set up by C code. */
1860 /* error is used similarly, but means print an error message
1861 and run the debugger if that is enabled. */
1862 if (EQ (handlers
, Qerror
)
1863 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1864 there is a handler. */
1866 int debugger_called
= 0;
1867 Lisp_Object sig_symbol
, combined_data
;
1868 /* This is set to 1 if we are handling a memory-full error,
1869 because these must not run the debugger.
1870 (There is no room in memory to do that!) */
1871 int no_debugger
= 0;
1875 combined_data
= data
;
1876 sig_symbol
= Fcar (data
);
1881 combined_data
= Fcons (sig
, data
);
1885 if (wants_debugger (Vstack_trace_on_error
, conditions
))
1889 internal_with_output_to_temp_buffer ("*Backtrace*",
1890 (Lisp_Object (*) (Lisp_Object
)) Fbacktrace
,
1893 internal_with_output_to_temp_buffer ("*Backtrace*",
1899 && (EQ (sig_symbol
, Qquit
)
1901 : wants_debugger (Vdebug_on_error
, conditions
))
1902 && ! skip_debugger (conditions
, combined_data
)
1903 && when_entered_debugger
< num_nonmacro_input_events
)
1906 = call_debugger (Fcons (Qerror
,
1907 Fcons (combined_data
, Qnil
)));
1908 debugger_called
= 1;
1910 /* If there is no handler, return saying whether we ran the debugger. */
1911 if (EQ (handlers
, Qerror
))
1913 if (debugger_called
)
1918 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1920 Lisp_Object handler
, condit
;
1923 if (!CONSP (handler
))
1925 condit
= Fcar (handler
);
1926 /* Handle a single condition name in handler HANDLER. */
1927 if (SYMBOLP (condit
))
1929 tem
= Fmemq (Fcar (handler
), conditions
);
1933 /* Handle a list of condition names in handler HANDLER. */
1934 else if (CONSP (condit
))
1936 while (CONSP (condit
))
1938 tem
= Fmemq (Fcar (condit
), conditions
);
1941 condit
= XCDR (condit
);
1948 /* dump an error message; called like printf */
1952 error (m
, a1
, a2
, a3
)
1972 int used
= doprnt (buffer
, size
, m
, m
+ mlen
, 3, args
);
1977 buffer
= (char *) xrealloc (buffer
, size
);
1980 buffer
= (char *) xmalloc (size
);
1985 string
= build_string (buffer
);
1989 xsignal1 (Qerror
, string
);
1992 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
1993 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
1994 This means it contains a description for how to read arguments to give it.
1995 The value is nil for an invalid function or a symbol with no function
1998 Interactively callable functions include strings and vectors (treated
1999 as keyboard macros), lambda-expressions that contain a top-level call
2000 to `interactive', autoload definitions made by `autoload' with non-nil
2001 fourth argument, and some of the built-in functions of Lisp.
2003 Also, a symbol satisfies `commandp' if its function definition does so.
2005 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
2006 then strings and vectors are not accepted. */)
2007 (function
, for_call_interactively
)
2008 Lisp_Object function
, for_call_interactively
;
2010 register Lisp_Object fun
;
2011 register Lisp_Object funcar
;
2015 fun
= indirect_function (fun
);
2016 if (EQ (fun
, Qunbound
))
2019 /* Emacs primitives are interactive if their DEFUN specifies an
2020 interactive spec. */
2023 if (XSUBR (fun
)->prompt
)
2029 /* Bytecode objects are interactive if they are long enough to
2030 have an element whose index is COMPILED_INTERACTIVE, which is
2031 where the interactive spec is stored. */
2032 else if (COMPILEDP (fun
))
2033 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
2036 /* Strings and vectors are keyboard macros. */
2037 if (NILP (for_call_interactively
) && (STRINGP (fun
) || VECTORP (fun
)))
2040 /* Lists may represent commands. */
2043 funcar
= XCAR (fun
);
2044 if (EQ (funcar
, Qlambda
))
2045 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
2046 if (EQ (funcar
, Qautoload
))
2047 return Fcar (Fcdr (Fcdr (XCDR (fun
))));
2053 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
2054 doc
: /* Define FUNCTION to autoload from FILE.
2055 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
2056 Third arg DOCSTRING is documentation for the function.
2057 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
2058 Fifth arg TYPE indicates the type of the object:
2059 nil or omitted says FUNCTION is a function,
2060 `keymap' says FUNCTION is really a keymap, and
2061 `macro' or t says FUNCTION is really a macro.
2062 Third through fifth args give info about the real definition.
2063 They default to nil.
2064 If FUNCTION is already defined other than as an autoload,
2065 this does nothing and returns nil. */)
2066 (function
, file
, docstring
, interactive
, type
)
2067 Lisp_Object function
, file
, docstring
, interactive
, type
;
2070 Lisp_Object args
[4];
2073 CHECK_SYMBOL (function
);
2074 CHECK_STRING (file
);
2076 /* If function is defined and not as an autoload, don't override */
2077 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
2078 && !(CONSP (XSYMBOL (function
)->function
)
2079 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
2082 if (NILP (Vpurify_flag
))
2083 /* Only add entries after dumping, because the ones before are
2084 not useful and else we get loads of them from the loaddefs.el. */
2085 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
2089 args
[1] = docstring
;
2090 args
[2] = interactive
;
2093 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
2094 #else /* NO_ARG_ARRAY */
2095 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
2096 #endif /* not NO_ARG_ARRAY */
2100 un_autoload (oldqueue
)
2101 Lisp_Object oldqueue
;
2103 register Lisp_Object queue
, first
, second
;
2105 /* Queue to unwind is current value of Vautoload_queue.
2106 oldqueue is the shadowed value to leave in Vautoload_queue. */
2107 queue
= Vautoload_queue
;
2108 Vautoload_queue
= oldqueue
;
2109 while (CONSP (queue
))
2111 first
= XCAR (queue
);
2112 second
= Fcdr (first
);
2113 first
= Fcar (first
);
2114 if (EQ (first
, make_number (0)))
2117 Ffset (first
, second
);
2118 queue
= XCDR (queue
);
2123 /* Load an autoloaded function.
2124 FUNNAME is the symbol which is the function's name.
2125 FUNDEF is the autoload definition (a list). */
2128 do_autoload (fundef
, funname
)
2129 Lisp_Object fundef
, funname
;
2131 int count
= SPECPDL_INDEX ();
2132 Lisp_Object fun
, queue
, first
, second
;
2133 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2135 /* This is to make sure that loadup.el gives a clear picture
2136 of what files are preloaded and when. */
2137 if (! NILP (Vpurify_flag
))
2138 error ("Attempt to autoload %s while preparing to dump",
2139 SDATA (SYMBOL_NAME (funname
)));
2142 CHECK_SYMBOL (funname
);
2143 GCPRO3 (fun
, funname
, fundef
);
2145 /* Preserve the match data. */
2146 record_unwind_save_match_data ();
2148 /* Value saved here is to be restored into Vautoload_queue. */
2149 record_unwind_protect (un_autoload
, Vautoload_queue
);
2150 Vautoload_queue
= Qt
;
2151 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
, Qt
);
2153 /* Save the old autoloads, in case we ever do an unload. */
2154 queue
= Vautoload_queue
;
2155 while (CONSP (queue
))
2157 first
= XCAR (queue
);
2158 second
= Fcdr (first
);
2159 first
= Fcar (first
);
2161 if (SYMBOLP (first
) && CONSP (second
) && EQ (XCAR (second
), Qautoload
))
2162 Fput (first
, Qautoload
, (XCDR (second
)));
2164 queue
= XCDR (queue
);
2167 /* Once loading finishes, don't undo it. */
2168 Vautoload_queue
= Qt
;
2169 unbind_to (count
, Qnil
);
2171 fun
= Findirect_function (fun
, Qnil
);
2173 if (!NILP (Fequal (fun
, fundef
)))
2174 error ("Autoloading failed to define function %s",
2175 SDATA (SYMBOL_NAME (funname
)));
2180 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
2181 doc
: /* Evaluate FORM and return its value. */)
2185 Lisp_Object fun
, val
, original_fun
, original_args
;
2187 struct backtrace backtrace
;
2188 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2190 if (handling_signal
)
2194 return Fsymbol_value (form
);
2199 if ((consing_since_gc
> gc_cons_threshold
2200 && consing_since_gc
> gc_relative_threshold
)
2202 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2205 Fgarbage_collect ();
2209 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2211 if (max_lisp_eval_depth
< 100)
2212 max_lisp_eval_depth
= 100;
2213 if (lisp_eval_depth
> max_lisp_eval_depth
)
2214 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2217 original_fun
= Fcar (form
);
2218 original_args
= Fcdr (form
);
2220 backtrace
.next
= backtrace_list
;
2221 backtrace_list
= &backtrace
;
2222 backtrace
.function
= &original_fun
; /* This also protects them from gc */
2223 backtrace
.args
= &original_args
;
2224 backtrace
.nargs
= UNEVALLED
;
2225 backtrace
.evalargs
= 1;
2226 backtrace
.debug_on_exit
= 0;
2228 if (debug_on_next_call
)
2229 do_debug_on_call (Qt
);
2231 /* At this point, only original_fun and original_args
2232 have values that will be used below */
2235 /* Optimize for no indirection. */
2237 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2238 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2239 fun
= indirect_function (fun
);
2243 Lisp_Object numargs
;
2244 Lisp_Object argvals
[8];
2245 Lisp_Object args_left
;
2246 register int i
, maxargs
;
2248 args_left
= original_args
;
2249 numargs
= Flength (args_left
);
2253 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
2254 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2255 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2257 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2259 backtrace
.evalargs
= 0;
2260 val
= (*XSUBR (fun
)->function
) (args_left
);
2264 if (XSUBR (fun
)->max_args
== MANY
)
2266 /* Pass a vector of evaluated arguments */
2268 register int argnum
= 0;
2270 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2272 GCPRO3 (args_left
, fun
, fun
);
2276 while (!NILP (args_left
))
2278 vals
[argnum
++] = Feval (Fcar (args_left
));
2279 args_left
= Fcdr (args_left
);
2280 gcpro3
.nvars
= argnum
;
2283 backtrace
.args
= vals
;
2284 backtrace
.nargs
= XINT (numargs
);
2286 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
2291 GCPRO3 (args_left
, fun
, fun
);
2292 gcpro3
.var
= argvals
;
2295 maxargs
= XSUBR (fun
)->max_args
;
2296 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
2298 argvals
[i
] = Feval (Fcar (args_left
));
2304 backtrace
.args
= argvals
;
2305 backtrace
.nargs
= XINT (numargs
);
2310 val
= (*XSUBR (fun
)->function
) ();
2313 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
2316 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
2319 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2323 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2324 argvals
[2], argvals
[3]);
2327 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2328 argvals
[3], argvals
[4]);
2331 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2332 argvals
[3], argvals
[4], argvals
[5]);
2335 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2336 argvals
[3], argvals
[4], argvals
[5],
2341 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2342 argvals
[3], argvals
[4], argvals
[5],
2343 argvals
[6], argvals
[7]);
2347 /* Someone has created a subr that takes more arguments than
2348 is supported by this code. We need to either rewrite the
2349 subr to use a different argument protocol, or add more
2350 cases to this switch. */
2354 if (COMPILEDP (fun
))
2355 val
= apply_lambda (fun
, original_args
, 1);
2358 if (EQ (fun
, Qunbound
))
2359 xsignal1 (Qvoid_function
, original_fun
);
2361 xsignal1 (Qinvalid_function
, original_fun
);
2362 funcar
= XCAR (fun
);
2363 if (!SYMBOLP (funcar
))
2364 xsignal1 (Qinvalid_function
, original_fun
);
2365 if (EQ (funcar
, Qautoload
))
2367 do_autoload (fun
, original_fun
);
2370 if (EQ (funcar
, Qmacro
))
2371 val
= Feval (apply1 (Fcdr (fun
), original_args
));
2372 else if (EQ (funcar
, Qlambda
))
2373 val
= apply_lambda (fun
, original_args
, 1);
2375 xsignal1 (Qinvalid_function
, original_fun
);
2381 if (backtrace
.debug_on_exit
)
2382 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2383 backtrace_list
= backtrace
.next
;
2388 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
2389 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2390 Then return the value FUNCTION returns.
2391 Thus, (apply '+ 1 2 '(3 4)) returns 10.
2392 usage: (apply FUNCTION &rest ARGUMENTS) */)
2397 register int i
, numargs
;
2398 register Lisp_Object spread_arg
;
2399 register Lisp_Object
*funcall_args
;
2401 struct gcpro gcpro1
;
2405 spread_arg
= args
[nargs
- 1];
2406 CHECK_LIST (spread_arg
);
2408 numargs
= XINT (Flength (spread_arg
));
2411 return Ffuncall (nargs
- 1, args
);
2412 else if (numargs
== 1)
2414 args
[nargs
- 1] = XCAR (spread_arg
);
2415 return Ffuncall (nargs
, args
);
2418 numargs
+= nargs
- 2;
2420 /* Optimize for no indirection. */
2421 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2422 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2423 fun
= indirect_function (fun
);
2424 if (EQ (fun
, Qunbound
))
2426 /* Let funcall get the error */
2433 if (numargs
< XSUBR (fun
)->min_args
2434 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2435 goto funcall
; /* Let funcall get the error */
2436 else if (XSUBR (fun
)->max_args
> numargs
)
2438 /* Avoid making funcall cons up a yet another new vector of arguments
2439 by explicitly supplying nil's for optional values */
2440 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
2441 * sizeof (Lisp_Object
));
2442 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2443 funcall_args
[++i
] = Qnil
;
2444 GCPRO1 (*funcall_args
);
2445 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2449 /* We add 1 to numargs because funcall_args includes the
2450 function itself as well as its arguments. */
2453 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
2454 * sizeof (Lisp_Object
));
2455 GCPRO1 (*funcall_args
);
2456 gcpro1
.nvars
= 1 + numargs
;
2459 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
2460 /* Spread the last arg we got. Its first element goes in
2461 the slot that it used to occupy, hence this value of I. */
2463 while (!NILP (spread_arg
))
2465 funcall_args
[i
++] = XCAR (spread_arg
);
2466 spread_arg
= XCDR (spread_arg
);
2469 /* By convention, the caller needs to gcpro Ffuncall's args. */
2470 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
2473 /* Run hook variables in various ways. */
2475 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
2476 static Lisp_Object run_hook_with_args
P_ ((int, Lisp_Object
*,
2477 enum run_hooks_condition
));
2479 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2480 doc
: /* Run each hook in HOOKS.
2481 Each argument should be a symbol, a hook variable.
2482 These symbols are processed in the order specified.
2483 If a hook symbol has a non-nil value, that value may be a function
2484 or a list of functions to be called to run the hook.
2485 If the value is a function, it is called with no arguments.
2486 If it is a list, the elements are called, in order, with no arguments.
2488 Major modes should not use this function directly to run their mode
2489 hook; they should use `run-mode-hooks' instead.
2491 Do not use `make-local-variable' to make a hook variable buffer-local.
2492 Instead, use `add-hook' and specify t for the LOCAL argument.
2493 usage: (run-hooks &rest HOOKS) */)
2498 Lisp_Object hook
[1];
2501 for (i
= 0; i
< nargs
; i
++)
2504 run_hook_with_args (1, hook
, to_completion
);
2510 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2511 Srun_hook_with_args
, 1, MANY
, 0,
2512 doc
: /* Run HOOK with the specified arguments ARGS.
2513 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2514 value, that value may be a function or a list of functions to be
2515 called to run the hook. If the value is a function, it is called with
2516 the given arguments and its return value is returned. If it is a list
2517 of functions, those functions are called, in order,
2518 with the given arguments ARGS.
2519 It is best not to depend on the value returned by `run-hook-with-args',
2522 Do not use `make-local-variable' to make a hook variable buffer-local.
2523 Instead, use `add-hook' and specify t for the LOCAL argument.
2524 usage: (run-hook-with-args HOOK &rest ARGS) */)
2529 return run_hook_with_args (nargs
, args
, to_completion
);
2532 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2533 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2534 doc
: /* Run HOOK with the specified arguments ARGS.
2535 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2536 value, that value may be a function or a list of functions to be
2537 called to run the hook. If the value is a function, it is called with
2538 the given arguments and its return value is returned.
2539 If it is a list of functions, those functions are called, in order,
2540 with the given arguments ARGS, until one of them
2541 returns a non-nil value. Then we return that value.
2542 However, if they all return nil, we return nil.
2544 Do not use `make-local-variable' to make a hook variable buffer-local.
2545 Instead, use `add-hook' and specify t for the LOCAL argument.
2546 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2551 return run_hook_with_args (nargs
, args
, until_success
);
2554 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2555 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2556 doc
: /* Run HOOK with the specified arguments ARGS.
2557 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2558 value, that value may be a function or a list of functions to be
2559 called to run the hook. If the value is a function, it is called with
2560 the given arguments and its return value is returned.
2561 If it is a list of functions, those functions are called, in order,
2562 with the given arguments ARGS, until one of them returns nil.
2563 Then we return nil. However, if they all return non-nil, we return non-nil.
2565 Do not use `make-local-variable' to make a hook variable buffer-local.
2566 Instead, use `add-hook' and specify t for the LOCAL argument.
2567 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2572 return run_hook_with_args (nargs
, args
, until_failure
);
2575 /* ARGS[0] should be a hook symbol.
2576 Call each of the functions in the hook value, passing each of them
2577 as arguments all the rest of ARGS (all NARGS - 1 elements).
2578 COND specifies a condition to test after each call
2579 to decide whether to stop.
2580 The caller (or its caller, etc) must gcpro all of ARGS,
2581 except that it isn't necessary to gcpro ARGS[0]. */
2584 run_hook_with_args (nargs
, args
, cond
)
2587 enum run_hooks_condition cond
;
2589 Lisp_Object sym
, val
, ret
;
2590 Lisp_Object globals
;
2591 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2593 /* If we are dying or still initializing,
2594 don't do anything--it would probably crash if we tried. */
2595 if (NILP (Vrun_hooks
))
2599 val
= find_symbol_value (sym
);
2600 ret
= (cond
== until_failure
? Qt
: Qnil
);
2602 if (EQ (val
, Qunbound
) || NILP (val
))
2604 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2607 return Ffuncall (nargs
, args
);
2612 GCPRO3 (sym
, val
, globals
);
2615 CONSP (val
) && ((cond
== to_completion
)
2616 || (cond
== until_success
? NILP (ret
)
2620 if (EQ (XCAR (val
), Qt
))
2622 /* t indicates this hook has a local binding;
2623 it means to run the global binding too. */
2625 for (globals
= Fdefault_value (sym
);
2626 CONSP (globals
) && ((cond
== to_completion
)
2627 || (cond
== until_success
? NILP (ret
)
2629 globals
= XCDR (globals
))
2631 args
[0] = XCAR (globals
);
2632 /* In a global value, t should not occur. If it does, we
2633 must ignore it to avoid an endless loop. */
2634 if (!EQ (args
[0], Qt
))
2635 ret
= Ffuncall (nargs
, args
);
2640 args
[0] = XCAR (val
);
2641 ret
= Ffuncall (nargs
, args
);
2650 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2651 present value of that symbol.
2652 Call each element of FUNLIST,
2653 passing each of them the rest of ARGS.
2654 The caller (or its caller, etc) must gcpro all of ARGS,
2655 except that it isn't necessary to gcpro ARGS[0]. */
2658 run_hook_list_with_args (funlist
, nargs
, args
)
2659 Lisp_Object funlist
;
2665 Lisp_Object globals
;
2666 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2670 GCPRO3 (sym
, val
, globals
);
2672 for (val
= funlist
; CONSP (val
); val
= XCDR (val
))
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
);
2681 globals
= XCDR (globals
))
2683 args
[0] = XCAR (globals
);
2684 /* In a global value, t should not occur. If it does, we
2685 must ignore it to avoid an endless loop. */
2686 if (!EQ (args
[0], Qt
))
2687 Ffuncall (nargs
, args
);
2692 args
[0] = XCAR (val
);
2693 Ffuncall (nargs
, args
);
2700 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2703 run_hook_with_args_2 (hook
, arg1
, arg2
)
2704 Lisp_Object hook
, arg1
, arg2
;
2706 Lisp_Object temp
[3];
2711 Frun_hook_with_args (3, temp
);
2714 /* Apply fn to arg */
2717 Lisp_Object fn
, arg
;
2719 struct gcpro gcpro1
;
2723 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2727 Lisp_Object args
[2];
2731 RETURN_UNGCPRO (Fapply (2, args
));
2733 #else /* not NO_ARG_ARRAY */
2734 RETURN_UNGCPRO (Fapply (2, &fn
));
2735 #endif /* not NO_ARG_ARRAY */
2738 /* Call function fn on no arguments */
2743 struct gcpro gcpro1
;
2746 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2749 /* Call function fn with 1 argument arg1 */
2753 Lisp_Object fn
, arg1
;
2755 struct gcpro gcpro1
;
2757 Lisp_Object args
[2];
2763 RETURN_UNGCPRO (Ffuncall (2, args
));
2764 #else /* not NO_ARG_ARRAY */
2767 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2768 #endif /* not NO_ARG_ARRAY */
2771 /* Call function fn with 2 arguments arg1, arg2 */
2774 call2 (fn
, arg1
, arg2
)
2775 Lisp_Object fn
, arg1
, arg2
;
2777 struct gcpro gcpro1
;
2779 Lisp_Object args
[3];
2785 RETURN_UNGCPRO (Ffuncall (3, args
));
2786 #else /* not NO_ARG_ARRAY */
2789 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2790 #endif /* not NO_ARG_ARRAY */
2793 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2796 call3 (fn
, arg1
, arg2
, arg3
)
2797 Lisp_Object fn
, arg1
, arg2
, arg3
;
2799 struct gcpro gcpro1
;
2801 Lisp_Object args
[4];
2808 RETURN_UNGCPRO (Ffuncall (4, args
));
2809 #else /* not NO_ARG_ARRAY */
2812 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2813 #endif /* not NO_ARG_ARRAY */
2816 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2819 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2820 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2822 struct gcpro gcpro1
;
2824 Lisp_Object args
[5];
2832 RETURN_UNGCPRO (Ffuncall (5, args
));
2833 #else /* not NO_ARG_ARRAY */
2836 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2837 #endif /* not NO_ARG_ARRAY */
2840 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2843 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2844 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2846 struct gcpro gcpro1
;
2848 Lisp_Object args
[6];
2857 RETURN_UNGCPRO (Ffuncall (6, args
));
2858 #else /* not NO_ARG_ARRAY */
2861 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2862 #endif /* not NO_ARG_ARRAY */
2865 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2868 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2869 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2871 struct gcpro gcpro1
;
2873 Lisp_Object args
[7];
2883 RETURN_UNGCPRO (Ffuncall (7, args
));
2884 #else /* not NO_ARG_ARRAY */
2887 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2888 #endif /* not NO_ARG_ARRAY */
2891 /* The caller should GCPRO all the elements of ARGS. */
2893 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2894 doc
: /* Call first argument as a function, passing remaining arguments to it.
2895 Return the value that function returns.
2896 Thus, (funcall 'cons 'x 'y) returns (x . y).
2897 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2902 Lisp_Object fun
, original_fun
;
2904 int numargs
= nargs
- 1;
2905 Lisp_Object lisp_numargs
;
2907 struct backtrace backtrace
;
2908 register Lisp_Object
*internal_args
;
2912 if ((consing_since_gc
> gc_cons_threshold
2913 && consing_since_gc
> gc_relative_threshold
)
2915 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2916 Fgarbage_collect ();
2918 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2920 if (max_lisp_eval_depth
< 100)
2921 max_lisp_eval_depth
= 100;
2922 if (lisp_eval_depth
> max_lisp_eval_depth
)
2923 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2926 backtrace
.next
= backtrace_list
;
2927 backtrace_list
= &backtrace
;
2928 backtrace
.function
= &args
[0];
2929 backtrace
.args
= &args
[1];
2930 backtrace
.nargs
= nargs
- 1;
2931 backtrace
.evalargs
= 0;
2932 backtrace
.debug_on_exit
= 0;
2934 if (debug_on_next_call
)
2935 do_debug_on_call (Qlambda
);
2939 original_fun
= args
[0];
2943 /* Optimize for no indirection. */
2945 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2946 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2947 fun
= indirect_function (fun
);
2951 if (numargs
< XSUBR (fun
)->min_args
2952 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2954 XSETFASTINT (lisp_numargs
, numargs
);
2955 xsignal2 (Qwrong_number_of_arguments
, original_fun
, lisp_numargs
);
2958 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2959 xsignal1 (Qinvalid_function
, original_fun
);
2961 if (XSUBR (fun
)->max_args
== MANY
)
2963 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
2967 if (XSUBR (fun
)->max_args
> numargs
)
2969 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2970 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
2971 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2972 internal_args
[i
] = Qnil
;
2975 internal_args
= args
+ 1;
2976 switch (XSUBR (fun
)->max_args
)
2979 val
= (*XSUBR (fun
)->function
) ();
2982 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
2985 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1]);
2988 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2992 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2993 internal_args
[2], internal_args
[3]);
2996 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2997 internal_args
[2], internal_args
[3],
3001 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3002 internal_args
[2], internal_args
[3],
3003 internal_args
[4], internal_args
[5]);
3006 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3007 internal_args
[2], internal_args
[3],
3008 internal_args
[4], internal_args
[5],
3013 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3014 internal_args
[2], internal_args
[3],
3015 internal_args
[4], internal_args
[5],
3016 internal_args
[6], internal_args
[7]);
3021 /* If a subr takes more than 8 arguments without using MANY
3022 or UNEVALLED, we need to extend this function to support it.
3023 Until this is done, there is no way to call the function. */
3027 if (COMPILEDP (fun
))
3028 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3031 if (EQ (fun
, Qunbound
))
3032 xsignal1 (Qvoid_function
, original_fun
);
3034 xsignal1 (Qinvalid_function
, original_fun
);
3035 funcar
= XCAR (fun
);
3036 if (!SYMBOLP (funcar
))
3037 xsignal1 (Qinvalid_function
, original_fun
);
3038 if (EQ (funcar
, Qlambda
))
3039 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3040 else if (EQ (funcar
, Qautoload
))
3042 do_autoload (fun
, original_fun
);
3047 xsignal1 (Qinvalid_function
, original_fun
);
3052 if (backtrace
.debug_on_exit
)
3053 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
3054 backtrace_list
= backtrace
.next
;
3059 apply_lambda (fun
, args
, eval_flag
)
3060 Lisp_Object fun
, args
;
3063 Lisp_Object args_left
;
3064 Lisp_Object numargs
;
3065 register Lisp_Object
*arg_vector
;
3066 struct gcpro gcpro1
, gcpro2
, gcpro3
;
3068 register Lisp_Object tem
;
3070 numargs
= Flength (args
);
3071 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
3074 GCPRO3 (*arg_vector
, args_left
, fun
);
3077 for (i
= 0; i
< XINT (numargs
);)
3079 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
3080 if (eval_flag
) tem
= Feval (tem
);
3081 arg_vector
[i
++] = tem
;
3089 backtrace_list
->args
= arg_vector
;
3090 backtrace_list
->nargs
= i
;
3092 backtrace_list
->evalargs
= 0;
3093 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
3095 /* Do the debug-on-exit now, while arg_vector still exists. */
3096 if (backtrace_list
->debug_on_exit
)
3097 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
3098 /* Don't do it again when we return to eval. */
3099 backtrace_list
->debug_on_exit
= 0;
3103 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
3104 and return the result of evaluation.
3105 FUN must be either a lambda-expression or a compiled-code object. */
3108 funcall_lambda (fun
, nargs
, arg_vector
)
3111 register Lisp_Object
*arg_vector
;
3113 Lisp_Object val
, syms_left
, next
;
3114 int count
= SPECPDL_INDEX ();
3115 int i
, optional
, rest
;
3119 syms_left
= XCDR (fun
);
3120 if (CONSP (syms_left
))
3121 syms_left
= XCAR (syms_left
);
3123 xsignal1 (Qinvalid_function
, fun
);
3125 else if (COMPILEDP (fun
))
3126 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3130 i
= optional
= rest
= 0;
3131 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3135 next
= XCAR (syms_left
);
3136 if (!SYMBOLP (next
))
3137 xsignal1 (Qinvalid_function
, fun
);
3139 if (EQ (next
, Qand_rest
))
3141 else if (EQ (next
, Qand_optional
))
3145 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
3149 specbind (next
, arg_vector
[i
++]);
3151 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3153 specbind (next
, Qnil
);
3156 if (!NILP (syms_left
))
3157 xsignal1 (Qinvalid_function
, fun
);
3159 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3162 val
= Fprogn (XCDR (XCDR (fun
)));
3165 /* If we have not actually read the bytecode string
3166 and constants vector yet, fetch them from the file. */
3167 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3168 Ffetch_bytecode (fun
);
3169 val
= Fbyte_code (AREF (fun
, COMPILED_BYTECODE
),
3170 AREF (fun
, COMPILED_CONSTANTS
),
3171 AREF (fun
, COMPILED_STACK_DEPTH
));
3174 return unbind_to (count
, val
);
3177 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3179 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3185 if (COMPILEDP (object
) && CONSP (AREF (object
, COMPILED_BYTECODE
)))
3187 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3190 tem
= AREF (object
, COMPILED_BYTECODE
);
3191 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3192 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3194 error ("Invalid byte code");
3196 AREF (object
, COMPILED_BYTECODE
) = XCAR (tem
);
3197 AREF (object
, COMPILED_CONSTANTS
) = XCDR (tem
);
3205 register int count
= SPECPDL_INDEX ();
3206 if (specpdl_size
>= max_specpdl_size
)
3208 if (max_specpdl_size
< 400)
3209 max_specpdl_size
= 400;
3210 if (specpdl_size
>= max_specpdl_size
)
3211 signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil
);
3214 if (specpdl_size
> max_specpdl_size
)
3215 specpdl_size
= max_specpdl_size
;
3216 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
3217 specpdl_ptr
= specpdl
+ count
;
3221 specbind (symbol
, value
)
3222 Lisp_Object symbol
, value
;
3225 Lisp_Object valcontents
;
3227 CHECK_SYMBOL (symbol
);
3228 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3231 /* The most common case is that of a non-constant symbol with a
3232 trivial value. Make that as fast as we can. */
3233 valcontents
= SYMBOL_VALUE (symbol
);
3234 if (!MISCP (valcontents
) && !SYMBOL_CONSTANT_P (symbol
))
3236 specpdl_ptr
->symbol
= symbol
;
3237 specpdl_ptr
->old_value
= valcontents
;
3238 specpdl_ptr
->func
= NULL
;
3240 SET_SYMBOL_VALUE (symbol
, value
);
3244 Lisp_Object valcontents
;
3246 ovalue
= find_symbol_value (symbol
);
3247 specpdl_ptr
->func
= 0;
3248 specpdl_ptr
->old_value
= ovalue
;
3250 valcontents
= XSYMBOL (symbol
)->value
;
3252 if (BUFFER_LOCAL_VALUEP (valcontents
)
3253 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
3254 || BUFFER_OBJFWDP (valcontents
))
3256 Lisp_Object where
, current_buffer
;
3258 current_buffer
= Fcurrent_buffer ();
3260 /* For a local variable, record both the symbol and which
3261 buffer's or frame's value we are saving. */
3262 if (!NILP (Flocal_variable_p (symbol
, Qnil
)))
3263 where
= current_buffer
;
3264 else if (!BUFFER_OBJFWDP (valcontents
)
3265 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
3266 where
= XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
3270 /* We're not using the `unused' slot in the specbinding
3271 structure because this would mean we have to do more
3272 work for simple variables. */
3273 specpdl_ptr
->symbol
= Fcons (symbol
, Fcons (where
, current_buffer
));
3275 /* If SYMBOL is a per-buffer variable which doesn't have a
3276 buffer-local value here, make the `let' change the global
3277 value by changing the value of SYMBOL in all buffers not
3278 having their own value. This is consistent with what
3279 happens with other buffer-local variables. */
3281 && BUFFER_OBJFWDP (valcontents
))
3284 Fset_default (symbol
, value
);
3289 specpdl_ptr
->symbol
= symbol
;
3292 if (BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
))
3293 store_symval_forwarding (symbol
, ovalue
, value
, NULL
);
3295 set_internal (symbol
, value
, 0, 1);
3300 record_unwind_protect (function
, arg
)
3301 Lisp_Object (*function
) P_ ((Lisp_Object
));
3304 eassert (!handling_signal
);
3306 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3308 specpdl_ptr
->func
= function
;
3309 specpdl_ptr
->symbol
= Qnil
;
3310 specpdl_ptr
->old_value
= arg
;
3315 unbind_to (count
, value
)
3319 Lisp_Object quitf
= Vquit_flag
;
3320 struct gcpro gcpro1
, gcpro2
;
3322 GCPRO2 (value
, quitf
);
3325 while (specpdl_ptr
!= specpdl
+ count
)
3327 /* Copy the binding, and decrement specpdl_ptr, before we do
3328 the work to unbind it. We decrement first
3329 so that an error in unbinding won't try to unbind
3330 the same entry again, and we copy the binding first
3331 in case more bindings are made during some of the code we run. */
3333 struct specbinding this_binding
;
3334 this_binding
= *--specpdl_ptr
;
3336 if (this_binding
.func
!= 0)
3337 (*this_binding
.func
) (this_binding
.old_value
);
3338 /* If the symbol is a list, it is really (SYMBOL WHERE
3339 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3340 frame. If WHERE is a buffer or frame, this indicates we
3341 bound a variable that had a buffer-local or frame-local
3342 binding. WHERE nil means that the variable had the default
3343 value when it was bound. CURRENT-BUFFER is the buffer that
3344 was current when the variable was bound. */
3345 else if (CONSP (this_binding
.symbol
))
3347 Lisp_Object symbol
, where
;
3349 symbol
= XCAR (this_binding
.symbol
);
3350 where
= XCAR (XCDR (this_binding
.symbol
));
3353 Fset_default (symbol
, this_binding
.old_value
);
3354 else if (BUFFERP (where
))
3355 set_internal (symbol
, this_binding
.old_value
, XBUFFER (where
), 1);
3357 set_internal (symbol
, this_binding
.old_value
, NULL
, 1);
3361 /* If variable has a trivial value (no forwarding), we can
3362 just set it. No need to check for constant symbols here,
3363 since that was already done by specbind. */
3364 if (!MISCP (SYMBOL_VALUE (this_binding
.symbol
)))
3365 SET_SYMBOL_VALUE (this_binding
.symbol
, this_binding
.old_value
);
3367 set_internal (this_binding
.symbol
, this_binding
.old_value
, 0, 1);
3371 if (NILP (Vquit_flag
) && !NILP (quitf
))
3378 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3379 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3380 The debugger is entered when that frame exits, if the flag is non-nil. */)
3382 Lisp_Object level
, flag
;
3384 register struct backtrace
*backlist
= backtrace_list
;
3387 CHECK_NUMBER (level
);
3389 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
3391 backlist
= backlist
->next
;
3395 backlist
->debug_on_exit
= !NILP (flag
);
3400 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3401 doc
: /* Print a trace of Lisp function calls currently active.
3402 Output stream used is value of `standard-output'. */)
3405 register struct backtrace
*backlist
= backtrace_list
;
3409 extern Lisp_Object Vprint_level
;
3410 struct gcpro gcpro1
;
3412 XSETFASTINT (Vprint_level
, 3);
3419 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
3420 if (backlist
->nargs
== UNEVALLED
)
3422 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
3423 write_string ("\n", -1);
3427 tem
= *backlist
->function
;
3428 Fprin1 (tem
, Qnil
); /* This can QUIT */
3429 write_string ("(", -1);
3430 if (backlist
->nargs
== MANY
)
3432 for (tail
= *backlist
->args
, i
= 0;
3434 tail
= Fcdr (tail
), i
++)
3436 if (i
) write_string (" ", -1);
3437 Fprin1 (Fcar (tail
), Qnil
);
3442 for (i
= 0; i
< backlist
->nargs
; i
++)
3444 if (i
) write_string (" ", -1);
3445 Fprin1 (backlist
->args
[i
], Qnil
);
3448 write_string (")\n", -1);
3450 backlist
= backlist
->next
;
3453 Vprint_level
= Qnil
;
3458 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, NULL
,
3459 doc
: /* Return the function and arguments NFRAMES up from current execution point.
3460 If that frame has not evaluated the arguments yet (or is a special form),
3461 the value is (nil FUNCTION ARG-FORMS...).
3462 If that frame has evaluated its arguments and called its function already,
3463 the value is (t FUNCTION ARG-VALUES...).
3464 A &rest arg is represented as the tail of the list ARG-VALUES.
3465 FUNCTION is whatever was supplied as car of evaluated list,
3466 or a lambda expression for macro calls.
3467 If NFRAMES is more than the number of frames, the value is nil. */)
3469 Lisp_Object nframes
;
3471 register struct backtrace
*backlist
= backtrace_list
;
3475 CHECK_NATNUM (nframes
);
3477 /* Find the frame requested. */
3478 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3479 backlist
= backlist
->next
;
3483 if (backlist
->nargs
== UNEVALLED
)
3484 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3487 if (backlist
->nargs
== MANY
)
3488 tem
= *backlist
->args
;
3490 tem
= Flist (backlist
->nargs
, backlist
->args
);
3492 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3500 register struct backtrace
*backlist
;
3503 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3505 mark_object (*backlist
->function
);
3507 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3510 i
= backlist
->nargs
- 1;
3512 mark_object (backlist
->args
[i
]);
3519 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
3520 doc
: /* *Limit on number of Lisp variable bindings and `unwind-protect's.
3521 If Lisp code tries to increase the total number past this amount,
3522 an error is signaled.
3523 You can safely use a value considerably larger than the default value,
3524 if that proves inconveniently small. However, if you increase it too far,
3525 Emacs could run out of memory trying to make the stack bigger. */);
3527 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
3528 doc
: /* *Limit on depth in `eval', `apply' and `funcall' before error.
3530 This limit serves to catch infinite recursions for you before they cause
3531 actual stack overflow in C, which would be fatal for Emacs.
3532 You can safely make it considerably larger than its default value,
3533 if that proves inconveniently small. However, if you increase it too far,
3534 Emacs could overflow the real C stack, and crash. */);
3536 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
3537 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3538 If the value is t, that means do an ordinary quit.
3539 If the value equals `throw-on-input', that means quit by throwing
3540 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3541 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3542 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3545 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
3546 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3547 Note that `quit-flag' will still be set by typing C-g,
3548 so a quit will be signaled as soon as `inhibit-quit' is nil.
3549 To prevent this happening, set `quit-flag' to nil
3550 before making `inhibit-quit' nil. */);
3551 Vinhibit_quit
= Qnil
;
3553 Qinhibit_quit
= intern ("inhibit-quit");
3554 staticpro (&Qinhibit_quit
);
3556 Qautoload
= intern ("autoload");
3557 staticpro (&Qautoload
);
3559 Qdebug_on_error
= intern ("debug-on-error");
3560 staticpro (&Qdebug_on_error
);
3562 Qmacro
= intern ("macro");
3563 staticpro (&Qmacro
);
3565 Qdeclare
= intern ("declare");
3566 staticpro (&Qdeclare
);
3568 /* Note that the process handling also uses Qexit, but we don't want
3569 to staticpro it twice, so we just do it here. */
3570 Qexit
= intern ("exit");
3573 Qinteractive
= intern ("interactive");
3574 staticpro (&Qinteractive
);
3576 Qcommandp
= intern ("commandp");
3577 staticpro (&Qcommandp
);
3579 Qdefun
= intern ("defun");
3580 staticpro (&Qdefun
);
3582 Qand_rest
= intern ("&rest");
3583 staticpro (&Qand_rest
);
3585 Qand_optional
= intern ("&optional");
3586 staticpro (&Qand_optional
);
3588 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
3589 doc
: /* *Non-nil means errors display a backtrace buffer.
3590 More precisely, this happens for any error that is handled
3591 by the editor command loop.
3592 If the value is a list, an error only means to display a backtrace
3593 if one of its condition symbols appears in the list. */);
3594 Vstack_trace_on_error
= Qnil
;
3596 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
3597 doc
: /* *Non-nil means enter debugger if an error is signaled.
3598 Does not apply to errors handled by `condition-case' or those
3599 matched by `debug-ignored-errors'.
3600 If the value is a list, an error only means to enter the debugger
3601 if one of its condition symbols appears in the list.
3602 When you evaluate an expression interactively, this variable
3603 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3604 See also variable `debug-on-quit'. */);
3605 Vdebug_on_error
= Qnil
;
3607 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
3608 doc
: /* *List of errors for which the debugger should not be called.
3609 Each element may be a condition-name or a regexp that matches error messages.
3610 If any element applies to a given error, that error skips the debugger
3611 and just returns to top level.
3612 This overrides the variable `debug-on-error'.
3613 It does not apply to errors handled by `condition-case'. */);
3614 Vdebug_ignored_errors
= Qnil
;
3616 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
3617 doc
: /* *Non-nil means enter debugger if quit is signaled (C-g, for example).
3618 Does not apply if quit is handled by a `condition-case'. */);
3621 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
3622 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3624 DEFVAR_BOOL ("debugger-may-continue", &debugger_may_continue
,
3625 doc
: /* Non-nil means debugger may continue execution.
3626 This is nil when the debugger is called under circumstances where it
3627 might not be safe to continue. */);
3628 debugger_may_continue
= 1;
3630 DEFVAR_LISP ("debugger", &Vdebugger
,
3631 doc
: /* Function to call to invoke debugger.
3632 If due to frame exit, args are `exit' and the value being returned;
3633 this function's value will be returned instead of that.
3634 If due to error, args are `error' and a list of the args to `signal'.
3635 If due to `apply' or `funcall' entry, one arg, `lambda'.
3636 If due to `eval' entry, one arg, t. */);
3639 DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function
,
3640 doc
: /* If non-nil, this is a function for `signal' to call.
3641 It receives the same arguments that `signal' was given.
3642 The Edebug package uses this to regain control. */);
3643 Vsignal_hook_function
= Qnil
;
3645 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal
,
3646 doc
: /* *Non-nil means call the debugger regardless of condition handlers.
3647 Note that `debug-on-error', `debug-on-quit' and friends
3648 still determine whether to handle the particular condition. */);
3649 Vdebug_on_signal
= Qnil
;
3651 DEFVAR_LISP ("macro-declaration-function", &Vmacro_declaration_function
,
3652 doc
: /* Function to process declarations in a macro definition.
3653 The function will be called with two args MACRO and DECL.
3654 MACRO is the name of the macro being defined.
3655 DECL is a list `(declare ...)' containing the declarations.
3656 The value the function returns is not used. */);
3657 Vmacro_declaration_function
= Qnil
;
3659 Vrun_hooks
= intern ("run-hooks");
3660 staticpro (&Vrun_hooks
);
3662 staticpro (&Vautoload_queue
);
3663 Vautoload_queue
= Qnil
;
3664 staticpro (&Vsignaling_function
);
3665 Vsignaling_function
= Qnil
;
3676 defsubr (&Sfunction
);
3678 defsubr (&Sdefmacro
);
3680 defsubr (&Sdefvaralias
);
3681 defsubr (&Sdefconst
);
3682 defsubr (&Suser_variable_p
);
3686 defsubr (&Smacroexpand
);
3689 defsubr (&Sunwind_protect
);
3690 defsubr (&Scondition_case
);
3692 defsubr (&Sinteractive_p
);
3693 defsubr (&Scalled_interactively_p
);
3694 defsubr (&Scommandp
);
3695 defsubr (&Sautoload
);
3698 defsubr (&Sfuncall
);
3699 defsubr (&Srun_hooks
);
3700 defsubr (&Srun_hook_with_args
);
3701 defsubr (&Srun_hook_with_args_until_success
);
3702 defsubr (&Srun_hook_with_args_until_failure
);
3703 defsubr (&Sfetch_bytecode
);
3704 defsubr (&Sbacktrace_debug
);
3705 defsubr (&Sbacktrace
);
3706 defsubr (&Sbacktrace_frame
);
3709 /* arch-tag: 014a07aa-33ab-4a8f-a3d2-ee8a4a9ff7fb
3710 (do not change this comment) */