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
;
204 /* "gcc -O3" enables automatic function inlining, which optimizes out
205 the arguments for the invocations of these functions, whereas they
206 expect these values on the stack. */
207 Lisp_Object
apply1 () __attribute__((noinline
));
208 Lisp_Object
call2 () __attribute__((noinline
));
215 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
216 specpdl_ptr
= specpdl
;
217 /* Don't forget to update docs (lispref node "Local Variables"). */
218 max_specpdl_size
= 1000;
219 max_lisp_eval_depth
= 300;
227 specpdl_ptr
= specpdl
;
232 debug_on_next_call
= 0;
237 /* This is less than the initial value of num_nonmacro_input_events. */
238 when_entered_debugger
= -1;
241 /* unwind-protect function used by call_debugger. */
244 restore_stack_limits (data
)
247 max_specpdl_size
= XINT (XCAR (data
));
248 max_lisp_eval_depth
= XINT (XCDR (data
));
252 /* Call the Lisp debugger, giving it argument ARG. */
258 int debug_while_redisplaying
;
259 int count
= SPECPDL_INDEX ();
261 int old_max
= max_specpdl_size
;
263 /* Temporarily bump up the stack limits,
264 so the debugger won't run out of stack. */
266 max_specpdl_size
+= 1;
267 record_unwind_protect (restore_stack_limits
,
268 Fcons (make_number (old_max
),
269 make_number (max_lisp_eval_depth
)));
270 max_specpdl_size
= old_max
;
272 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
273 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
275 if (SPECPDL_INDEX () + 100 > max_specpdl_size
)
276 max_specpdl_size
= SPECPDL_INDEX () + 100;
278 #ifdef HAVE_X_WINDOWS
279 if (display_hourglass_p
)
283 debug_on_next_call
= 0;
284 when_entered_debugger
= num_nonmacro_input_events
;
286 /* Resetting redisplaying_p to 0 makes sure that debug output is
287 displayed if the debugger is invoked during redisplay. */
288 debug_while_redisplaying
= redisplaying_p
;
290 specbind (intern ("debugger-may-continue"),
291 debug_while_redisplaying
? Qnil
: Qt
);
292 specbind (Qinhibit_redisplay
, Qnil
);
293 specbind (Qdebug_on_error
, Qnil
);
295 #if 0 /* Binding this prevents execution of Lisp code during
296 redisplay, which necessarily leads to display problems. */
297 specbind (Qinhibit_eval_during_redisplay
, Qt
);
300 val
= apply1 (Vdebugger
, arg
);
302 /* Interrupting redisplay and resuming it later is not safe under
303 all circumstances. So, when the debugger returns, abort the
304 interrupted redisplay by going back to the top-level. */
305 if (debug_while_redisplaying
)
308 return unbind_to (count
, val
);
312 do_debug_on_call (code
)
315 debug_on_next_call
= 0;
316 backtrace_list
->debug_on_exit
= 1;
317 call_debugger (Fcons (code
, Qnil
));
320 /* NOTE!!! Every function that can call EVAL must protect its args
321 and temporaries from garbage collection while it needs them.
322 The definition of `For' shows what you have to do. */
324 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
325 doc
: /* Eval args until one of them yields non-nil, then return that value.
326 The remaining args are not evalled at all.
327 If all args return nil, return nil.
328 usage: (or CONDITIONS ...) */)
332 register Lisp_Object val
= Qnil
;
339 val
= Feval (XCAR (args
));
349 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
350 doc
: /* Eval args until one of them yields nil, then return nil.
351 The remaining args are not evalled at all.
352 If no arg yields nil, return the last arg's value.
353 usage: (and CONDITIONS ...) */)
357 register Lisp_Object val
= Qt
;
364 val
= Feval (XCAR (args
));
374 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
375 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
376 Returns the value of THEN or the value of the last of the ELSE's.
377 THEN must be one expression, but ELSE... can be zero or more expressions.
378 If COND yields nil, and there are no ELSE's, the value is nil.
379 usage: (if COND THEN ELSE...) */)
383 register Lisp_Object cond
;
387 cond
= Feval (Fcar (args
));
391 return Feval (Fcar (Fcdr (args
)));
392 return Fprogn (Fcdr (Fcdr (args
)));
395 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
396 doc
: /* Try each clause until one succeeds.
397 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
398 and, if the value is non-nil, this clause succeeds:
399 then the expressions in BODY are evaluated and the last one's
400 value is the value of the cond-form.
401 If no clause succeeds, cond returns nil.
402 If a clause has one element, as in (CONDITION),
403 CONDITION's value if non-nil is returned from the cond-form.
404 usage: (cond CLAUSES...) */)
408 register Lisp_Object clause
, val
;
415 clause
= Fcar (args
);
416 val
= Feval (Fcar (clause
));
419 if (!EQ (XCDR (clause
), Qnil
))
420 val
= Fprogn (XCDR (clause
));
430 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
431 doc
: /* Eval BODY forms sequentially and return value of last one.
432 usage: (progn BODY ...) */)
436 register Lisp_Object val
= Qnil
;
443 val
= Feval (XCAR (args
));
451 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
452 doc
: /* Eval FIRST and BODY sequentially; value from FIRST.
453 The value of FIRST is saved during the evaluation of the remaining args,
454 whose values are discarded.
455 usage: (prog1 FIRST BODY...) */)
460 register Lisp_Object args_left
;
461 struct gcpro gcpro1
, gcpro2
;
462 register int argnum
= 0;
474 val
= Feval (Fcar (args_left
));
476 Feval (Fcar (args_left
));
477 args_left
= Fcdr (args_left
);
479 while (!NILP(args_left
));
485 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
486 doc
: /* Eval FORM1, FORM2 and BODY sequentially; value from FORM2.
487 The value of FORM2 is saved during the evaluation of the
488 remaining args, whose values are discarded.
489 usage: (prog2 FORM1 FORM2 BODY...) */)
494 register Lisp_Object args_left
;
495 struct gcpro gcpro1
, gcpro2
;
496 register int argnum
= -1;
510 val
= Feval (Fcar (args_left
));
512 Feval (Fcar (args_left
));
513 args_left
= Fcdr (args_left
);
515 while (!NILP (args_left
));
521 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
522 doc
: /* Set each SYM to the value of its VAL.
523 The symbols SYM are variables; they are literal (not evaluated).
524 The values VAL are expressions; they are evaluated.
525 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
526 The second VAL is not computed until after the first SYM is set, and so on;
527 each VAL can use the new value of variables set earlier in the `setq'.
528 The return value of the `setq' form is the value of the last VAL.
529 usage: (setq SYM VAL SYM VAL ...) */)
533 register Lisp_Object args_left
;
534 register Lisp_Object val
, sym
;
545 val
= Feval (Fcar (Fcdr (args_left
)));
546 sym
= Fcar (args_left
);
548 args_left
= Fcdr (Fcdr (args_left
));
550 while (!NILP(args_left
));
556 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
557 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
558 usage: (quote ARG) */)
565 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
566 doc
: /* Like `quote', but preferred for objects which are functions.
567 In byte compilation, `function' causes its argument to be compiled.
568 `quote' cannot do that.
569 usage: (function ARG) */)
577 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
578 doc
: /* Return t if the function was run directly by user input.
579 This means that the function was called with `call-interactively'
580 \(which includes being called as the binding of a key)
581 and input is currently coming from the keyboard (not in keyboard macro),
582 and Emacs is not running in batch mode (`noninteractive' is nil).
584 The only known proper use of `interactive-p' is in deciding whether to
585 display a helpful message, or how to display it. If you're thinking
586 of using it for any other purpose, it is quite likely that you're
587 making a mistake. Think: what do you want to do when the command is
588 called from a keyboard macro?
590 If you want to test whether your function was called with
591 `call-interactively', the way to do that is by adding an extra
592 optional argument, and making the `interactive' spec specify non-nil
593 unconditionally for that argument. (`p' is a good way to do this.) */)
596 return (INTERACTIVE
&& interactive_p (1)) ? Qt
: Qnil
;
600 DEFUN ("called-interactively-p", Fcalled_interactively_p
, Scalled_interactively_p
, 0, 0, 0,
601 doc
: /* Return t if the function using this was called with `call-interactively'.
602 This is used for implementing advice and other function-modifying
605 The cleanest way to test whether your function was called with
606 `call-interactively' is by adding an extra optional argument,
607 and making the `interactive' spec specify non-nil unconditionally
608 for that argument. (`p' is a good way to do this.) */)
611 return interactive_p (1) ? Qt
: Qnil
;
615 /* Return 1 if function in which this appears was called using
618 EXCLUDE_SUBRS_P non-zero means always return 0 if the function
619 called is a built-in. */
622 interactive_p (exclude_subrs_p
)
625 struct backtrace
*btp
;
628 btp
= backtrace_list
;
630 /* If this isn't a byte-compiled function, there may be a frame at
631 the top for Finteractive_p. If so, skip it. */
632 fun
= Findirect_function (*btp
->function
, Qnil
);
633 if (SUBRP (fun
) && (XSUBR (fun
) == &Sinteractive_p
634 || XSUBR (fun
) == &Scalled_interactively_p
))
637 /* If we're running an Emacs 18-style byte-compiled function, there
638 may be a frame for Fbytecode at the top level. In any version of
639 Emacs there can be Fbytecode frames for subexpressions evaluated
640 inside catch and condition-case. Skip past them.
642 If this isn't a byte-compiled function, then we may now be
643 looking at several frames for special forms. Skip past them. */
645 && (EQ (*btp
->function
, Qbytecode
)
646 || btp
->nargs
== UNEVALLED
))
649 /* btp now points at the frame of the innermost function that isn't
650 a special form, ignoring frames for Finteractive_p and/or
651 Fbytecode at the top. If this frame is for a built-in function
652 (such as load or eval-region) return nil. */
653 fun
= Findirect_function (*btp
->function
, Qnil
);
654 if (exclude_subrs_p
&& SUBRP (fun
))
657 /* btp points to the frame of a Lisp function that called interactive-p.
658 Return t if that function was called interactively. */
659 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
665 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
666 doc
: /* Define NAME as a function.
667 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
668 See also the function `interactive'.
669 usage: (defun NAME ARGLIST [DOCSTRING] BODY...) */)
673 register Lisp_Object fn_name
;
674 register Lisp_Object defn
;
676 fn_name
= Fcar (args
);
677 CHECK_SYMBOL (fn_name
);
678 defn
= Fcons (Qlambda
, Fcdr (args
));
679 if (!NILP (Vpurify_flag
))
680 defn
= Fpurecopy (defn
);
681 if (CONSP (XSYMBOL (fn_name
)->function
)
682 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
683 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
684 Ffset (fn_name
, defn
);
685 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
689 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
690 doc
: /* Define NAME as a macro.
691 The actual definition looks like
692 (macro lambda ARGLIST [DOCSTRING] [DECL] BODY...).
693 When the macro is called, as in (NAME ARGS...),
694 the function (lambda ARGLIST BODY...) is applied to
695 the list ARGS... as it appears in the expression,
696 and the result should be a form to be evaluated instead of the original.
698 DECL is a declaration, optional, which can specify how to indent
699 calls to this macro and how Edebug should handle it. It looks like this:
701 The elements can look like this:
703 Set NAME's `lisp-indent-function' property to INDENT.
706 Set NAME's `edebug-form-spec' property to DEBUG. (This is
707 equivalent to writing a `def-edebug-spec' for the macro.)
708 usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */)
712 register Lisp_Object fn_name
;
713 register Lisp_Object defn
;
714 Lisp_Object lambda_list
, doc
, tail
;
716 fn_name
= Fcar (args
);
717 CHECK_SYMBOL (fn_name
);
718 lambda_list
= Fcar (Fcdr (args
));
719 tail
= Fcdr (Fcdr (args
));
722 if (STRINGP (Fcar (tail
)))
728 while (CONSP (Fcar (tail
))
729 && EQ (Fcar (Fcar (tail
)), Qdeclare
))
731 if (!NILP (Vmacro_declaration_function
))
735 call2 (Vmacro_declaration_function
, fn_name
, Fcar (tail
));
743 tail
= Fcons (lambda_list
, tail
);
745 tail
= Fcons (lambda_list
, Fcons (doc
, tail
));
746 defn
= Fcons (Qmacro
, Fcons (Qlambda
, tail
));
748 if (!NILP (Vpurify_flag
))
749 defn
= Fpurecopy (defn
);
750 if (CONSP (XSYMBOL (fn_name
)->function
)
751 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
752 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
753 Ffset (fn_name
, defn
);
754 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
759 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
760 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
761 Aliased variables always have the same value; setting one sets the other.
762 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
763 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
764 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
766 The return value is BASE-VARIABLE. */)
767 (new_alias
, base_variable
, docstring
)
768 Lisp_Object new_alias
, base_variable
, docstring
;
770 struct Lisp_Symbol
*sym
;
772 CHECK_SYMBOL (new_alias
);
773 CHECK_SYMBOL (base_variable
);
775 if (SYMBOL_CONSTANT_P (new_alias
))
776 error ("Cannot make a constant an alias");
778 sym
= XSYMBOL (new_alias
);
779 sym
->indirect_variable
= 1;
780 sym
->value
= base_variable
;
781 sym
->constant
= SYMBOL_CONSTANT_P (base_variable
);
782 LOADHIST_ATTACH (new_alias
);
783 if (!NILP (docstring
))
784 Fput (new_alias
, Qvariable_documentation
, docstring
);
786 Fput (new_alias
, Qvariable_documentation
, Qnil
);
788 return base_variable
;
792 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
793 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
794 You are not required to define a variable in order to use it,
795 but the definition can supply documentation and an initial value
796 in a way that tags can recognize.
798 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.
799 If SYMBOL is buffer-local, its default value is what is set;
800 buffer-local values are not affected.
801 INITVALUE and DOCSTRING are optional.
802 If DOCSTRING starts with *, this variable is identified as a user option.
803 This means that M-x set-variable recognizes it.
804 See also `user-variable-p'.
805 If INITVALUE is missing, SYMBOL's value is not set.
807 If SYMBOL has a local binding, then this form affects the local
808 binding. This is usually not what you want. Thus, if you need to
809 load a file defining variables, with this form or with `defconst' or
810 `defcustom', you should always load that file _outside_ any bindings
811 for these variables. \(`defconst' and `defcustom' behave similarly in
813 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
817 register Lisp_Object sym
, tem
, tail
;
821 if (!NILP (Fcdr (Fcdr (tail
))))
822 error ("Too many arguments");
824 tem
= Fdefault_boundp (sym
);
827 if (SYMBOL_CONSTANT_P (sym
))
829 /* For upward compatibility, allow (defvar :foo (quote :foo)). */
830 Lisp_Object tem
= Fcar (tail
);
832 && EQ (XCAR (tem
), Qquote
)
833 && CONSP (XCDR (tem
))
834 && EQ (XCAR (XCDR (tem
)), sym
)))
835 error ("Constant symbol `%s' specified in defvar",
836 SDATA (SYMBOL_NAME (sym
)));
840 Fset_default (sym
, Feval (Fcar (tail
)));
842 { /* Check if there is really a global binding rather than just a let
843 binding that shadows the global unboundness of the var. */
844 volatile struct specbinding
*pdl
= specpdl_ptr
;
845 while (--pdl
>= specpdl
)
847 if (EQ (pdl
->symbol
, sym
) && !pdl
->func
848 && EQ (pdl
->old_value
, Qunbound
))
850 message_with_string ("Warning: defvar ignored because %s is let-bound",
851 SYMBOL_NAME (sym
), 1);
860 if (!NILP (Vpurify_flag
))
861 tem
= Fpurecopy (tem
);
862 Fput (sym
, Qvariable_documentation
, tem
);
864 LOADHIST_ATTACH (sym
);
867 /* Simple (defvar <var>) should not count as a definition at all.
868 It could get in the way of other definitions, and unloading this
869 package could try to make the variable unbound. */
875 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
876 doc
: /* Define SYMBOL as a constant variable.
877 The intent is that neither programs nor users should ever change this value.
878 Always sets the value of SYMBOL to the result of evalling INITVALUE.
879 If SYMBOL is buffer-local, its default value is what is set;
880 buffer-local values are not affected.
881 DOCSTRING is optional.
883 If SYMBOL has a local binding, then this form sets the local binding's
884 value. However, you should normally not make local bindings for
885 variables defined with this form.
886 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
890 register Lisp_Object sym
, tem
;
893 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
894 error ("Too many arguments");
896 tem
= Feval (Fcar (Fcdr (args
)));
897 if (!NILP (Vpurify_flag
))
898 tem
= Fpurecopy (tem
);
899 Fset_default (sym
, tem
);
900 tem
= Fcar (Fcdr (Fcdr (args
)));
903 if (!NILP (Vpurify_flag
))
904 tem
= Fpurecopy (tem
);
905 Fput (sym
, Qvariable_documentation
, tem
);
907 Fput (sym
, Qrisky_local_variable
, Qt
);
908 LOADHIST_ATTACH (sym
);
912 /* Error handler used in Fuser_variable_p. */
914 user_variable_p_eh (ignore
)
920 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
921 doc
: /* Return t if VARIABLE is intended to be set and modified by users.
922 \(The alternative is a variable used internally in a Lisp program.)
923 A variable is a user variable if
924 \(1) the first character of its documentation is `*', or
925 \(2) it is customizable (its property list contains a non-nil value
926 of `standard-value' or `custom-autoload'), or
927 \(3) it is an alias for another user variable.
928 Return nil if VARIABLE is an alias and there is a loop in the
929 chain of symbols. */)
931 Lisp_Object variable
;
933 Lisp_Object documentation
;
935 if (!SYMBOLP (variable
))
938 /* If indirect and there's an alias loop, don't check anything else. */
939 if (XSYMBOL (variable
)->indirect_variable
940 && NILP (internal_condition_case_1 (indirect_variable
, variable
,
941 Qt
, user_variable_p_eh
)))
946 documentation
= Fget (variable
, Qvariable_documentation
);
947 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
949 if (STRINGP (documentation
)
950 && ((unsigned char) SREF (documentation
, 0) == '*'))
952 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
953 if (CONSP (documentation
)
954 && STRINGP (XCAR (documentation
))
955 && INTEGERP (XCDR (documentation
))
956 && XINT (XCDR (documentation
)) < 0)
958 /* Customizable? See `custom-variable-p'. */
959 if ((!NILP (Fget (variable
, intern ("standard-value"))))
960 || (!NILP (Fget (variable
, intern ("custom-autoload")))))
963 if (!XSYMBOL (variable
)->indirect_variable
)
966 /* An indirect variable? Let's follow the chain. */
967 variable
= XSYMBOL (variable
)->value
;
971 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
972 doc
: /* Bind variables according to VARLIST then eval BODY.
973 The value of the last form in BODY is returned.
974 Each element of VARLIST is a symbol (which is bound to nil)
975 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
976 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
977 usage: (let* VARLIST BODY...) */)
981 Lisp_Object varlist
, val
, elt
;
982 int count
= SPECPDL_INDEX ();
983 struct gcpro gcpro1
, gcpro2
, gcpro3
;
985 GCPRO3 (args
, elt
, varlist
);
987 varlist
= Fcar (args
);
988 while (!NILP (varlist
))
991 elt
= Fcar (varlist
);
993 specbind (elt
, Qnil
);
994 else if (! NILP (Fcdr (Fcdr (elt
))))
995 signal_error ("`let' bindings can have only one value-form", elt
);
998 val
= Feval (Fcar (Fcdr (elt
)));
999 specbind (Fcar (elt
), val
);
1001 varlist
= Fcdr (varlist
);
1004 val
= Fprogn (Fcdr (args
));
1005 return unbind_to (count
, val
);
1008 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
1009 doc
: /* Bind variables according to VARLIST then eval BODY.
1010 The value of the last form in BODY is returned.
1011 Each element of VARLIST is a symbol (which is bound to nil)
1012 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
1013 All the VALUEFORMs are evalled before any symbols are bound.
1014 usage: (let VARLIST BODY...) */)
1018 Lisp_Object
*temps
, tem
;
1019 register Lisp_Object elt
, varlist
;
1020 int count
= SPECPDL_INDEX ();
1021 register int argnum
;
1022 struct gcpro gcpro1
, gcpro2
;
1024 varlist
= Fcar (args
);
1026 /* Make space to hold the values to give the bound variables */
1027 elt
= Flength (varlist
);
1028 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
1030 /* Compute the values and store them in `temps' */
1032 GCPRO2 (args
, *temps
);
1035 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
1038 elt
= Fcar (varlist
);
1040 temps
[argnum
++] = Qnil
;
1041 else if (! NILP (Fcdr (Fcdr (elt
))))
1042 signal_error ("`let' bindings can have only one value-form", elt
);
1044 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
1045 gcpro2
.nvars
= argnum
;
1049 varlist
= Fcar (args
);
1050 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
1052 elt
= Fcar (varlist
);
1053 tem
= temps
[argnum
++];
1055 specbind (elt
, tem
);
1057 specbind (Fcar (elt
), tem
);
1060 elt
= Fprogn (Fcdr (args
));
1061 return unbind_to (count
, elt
);
1064 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
1065 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
1066 The order of execution is thus TEST, BODY, TEST, BODY and so on
1067 until TEST returns nil.
1068 usage: (while TEST BODY...) */)
1072 Lisp_Object test
, body
;
1073 struct gcpro gcpro1
, gcpro2
;
1075 GCPRO2 (test
, body
);
1079 while (!NILP (Feval (test
)))
1089 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
1090 doc
: /* Return result of expanding macros at top level of FORM.
1091 If FORM is not a macro call, it is returned unchanged.
1092 Otherwise, the macro is expanded and the expansion is considered
1093 in place of FORM. When a non-macro-call results, it is returned.
1095 The second optional arg ENVIRONMENT specifies an environment of macro
1096 definitions to shadow the loaded ones for use in file byte-compilation. */)
1099 Lisp_Object environment
;
1101 /* With cleanups from Hallvard Furuseth. */
1102 register Lisp_Object expander
, sym
, def
, tem
;
1106 /* Come back here each time we expand a macro call,
1107 in case it expands into another macro call. */
1110 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1111 def
= sym
= XCAR (form
);
1113 /* Trace symbols aliases to other symbols
1114 until we get a symbol that is not an alias. */
1115 while (SYMBOLP (def
))
1119 tem
= Fassq (sym
, environment
);
1122 def
= XSYMBOL (sym
)->function
;
1123 if (!EQ (def
, Qunbound
))
1128 /* Right now TEM is the result from SYM in ENVIRONMENT,
1129 and if TEM is nil then DEF is SYM's function definition. */
1132 /* SYM is not mentioned in ENVIRONMENT.
1133 Look at its function definition. */
1134 if (EQ (def
, Qunbound
) || !CONSP (def
))
1135 /* Not defined or definition not suitable */
1137 if (EQ (XCAR (def
), Qautoload
))
1139 /* Autoloading function: will it be a macro when loaded? */
1140 tem
= Fnth (make_number (4), def
);
1141 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
1142 /* Yes, load it and try again. */
1144 struct gcpro gcpro1
;
1146 do_autoload (def
, sym
);
1153 else if (!EQ (XCAR (def
), Qmacro
))
1155 else expander
= XCDR (def
);
1159 expander
= XCDR (tem
);
1160 if (NILP (expander
))
1163 form
= apply1 (expander
, XCDR (form
));
1168 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1169 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1170 TAG is evalled to get the tag to use; it must not be nil.
1172 Then the BODY is executed.
1173 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.
1174 If no throw happens, `catch' returns the value of the last BODY form.
1175 If a throw happens, it specifies the value to return from `catch'.
1176 usage: (catch TAG BODY...) */)
1180 register Lisp_Object tag
;
1181 struct gcpro gcpro1
;
1184 tag
= Feval (Fcar (args
));
1186 return internal_catch (tag
, Fprogn
, Fcdr (args
));
1189 /* Set up a catch, then call C function FUNC on argument ARG.
1190 FUNC should return a Lisp_Object.
1191 This is how catches are done from within C code. */
1194 internal_catch (tag
, func
, arg
)
1196 Lisp_Object (*func
) ();
1199 /* This structure is made part of the chain `catchlist'. */
1202 /* Fill in the components of c, and put it on the list. */
1206 c
.backlist
= backtrace_list
;
1207 c
.handlerlist
= handlerlist
;
1208 c
.lisp_eval_depth
= lisp_eval_depth
;
1209 c
.pdlcount
= SPECPDL_INDEX ();
1210 c
.poll_suppress_count
= poll_suppress_count
;
1211 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1212 c
.gcpro
= gcprolist
;
1213 c
.byte_stack
= byte_stack_list
;
1217 if (! _setjmp (c
.jmp
))
1218 c
.val
= (*func
) (arg
);
1220 /* Throw works by a longjmp that comes right here. */
1225 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1226 jump to that CATCH, returning VALUE as the value of that catch.
1228 This is the guts Fthrow and Fsignal; they differ only in the way
1229 they choose the catch tag to throw to. A catch tag for a
1230 condition-case form has a TAG of Qnil.
1232 Before each catch is discarded, unbind all special bindings and
1233 execute all unwind-protect clauses made above that catch. Unwind
1234 the handler stack as we go, so that the proper handlers are in
1235 effect for each unwind-protect clause we run. At the end, restore
1236 some static info saved in CATCH, and longjmp to the location
1239 This is used for correct unwinding in Fthrow and Fsignal. */
1242 unwind_to_catch (catch, value
)
1243 struct catchtag
*catch;
1246 register int last_time
;
1248 /* Save the value in the tag. */
1251 /* Restore certain special C variables. */
1252 set_poll_suppress_count (catch->poll_suppress_count
);
1253 UNBLOCK_INPUT_TO (catch->interrupt_input_blocked
);
1254 handling_signal
= 0;
1259 last_time
= catchlist
== catch;
1261 /* Unwind the specpdl stack, and then restore the proper set of
1263 unbind_to (catchlist
->pdlcount
, Qnil
);
1264 handlerlist
= catchlist
->handlerlist
;
1265 catchlist
= catchlist
->next
;
1267 while (! last_time
);
1270 /* If x_catch_errors was done, turn it off now.
1271 (First we give unbind_to a chance to do that.) */
1272 x_fully_uncatch_errors ();
1275 byte_stack_list
= catch->byte_stack
;
1276 gcprolist
= catch->gcpro
;
1279 gcpro_level
= gcprolist
->level
+ 1;
1283 backtrace_list
= catch->backlist
;
1284 lisp_eval_depth
= catch->lisp_eval_depth
;
1286 _longjmp (catch->jmp
, 1);
1289 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1290 doc
: /* Throw to the catch for TAG and return VALUE from it.
1291 Both TAG and VALUE are evalled. */)
1293 register Lisp_Object tag
, value
;
1295 register struct catchtag
*c
;
1298 for (c
= catchlist
; c
; c
= c
->next
)
1300 if (EQ (c
->tag
, tag
))
1301 unwind_to_catch (c
, value
);
1303 xsignal2 (Qno_catch
, tag
, value
);
1307 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1308 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1309 If BODYFORM completes normally, its value is returned
1310 after executing the UNWINDFORMS.
1311 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1312 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1317 int count
= SPECPDL_INDEX ();
1319 record_unwind_protect (Fprogn
, Fcdr (args
));
1320 val
= Feval (Fcar (args
));
1321 return unbind_to (count
, val
);
1324 /* Chain of condition handlers currently in effect.
1325 The elements of this chain are contained in the stack frames
1326 of Fcondition_case and internal_condition_case.
1327 When an error is signaled (by calling Fsignal, below),
1328 this chain is searched for an element that applies. */
1330 struct handler
*handlerlist
;
1332 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1333 doc
: /* Regain control when an error is signaled.
1334 Executes BODYFORM and returns its value if no error happens.
1335 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1336 where the BODY is made of Lisp expressions.
1338 A handler is applicable to an error
1339 if CONDITION-NAME is one of the error's condition names.
1340 If an error happens, the first applicable handler is run.
1342 The car of a handler may be a list of condition names
1343 instead of a single condition name.
1345 When a handler handles an error,
1346 control returns to the condition-case and the handler BODY... is executed
1347 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).
1348 VAR may be nil; then you do not get access to the signal information.
1350 The value of the last BODY form is returned from the condition-case.
1351 See also the function `signal' for more info.
1352 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1356 register Lisp_Object bodyform
, handlers
;
1357 volatile Lisp_Object var
;
1360 bodyform
= Fcar (Fcdr (args
));
1361 handlers
= Fcdr (Fcdr (args
));
1363 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1366 /* Like Fcondition_case, but the args are separate
1367 rather than passed in a list. Used by Fbyte_code. */
1370 internal_lisp_condition_case (var
, bodyform
, handlers
)
1371 volatile Lisp_Object var
;
1372 Lisp_Object bodyform
, handlers
;
1380 for (val
= handlers
; CONSP (val
); val
= XCDR (val
))
1386 && (SYMBOLP (XCAR (tem
))
1387 || CONSP (XCAR (tem
))))))
1388 error ("Invalid condition handler", tem
);
1393 c
.backlist
= backtrace_list
;
1394 c
.handlerlist
= handlerlist
;
1395 c
.lisp_eval_depth
= lisp_eval_depth
;
1396 c
.pdlcount
= SPECPDL_INDEX ();
1397 c
.poll_suppress_count
= poll_suppress_count
;
1398 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1399 c
.gcpro
= gcprolist
;
1400 c
.byte_stack
= byte_stack_list
;
1401 if (_setjmp (c
.jmp
))
1404 specbind (h
.var
, c
.val
);
1405 val
= Fprogn (Fcdr (h
.chosen_clause
));
1407 /* Note that this just undoes the binding of h.var; whoever
1408 longjumped to us unwound the stack to c.pdlcount before
1410 unbind_to (c
.pdlcount
, Qnil
);
1417 h
.handler
= handlers
;
1418 h
.next
= handlerlist
;
1422 val
= Feval (bodyform
);
1424 handlerlist
= h
.next
;
1428 /* Call the function BFUN with no arguments, catching errors within it
1429 according to HANDLERS. If there is an error, call HFUN with
1430 one argument which is the data that describes the error:
1433 HANDLERS can be a list of conditions to catch.
1434 If HANDLERS is Qt, catch all errors.
1435 If HANDLERS is Qerror, catch all errors
1436 but allow the debugger to run if that is enabled. */
1439 internal_condition_case (bfun
, handlers
, hfun
)
1440 Lisp_Object (*bfun
) ();
1441 Lisp_Object handlers
;
1442 Lisp_Object (*hfun
) ();
1448 /* Since Fsignal will close off all calls to x_catch_errors,
1449 we will get the wrong results if some are not closed now. */
1451 if (x_catching_errors ())
1457 c
.backlist
= backtrace_list
;
1458 c
.handlerlist
= handlerlist
;
1459 c
.lisp_eval_depth
= lisp_eval_depth
;
1460 c
.pdlcount
= SPECPDL_INDEX ();
1461 c
.poll_suppress_count
= poll_suppress_count
;
1462 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1463 c
.gcpro
= gcprolist
;
1464 c
.byte_stack
= byte_stack_list
;
1465 if (_setjmp (c
.jmp
))
1467 return (*hfun
) (c
.val
);
1471 h
.handler
= handlers
;
1473 h
.next
= handlerlist
;
1479 handlerlist
= h
.next
;
1483 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1486 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1487 Lisp_Object (*bfun
) ();
1489 Lisp_Object handlers
;
1490 Lisp_Object (*hfun
) ();
1496 /* Since Fsignal will close off all calls to x_catch_errors,
1497 we will get the wrong results if some are not closed now. */
1499 if (x_catching_errors ())
1505 c
.backlist
= backtrace_list
;
1506 c
.handlerlist
= handlerlist
;
1507 c
.lisp_eval_depth
= lisp_eval_depth
;
1508 c
.pdlcount
= SPECPDL_INDEX ();
1509 c
.poll_suppress_count
= poll_suppress_count
;
1510 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1511 c
.gcpro
= gcprolist
;
1512 c
.byte_stack
= byte_stack_list
;
1513 if (_setjmp (c
.jmp
))
1515 return (*hfun
) (c
.val
);
1519 h
.handler
= handlers
;
1521 h
.next
= handlerlist
;
1525 val
= (*bfun
) (arg
);
1527 handlerlist
= h
.next
;
1532 /* Like internal_condition_case but call BFUN with NARGS as first,
1533 and ARGS as second argument. */
1536 internal_condition_case_2 (bfun
, nargs
, args
, handlers
, hfun
)
1537 Lisp_Object (*bfun
) ();
1540 Lisp_Object handlers
;
1541 Lisp_Object (*hfun
) ();
1547 /* Since Fsignal will close off all calls to x_catch_errors,
1548 we will get the wrong results if some are not closed now. */
1550 if (x_catching_errors ())
1556 c
.backlist
= backtrace_list
;
1557 c
.handlerlist
= handlerlist
;
1558 c
.lisp_eval_depth
= lisp_eval_depth
;
1559 c
.pdlcount
= SPECPDL_INDEX ();
1560 c
.poll_suppress_count
= poll_suppress_count
;
1561 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1562 c
.gcpro
= gcprolist
;
1563 c
.byte_stack
= byte_stack_list
;
1564 if (_setjmp (c
.jmp
))
1566 return (*hfun
) (c
.val
);
1570 h
.handler
= handlers
;
1572 h
.next
= handlerlist
;
1576 val
= (*bfun
) (nargs
, args
);
1578 handlerlist
= h
.next
;
1583 static Lisp_Object find_handler_clause
P_ ((Lisp_Object
, Lisp_Object
,
1584 Lisp_Object
, Lisp_Object
,
1587 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1588 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1589 This function does not return.
1591 An error symbol is a symbol with an `error-conditions' property
1592 that is a list of condition names.
1593 A handler for any of those names will get to handle this signal.
1594 The symbol `error' should normally be one of them.
1596 DATA should be a list. Its elements are printed as part of the error message.
1597 See Info anchor `(elisp)Definition of signal' for some details on how this
1598 error message is constructed.
1599 If the signal is handled, DATA is made available to the handler.
1600 See also the function `condition-case'. */)
1601 (error_symbol
, data
)
1602 Lisp_Object error_symbol
, data
;
1604 /* When memory is full, ERROR-SYMBOL is nil,
1605 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1606 That is a special case--don't do this in other situations. */
1607 register struct handler
*allhandlers
= handlerlist
;
1608 Lisp_Object conditions
;
1609 extern int gc_in_progress
;
1610 extern int waiting_for_input
;
1611 Lisp_Object debugger_value
;
1613 Lisp_Object real_error_symbol
;
1614 struct backtrace
*bp
;
1616 immediate_quit
= handling_signal
= 0;
1618 if (gc_in_progress
|| waiting_for_input
)
1621 if (NILP (error_symbol
))
1622 real_error_symbol
= Fcar (data
);
1624 real_error_symbol
= error_symbol
;
1626 #if 0 /* rms: I don't know why this was here,
1627 but it is surely wrong for an error that is handled. */
1628 #ifdef HAVE_X_WINDOWS
1629 if (display_hourglass_p
)
1630 cancel_hourglass ();
1634 /* This hook is used by edebug. */
1635 if (! NILP (Vsignal_hook_function
)
1636 && ! NILP (error_symbol
))
1638 /* Edebug takes care of restoring these variables when it exits. */
1639 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1640 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1642 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1643 max_specpdl_size
= SPECPDL_INDEX () + 40;
1645 call2 (Vsignal_hook_function
, error_symbol
, data
);
1648 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1650 /* Remember from where signal was called. Skip over the frame for
1651 `signal' itself. If a frame for `error' follows, skip that,
1652 too. Don't do this when ERROR_SYMBOL is nil, because that
1653 is a memory-full error. */
1654 Vsignaling_function
= Qnil
;
1655 if (backtrace_list
&& !NILP (error_symbol
))
1657 bp
= backtrace_list
->next
;
1658 if (bp
&& bp
->function
&& EQ (*bp
->function
, Qerror
))
1660 if (bp
&& bp
->function
)
1661 Vsignaling_function
= *bp
->function
;
1664 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1666 register Lisp_Object clause
;
1668 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1669 error_symbol
, data
, &debugger_value
);
1671 if (EQ (clause
, Qlambda
))
1673 /* We can't return values to code which signaled an error, but we
1674 can continue code which has signaled a quit. */
1675 if (EQ (real_error_symbol
, Qquit
))
1678 error ("Cannot return from the debugger in an error");
1683 Lisp_Object unwind_data
;
1684 struct handler
*h
= handlerlist
;
1686 handlerlist
= allhandlers
;
1688 if (NILP (error_symbol
))
1691 unwind_data
= Fcons (error_symbol
, data
);
1692 h
->chosen_clause
= clause
;
1693 unwind_to_catch (h
->tag
, unwind_data
);
1697 handlerlist
= allhandlers
;
1698 /* If no handler is present now, try to run the debugger,
1699 and if that fails, throw to top level. */
1700 find_handler_clause (Qerror
, conditions
, error_symbol
, data
, &debugger_value
);
1702 Fthrow (Qtop_level
, Qt
);
1704 if (! NILP (error_symbol
))
1705 data
= Fcons (error_symbol
, data
);
1707 string
= Ferror_message_string (data
);
1708 fatal ("%s", SDATA (string
), 0);
1711 /* Internal version of Fsignal that never returns.
1712 Used for anything but Qquit (which can return from Fsignal). */
1715 xsignal (error_symbol
, data
)
1716 Lisp_Object error_symbol
, data
;
1718 Fsignal (error_symbol
, data
);
1722 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1725 xsignal0 (error_symbol
)
1726 Lisp_Object error_symbol
;
1728 xsignal (error_symbol
, Qnil
);
1732 xsignal1 (error_symbol
, arg
)
1733 Lisp_Object error_symbol
, arg
;
1735 xsignal (error_symbol
, list1 (arg
));
1739 xsignal2 (error_symbol
, arg1
, arg2
)
1740 Lisp_Object error_symbol
, arg1
, arg2
;
1742 xsignal (error_symbol
, list2 (arg1
, arg2
));
1746 xsignal3 (error_symbol
, arg1
, arg2
, arg3
)
1747 Lisp_Object error_symbol
, arg1
, arg2
, arg3
;
1749 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1752 /* Signal `error' with message S, and additional arg ARG.
1753 If ARG is not a genuine list, make it a one-element list. */
1756 signal_error (s
, arg
)
1760 Lisp_Object tortoise
, hare
;
1762 hare
= tortoise
= arg
;
1763 while (CONSP (hare
))
1770 tortoise
= XCDR (tortoise
);
1772 if (EQ (hare
, tortoise
))
1777 arg
= Fcons (arg
, Qnil
); /* Make it a list. */
1779 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1783 /* Return nonzero iff LIST is a non-nil atom or
1784 a list containing one of CONDITIONS. */
1787 wants_debugger (list
, conditions
)
1788 Lisp_Object list
, conditions
;
1795 while (CONSP (conditions
))
1797 Lisp_Object
this, tail
;
1798 this = XCAR (conditions
);
1799 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1800 if (EQ (XCAR (tail
), this))
1802 conditions
= XCDR (conditions
);
1807 /* Return 1 if an error with condition-symbols CONDITIONS,
1808 and described by SIGNAL-DATA, should skip the debugger
1809 according to debugger-ignored-errors. */
1812 skip_debugger (conditions
, data
)
1813 Lisp_Object conditions
, data
;
1816 int first_string
= 1;
1817 Lisp_Object error_message
;
1819 error_message
= Qnil
;
1820 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1822 if (STRINGP (XCAR (tail
)))
1826 error_message
= Ferror_message_string (data
);
1830 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1835 Lisp_Object contail
;
1837 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1838 if (EQ (XCAR (tail
), XCAR (contail
)))
1846 /* Value of Qlambda means we have called debugger and user has continued.
1847 There are two ways to pass SIG and DATA:
1848 = SIG is the error symbol, and DATA is the rest of the data.
1849 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1850 This is for memory-full errors only.
1852 Store value returned from debugger into *DEBUGGER_VALUE_PTR.
1854 We need to increase max_specpdl_size temporarily around
1855 anything we do that can push on the specpdl, so as not to get
1856 a second error here in case we're handling specpdl overflow. */
1859 find_handler_clause (handlers
, conditions
, sig
, data
, debugger_value_ptr
)
1860 Lisp_Object handlers
, conditions
, sig
, data
;
1861 Lisp_Object
*debugger_value_ptr
;
1863 register Lisp_Object h
;
1864 register Lisp_Object tem
;
1866 if (EQ (handlers
, Qt
)) /* t is used by handlers for all conditions, set up by C code. */
1868 /* error is used similarly, but means print an error message
1869 and run the debugger if that is enabled. */
1870 if (EQ (handlers
, Qerror
)
1871 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1872 there is a handler. */
1874 int debugger_called
= 0;
1875 Lisp_Object sig_symbol
, combined_data
;
1876 /* This is set to 1 if we are handling a memory-full error,
1877 because these must not run the debugger.
1878 (There is no room in memory to do that!) */
1879 int no_debugger
= 0;
1883 combined_data
= data
;
1884 sig_symbol
= Fcar (data
);
1889 combined_data
= Fcons (sig
, data
);
1893 if (wants_debugger (Vstack_trace_on_error
, conditions
))
1897 internal_with_output_to_temp_buffer ("*Backtrace*",
1898 (Lisp_Object (*) (Lisp_Object
)) Fbacktrace
,
1901 internal_with_output_to_temp_buffer ("*Backtrace*",
1907 /* Don't try to run the debugger with interrupts blocked.
1908 The editing loop would return anyway. */
1909 && ! INPUT_BLOCKED_P
1910 && (EQ (sig_symbol
, Qquit
)
1912 : wants_debugger (Vdebug_on_error
, conditions
))
1913 && ! skip_debugger (conditions
, combined_data
)
1914 && when_entered_debugger
< num_nonmacro_input_events
)
1917 = call_debugger (Fcons (Qerror
,
1918 Fcons (combined_data
, Qnil
)));
1919 debugger_called
= 1;
1921 /* If there is no handler, return saying whether we ran the debugger. */
1922 if (EQ (handlers
, Qerror
))
1924 if (debugger_called
)
1929 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1931 Lisp_Object handler
, condit
;
1934 if (!CONSP (handler
))
1936 condit
= Fcar (handler
);
1937 /* Handle a single condition name in handler HANDLER. */
1938 if (SYMBOLP (condit
))
1940 tem
= Fmemq (Fcar (handler
), conditions
);
1944 /* Handle a list of condition names in handler HANDLER. */
1945 else if (CONSP (condit
))
1947 while (CONSP (condit
))
1949 tem
= Fmemq (Fcar (condit
), conditions
);
1952 condit
= XCDR (condit
);
1959 /* dump an error message; called like printf */
1963 error (m
, a1
, a2
, a3
)
1983 int used
= doprnt (buffer
, size
, m
, m
+ mlen
, 3, args
);
1988 buffer
= (char *) xrealloc (buffer
, size
);
1991 buffer
= (char *) xmalloc (size
);
1996 string
= build_string (buffer
);
2000 xsignal1 (Qerror
, string
);
2003 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
2004 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
2005 This means it contains a description for how to read arguments to give it.
2006 The value is nil for an invalid function or a symbol with no function
2009 Interactively callable functions include strings and vectors (treated
2010 as keyboard macros), lambda-expressions that contain a top-level call
2011 to `interactive', autoload definitions made by `autoload' with non-nil
2012 fourth argument, and some of the built-in functions of Lisp.
2014 Also, a symbol satisfies `commandp' if its function definition does so.
2016 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
2017 then strings and vectors are not accepted. */)
2018 (function
, for_call_interactively
)
2019 Lisp_Object function
, for_call_interactively
;
2021 register Lisp_Object fun
;
2022 register Lisp_Object funcar
;
2026 fun
= indirect_function (fun
);
2027 if (EQ (fun
, Qunbound
))
2030 /* Emacs primitives are interactive if their DEFUN specifies an
2031 interactive spec. */
2034 if (XSUBR (fun
)->prompt
)
2040 /* Bytecode objects are interactive if they are long enough to
2041 have an element whose index is COMPILED_INTERACTIVE, which is
2042 where the interactive spec is stored. */
2043 else if (COMPILEDP (fun
))
2044 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
2047 /* Strings and vectors are keyboard macros. */
2048 if (NILP (for_call_interactively
) && (STRINGP (fun
) || VECTORP (fun
)))
2051 /* Lists may represent commands. */
2054 funcar
= XCAR (fun
);
2055 if (EQ (funcar
, Qlambda
))
2056 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
2057 if (EQ (funcar
, Qautoload
))
2058 return Fcar (Fcdr (Fcdr (XCDR (fun
))));
2064 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
2065 doc
: /* Define FUNCTION to autoload from FILE.
2066 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
2067 Third arg DOCSTRING is documentation for the function.
2068 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
2069 Fifth arg TYPE indicates the type of the object:
2070 nil or omitted says FUNCTION is a function,
2071 `keymap' says FUNCTION is really a keymap, and
2072 `macro' or t says FUNCTION is really a macro.
2073 Third through fifth args give info about the real definition.
2074 They default to nil.
2075 If FUNCTION is already defined other than as an autoload,
2076 this does nothing and returns nil. */)
2077 (function
, file
, docstring
, interactive
, type
)
2078 Lisp_Object function
, file
, docstring
, interactive
, type
;
2081 Lisp_Object args
[4];
2084 CHECK_SYMBOL (function
);
2085 CHECK_STRING (file
);
2087 /* If function is defined and not as an autoload, don't override */
2088 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
2089 && !(CONSP (XSYMBOL (function
)->function
)
2090 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
2093 if (NILP (Vpurify_flag
))
2094 /* Only add entries after dumping, because the ones before are
2095 not useful and else we get loads of them from the loaddefs.el. */
2096 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
2100 args
[1] = docstring
;
2101 args
[2] = interactive
;
2104 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
2105 #else /* NO_ARG_ARRAY */
2106 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
2107 #endif /* not NO_ARG_ARRAY */
2111 un_autoload (oldqueue
)
2112 Lisp_Object oldqueue
;
2114 register Lisp_Object queue
, first
, second
;
2116 /* Queue to unwind is current value of Vautoload_queue.
2117 oldqueue is the shadowed value to leave in Vautoload_queue. */
2118 queue
= Vautoload_queue
;
2119 Vautoload_queue
= oldqueue
;
2120 while (CONSP (queue
))
2122 first
= XCAR (queue
);
2123 second
= Fcdr (first
);
2124 first
= Fcar (first
);
2125 if (EQ (first
, make_number (0)))
2128 Ffset (first
, second
);
2129 queue
= XCDR (queue
);
2134 /* Load an autoloaded function.
2135 FUNNAME is the symbol which is the function's name.
2136 FUNDEF is the autoload definition (a list). */
2139 do_autoload (fundef
, funname
)
2140 Lisp_Object fundef
, funname
;
2142 int count
= SPECPDL_INDEX ();
2143 Lisp_Object fun
, queue
, first
, second
;
2144 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2146 /* This is to make sure that loadup.el gives a clear picture
2147 of what files are preloaded and when. */
2148 if (! NILP (Vpurify_flag
))
2149 error ("Attempt to autoload %s while preparing to dump",
2150 SDATA (SYMBOL_NAME (funname
)));
2153 CHECK_SYMBOL (funname
);
2154 GCPRO3 (fun
, funname
, fundef
);
2156 /* Preserve the match data. */
2157 record_unwind_save_match_data ();
2159 /* Value saved here is to be restored into Vautoload_queue. */
2160 record_unwind_protect (un_autoload
, Vautoload_queue
);
2161 Vautoload_queue
= Qt
;
2162 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
, Qt
);
2164 /* Save the old autoloads, in case we ever do an unload. */
2165 queue
= Vautoload_queue
;
2166 while (CONSP (queue
))
2168 first
= XCAR (queue
);
2169 second
= Fcdr (first
);
2170 first
= Fcar (first
);
2172 if (SYMBOLP (first
) && CONSP (second
) && EQ (XCAR (second
), Qautoload
))
2173 Fput (first
, Qautoload
, (XCDR (second
)));
2175 queue
= XCDR (queue
);
2178 /* Once loading finishes, don't undo it. */
2179 Vautoload_queue
= Qt
;
2180 unbind_to (count
, Qnil
);
2182 fun
= Findirect_function (fun
, Qnil
);
2184 if (!NILP (Fequal (fun
, fundef
)))
2185 error ("Autoloading failed to define function %s",
2186 SDATA (SYMBOL_NAME (funname
)));
2191 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
2192 doc
: /* Evaluate FORM and return its value. */)
2196 Lisp_Object fun
, val
, original_fun
, original_args
;
2198 struct backtrace backtrace
;
2199 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2201 if (handling_signal
)
2205 return Fsymbol_value (form
);
2210 if ((consing_since_gc
> gc_cons_threshold
2211 && consing_since_gc
> gc_relative_threshold
)
2213 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2216 Fgarbage_collect ();
2220 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2222 if (max_lisp_eval_depth
< 100)
2223 max_lisp_eval_depth
= 100;
2224 if (lisp_eval_depth
> max_lisp_eval_depth
)
2225 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2228 original_fun
= Fcar (form
);
2229 original_args
= Fcdr (form
);
2231 backtrace
.next
= backtrace_list
;
2232 backtrace_list
= &backtrace
;
2233 backtrace
.function
= &original_fun
; /* This also protects them from gc */
2234 backtrace
.args
= &original_args
;
2235 backtrace
.nargs
= UNEVALLED
;
2236 backtrace
.evalargs
= 1;
2237 backtrace
.debug_on_exit
= 0;
2239 if (debug_on_next_call
)
2240 do_debug_on_call (Qt
);
2242 /* At this point, only original_fun and original_args
2243 have values that will be used below */
2246 /* Optimize for no indirection. */
2248 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2249 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2250 fun
= indirect_function (fun
);
2254 Lisp_Object numargs
;
2255 Lisp_Object argvals
[8];
2256 Lisp_Object args_left
;
2257 register int i
, maxargs
;
2259 args_left
= original_args
;
2260 numargs
= Flength (args_left
);
2264 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
2265 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2266 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2268 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2270 backtrace
.evalargs
= 0;
2271 val
= (*XSUBR (fun
)->function
) (args_left
);
2275 if (XSUBR (fun
)->max_args
== MANY
)
2277 /* Pass a vector of evaluated arguments */
2279 register int argnum
= 0;
2281 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2283 GCPRO3 (args_left
, fun
, fun
);
2287 while (!NILP (args_left
))
2289 vals
[argnum
++] = Feval (Fcar (args_left
));
2290 args_left
= Fcdr (args_left
);
2291 gcpro3
.nvars
= argnum
;
2294 backtrace
.args
= vals
;
2295 backtrace
.nargs
= XINT (numargs
);
2297 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
2302 GCPRO3 (args_left
, fun
, fun
);
2303 gcpro3
.var
= argvals
;
2306 maxargs
= XSUBR (fun
)->max_args
;
2307 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
2309 argvals
[i
] = Feval (Fcar (args_left
));
2315 backtrace
.args
= argvals
;
2316 backtrace
.nargs
= XINT (numargs
);
2321 val
= (*XSUBR (fun
)->function
) ();
2324 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
2327 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
2330 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2334 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2335 argvals
[2], argvals
[3]);
2338 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2339 argvals
[3], argvals
[4]);
2342 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2343 argvals
[3], argvals
[4], argvals
[5]);
2346 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2347 argvals
[3], argvals
[4], argvals
[5],
2352 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2353 argvals
[3], argvals
[4], argvals
[5],
2354 argvals
[6], argvals
[7]);
2358 /* Someone has created a subr that takes more arguments than
2359 is supported by this code. We need to either rewrite the
2360 subr to use a different argument protocol, or add more
2361 cases to this switch. */
2365 if (COMPILEDP (fun
))
2366 val
= apply_lambda (fun
, original_args
, 1);
2369 if (EQ (fun
, Qunbound
))
2370 xsignal1 (Qvoid_function
, original_fun
);
2372 xsignal1 (Qinvalid_function
, original_fun
);
2373 funcar
= XCAR (fun
);
2374 if (!SYMBOLP (funcar
))
2375 xsignal1 (Qinvalid_function
, original_fun
);
2376 if (EQ (funcar
, Qautoload
))
2378 do_autoload (fun
, original_fun
);
2381 if (EQ (funcar
, Qmacro
))
2382 val
= Feval (apply1 (Fcdr (fun
), original_args
));
2383 else if (EQ (funcar
, Qlambda
))
2384 val
= apply_lambda (fun
, original_args
, 1);
2386 xsignal1 (Qinvalid_function
, original_fun
);
2392 if (backtrace
.debug_on_exit
)
2393 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2394 backtrace_list
= backtrace
.next
;
2399 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
2400 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2401 Then return the value FUNCTION returns.
2402 Thus, (apply '+ 1 2 '(3 4)) returns 10.
2403 usage: (apply FUNCTION &rest ARGUMENTS) */)
2408 register int i
, numargs
;
2409 register Lisp_Object spread_arg
;
2410 register Lisp_Object
*funcall_args
;
2412 struct gcpro gcpro1
;
2416 spread_arg
= args
[nargs
- 1];
2417 CHECK_LIST (spread_arg
);
2419 numargs
= XINT (Flength (spread_arg
));
2422 return Ffuncall (nargs
- 1, args
);
2423 else if (numargs
== 1)
2425 args
[nargs
- 1] = XCAR (spread_arg
);
2426 return Ffuncall (nargs
, args
);
2429 numargs
+= nargs
- 2;
2431 /* Optimize for no indirection. */
2432 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2433 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2434 fun
= indirect_function (fun
);
2435 if (EQ (fun
, Qunbound
))
2437 /* Let funcall get the error */
2444 if (numargs
< XSUBR (fun
)->min_args
2445 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2446 goto funcall
; /* Let funcall get the error */
2447 else if (XSUBR (fun
)->max_args
> numargs
)
2449 /* Avoid making funcall cons up a yet another new vector of arguments
2450 by explicitly supplying nil's for optional values */
2451 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
2452 * sizeof (Lisp_Object
));
2453 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2454 funcall_args
[++i
] = Qnil
;
2455 GCPRO1 (*funcall_args
);
2456 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2460 /* We add 1 to numargs because funcall_args includes the
2461 function itself as well as its arguments. */
2464 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
2465 * sizeof (Lisp_Object
));
2466 GCPRO1 (*funcall_args
);
2467 gcpro1
.nvars
= 1 + numargs
;
2470 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
2471 /* Spread the last arg we got. Its first element goes in
2472 the slot that it used to occupy, hence this value of I. */
2474 while (!NILP (spread_arg
))
2476 funcall_args
[i
++] = XCAR (spread_arg
);
2477 spread_arg
= XCDR (spread_arg
);
2480 /* By convention, the caller needs to gcpro Ffuncall's args. */
2481 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
2484 /* Run hook variables in various ways. */
2486 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
2487 static Lisp_Object run_hook_with_args
P_ ((int, Lisp_Object
*,
2488 enum run_hooks_condition
));
2490 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2491 doc
: /* Run each hook in HOOKS.
2492 Each argument should be a symbol, a hook variable.
2493 These symbols are processed in the order specified.
2494 If a hook symbol has a non-nil value, that value may be a function
2495 or a list of functions to be called to run the hook.
2496 If the value is a function, it is called with no arguments.
2497 If it is a list, the elements are called, in order, with no arguments.
2499 Major modes should not use this function directly to run their mode
2500 hook; they should use `run-mode-hooks' instead.
2502 Do not use `make-local-variable' to make a hook variable buffer-local.
2503 Instead, use `add-hook' and specify t for the LOCAL argument.
2504 usage: (run-hooks &rest HOOKS) */)
2509 Lisp_Object hook
[1];
2512 for (i
= 0; i
< nargs
; i
++)
2515 run_hook_with_args (1, hook
, to_completion
);
2521 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2522 Srun_hook_with_args
, 1, MANY
, 0,
2523 doc
: /* Run HOOK with the specified arguments ARGS.
2524 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2525 value, that value may be a function or a list of functions to be
2526 called to run the hook. If the value is a function, it is called with
2527 the given arguments and its return value is returned. If it is a list
2528 of functions, those functions are called, in order,
2529 with the given arguments ARGS.
2530 It is best not to depend on the value returned by `run-hook-with-args',
2533 Do not use `make-local-variable' to make a hook variable buffer-local.
2534 Instead, use `add-hook' and specify t for the LOCAL argument.
2535 usage: (run-hook-with-args HOOK &rest ARGS) */)
2540 return run_hook_with_args (nargs
, args
, to_completion
);
2543 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2544 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2545 doc
: /* Run HOOK with the specified arguments ARGS.
2546 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2547 value, that value may be a function or a list of functions to be
2548 called to run the hook. If the value is a function, it is called with
2549 the given arguments and its return value is returned.
2550 If it is a list of functions, those functions are called, in order,
2551 with the given arguments ARGS, until one of them
2552 returns a non-nil value. Then we return that value.
2553 However, if they all return nil, we return nil.
2555 Do not use `make-local-variable' to make a hook variable buffer-local.
2556 Instead, use `add-hook' and specify t for the LOCAL argument.
2557 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2562 return run_hook_with_args (nargs
, args
, until_success
);
2565 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2566 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2567 doc
: /* Run HOOK with the specified arguments ARGS.
2568 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2569 value, that value may be a function or a list of functions to be
2570 called to run the hook. If the value is a function, it is called with
2571 the given arguments and its return value is returned.
2572 If it is a list of functions, those functions are called, in order,
2573 with the given arguments ARGS, until one of them returns nil.
2574 Then we return nil. However, if they all return non-nil, we return non-nil.
2576 Do not use `make-local-variable' to make a hook variable buffer-local.
2577 Instead, use `add-hook' and specify t for the LOCAL argument.
2578 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2583 return run_hook_with_args (nargs
, args
, until_failure
);
2586 /* ARGS[0] should be a hook symbol.
2587 Call each of the functions in the hook value, passing each of them
2588 as arguments all the rest of ARGS (all NARGS - 1 elements).
2589 COND specifies a condition to test after each call
2590 to decide whether to stop.
2591 The caller (or its caller, etc) must gcpro all of ARGS,
2592 except that it isn't necessary to gcpro ARGS[0]. */
2595 run_hook_with_args (nargs
, args
, cond
)
2598 enum run_hooks_condition cond
;
2600 Lisp_Object sym
, val
, ret
;
2601 Lisp_Object globals
;
2602 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2604 /* If we are dying or still initializing,
2605 don't do anything--it would probably crash if we tried. */
2606 if (NILP (Vrun_hooks
))
2610 val
= find_symbol_value (sym
);
2611 ret
= (cond
== until_failure
? Qt
: Qnil
);
2613 if (EQ (val
, Qunbound
) || NILP (val
))
2615 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2618 return Ffuncall (nargs
, args
);
2623 GCPRO3 (sym
, val
, globals
);
2626 CONSP (val
) && ((cond
== to_completion
)
2627 || (cond
== until_success
? NILP (ret
)
2631 if (EQ (XCAR (val
), Qt
))
2633 /* t indicates this hook has a local binding;
2634 it means to run the global binding too. */
2636 for (globals
= Fdefault_value (sym
);
2637 CONSP (globals
) && ((cond
== to_completion
)
2638 || (cond
== until_success
? NILP (ret
)
2640 globals
= XCDR (globals
))
2642 args
[0] = XCAR (globals
);
2643 /* In a global value, t should not occur. If it does, we
2644 must ignore it to avoid an endless loop. */
2645 if (!EQ (args
[0], Qt
))
2646 ret
= Ffuncall (nargs
, args
);
2651 args
[0] = XCAR (val
);
2652 ret
= Ffuncall (nargs
, args
);
2661 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2662 present value of that symbol.
2663 Call each element of FUNLIST,
2664 passing each of them the rest of ARGS.
2665 The caller (or its caller, etc) must gcpro all of ARGS,
2666 except that it isn't necessary to gcpro ARGS[0]. */
2669 run_hook_list_with_args (funlist
, nargs
, args
)
2670 Lisp_Object funlist
;
2676 Lisp_Object globals
;
2677 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2681 GCPRO3 (sym
, val
, globals
);
2683 for (val
= funlist
; CONSP (val
); val
= XCDR (val
))
2685 if (EQ (XCAR (val
), Qt
))
2687 /* t indicates this hook has a local binding;
2688 it means to run the global binding too. */
2690 for (globals
= Fdefault_value (sym
);
2692 globals
= XCDR (globals
))
2694 args
[0] = XCAR (globals
);
2695 /* In a global value, t should not occur. If it does, we
2696 must ignore it to avoid an endless loop. */
2697 if (!EQ (args
[0], Qt
))
2698 Ffuncall (nargs
, args
);
2703 args
[0] = XCAR (val
);
2704 Ffuncall (nargs
, args
);
2711 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2714 run_hook_with_args_2 (hook
, arg1
, arg2
)
2715 Lisp_Object hook
, arg1
, arg2
;
2717 Lisp_Object temp
[3];
2722 Frun_hook_with_args (3, temp
);
2725 /* Apply fn to arg */
2728 Lisp_Object fn
, arg
;
2730 struct gcpro gcpro1
;
2734 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2738 Lisp_Object args
[2];
2742 RETURN_UNGCPRO (Fapply (2, args
));
2744 #else /* not NO_ARG_ARRAY */
2745 RETURN_UNGCPRO (Fapply (2, &fn
));
2746 #endif /* not NO_ARG_ARRAY */
2749 /* Call function fn on no arguments */
2754 struct gcpro gcpro1
;
2757 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2760 /* Call function fn with 1 argument arg1 */
2764 Lisp_Object fn
, arg1
;
2766 struct gcpro gcpro1
;
2768 Lisp_Object args
[2];
2774 RETURN_UNGCPRO (Ffuncall (2, args
));
2775 #else /* not NO_ARG_ARRAY */
2778 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2779 #endif /* not NO_ARG_ARRAY */
2782 /* Call function fn with 2 arguments arg1, arg2 */
2785 call2 (fn
, arg1
, arg2
)
2786 Lisp_Object fn
, arg1
, arg2
;
2788 struct gcpro gcpro1
;
2790 Lisp_Object args
[3];
2796 RETURN_UNGCPRO (Ffuncall (3, args
));
2797 #else /* not NO_ARG_ARRAY */
2800 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2801 #endif /* not NO_ARG_ARRAY */
2804 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2807 call3 (fn
, arg1
, arg2
, arg3
)
2808 Lisp_Object fn
, arg1
, arg2
, arg3
;
2810 struct gcpro gcpro1
;
2812 Lisp_Object args
[4];
2819 RETURN_UNGCPRO (Ffuncall (4, args
));
2820 #else /* not NO_ARG_ARRAY */
2823 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2824 #endif /* not NO_ARG_ARRAY */
2827 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2830 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2831 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2833 struct gcpro gcpro1
;
2835 Lisp_Object args
[5];
2843 RETURN_UNGCPRO (Ffuncall (5, args
));
2844 #else /* not NO_ARG_ARRAY */
2847 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2848 #endif /* not NO_ARG_ARRAY */
2851 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2854 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2855 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2857 struct gcpro gcpro1
;
2859 Lisp_Object args
[6];
2868 RETURN_UNGCPRO (Ffuncall (6, args
));
2869 #else /* not NO_ARG_ARRAY */
2872 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2873 #endif /* not NO_ARG_ARRAY */
2876 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2879 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2880 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2882 struct gcpro gcpro1
;
2884 Lisp_Object args
[7];
2894 RETURN_UNGCPRO (Ffuncall (7, args
));
2895 #else /* not NO_ARG_ARRAY */
2898 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2899 #endif /* not NO_ARG_ARRAY */
2902 /* The caller should GCPRO all the elements of ARGS. */
2904 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2905 doc
: /* Call first argument as a function, passing remaining arguments to it.
2906 Return the value that function returns.
2907 Thus, (funcall 'cons 'x 'y) returns (x . y).
2908 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2913 Lisp_Object fun
, original_fun
;
2915 int numargs
= nargs
- 1;
2916 Lisp_Object lisp_numargs
;
2918 struct backtrace backtrace
;
2919 register Lisp_Object
*internal_args
;
2923 if ((consing_since_gc
> gc_cons_threshold
2924 && consing_since_gc
> gc_relative_threshold
)
2926 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2927 Fgarbage_collect ();
2929 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2931 if (max_lisp_eval_depth
< 100)
2932 max_lisp_eval_depth
= 100;
2933 if (lisp_eval_depth
> max_lisp_eval_depth
)
2934 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2937 backtrace
.next
= backtrace_list
;
2938 backtrace_list
= &backtrace
;
2939 backtrace
.function
= &args
[0];
2940 backtrace
.args
= &args
[1];
2941 backtrace
.nargs
= nargs
- 1;
2942 backtrace
.evalargs
= 0;
2943 backtrace
.debug_on_exit
= 0;
2945 if (debug_on_next_call
)
2946 do_debug_on_call (Qlambda
);
2950 original_fun
= args
[0];
2954 /* Optimize for no indirection. */
2956 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2957 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2958 fun
= indirect_function (fun
);
2962 if (numargs
< XSUBR (fun
)->min_args
2963 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2965 XSETFASTINT (lisp_numargs
, numargs
);
2966 xsignal2 (Qwrong_number_of_arguments
, original_fun
, lisp_numargs
);
2969 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2970 xsignal1 (Qinvalid_function
, original_fun
);
2972 if (XSUBR (fun
)->max_args
== MANY
)
2974 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
2978 if (XSUBR (fun
)->max_args
> numargs
)
2980 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2981 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
2982 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2983 internal_args
[i
] = Qnil
;
2986 internal_args
= args
+ 1;
2987 switch (XSUBR (fun
)->max_args
)
2990 val
= (*XSUBR (fun
)->function
) ();
2993 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
2996 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1]);
2999 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3003 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3004 internal_args
[2], internal_args
[3]);
3007 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3008 internal_args
[2], internal_args
[3],
3012 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3013 internal_args
[2], internal_args
[3],
3014 internal_args
[4], internal_args
[5]);
3017 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3018 internal_args
[2], internal_args
[3],
3019 internal_args
[4], internal_args
[5],
3024 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3025 internal_args
[2], internal_args
[3],
3026 internal_args
[4], internal_args
[5],
3027 internal_args
[6], internal_args
[7]);
3032 /* If a subr takes more than 8 arguments without using MANY
3033 or UNEVALLED, we need to extend this function to support it.
3034 Until this is done, there is no way to call the function. */
3038 if (COMPILEDP (fun
))
3039 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3042 if (EQ (fun
, Qunbound
))
3043 xsignal1 (Qvoid_function
, original_fun
);
3045 xsignal1 (Qinvalid_function
, original_fun
);
3046 funcar
= XCAR (fun
);
3047 if (!SYMBOLP (funcar
))
3048 xsignal1 (Qinvalid_function
, original_fun
);
3049 if (EQ (funcar
, Qlambda
))
3050 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3051 else if (EQ (funcar
, Qautoload
))
3053 do_autoload (fun
, original_fun
);
3058 xsignal1 (Qinvalid_function
, original_fun
);
3063 if (backtrace
.debug_on_exit
)
3064 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
3065 backtrace_list
= backtrace
.next
;
3070 apply_lambda (fun
, args
, eval_flag
)
3071 Lisp_Object fun
, args
;
3074 Lisp_Object args_left
;
3075 Lisp_Object numargs
;
3076 register Lisp_Object
*arg_vector
;
3077 struct gcpro gcpro1
, gcpro2
, gcpro3
;
3079 register Lisp_Object tem
;
3081 numargs
= Flength (args
);
3082 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
3085 GCPRO3 (*arg_vector
, args_left
, fun
);
3088 for (i
= 0; i
< XINT (numargs
);)
3090 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
3091 if (eval_flag
) tem
= Feval (tem
);
3092 arg_vector
[i
++] = tem
;
3100 backtrace_list
->args
= arg_vector
;
3101 backtrace_list
->nargs
= i
;
3103 backtrace_list
->evalargs
= 0;
3104 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
3106 /* Do the debug-on-exit now, while arg_vector still exists. */
3107 if (backtrace_list
->debug_on_exit
)
3108 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
3109 /* Don't do it again when we return to eval. */
3110 backtrace_list
->debug_on_exit
= 0;
3114 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
3115 and return the result of evaluation.
3116 FUN must be either a lambda-expression or a compiled-code object. */
3119 funcall_lambda (fun
, nargs
, arg_vector
)
3122 register Lisp_Object
*arg_vector
;
3124 Lisp_Object val
, syms_left
, next
;
3125 int count
= SPECPDL_INDEX ();
3126 int i
, optional
, rest
;
3130 syms_left
= XCDR (fun
);
3131 if (CONSP (syms_left
))
3132 syms_left
= XCAR (syms_left
);
3134 xsignal1 (Qinvalid_function
, fun
);
3136 else if (COMPILEDP (fun
))
3137 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3141 i
= optional
= rest
= 0;
3142 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3146 next
= XCAR (syms_left
);
3147 if (!SYMBOLP (next
))
3148 xsignal1 (Qinvalid_function
, fun
);
3150 if (EQ (next
, Qand_rest
))
3152 else if (EQ (next
, Qand_optional
))
3156 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
3160 specbind (next
, arg_vector
[i
++]);
3162 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3164 specbind (next
, Qnil
);
3167 if (!NILP (syms_left
))
3168 xsignal1 (Qinvalid_function
, fun
);
3170 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3173 val
= Fprogn (XCDR (XCDR (fun
)));
3176 /* If we have not actually read the bytecode string
3177 and constants vector yet, fetch them from the file. */
3178 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3179 Ffetch_bytecode (fun
);
3180 val
= Fbyte_code (AREF (fun
, COMPILED_BYTECODE
),
3181 AREF (fun
, COMPILED_CONSTANTS
),
3182 AREF (fun
, COMPILED_STACK_DEPTH
));
3185 return unbind_to (count
, val
);
3188 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3190 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3196 if (COMPILEDP (object
) && CONSP (AREF (object
, COMPILED_BYTECODE
)))
3198 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3201 tem
= AREF (object
, COMPILED_BYTECODE
);
3202 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3203 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3205 error ("Invalid byte code");
3207 AREF (object
, COMPILED_BYTECODE
) = XCAR (tem
);
3208 AREF (object
, COMPILED_CONSTANTS
) = XCDR (tem
);
3216 register int count
= SPECPDL_INDEX ();
3217 if (specpdl_size
>= max_specpdl_size
)
3219 if (max_specpdl_size
< 400)
3220 max_specpdl_size
= 400;
3221 if (specpdl_size
>= max_specpdl_size
)
3222 signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil
);
3225 if (specpdl_size
> max_specpdl_size
)
3226 specpdl_size
= max_specpdl_size
;
3227 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
3228 specpdl_ptr
= specpdl
+ count
;
3232 specbind (symbol
, value
)
3233 Lisp_Object symbol
, value
;
3236 Lisp_Object valcontents
;
3238 CHECK_SYMBOL (symbol
);
3239 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3242 /* The most common case is that of a non-constant symbol with a
3243 trivial value. Make that as fast as we can. */
3244 valcontents
= SYMBOL_VALUE (symbol
);
3245 if (!MISCP (valcontents
) && !SYMBOL_CONSTANT_P (symbol
))
3247 specpdl_ptr
->symbol
= symbol
;
3248 specpdl_ptr
->old_value
= valcontents
;
3249 specpdl_ptr
->func
= NULL
;
3251 SET_SYMBOL_VALUE (symbol
, value
);
3255 Lisp_Object valcontents
;
3257 ovalue
= find_symbol_value (symbol
);
3258 specpdl_ptr
->func
= 0;
3259 specpdl_ptr
->old_value
= ovalue
;
3261 valcontents
= XSYMBOL (symbol
)->value
;
3263 if (BUFFER_LOCAL_VALUEP (valcontents
)
3264 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
3265 || BUFFER_OBJFWDP (valcontents
))
3267 Lisp_Object where
, current_buffer
;
3269 current_buffer
= Fcurrent_buffer ();
3271 /* For a local variable, record both the symbol and which
3272 buffer's or frame's value we are saving. */
3273 if (!NILP (Flocal_variable_p (symbol
, Qnil
)))
3274 where
= current_buffer
;
3275 else if (!BUFFER_OBJFWDP (valcontents
)
3276 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
3277 where
= XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
3281 /* We're not using the `unused' slot in the specbinding
3282 structure because this would mean we have to do more
3283 work for simple variables. */
3284 specpdl_ptr
->symbol
= Fcons (symbol
, Fcons (where
, current_buffer
));
3286 /* If SYMBOL is a per-buffer variable which doesn't have a
3287 buffer-local value here, make the `let' change the global
3288 value by changing the value of SYMBOL in all buffers not
3289 having their own value. This is consistent with what
3290 happens with other buffer-local variables. */
3292 && BUFFER_OBJFWDP (valcontents
))
3295 Fset_default (symbol
, value
);
3300 specpdl_ptr
->symbol
= symbol
;
3303 if (BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
))
3304 store_symval_forwarding (symbol
, ovalue
, value
, NULL
);
3306 set_internal (symbol
, value
, 0, 1);
3311 record_unwind_protect (function
, arg
)
3312 Lisp_Object (*function
) P_ ((Lisp_Object
));
3315 eassert (!handling_signal
);
3317 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3319 specpdl_ptr
->func
= function
;
3320 specpdl_ptr
->symbol
= Qnil
;
3321 specpdl_ptr
->old_value
= arg
;
3326 unbind_to (count
, value
)
3330 Lisp_Object quitf
= Vquit_flag
;
3331 struct gcpro gcpro1
, gcpro2
;
3333 GCPRO2 (value
, quitf
);
3336 while (specpdl_ptr
!= specpdl
+ count
)
3338 /* Copy the binding, and decrement specpdl_ptr, before we do
3339 the work to unbind it. We decrement first
3340 so that an error in unbinding won't try to unbind
3341 the same entry again, and we copy the binding first
3342 in case more bindings are made during some of the code we run. */
3344 struct specbinding this_binding
;
3345 this_binding
= *--specpdl_ptr
;
3347 if (this_binding
.func
!= 0)
3348 (*this_binding
.func
) (this_binding
.old_value
);
3349 /* If the symbol is a list, it is really (SYMBOL WHERE
3350 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3351 frame. If WHERE is a buffer or frame, this indicates we
3352 bound a variable that had a buffer-local or frame-local
3353 binding. WHERE nil means that the variable had the default
3354 value when it was bound. CURRENT-BUFFER is the buffer that
3355 was current when the variable was bound. */
3356 else if (CONSP (this_binding
.symbol
))
3358 Lisp_Object symbol
, where
;
3360 symbol
= XCAR (this_binding
.symbol
);
3361 where
= XCAR (XCDR (this_binding
.symbol
));
3364 Fset_default (symbol
, this_binding
.old_value
);
3365 else if (BUFFERP (where
))
3366 set_internal (symbol
, this_binding
.old_value
, XBUFFER (where
), 1);
3368 set_internal (symbol
, this_binding
.old_value
, NULL
, 1);
3372 /* If variable has a trivial value (no forwarding), we can
3373 just set it. No need to check for constant symbols here,
3374 since that was already done by specbind. */
3375 if (!MISCP (SYMBOL_VALUE (this_binding
.symbol
)))
3376 SET_SYMBOL_VALUE (this_binding
.symbol
, this_binding
.old_value
);
3378 set_internal (this_binding
.symbol
, this_binding
.old_value
, 0, 1);
3382 if (NILP (Vquit_flag
) && !NILP (quitf
))
3389 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3390 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3391 The debugger is entered when that frame exits, if the flag is non-nil. */)
3393 Lisp_Object level
, flag
;
3395 register struct backtrace
*backlist
= backtrace_list
;
3398 CHECK_NUMBER (level
);
3400 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
3402 backlist
= backlist
->next
;
3406 backlist
->debug_on_exit
= !NILP (flag
);
3411 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3412 doc
: /* Print a trace of Lisp function calls currently active.
3413 Output stream used is value of `standard-output'. */)
3416 register struct backtrace
*backlist
= backtrace_list
;
3420 extern Lisp_Object Vprint_level
;
3421 struct gcpro gcpro1
;
3423 XSETFASTINT (Vprint_level
, 3);
3430 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
3431 if (backlist
->nargs
== UNEVALLED
)
3433 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
3434 write_string ("\n", -1);
3438 tem
= *backlist
->function
;
3439 Fprin1 (tem
, Qnil
); /* This can QUIT */
3440 write_string ("(", -1);
3441 if (backlist
->nargs
== MANY
)
3443 for (tail
= *backlist
->args
, i
= 0;
3445 tail
= Fcdr (tail
), i
++)
3447 if (i
) write_string (" ", -1);
3448 Fprin1 (Fcar (tail
), Qnil
);
3453 for (i
= 0; i
< backlist
->nargs
; i
++)
3455 if (i
) write_string (" ", -1);
3456 Fprin1 (backlist
->args
[i
], Qnil
);
3459 write_string (")\n", -1);
3461 backlist
= backlist
->next
;
3464 Vprint_level
= Qnil
;
3469 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, NULL
,
3470 doc
: /* Return the function and arguments NFRAMES up from current execution point.
3471 If that frame has not evaluated the arguments yet (or is a special form),
3472 the value is (nil FUNCTION ARG-FORMS...).
3473 If that frame has evaluated its arguments and called its function already,
3474 the value is (t FUNCTION ARG-VALUES...).
3475 A &rest arg is represented as the tail of the list ARG-VALUES.
3476 FUNCTION is whatever was supplied as car of evaluated list,
3477 or a lambda expression for macro calls.
3478 If NFRAMES is more than the number of frames, the value is nil. */)
3480 Lisp_Object nframes
;
3482 register struct backtrace
*backlist
= backtrace_list
;
3486 CHECK_NATNUM (nframes
);
3488 /* Find the frame requested. */
3489 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3490 backlist
= backlist
->next
;
3494 if (backlist
->nargs
== UNEVALLED
)
3495 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3498 if (backlist
->nargs
== MANY
)
3499 tem
= *backlist
->args
;
3501 tem
= Flist (backlist
->nargs
, backlist
->args
);
3503 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3511 register struct backtrace
*backlist
;
3514 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3516 mark_object (*backlist
->function
);
3518 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3521 i
= backlist
->nargs
- 1;
3523 mark_object (backlist
->args
[i
]);
3530 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
3531 doc
: /* *Limit on number of Lisp variable bindings and `unwind-protect's.
3532 If Lisp code tries to increase the total number past this amount,
3533 an error is signaled.
3534 You can safely use a value considerably larger than the default value,
3535 if that proves inconveniently small. However, if you increase it too far,
3536 Emacs could run out of memory trying to make the stack bigger. */);
3538 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
3539 doc
: /* *Limit on depth in `eval', `apply' and `funcall' before error.
3541 This limit serves to catch infinite recursions for you before they cause
3542 actual stack overflow in C, which would be fatal for Emacs.
3543 You can safely make it considerably larger than its default value,
3544 if that proves inconveniently small. However, if you increase it too far,
3545 Emacs could overflow the real C stack, and crash. */);
3547 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
3548 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3549 If the value is t, that means do an ordinary quit.
3550 If the value equals `throw-on-input', that means quit by throwing
3551 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3552 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3553 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3556 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
3557 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3558 Note that `quit-flag' will still be set by typing C-g,
3559 so a quit will be signaled as soon as `inhibit-quit' is nil.
3560 To prevent this happening, set `quit-flag' to nil
3561 before making `inhibit-quit' nil. */);
3562 Vinhibit_quit
= Qnil
;
3564 Qinhibit_quit
= intern ("inhibit-quit");
3565 staticpro (&Qinhibit_quit
);
3567 Qautoload
= intern ("autoload");
3568 staticpro (&Qautoload
);
3570 Qdebug_on_error
= intern ("debug-on-error");
3571 staticpro (&Qdebug_on_error
);
3573 Qmacro
= intern ("macro");
3574 staticpro (&Qmacro
);
3576 Qdeclare
= intern ("declare");
3577 staticpro (&Qdeclare
);
3579 /* Note that the process handling also uses Qexit, but we don't want
3580 to staticpro it twice, so we just do it here. */
3581 Qexit
= intern ("exit");
3584 Qinteractive
= intern ("interactive");
3585 staticpro (&Qinteractive
);
3587 Qcommandp
= intern ("commandp");
3588 staticpro (&Qcommandp
);
3590 Qdefun
= intern ("defun");
3591 staticpro (&Qdefun
);
3593 Qand_rest
= intern ("&rest");
3594 staticpro (&Qand_rest
);
3596 Qand_optional
= intern ("&optional");
3597 staticpro (&Qand_optional
);
3599 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
3600 doc
: /* *Non-nil means errors display a backtrace buffer.
3601 More precisely, this happens for any error that is handled
3602 by the editor command loop.
3603 If the value is a list, an error only means to display a backtrace
3604 if one of its condition symbols appears in the list. */);
3605 Vstack_trace_on_error
= Qnil
;
3607 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
3608 doc
: /* *Non-nil means enter debugger if an error is signaled.
3609 Does not apply to errors handled by `condition-case' or those
3610 matched by `debug-ignored-errors'.
3611 If the value is a list, an error only means to enter the debugger
3612 if one of its condition symbols appears in the list.
3613 When you evaluate an expression interactively, this variable
3614 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3615 See also variable `debug-on-quit'. */);
3616 Vdebug_on_error
= Qnil
;
3618 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
3619 doc
: /* *List of errors for which the debugger should not be called.
3620 Each element may be a condition-name or a regexp that matches error messages.
3621 If any element applies to a given error, that error skips the debugger
3622 and just returns to top level.
3623 This overrides the variable `debug-on-error'.
3624 It does not apply to errors handled by `condition-case'. */);
3625 Vdebug_ignored_errors
= Qnil
;
3627 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
3628 doc
: /* *Non-nil means enter debugger if quit is signaled (C-g, for example).
3629 Does not apply if quit is handled by a `condition-case'. */);
3632 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
3633 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3635 DEFVAR_BOOL ("debugger-may-continue", &debugger_may_continue
,
3636 doc
: /* Non-nil means debugger may continue execution.
3637 This is nil when the debugger is called under circumstances where it
3638 might not be safe to continue. */);
3639 debugger_may_continue
= 1;
3641 DEFVAR_LISP ("debugger", &Vdebugger
,
3642 doc
: /* Function to call to invoke debugger.
3643 If due to frame exit, args are `exit' and the value being returned;
3644 this function's value will be returned instead of that.
3645 If due to error, args are `error' and a list of the args to `signal'.
3646 If due to `apply' or `funcall' entry, one arg, `lambda'.
3647 If due to `eval' entry, one arg, t. */);
3650 DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function
,
3651 doc
: /* If non-nil, this is a function for `signal' to call.
3652 It receives the same arguments that `signal' was given.
3653 The Edebug package uses this to regain control. */);
3654 Vsignal_hook_function
= Qnil
;
3656 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal
,
3657 doc
: /* *Non-nil means call the debugger regardless of condition handlers.
3658 Note that `debug-on-error', `debug-on-quit' and friends
3659 still determine whether to handle the particular condition. */);
3660 Vdebug_on_signal
= Qnil
;
3662 DEFVAR_LISP ("macro-declaration-function", &Vmacro_declaration_function
,
3663 doc
: /* Function to process declarations in a macro definition.
3664 The function will be called with two args MACRO and DECL.
3665 MACRO is the name of the macro being defined.
3666 DECL is a list `(declare ...)' containing the declarations.
3667 The value the function returns is not used. */);
3668 Vmacro_declaration_function
= Qnil
;
3670 Vrun_hooks
= intern ("run-hooks");
3671 staticpro (&Vrun_hooks
);
3673 staticpro (&Vautoload_queue
);
3674 Vautoload_queue
= Qnil
;
3675 staticpro (&Vsignaling_function
);
3676 Vsignaling_function
= Qnil
;
3687 defsubr (&Sfunction
);
3689 defsubr (&Sdefmacro
);
3691 defsubr (&Sdefvaralias
);
3692 defsubr (&Sdefconst
);
3693 defsubr (&Suser_variable_p
);
3697 defsubr (&Smacroexpand
);
3700 defsubr (&Sunwind_protect
);
3701 defsubr (&Scondition_case
);
3703 defsubr (&Sinteractive_p
);
3704 defsubr (&Scalled_interactively_p
);
3705 defsubr (&Scommandp
);
3706 defsubr (&Sautoload
);
3709 defsubr (&Sfuncall
);
3710 defsubr (&Srun_hooks
);
3711 defsubr (&Srun_hook_with_args
);
3712 defsubr (&Srun_hook_with_args_until_success
);
3713 defsubr (&Srun_hook_with_args_until_failure
);
3714 defsubr (&Sfetch_bytecode
);
3715 defsubr (&Sbacktrace_debug
);
3716 defsubr (&Sbacktrace
);
3717 defsubr (&Sbacktrace_frame
);
3720 /* arch-tag: 014a07aa-33ab-4a8f-a3d2-ee8a4a9ff7fb
3721 (do not change this comment) */