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"
35 /* This definition is duplicated in alloc.c and keyboard.c */
36 /* Putting it in lisp.h makes cc bomb out! */
40 struct backtrace
*next
;
41 Lisp_Object
*function
;
42 Lisp_Object
*args
; /* Points to vector of args. */
43 int nargs
; /* Length of vector.
44 If nargs is UNEVALLED, args points to slot holding
45 list of unevalled args */
47 /* Nonzero means call value of debugger when done with this operation. */
51 struct backtrace
*backtrace_list
;
53 /* This structure helps implement the `catch' and `throw' control
54 structure. A struct catchtag contains all the information needed
55 to restore the state of the interpreter after a non-local jump.
57 Handlers for error conditions (represented by `struct handler'
58 structures) just point to a catch tag to do the cleanup required
61 catchtag structures are chained together in the C calling stack;
62 the `next' member points to the next outer catchtag.
64 A call like (throw TAG VAL) searches for a catchtag whose `tag'
65 member is TAG, and then unbinds to it. The `val' member is used to
66 hold VAL while the stack is unwound; `val' is returned as the value
69 All the other members are concerned with restoring the interpreter
76 struct catchtag
*next
;
79 struct backtrace
*backlist
;
80 struct handler
*handlerlist
;
83 int poll_suppress_count
;
84 int interrupt_input_blocked
;
85 struct byte_stack
*byte_stack
;
88 struct catchtag
*catchlist
;
91 /* Count levels of GCPRO to detect failure to UNGCPRO. */
95 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
96 Lisp_Object Qinhibit_quit
, Vinhibit_quit
, Vquit_flag
;
97 Lisp_Object Qand_rest
, Qand_optional
;
98 Lisp_Object Qdebug_on_error
;
101 /* This holds either the symbol `run-hooks' or nil.
102 It is nil at an early stage of startup, and when Emacs
105 Lisp_Object Vrun_hooks
;
107 /* Non-nil means record all fset's and provide's, to be undone
108 if the file being autoloaded is not fully loaded.
109 They are recorded by being consed onto the front of Vautoload_queue:
110 (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide. */
112 Lisp_Object Vautoload_queue
;
114 /* Current number of specbindings allocated in specpdl. */
118 /* Pointer to beginning of specpdl. */
120 struct specbinding
*specpdl
;
122 /* Pointer to first unused element in specpdl. */
124 struct specbinding
*specpdl_ptr
;
126 /* Maximum size allowed for specpdl allocation */
128 EMACS_INT max_specpdl_size
;
130 /* Depth in Lisp evaluations and function calls. */
134 /* Maximum allowed depth in Lisp evaluations and function calls. */
136 EMACS_INT max_lisp_eval_depth
;
138 /* Nonzero means enter debugger before next function call */
140 int debug_on_next_call
;
142 /* Non-zero means debugger may continue. This is zero when the
143 debugger is called during redisplay, where it might not be safe to
144 continue the interrupted redisplay. */
146 int debugger_may_continue
;
148 /* List of conditions (non-nil atom means all) which cause a backtrace
149 if an error is handled by the command loop's error handler. */
151 Lisp_Object Vstack_trace_on_error
;
153 /* List of conditions (non-nil atom means all) which enter the debugger
154 if an error is handled by the command loop's error handler. */
156 Lisp_Object Vdebug_on_error
;
158 /* List of conditions and regexps specifying error messages which
159 do not enter the debugger even if Vdebug_on_error says they should. */
161 Lisp_Object Vdebug_ignored_errors
;
163 /* Non-nil means call the debugger even if the error will be handled. */
165 Lisp_Object Vdebug_on_signal
;
167 /* Hook for edebug to use. */
169 Lisp_Object Vsignal_hook_function
;
171 /* Nonzero means enter debugger if a quit signal
172 is handled by the command loop's error handler. */
176 /* The value of num_nonmacro_input_events as of the last time we
177 started to enter the debugger. If we decide to enter the debugger
178 again when this is still equal to num_nonmacro_input_events, then we
179 know that the debugger itself has an error, and we should just
180 signal the error instead of entering an infinite loop of debugger
183 int when_entered_debugger
;
185 Lisp_Object Vdebugger
;
187 /* The function from which the last `signal' was called. Set in
190 Lisp_Object Vsignaling_function
;
192 /* Set to non-zero while processing X events. Checked in Feval to
193 make sure the Lisp interpreter isn't called from a signal handler,
194 which is unsafe because the interpreter isn't reentrant. */
198 /* Function to process declarations in defmacro forms. */
200 Lisp_Object Vmacro_declaration_function
;
202 extern Lisp_Object Qrisky_local_variable
;
204 static Lisp_Object funcall_lambda
P_ ((Lisp_Object
, int, Lisp_Object
*));
205 static void unwind_to_catch
P_ ((struct catchtag
*, Lisp_Object
)) NO_RETURN
;
208 /* "gcc -O3" enables automatic function inlining, which optimizes out
209 the arguments for the invocations of these functions, whereas they
210 expect these values on the stack. */
211 Lisp_Object
apply1 () __attribute__((noinline
));
212 Lisp_Object
call2 () __attribute__((noinline
));
219 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
220 specpdl_ptr
= specpdl
;
221 /* Don't forget to update docs (lispref node "Local Variables"). */
222 max_specpdl_size
= 1000;
223 max_lisp_eval_depth
= 300;
231 specpdl_ptr
= specpdl
;
236 debug_on_next_call
= 0;
241 /* This is less than the initial value of num_nonmacro_input_events. */
242 when_entered_debugger
= -1;
245 /* unwind-protect function used by call_debugger. */
248 restore_stack_limits (data
)
251 max_specpdl_size
= XINT (XCAR (data
));
252 max_lisp_eval_depth
= XINT (XCDR (data
));
256 /* Call the Lisp debugger, giving it argument ARG. */
262 int debug_while_redisplaying
;
263 int count
= SPECPDL_INDEX ();
265 int old_max
= max_specpdl_size
;
267 /* Temporarily bump up the stack limits,
268 so the debugger won't run out of stack. */
270 max_specpdl_size
+= 1;
271 record_unwind_protect (restore_stack_limits
,
272 Fcons (make_number (old_max
),
273 make_number (max_lisp_eval_depth
)));
274 max_specpdl_size
= old_max
;
276 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
277 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
279 if (SPECPDL_INDEX () + 100 > max_specpdl_size
)
280 max_specpdl_size
= SPECPDL_INDEX () + 100;
282 #ifdef HAVE_X_WINDOWS
283 if (display_hourglass_p
)
287 debug_on_next_call
= 0;
288 when_entered_debugger
= num_nonmacro_input_events
;
290 /* Resetting redisplaying_p to 0 makes sure that debug output is
291 displayed if the debugger is invoked during redisplay. */
292 debug_while_redisplaying
= redisplaying_p
;
294 specbind (intern ("debugger-may-continue"),
295 debug_while_redisplaying
? Qnil
: Qt
);
296 specbind (Qinhibit_redisplay
, Qnil
);
297 specbind (Qdebug_on_error
, Qnil
);
299 #if 0 /* Binding this prevents execution of Lisp code during
300 redisplay, which necessarily leads to display problems. */
301 specbind (Qinhibit_eval_during_redisplay
, Qt
);
304 val
= apply1 (Vdebugger
, arg
);
306 /* Interrupting redisplay and resuming it later is not safe under
307 all circumstances. So, when the debugger returns, abort the
308 interrupted redisplay by going back to the top-level. */
309 if (debug_while_redisplaying
)
312 return unbind_to (count
, val
);
316 do_debug_on_call (code
)
319 debug_on_next_call
= 0;
320 backtrace_list
->debug_on_exit
= 1;
321 call_debugger (Fcons (code
, Qnil
));
324 /* NOTE!!! Every function that can call EVAL must protect its args
325 and temporaries from garbage collection while it needs them.
326 The definition of `For' shows what you have to do. */
328 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
329 doc
: /* Eval args until one of them yields non-nil, then return that value.
330 The remaining args are not evalled at all.
331 If all args return nil, return nil.
332 usage: (or CONDITIONS ...) */)
336 register Lisp_Object val
= Qnil
;
343 val
= Feval (XCAR (args
));
353 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
354 doc
: /* Eval args until one of them yields nil, then return nil.
355 The remaining args are not evalled at all.
356 If no arg yields nil, return the last arg's value.
357 usage: (and CONDITIONS ...) */)
361 register Lisp_Object val
= Qt
;
368 val
= Feval (XCAR (args
));
378 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
379 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
380 Returns the value of THEN or the value of the last of the ELSE's.
381 THEN must be one expression, but ELSE... can be zero or more expressions.
382 If COND yields nil, and there are no ELSE's, the value is nil.
383 usage: (if COND THEN ELSE...) */)
387 register Lisp_Object cond
;
391 cond
= Feval (Fcar (args
));
395 return Feval (Fcar (Fcdr (args
)));
396 return Fprogn (Fcdr (Fcdr (args
)));
399 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
400 doc
: /* Try each clause until one succeeds.
401 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
402 and, if the value is non-nil, this clause succeeds:
403 then the expressions in BODY are evaluated and the last one's
404 value is the value of the cond-form.
405 If no clause succeeds, cond returns nil.
406 If a clause has one element, as in (CONDITION),
407 CONDITION's value if non-nil is returned from the cond-form.
408 usage: (cond CLAUSES...) */)
412 register Lisp_Object clause
, val
;
419 clause
= Fcar (args
);
420 val
= Feval (Fcar (clause
));
423 if (!EQ (XCDR (clause
), Qnil
))
424 val
= Fprogn (XCDR (clause
));
434 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
435 doc
: /* Eval BODY forms sequentially and return value of last one.
436 usage: (progn BODY ...) */)
440 register Lisp_Object val
= Qnil
;
447 val
= Feval (XCAR (args
));
455 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
456 doc
: /* Eval FIRST and BODY sequentially; value from FIRST.
457 The value of FIRST is saved during the evaluation of the remaining args,
458 whose values are discarded.
459 usage: (prog1 FIRST BODY...) */)
464 register Lisp_Object args_left
;
465 struct gcpro gcpro1
, gcpro2
;
466 register int argnum
= 0;
478 val
= Feval (Fcar (args_left
));
480 Feval (Fcar (args_left
));
481 args_left
= Fcdr (args_left
);
483 while (!NILP(args_left
));
489 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
490 doc
: /* Eval FORM1, FORM2 and BODY sequentially; value from FORM2.
491 The value of FORM2 is saved during the evaluation of the
492 remaining args, whose values are discarded.
493 usage: (prog2 FORM1 FORM2 BODY...) */)
498 register Lisp_Object args_left
;
499 struct gcpro gcpro1
, gcpro2
;
500 register int argnum
= -1;
514 val
= Feval (Fcar (args_left
));
516 Feval (Fcar (args_left
));
517 args_left
= Fcdr (args_left
);
519 while (!NILP (args_left
));
525 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
526 doc
: /* Set each SYM to the value of its VAL.
527 The symbols SYM are variables; they are literal (not evaluated).
528 The values VAL are expressions; they are evaluated.
529 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
530 The second VAL is not computed until after the first SYM is set, and so on;
531 each VAL can use the new value of variables set earlier in the `setq'.
532 The return value of the `setq' form is the value of the last VAL.
533 usage: (setq SYM VAL SYM VAL ...) */)
537 register Lisp_Object args_left
;
538 register Lisp_Object val
, sym
;
549 val
= Feval (Fcar (Fcdr (args_left
)));
550 sym
= Fcar (args_left
);
552 args_left
= Fcdr (Fcdr (args_left
));
554 while (!NILP(args_left
));
560 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
561 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
562 usage: (quote ARG) */)
569 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
570 doc
: /* Like `quote', but preferred for objects which are functions.
571 In byte compilation, `function' causes its argument to be compiled.
572 `quote' cannot do that.
573 usage: (function ARG) */)
581 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
582 doc
: /* Return t if the function was run directly by user input.
583 This means that the function was called with `call-interactively'
584 \(which includes being called as the binding of a key)
585 and input is currently coming from the keyboard (not in keyboard macro),
586 and Emacs is not running in batch mode (`noninteractive' is nil).
588 The only known proper use of `interactive-p' is in deciding whether to
589 display a helpful message, or how to display it. If you're thinking
590 of using it for any other purpose, it is quite likely that you're
591 making a mistake. Think: what do you want to do when the command is
592 called from a keyboard macro?
594 If you want to test whether your function was called with
595 `call-interactively', the way to do that is by adding an extra
596 optional argument, and making the `interactive' spec specify non-nil
597 unconditionally for that argument. (`p' is a good way to do this.) */)
600 return (INTERACTIVE
&& interactive_p (1)) ? Qt
: Qnil
;
604 DEFUN ("called-interactively-p", Fcalled_interactively_p
, Scalled_interactively_p
, 0, 0, 0,
605 doc
: /* Return t if the function using this was called with `call-interactively'.
606 This is used for implementing advice and other function-modifying
609 The cleanest way to test whether your function was called with
610 `call-interactively' is by adding an extra optional argument,
611 and making the `interactive' spec specify non-nil unconditionally
612 for that argument. (`p' is a good way to do this.) */)
615 return interactive_p (1) ? Qt
: Qnil
;
619 /* Return 1 if function in which this appears was called using
622 EXCLUDE_SUBRS_P non-zero means always return 0 if the function
623 called is a built-in. */
626 interactive_p (exclude_subrs_p
)
629 struct backtrace
*btp
;
632 btp
= backtrace_list
;
634 /* If this isn't a byte-compiled function, there may be a frame at
635 the top for Finteractive_p. If so, skip it. */
636 fun
= Findirect_function (*btp
->function
, Qnil
);
637 if (SUBRP (fun
) && (XSUBR (fun
) == &Sinteractive_p
638 || XSUBR (fun
) == &Scalled_interactively_p
))
641 /* If we're running an Emacs 18-style byte-compiled function, there
642 may be a frame for Fbytecode at the top level. In any version of
643 Emacs there can be Fbytecode frames for subexpressions evaluated
644 inside catch and condition-case. Skip past them.
646 If this isn't a byte-compiled function, then we may now be
647 looking at several frames for special forms. Skip past them. */
649 && (EQ (*btp
->function
, Qbytecode
)
650 || btp
->nargs
== UNEVALLED
))
653 /* btp now points at the frame of the innermost function that isn't
654 a special form, ignoring frames for Finteractive_p and/or
655 Fbytecode at the top. If this frame is for a built-in function
656 (such as load or eval-region) return nil. */
657 fun
= Findirect_function (*btp
->function
, Qnil
);
658 if (exclude_subrs_p
&& SUBRP (fun
))
661 /* btp points to the frame of a Lisp function that called interactive-p.
662 Return t if that function was called interactively. */
663 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
669 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
670 doc
: /* Define NAME as a function.
671 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
672 See also the function `interactive'.
673 usage: (defun NAME ARGLIST [DOCSTRING] BODY...) */)
677 register Lisp_Object fn_name
;
678 register Lisp_Object defn
;
680 fn_name
= Fcar (args
);
681 CHECK_SYMBOL (fn_name
);
682 defn
= Fcons (Qlambda
, Fcdr (args
));
683 if (!NILP (Vpurify_flag
))
684 defn
= Fpurecopy (defn
);
685 if (CONSP (XSYMBOL (fn_name
)->function
)
686 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
687 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
688 Ffset (fn_name
, defn
);
689 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
693 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
694 doc
: /* Define NAME as a macro.
695 The actual definition looks like
696 (macro lambda ARGLIST [DOCSTRING] [DECL] BODY...).
697 When the macro is called, as in (NAME ARGS...),
698 the function (lambda ARGLIST BODY...) is applied to
699 the list ARGS... as it appears in the expression,
700 and the result should be a form to be evaluated instead of the original.
702 DECL is a declaration, optional, which can specify how to indent
703 calls to this macro and how Edebug should handle it. It looks like this:
705 The elements can look like this:
707 Set NAME's `lisp-indent-function' property to INDENT.
710 Set NAME's `edebug-form-spec' property to DEBUG. (This is
711 equivalent to writing a `def-edebug-spec' for the macro.)
712 usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */)
716 register Lisp_Object fn_name
;
717 register Lisp_Object defn
;
718 Lisp_Object lambda_list
, doc
, tail
;
720 fn_name
= Fcar (args
);
721 CHECK_SYMBOL (fn_name
);
722 lambda_list
= Fcar (Fcdr (args
));
723 tail
= Fcdr (Fcdr (args
));
726 if (STRINGP (Fcar (tail
)))
732 while (CONSP (Fcar (tail
))
733 && EQ (Fcar (Fcar (tail
)), Qdeclare
))
735 if (!NILP (Vmacro_declaration_function
))
739 call2 (Vmacro_declaration_function
, fn_name
, Fcar (tail
));
747 tail
= Fcons (lambda_list
, tail
);
749 tail
= Fcons (lambda_list
, Fcons (doc
, tail
));
750 defn
= Fcons (Qmacro
, Fcons (Qlambda
, tail
));
752 if (!NILP (Vpurify_flag
))
753 defn
= Fpurecopy (defn
);
754 if (CONSP (XSYMBOL (fn_name
)->function
)
755 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
756 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
757 Ffset (fn_name
, defn
);
758 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
763 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
764 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
765 Aliased variables always have the same value; setting one sets the other.
766 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
767 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
768 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
770 The return value is BASE-VARIABLE. */)
771 (new_alias
, base_variable
, docstring
)
772 Lisp_Object new_alias
, base_variable
, docstring
;
774 struct Lisp_Symbol
*sym
;
776 CHECK_SYMBOL (new_alias
);
777 CHECK_SYMBOL (base_variable
);
779 if (SYMBOL_CONSTANT_P (new_alias
))
780 error ("Cannot make a constant an alias");
782 sym
= XSYMBOL (new_alias
);
783 sym
->indirect_variable
= 1;
784 sym
->value
= base_variable
;
785 sym
->constant
= SYMBOL_CONSTANT_P (base_variable
);
786 LOADHIST_ATTACH (new_alias
);
787 if (!NILP (docstring
))
788 Fput (new_alias
, Qvariable_documentation
, docstring
);
790 Fput (new_alias
, Qvariable_documentation
, Qnil
);
792 return base_variable
;
796 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
797 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
798 You are not required to define a variable in order to use it,
799 but the definition can supply documentation and an initial value
800 in a way that tags can recognize.
802 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.
803 If SYMBOL is buffer-local, its default value is what is set;
804 buffer-local values are not affected.
805 INITVALUE and DOCSTRING are optional.
806 If DOCSTRING starts with *, this variable is identified as a user option.
807 This means that M-x set-variable recognizes it.
808 See also `user-variable-p'.
809 If INITVALUE is missing, SYMBOL's value is not set.
811 If SYMBOL has a local binding, then this form affects the local
812 binding. This is usually not what you want. Thus, if you need to
813 load a file defining variables, with this form or with `defconst' or
814 `defcustom', you should always load that file _outside_ any bindings
815 for these variables. \(`defconst' and `defcustom' behave similarly in
817 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
821 register Lisp_Object sym
, tem
, tail
;
825 if (!NILP (Fcdr (Fcdr (tail
))))
826 error ("Too many arguments");
828 tem
= Fdefault_boundp (sym
);
831 if (SYMBOL_CONSTANT_P (sym
))
833 /* For upward compatibility, allow (defvar :foo (quote :foo)). */
834 Lisp_Object tem
= Fcar (tail
);
836 && EQ (XCAR (tem
), Qquote
)
837 && CONSP (XCDR (tem
))
838 && EQ (XCAR (XCDR (tem
)), sym
)))
839 error ("Constant symbol `%s' specified in defvar",
840 SDATA (SYMBOL_NAME (sym
)));
844 Fset_default (sym
, Feval (Fcar (tail
)));
846 { /* Check if there is really a global binding rather than just a let
847 binding that shadows the global unboundness of the var. */
848 volatile struct specbinding
*pdl
= specpdl_ptr
;
849 while (--pdl
>= specpdl
)
851 if (EQ (pdl
->symbol
, sym
) && !pdl
->func
852 && EQ (pdl
->old_value
, Qunbound
))
854 message_with_string ("Warning: defvar ignored because %s is let-bound",
855 SYMBOL_NAME (sym
), 1);
864 if (!NILP (Vpurify_flag
))
865 tem
= Fpurecopy (tem
);
866 Fput (sym
, Qvariable_documentation
, tem
);
868 LOADHIST_ATTACH (sym
);
871 /* Simple (defvar <var>) should not count as a definition at all.
872 It could get in the way of other definitions, and unloading this
873 package could try to make the variable unbound. */
879 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
880 doc
: /* Define SYMBOL as a constant variable.
881 The intent is that neither programs nor users should ever change this value.
882 Always sets the value of SYMBOL to the result of evalling INITVALUE.
883 If SYMBOL is buffer-local, its default value is what is set;
884 buffer-local values are not affected.
885 DOCSTRING is optional.
887 If SYMBOL has a local binding, then this form sets the local binding's
888 value. However, you should normally not make local bindings for
889 variables defined with this form.
890 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
894 register Lisp_Object sym
, tem
;
897 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
898 error ("Too many arguments");
900 tem
= Feval (Fcar (Fcdr (args
)));
901 if (!NILP (Vpurify_flag
))
902 tem
= Fpurecopy (tem
);
903 Fset_default (sym
, tem
);
904 tem
= Fcar (Fcdr (Fcdr (args
)));
907 if (!NILP (Vpurify_flag
))
908 tem
= Fpurecopy (tem
);
909 Fput (sym
, Qvariable_documentation
, tem
);
911 Fput (sym
, Qrisky_local_variable
, Qt
);
912 LOADHIST_ATTACH (sym
);
916 /* Error handler used in Fuser_variable_p. */
918 user_variable_p_eh (ignore
)
924 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
925 doc
: /* Return t if VARIABLE is intended to be set and modified by users.
926 \(The alternative is a variable used internally in a Lisp program.)
927 A variable is a user variable if
928 \(1) the first character of its documentation is `*', or
929 \(2) it is customizable (its property list contains a non-nil value
930 of `standard-value' or `custom-autoload'), or
931 \(3) it is an alias for another user variable.
932 Return nil if VARIABLE is an alias and there is a loop in the
933 chain of symbols. */)
935 Lisp_Object variable
;
937 Lisp_Object documentation
;
939 if (!SYMBOLP (variable
))
942 /* If indirect and there's an alias loop, don't check anything else. */
943 if (XSYMBOL (variable
)->indirect_variable
944 && NILP (internal_condition_case_1 (indirect_variable
, variable
,
945 Qt
, user_variable_p_eh
)))
950 documentation
= Fget (variable
, Qvariable_documentation
);
951 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
953 if (STRINGP (documentation
)
954 && ((unsigned char) SREF (documentation
, 0) == '*'))
956 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
957 if (CONSP (documentation
)
958 && STRINGP (XCAR (documentation
))
959 && INTEGERP (XCDR (documentation
))
960 && XINT (XCDR (documentation
)) < 0)
962 /* Customizable? See `custom-variable-p'. */
963 if ((!NILP (Fget (variable
, intern ("standard-value"))))
964 || (!NILP (Fget (variable
, intern ("custom-autoload")))))
967 if (!XSYMBOL (variable
)->indirect_variable
)
970 /* An indirect variable? Let's follow the chain. */
971 variable
= XSYMBOL (variable
)->value
;
975 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
976 doc
: /* Bind variables according to VARLIST then eval BODY.
977 The value of the last form in BODY is returned.
978 Each element of VARLIST is a symbol (which is bound to nil)
979 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
980 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
981 usage: (let* VARLIST BODY...) */)
985 Lisp_Object varlist
, val
, elt
;
986 int count
= SPECPDL_INDEX ();
987 struct gcpro gcpro1
, gcpro2
, gcpro3
;
989 GCPRO3 (args
, elt
, varlist
);
991 varlist
= Fcar (args
);
992 while (!NILP (varlist
))
995 elt
= Fcar (varlist
);
997 specbind (elt
, Qnil
);
998 else if (! NILP (Fcdr (Fcdr (elt
))))
999 signal_error ("`let' bindings can have only one value-form", elt
);
1002 val
= Feval (Fcar (Fcdr (elt
)));
1003 specbind (Fcar (elt
), val
);
1005 varlist
= Fcdr (varlist
);
1008 val
= Fprogn (Fcdr (args
));
1009 return unbind_to (count
, val
);
1012 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
1013 doc
: /* Bind variables according to VARLIST then eval BODY.
1014 The value of the last form in BODY is returned.
1015 Each element of VARLIST is a symbol (which is bound to nil)
1016 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
1017 All the VALUEFORMs are evalled before any symbols are bound.
1018 usage: (let VARLIST BODY...) */)
1022 Lisp_Object
*temps
, tem
;
1023 register Lisp_Object elt
, varlist
;
1024 int count
= SPECPDL_INDEX ();
1025 register int argnum
;
1026 struct gcpro gcpro1
, gcpro2
;
1028 varlist
= Fcar (args
);
1030 /* Make space to hold the values to give the bound variables */
1031 elt
= Flength (varlist
);
1032 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
1034 /* Compute the values and store them in `temps' */
1036 GCPRO2 (args
, *temps
);
1039 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
1042 elt
= Fcar (varlist
);
1044 temps
[argnum
++] = Qnil
;
1045 else if (! NILP (Fcdr (Fcdr (elt
))))
1046 signal_error ("`let' bindings can have only one value-form", elt
);
1048 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
1049 gcpro2
.nvars
= argnum
;
1053 varlist
= Fcar (args
);
1054 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
1056 elt
= Fcar (varlist
);
1057 tem
= temps
[argnum
++];
1059 specbind (elt
, tem
);
1061 specbind (Fcar (elt
), tem
);
1064 elt
= Fprogn (Fcdr (args
));
1065 return unbind_to (count
, elt
);
1068 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
1069 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
1070 The order of execution is thus TEST, BODY, TEST, BODY and so on
1071 until TEST returns nil.
1072 usage: (while TEST BODY...) */)
1076 Lisp_Object test
, body
;
1077 struct gcpro gcpro1
, gcpro2
;
1079 GCPRO2 (test
, body
);
1083 while (!NILP (Feval (test
)))
1093 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
1094 doc
: /* Return result of expanding macros at top level of FORM.
1095 If FORM is not a macro call, it is returned unchanged.
1096 Otherwise, the macro is expanded and the expansion is considered
1097 in place of FORM. When a non-macro-call results, it is returned.
1099 The second optional arg ENVIRONMENT specifies an environment of macro
1100 definitions to shadow the loaded ones for use in file byte-compilation. */)
1103 Lisp_Object environment
;
1105 /* With cleanups from Hallvard Furuseth. */
1106 register Lisp_Object expander
, sym
, def
, tem
;
1110 /* Come back here each time we expand a macro call,
1111 in case it expands into another macro call. */
1114 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1115 def
= sym
= XCAR (form
);
1117 /* Trace symbols aliases to other symbols
1118 until we get a symbol that is not an alias. */
1119 while (SYMBOLP (def
))
1123 tem
= Fassq (sym
, environment
);
1126 def
= XSYMBOL (sym
)->function
;
1127 if (!EQ (def
, Qunbound
))
1132 /* Right now TEM is the result from SYM in ENVIRONMENT,
1133 and if TEM is nil then DEF is SYM's function definition. */
1136 /* SYM is not mentioned in ENVIRONMENT.
1137 Look at its function definition. */
1138 if (EQ (def
, Qunbound
) || !CONSP (def
))
1139 /* Not defined or definition not suitable */
1141 if (EQ (XCAR (def
), Qautoload
))
1143 /* Autoloading function: will it be a macro when loaded? */
1144 tem
= Fnth (make_number (4), def
);
1145 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
1146 /* Yes, load it and try again. */
1148 struct gcpro gcpro1
;
1150 do_autoload (def
, sym
);
1157 else if (!EQ (XCAR (def
), Qmacro
))
1159 else expander
= XCDR (def
);
1163 expander
= XCDR (tem
);
1164 if (NILP (expander
))
1167 form
= apply1 (expander
, XCDR (form
));
1172 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1173 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1174 TAG is evalled to get the tag to use; it must not be nil.
1176 Then the BODY is executed.
1177 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.
1178 If no throw happens, `catch' returns the value of the last BODY form.
1179 If a throw happens, it specifies the value to return from `catch'.
1180 usage: (catch TAG BODY...) */)
1184 register Lisp_Object tag
;
1185 struct gcpro gcpro1
;
1188 tag
= Feval (Fcar (args
));
1190 return internal_catch (tag
, Fprogn
, Fcdr (args
));
1193 /* Set up a catch, then call C function FUNC on argument ARG.
1194 FUNC should return a Lisp_Object.
1195 This is how catches are done from within C code. */
1198 internal_catch (tag
, func
, arg
)
1200 Lisp_Object (*func
) ();
1203 /* This structure is made part of the chain `catchlist'. */
1206 /* Fill in the components of c, and put it on the list. */
1210 c
.backlist
= backtrace_list
;
1211 c
.handlerlist
= handlerlist
;
1212 c
.lisp_eval_depth
= lisp_eval_depth
;
1213 c
.pdlcount
= SPECPDL_INDEX ();
1214 c
.poll_suppress_count
= poll_suppress_count
;
1215 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1216 c
.gcpro
= gcprolist
;
1217 c
.byte_stack
= byte_stack_list
;
1221 if (! _setjmp (c
.jmp
))
1222 c
.val
= (*func
) (arg
);
1224 /* Throw works by a longjmp that comes right here. */
1229 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1230 jump to that CATCH, returning VALUE as the value of that catch.
1232 This is the guts Fthrow and Fsignal; they differ only in the way
1233 they choose the catch tag to throw to. A catch tag for a
1234 condition-case form has a TAG of Qnil.
1236 Before each catch is discarded, unbind all special bindings and
1237 execute all unwind-protect clauses made above that catch. Unwind
1238 the handler stack as we go, so that the proper handlers are in
1239 effect for each unwind-protect clause we run. At the end, restore
1240 some static info saved in CATCH, and longjmp to the location
1243 This is used for correct unwinding in Fthrow and Fsignal. */
1246 unwind_to_catch (catch, value
)
1247 struct catchtag
*catch;
1250 register int last_time
;
1252 /* Save the value in the tag. */
1255 /* Restore certain special C variables. */
1256 set_poll_suppress_count (catch->poll_suppress_count
);
1257 UNBLOCK_INPUT_TO (catch->interrupt_input_blocked
);
1258 handling_signal
= 0;
1263 last_time
= catchlist
== catch;
1265 /* Unwind the specpdl stack, and then restore the proper set of
1267 unbind_to (catchlist
->pdlcount
, Qnil
);
1268 handlerlist
= catchlist
->handlerlist
;
1269 catchlist
= catchlist
->next
;
1271 while (! last_time
);
1274 /* If x_catch_errors was done, turn it off now.
1275 (First we give unbind_to a chance to do that.) */
1276 x_fully_uncatch_errors ();
1279 byte_stack_list
= catch->byte_stack
;
1280 gcprolist
= catch->gcpro
;
1283 gcpro_level
= gcprolist
->level
+ 1;
1287 backtrace_list
= catch->backlist
;
1288 lisp_eval_depth
= catch->lisp_eval_depth
;
1290 _longjmp (catch->jmp
, 1);
1293 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1294 doc
: /* Throw to the catch for TAG and return VALUE from it.
1295 Both TAG and VALUE are evalled. */)
1297 register Lisp_Object tag
, value
;
1299 register struct catchtag
*c
;
1302 for (c
= catchlist
; c
; c
= c
->next
)
1304 if (EQ (c
->tag
, tag
))
1305 unwind_to_catch (c
, value
);
1307 xsignal2 (Qno_catch
, tag
, value
);
1311 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1312 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1313 If BODYFORM completes normally, its value is returned
1314 after executing the UNWINDFORMS.
1315 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1316 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1321 int count
= SPECPDL_INDEX ();
1323 record_unwind_protect (Fprogn
, Fcdr (args
));
1324 val
= Feval (Fcar (args
));
1325 return unbind_to (count
, val
);
1328 /* Chain of condition handlers currently in effect.
1329 The elements of this chain are contained in the stack frames
1330 of Fcondition_case and internal_condition_case.
1331 When an error is signaled (by calling Fsignal, below),
1332 this chain is searched for an element that applies. */
1334 struct handler
*handlerlist
;
1336 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1337 doc
: /* Regain control when an error is signaled.
1338 Executes BODYFORM and returns its value if no error happens.
1339 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1340 where the BODY is made of Lisp expressions.
1342 A handler is applicable to an error
1343 if CONDITION-NAME is one of the error's condition names.
1344 If an error happens, the first applicable handler is run.
1346 The car of a handler may be a list of condition names
1347 instead of a single condition name.
1349 When a handler handles an error,
1350 control returns to the condition-case and the handler BODY... is executed
1351 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).
1352 VAR may be nil; then you do not get access to the signal information.
1354 The value of the last BODY form is returned from the condition-case.
1355 See also the function `signal' for more info.
1356 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1360 register Lisp_Object bodyform
, handlers
;
1361 volatile Lisp_Object var
;
1364 bodyform
= Fcar (Fcdr (args
));
1365 handlers
= Fcdr (Fcdr (args
));
1367 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1370 /* Like Fcondition_case, but the args are separate
1371 rather than passed in a list. Used by Fbyte_code. */
1374 internal_lisp_condition_case (var
, bodyform
, handlers
)
1375 volatile Lisp_Object var
;
1376 Lisp_Object bodyform
, handlers
;
1384 for (val
= handlers
; CONSP (val
); val
= XCDR (val
))
1390 && (SYMBOLP (XCAR (tem
))
1391 || CONSP (XCAR (tem
))))))
1392 error ("Invalid condition handler", tem
);
1397 c
.backlist
= backtrace_list
;
1398 c
.handlerlist
= handlerlist
;
1399 c
.lisp_eval_depth
= lisp_eval_depth
;
1400 c
.pdlcount
= SPECPDL_INDEX ();
1401 c
.poll_suppress_count
= poll_suppress_count
;
1402 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1403 c
.gcpro
= gcprolist
;
1404 c
.byte_stack
= byte_stack_list
;
1405 if (_setjmp (c
.jmp
))
1408 specbind (h
.var
, c
.val
);
1409 val
= Fprogn (Fcdr (h
.chosen_clause
));
1411 /* Note that this just undoes the binding of h.var; whoever
1412 longjumped to us unwound the stack to c.pdlcount before
1414 unbind_to (c
.pdlcount
, Qnil
);
1421 h
.handler
= handlers
;
1422 h
.next
= handlerlist
;
1426 val
= Feval (bodyform
);
1428 handlerlist
= h
.next
;
1432 /* Call the function BFUN with no arguments, catching errors within it
1433 according to HANDLERS. If there is an error, call HFUN with
1434 one argument which is the data that describes the error:
1437 HANDLERS can be a list of conditions to catch.
1438 If HANDLERS is Qt, catch all errors.
1439 If HANDLERS is Qerror, catch all errors
1440 but allow the debugger to run if that is enabled. */
1443 internal_condition_case (bfun
, handlers
, hfun
)
1444 Lisp_Object (*bfun
) ();
1445 Lisp_Object handlers
;
1446 Lisp_Object (*hfun
) ();
1452 /* Since Fsignal will close off all calls to x_catch_errors,
1453 we will get the wrong results if some are not closed now. */
1455 if (x_catching_errors ())
1461 c
.backlist
= backtrace_list
;
1462 c
.handlerlist
= handlerlist
;
1463 c
.lisp_eval_depth
= lisp_eval_depth
;
1464 c
.pdlcount
= SPECPDL_INDEX ();
1465 c
.poll_suppress_count
= poll_suppress_count
;
1466 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1467 c
.gcpro
= gcprolist
;
1468 c
.byte_stack
= byte_stack_list
;
1469 if (_setjmp (c
.jmp
))
1471 return (*hfun
) (c
.val
);
1475 h
.handler
= handlers
;
1477 h
.next
= handlerlist
;
1483 handlerlist
= h
.next
;
1487 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1490 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1491 Lisp_Object (*bfun
) ();
1493 Lisp_Object handlers
;
1494 Lisp_Object (*hfun
) ();
1500 /* Since Fsignal will close off all calls to x_catch_errors,
1501 we will get the wrong results if some are not closed now. */
1503 if (x_catching_errors ())
1509 c
.backlist
= backtrace_list
;
1510 c
.handlerlist
= handlerlist
;
1511 c
.lisp_eval_depth
= lisp_eval_depth
;
1512 c
.pdlcount
= SPECPDL_INDEX ();
1513 c
.poll_suppress_count
= poll_suppress_count
;
1514 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1515 c
.gcpro
= gcprolist
;
1516 c
.byte_stack
= byte_stack_list
;
1517 if (_setjmp (c
.jmp
))
1519 return (*hfun
) (c
.val
);
1523 h
.handler
= handlers
;
1525 h
.next
= handlerlist
;
1529 val
= (*bfun
) (arg
);
1531 handlerlist
= h
.next
;
1536 /* Like internal_condition_case but call BFUN with NARGS as first,
1537 and ARGS as second argument. */
1540 internal_condition_case_2 (bfun
, nargs
, args
, handlers
, hfun
)
1541 Lisp_Object (*bfun
) ();
1544 Lisp_Object handlers
;
1545 Lisp_Object (*hfun
) ();
1551 /* Since Fsignal will close off all calls to x_catch_errors,
1552 we will get the wrong results if some are not closed now. */
1554 if (x_catching_errors ())
1560 c
.backlist
= backtrace_list
;
1561 c
.handlerlist
= handlerlist
;
1562 c
.lisp_eval_depth
= lisp_eval_depth
;
1563 c
.pdlcount
= SPECPDL_INDEX ();
1564 c
.poll_suppress_count
= poll_suppress_count
;
1565 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1566 c
.gcpro
= gcprolist
;
1567 c
.byte_stack
= byte_stack_list
;
1568 if (_setjmp (c
.jmp
))
1570 return (*hfun
) (c
.val
);
1574 h
.handler
= handlers
;
1576 h
.next
= handlerlist
;
1580 val
= (*bfun
) (nargs
, args
);
1582 handlerlist
= h
.next
;
1587 static Lisp_Object find_handler_clause
P_ ((Lisp_Object
, Lisp_Object
,
1588 Lisp_Object
, Lisp_Object
,
1591 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1592 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1593 This function does not return.
1595 An error symbol is a symbol with an `error-conditions' property
1596 that is a list of condition names.
1597 A handler for any of those names will get to handle this signal.
1598 The symbol `error' should normally be one of them.
1600 DATA should be a list. Its elements are printed as part of the error message.
1601 See Info anchor `(elisp)Definition of signal' for some details on how this
1602 error message is constructed.
1603 If the signal is handled, DATA is made available to the handler.
1604 See also the function `condition-case'. */)
1605 (error_symbol
, data
)
1606 Lisp_Object error_symbol
, data
;
1608 /* When memory is full, ERROR-SYMBOL is nil,
1609 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1610 That is a special case--don't do this in other situations. */
1611 register struct handler
*allhandlers
= handlerlist
;
1612 Lisp_Object conditions
;
1613 extern int gc_in_progress
;
1614 extern int waiting_for_input
;
1615 Lisp_Object debugger_value
;
1617 Lisp_Object real_error_symbol
;
1618 struct backtrace
*bp
;
1620 immediate_quit
= handling_signal
= 0;
1622 if (gc_in_progress
|| waiting_for_input
)
1625 if (NILP (error_symbol
))
1626 real_error_symbol
= Fcar (data
);
1628 real_error_symbol
= error_symbol
;
1630 #if 0 /* rms: I don't know why this was here,
1631 but it is surely wrong for an error that is handled. */
1632 #ifdef HAVE_X_WINDOWS
1633 if (display_hourglass_p
)
1634 cancel_hourglass ();
1638 /* This hook is used by edebug. */
1639 if (! NILP (Vsignal_hook_function
)
1640 && ! NILP (error_symbol
))
1642 /* Edebug takes care of restoring these variables when it exits. */
1643 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1644 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1646 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1647 max_specpdl_size
= SPECPDL_INDEX () + 40;
1649 call2 (Vsignal_hook_function
, error_symbol
, data
);
1652 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1654 /* Remember from where signal was called. Skip over the frame for
1655 `signal' itself. If a frame for `error' follows, skip that,
1656 too. Don't do this when ERROR_SYMBOL is nil, because that
1657 is a memory-full error. */
1658 Vsignaling_function
= Qnil
;
1659 if (backtrace_list
&& !NILP (error_symbol
))
1661 bp
= backtrace_list
->next
;
1662 if (bp
&& bp
->function
&& EQ (*bp
->function
, Qerror
))
1664 if (bp
&& bp
->function
)
1665 Vsignaling_function
= *bp
->function
;
1668 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1670 register Lisp_Object clause
;
1672 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1673 error_symbol
, data
, &debugger_value
);
1675 if (EQ (clause
, Qlambda
))
1677 /* We can't return values to code which signaled an error, but we
1678 can continue code which has signaled a quit. */
1679 if (EQ (real_error_symbol
, Qquit
))
1682 error ("Cannot return from the debugger in an error");
1687 Lisp_Object unwind_data
;
1688 struct handler
*h
= handlerlist
;
1690 handlerlist
= allhandlers
;
1692 if (NILP (error_symbol
))
1695 unwind_data
= Fcons (error_symbol
, data
);
1696 h
->chosen_clause
= clause
;
1697 unwind_to_catch (h
->tag
, unwind_data
);
1701 handlerlist
= allhandlers
;
1702 /* If no handler is present now, try to run the debugger,
1703 and if that fails, throw to top level. */
1704 find_handler_clause (Qerror
, conditions
, error_symbol
, data
, &debugger_value
);
1706 Fthrow (Qtop_level
, Qt
);
1708 if (! NILP (error_symbol
))
1709 data
= Fcons (error_symbol
, data
);
1711 string
= Ferror_message_string (data
);
1712 fatal ("%s", SDATA (string
), 0);
1715 /* Internal version of Fsignal that never returns.
1716 Used for anything but Qquit (which can return from Fsignal). */
1719 xsignal (error_symbol
, data
)
1720 Lisp_Object error_symbol
, data
;
1722 Fsignal (error_symbol
, data
);
1726 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1729 xsignal0 (error_symbol
)
1730 Lisp_Object error_symbol
;
1732 xsignal (error_symbol
, Qnil
);
1736 xsignal1 (error_symbol
, arg
)
1737 Lisp_Object error_symbol
, arg
;
1739 xsignal (error_symbol
, list1 (arg
));
1743 xsignal2 (error_symbol
, arg1
, arg2
)
1744 Lisp_Object error_symbol
, arg1
, arg2
;
1746 xsignal (error_symbol
, list2 (arg1
, arg2
));
1750 xsignal3 (error_symbol
, arg1
, arg2
, arg3
)
1751 Lisp_Object error_symbol
, arg1
, arg2
, arg3
;
1753 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1756 /* Signal `error' with message S, and additional arg ARG.
1757 If ARG is not a genuine list, make it a one-element list. */
1760 signal_error (s
, arg
)
1764 Lisp_Object tortoise
, hare
;
1766 hare
= tortoise
= arg
;
1767 while (CONSP (hare
))
1774 tortoise
= XCDR (tortoise
);
1776 if (EQ (hare
, tortoise
))
1781 arg
= Fcons (arg
, Qnil
); /* Make it a list. */
1783 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1787 /* Return nonzero iff LIST is a non-nil atom or
1788 a list containing one of CONDITIONS. */
1791 wants_debugger (list
, conditions
)
1792 Lisp_Object list
, conditions
;
1799 while (CONSP (conditions
))
1801 Lisp_Object
this, tail
;
1802 this = XCAR (conditions
);
1803 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1804 if (EQ (XCAR (tail
), this))
1806 conditions
= XCDR (conditions
);
1811 /* Return 1 if an error with condition-symbols CONDITIONS,
1812 and described by SIGNAL-DATA, should skip the debugger
1813 according to debugger-ignored-errors. */
1816 skip_debugger (conditions
, data
)
1817 Lisp_Object conditions
, data
;
1820 int first_string
= 1;
1821 Lisp_Object error_message
;
1823 error_message
= Qnil
;
1824 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1826 if (STRINGP (XCAR (tail
)))
1830 error_message
= Ferror_message_string (data
);
1834 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1839 Lisp_Object contail
;
1841 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1842 if (EQ (XCAR (tail
), XCAR (contail
)))
1850 /* Value of Qlambda means we have called debugger and user has continued.
1851 There are two ways to pass SIG and DATA:
1852 = SIG is the error symbol, and DATA is the rest of the data.
1853 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1854 This is for memory-full errors only.
1856 Store value returned from debugger into *DEBUGGER_VALUE_PTR.
1858 We need to increase max_specpdl_size temporarily around
1859 anything we do that can push on the specpdl, so as not to get
1860 a second error here in case we're handling specpdl overflow. */
1863 find_handler_clause (handlers
, conditions
, sig
, data
, debugger_value_ptr
)
1864 Lisp_Object handlers
, conditions
, sig
, data
;
1865 Lisp_Object
*debugger_value_ptr
;
1867 register Lisp_Object h
;
1868 register Lisp_Object tem
;
1870 if (EQ (handlers
, Qt
)) /* t is used by handlers for all conditions, set up by C code. */
1872 /* error is used similarly, but means print an error message
1873 and run the debugger if that is enabled. */
1874 if (EQ (handlers
, Qerror
)
1875 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1876 there is a handler. */
1878 int debugger_called
= 0;
1879 Lisp_Object sig_symbol
, combined_data
;
1880 /* This is set to 1 if we are handling a memory-full error,
1881 because these must not run the debugger.
1882 (There is no room in memory to do that!) */
1883 int no_debugger
= 0;
1887 combined_data
= data
;
1888 sig_symbol
= Fcar (data
);
1893 combined_data
= Fcons (sig
, data
);
1897 if (wants_debugger (Vstack_trace_on_error
, conditions
))
1901 internal_with_output_to_temp_buffer ("*Backtrace*",
1902 (Lisp_Object (*) (Lisp_Object
)) Fbacktrace
,
1905 internal_with_output_to_temp_buffer ("*Backtrace*",
1911 /* Don't try to run the debugger with interrupts blocked.
1912 The editing loop would return anyway. */
1913 && ! INPUT_BLOCKED_P
1914 && (EQ (sig_symbol
, Qquit
)
1916 : wants_debugger (Vdebug_on_error
, conditions
))
1917 && ! skip_debugger (conditions
, combined_data
)
1918 && when_entered_debugger
< num_nonmacro_input_events
)
1921 = call_debugger (Fcons (Qerror
,
1922 Fcons (combined_data
, Qnil
)));
1923 debugger_called
= 1;
1925 /* If there is no handler, return saying whether we ran the debugger. */
1926 if (EQ (handlers
, Qerror
))
1928 if (debugger_called
)
1933 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1935 Lisp_Object handler
, condit
;
1938 if (!CONSP (handler
))
1940 condit
= Fcar (handler
);
1941 /* Handle a single condition name in handler HANDLER. */
1942 if (SYMBOLP (condit
))
1944 tem
= Fmemq (Fcar (handler
), conditions
);
1948 /* Handle a list of condition names in handler HANDLER. */
1949 else if (CONSP (condit
))
1951 while (CONSP (condit
))
1953 tem
= Fmemq (Fcar (condit
), conditions
);
1956 condit
= XCDR (condit
);
1963 /* dump an error message; called like printf */
1967 error (m
, a1
, a2
, a3
)
1987 int used
= doprnt (buffer
, size
, m
, m
+ mlen
, 3, args
);
1992 buffer
= (char *) xrealloc (buffer
, size
);
1995 buffer
= (char *) xmalloc (size
);
2000 string
= build_string (buffer
);
2004 xsignal1 (Qerror
, string
);
2007 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
2008 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
2009 This means it contains a description for how to read arguments to give it.
2010 The value is nil for an invalid function or a symbol with no function
2013 Interactively callable functions include strings and vectors (treated
2014 as keyboard macros), lambda-expressions that contain a top-level call
2015 to `interactive', autoload definitions made by `autoload' with non-nil
2016 fourth argument, and some of the built-in functions of Lisp.
2018 Also, a symbol satisfies `commandp' if its function definition does so.
2020 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
2021 then strings and vectors are not accepted. */)
2022 (function
, for_call_interactively
)
2023 Lisp_Object function
, for_call_interactively
;
2025 register Lisp_Object fun
;
2026 register Lisp_Object funcar
;
2030 fun
= indirect_function (fun
);
2031 if (EQ (fun
, Qunbound
))
2034 /* Emacs primitives are interactive if their DEFUN specifies an
2035 interactive spec. */
2038 if (XSUBR (fun
)->prompt
)
2044 /* Bytecode objects are interactive if they are long enough to
2045 have an element whose index is COMPILED_INTERACTIVE, which is
2046 where the interactive spec is stored. */
2047 else if (COMPILEDP (fun
))
2048 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
2051 /* Strings and vectors are keyboard macros. */
2052 if (NILP (for_call_interactively
) && (STRINGP (fun
) || VECTORP (fun
)))
2055 /* Lists may represent commands. */
2058 funcar
= XCAR (fun
);
2059 if (EQ (funcar
, Qlambda
))
2060 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
2061 if (EQ (funcar
, Qautoload
))
2062 return Fcar (Fcdr (Fcdr (XCDR (fun
))));
2068 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
2069 doc
: /* Define FUNCTION to autoload from FILE.
2070 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
2071 Third arg DOCSTRING is documentation for the function.
2072 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
2073 Fifth arg TYPE indicates the type of the object:
2074 nil or omitted says FUNCTION is a function,
2075 `keymap' says FUNCTION is really a keymap, and
2076 `macro' or t says FUNCTION is really a macro.
2077 Third through fifth args give info about the real definition.
2078 They default to nil.
2079 If FUNCTION is already defined other than as an autoload,
2080 this does nothing and returns nil. */)
2081 (function
, file
, docstring
, interactive
, type
)
2082 Lisp_Object function
, file
, docstring
, interactive
, type
;
2085 Lisp_Object args
[4];
2088 CHECK_SYMBOL (function
);
2089 CHECK_STRING (file
);
2091 /* If function is defined and not as an autoload, don't override */
2092 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
2093 && !(CONSP (XSYMBOL (function
)->function
)
2094 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
2097 if (NILP (Vpurify_flag
))
2098 /* Only add entries after dumping, because the ones before are
2099 not useful and else we get loads of them from the loaddefs.el. */
2100 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
2104 args
[1] = docstring
;
2105 args
[2] = interactive
;
2108 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
2109 #else /* NO_ARG_ARRAY */
2110 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
2111 #endif /* not NO_ARG_ARRAY */
2115 un_autoload (oldqueue
)
2116 Lisp_Object oldqueue
;
2118 register Lisp_Object queue
, first
, second
;
2120 /* Queue to unwind is current value of Vautoload_queue.
2121 oldqueue is the shadowed value to leave in Vautoload_queue. */
2122 queue
= Vautoload_queue
;
2123 Vautoload_queue
= oldqueue
;
2124 while (CONSP (queue
))
2126 first
= XCAR (queue
);
2127 second
= Fcdr (first
);
2128 first
= Fcar (first
);
2129 if (EQ (first
, make_number (0)))
2132 Ffset (first
, second
);
2133 queue
= XCDR (queue
);
2138 /* Load an autoloaded function.
2139 FUNNAME is the symbol which is the function's name.
2140 FUNDEF is the autoload definition (a list). */
2143 do_autoload (fundef
, funname
)
2144 Lisp_Object fundef
, funname
;
2146 int count
= SPECPDL_INDEX ();
2147 Lisp_Object fun
, queue
, first
, second
;
2148 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2150 /* This is to make sure that loadup.el gives a clear picture
2151 of what files are preloaded and when. */
2152 if (! NILP (Vpurify_flag
))
2153 error ("Attempt to autoload %s while preparing to dump",
2154 SDATA (SYMBOL_NAME (funname
)));
2157 CHECK_SYMBOL (funname
);
2158 GCPRO3 (fun
, funname
, fundef
);
2160 /* Preserve the match data. */
2161 record_unwind_save_match_data ();
2163 /* Value saved here is to be restored into Vautoload_queue. */
2164 record_unwind_protect (un_autoload
, Vautoload_queue
);
2165 Vautoload_queue
= Qt
;
2166 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
, Qt
);
2168 /* Save the old autoloads, in case we ever do an unload. */
2169 queue
= Vautoload_queue
;
2170 while (CONSP (queue
))
2172 first
= XCAR (queue
);
2173 second
= Fcdr (first
);
2174 first
= Fcar (first
);
2176 if (SYMBOLP (first
) && CONSP (second
) && EQ (XCAR (second
), Qautoload
))
2177 Fput (first
, Qautoload
, (XCDR (second
)));
2179 queue
= XCDR (queue
);
2182 /* Once loading finishes, don't undo it. */
2183 Vautoload_queue
= Qt
;
2184 unbind_to (count
, Qnil
);
2186 fun
= Findirect_function (fun
, Qnil
);
2188 if (!NILP (Fequal (fun
, fundef
)))
2189 error ("Autoloading failed to define function %s",
2190 SDATA (SYMBOL_NAME (funname
)));
2195 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
2196 doc
: /* Evaluate FORM and return its value. */)
2200 Lisp_Object fun
, val
, original_fun
, original_args
;
2202 struct backtrace backtrace
;
2203 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2205 if (handling_signal
)
2209 return Fsymbol_value (form
);
2214 if ((consing_since_gc
> gc_cons_threshold
2215 && consing_since_gc
> gc_relative_threshold
)
2217 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2220 Fgarbage_collect ();
2224 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2226 if (max_lisp_eval_depth
< 100)
2227 max_lisp_eval_depth
= 100;
2228 if (lisp_eval_depth
> max_lisp_eval_depth
)
2229 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2232 original_fun
= Fcar (form
);
2233 original_args
= Fcdr (form
);
2235 backtrace
.next
= backtrace_list
;
2236 backtrace_list
= &backtrace
;
2237 backtrace
.function
= &original_fun
; /* This also protects them from gc */
2238 backtrace
.args
= &original_args
;
2239 backtrace
.nargs
= UNEVALLED
;
2240 backtrace
.evalargs
= 1;
2241 backtrace
.debug_on_exit
= 0;
2243 if (debug_on_next_call
)
2244 do_debug_on_call (Qt
);
2246 /* At this point, only original_fun and original_args
2247 have values that will be used below */
2250 /* Optimize for no indirection. */
2252 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2253 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2254 fun
= indirect_function (fun
);
2258 Lisp_Object numargs
;
2259 Lisp_Object argvals
[8];
2260 Lisp_Object args_left
;
2261 register int i
, maxargs
;
2263 args_left
= original_args
;
2264 numargs
= Flength (args_left
);
2268 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
2269 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2270 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2272 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2274 backtrace
.evalargs
= 0;
2275 val
= (*XSUBR (fun
)->function
) (args_left
);
2279 if (XSUBR (fun
)->max_args
== MANY
)
2281 /* Pass a vector of evaluated arguments */
2283 register int argnum
= 0;
2285 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2287 GCPRO3 (args_left
, fun
, fun
);
2291 while (!NILP (args_left
))
2293 vals
[argnum
++] = Feval (Fcar (args_left
));
2294 args_left
= Fcdr (args_left
);
2295 gcpro3
.nvars
= argnum
;
2298 backtrace
.args
= vals
;
2299 backtrace
.nargs
= XINT (numargs
);
2301 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
2306 GCPRO3 (args_left
, fun
, fun
);
2307 gcpro3
.var
= argvals
;
2310 maxargs
= XSUBR (fun
)->max_args
;
2311 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
2313 argvals
[i
] = Feval (Fcar (args_left
));
2319 backtrace
.args
= argvals
;
2320 backtrace
.nargs
= XINT (numargs
);
2325 val
= (*XSUBR (fun
)->function
) ();
2328 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
2331 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
2334 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2338 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2339 argvals
[2], argvals
[3]);
2342 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2343 argvals
[3], argvals
[4]);
2346 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2347 argvals
[3], argvals
[4], argvals
[5]);
2350 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2351 argvals
[3], argvals
[4], argvals
[5],
2356 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2357 argvals
[3], argvals
[4], argvals
[5],
2358 argvals
[6], argvals
[7]);
2362 /* Someone has created a subr that takes more arguments than
2363 is supported by this code. We need to either rewrite the
2364 subr to use a different argument protocol, or add more
2365 cases to this switch. */
2369 if (COMPILEDP (fun
))
2370 val
= apply_lambda (fun
, original_args
, 1);
2373 if (EQ (fun
, Qunbound
))
2374 xsignal1 (Qvoid_function
, original_fun
);
2376 xsignal1 (Qinvalid_function
, original_fun
);
2377 funcar
= XCAR (fun
);
2378 if (!SYMBOLP (funcar
))
2379 xsignal1 (Qinvalid_function
, original_fun
);
2380 if (EQ (funcar
, Qautoload
))
2382 do_autoload (fun
, original_fun
);
2385 if (EQ (funcar
, Qmacro
))
2386 val
= Feval (apply1 (Fcdr (fun
), original_args
));
2387 else if (EQ (funcar
, Qlambda
))
2388 val
= apply_lambda (fun
, original_args
, 1);
2390 xsignal1 (Qinvalid_function
, original_fun
);
2396 if (backtrace
.debug_on_exit
)
2397 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2398 backtrace_list
= backtrace
.next
;
2403 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
2404 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2405 Then return the value FUNCTION returns.
2406 Thus, (apply '+ 1 2 '(3 4)) returns 10.
2407 usage: (apply FUNCTION &rest ARGUMENTS) */)
2412 register int i
, numargs
;
2413 register Lisp_Object spread_arg
;
2414 register Lisp_Object
*funcall_args
;
2416 struct gcpro gcpro1
;
2420 spread_arg
= args
[nargs
- 1];
2421 CHECK_LIST (spread_arg
);
2423 numargs
= XINT (Flength (spread_arg
));
2426 return Ffuncall (nargs
- 1, args
);
2427 else if (numargs
== 1)
2429 args
[nargs
- 1] = XCAR (spread_arg
);
2430 return Ffuncall (nargs
, args
);
2433 numargs
+= nargs
- 2;
2435 /* Optimize for no indirection. */
2436 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2437 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2438 fun
= indirect_function (fun
);
2439 if (EQ (fun
, Qunbound
))
2441 /* Let funcall get the error */
2448 if (numargs
< XSUBR (fun
)->min_args
2449 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2450 goto funcall
; /* Let funcall get the error */
2451 else if (XSUBR (fun
)->max_args
> numargs
)
2453 /* Avoid making funcall cons up a yet another new vector of arguments
2454 by explicitly supplying nil's for optional values */
2455 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
2456 * sizeof (Lisp_Object
));
2457 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2458 funcall_args
[++i
] = Qnil
;
2459 GCPRO1 (*funcall_args
);
2460 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2464 /* We add 1 to numargs because funcall_args includes the
2465 function itself as well as its arguments. */
2468 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
2469 * sizeof (Lisp_Object
));
2470 GCPRO1 (*funcall_args
);
2471 gcpro1
.nvars
= 1 + numargs
;
2474 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
2475 /* Spread the last arg we got. Its first element goes in
2476 the slot that it used to occupy, hence this value of I. */
2478 while (!NILP (spread_arg
))
2480 funcall_args
[i
++] = XCAR (spread_arg
);
2481 spread_arg
= XCDR (spread_arg
);
2484 /* By convention, the caller needs to gcpro Ffuncall's args. */
2485 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
2488 /* Run hook variables in various ways. */
2490 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
2491 static Lisp_Object run_hook_with_args
P_ ((int, Lisp_Object
*,
2492 enum run_hooks_condition
));
2494 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2495 doc
: /* Run each hook in HOOKS.
2496 Each argument should be a symbol, a hook variable.
2497 These symbols are processed in the order specified.
2498 If a hook symbol has a non-nil value, that value may be a function
2499 or a list of functions to be called to run the hook.
2500 If the value is a function, it is called with no arguments.
2501 If it is a list, the elements are called, in order, with no arguments.
2503 Major modes should not use this function directly to run their mode
2504 hook; they should use `run-mode-hooks' instead.
2506 Do not use `make-local-variable' to make a hook variable buffer-local.
2507 Instead, use `add-hook' and specify t for the LOCAL argument.
2508 usage: (run-hooks &rest HOOKS) */)
2513 Lisp_Object hook
[1];
2516 for (i
= 0; i
< nargs
; i
++)
2519 run_hook_with_args (1, hook
, to_completion
);
2525 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2526 Srun_hook_with_args
, 1, MANY
, 0,
2527 doc
: /* Run HOOK with the specified arguments ARGS.
2528 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2529 value, that value may be a function or a list of functions to be
2530 called to run the hook. If the value is a function, it is called with
2531 the given arguments and its return value is returned. If it is a list
2532 of functions, those functions are called, in order,
2533 with the given arguments ARGS.
2534 It is best not to depend on the value returned by `run-hook-with-args',
2537 Do not use `make-local-variable' to make a hook variable buffer-local.
2538 Instead, use `add-hook' and specify t for the LOCAL argument.
2539 usage: (run-hook-with-args HOOK &rest ARGS) */)
2544 return run_hook_with_args (nargs
, args
, to_completion
);
2547 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2548 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2549 doc
: /* Run HOOK with the specified arguments ARGS.
2550 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2551 value, that value may be a function or a list of functions to be
2552 called to run the hook. If the value is a function, it is called with
2553 the given arguments and its return value is returned.
2554 If it is a list of functions, those functions are called, in order,
2555 with the given arguments ARGS, until one of them
2556 returns a non-nil value. Then we return that value.
2557 However, if they all return nil, we return nil.
2559 Do not use `make-local-variable' to make a hook variable buffer-local.
2560 Instead, use `add-hook' and specify t for the LOCAL argument.
2561 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2566 return run_hook_with_args (nargs
, args
, until_success
);
2569 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2570 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2571 doc
: /* Run HOOK with the specified arguments ARGS.
2572 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2573 value, that value may be a function or a list of functions to be
2574 called to run the hook. If the value is a function, it is called with
2575 the given arguments and its return value is returned.
2576 If it is a list of functions, those functions are called, in order,
2577 with the given arguments ARGS, until one of them returns nil.
2578 Then we return nil. However, if they all return non-nil, we return non-nil.
2580 Do not use `make-local-variable' to make a hook variable buffer-local.
2581 Instead, use `add-hook' and specify t for the LOCAL argument.
2582 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2587 return run_hook_with_args (nargs
, args
, until_failure
);
2590 /* ARGS[0] should be a hook symbol.
2591 Call each of the functions in the hook value, passing each of them
2592 as arguments all the rest of ARGS (all NARGS - 1 elements).
2593 COND specifies a condition to test after each call
2594 to decide whether to stop.
2595 The caller (or its caller, etc) must gcpro all of ARGS,
2596 except that it isn't necessary to gcpro ARGS[0]. */
2599 run_hook_with_args (nargs
, args
, cond
)
2602 enum run_hooks_condition cond
;
2604 Lisp_Object sym
, val
, ret
;
2605 Lisp_Object globals
;
2606 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2608 /* If we are dying or still initializing,
2609 don't do anything--it would probably crash if we tried. */
2610 if (NILP (Vrun_hooks
))
2614 val
= find_symbol_value (sym
);
2615 ret
= (cond
== until_failure
? Qt
: Qnil
);
2617 if (EQ (val
, Qunbound
) || NILP (val
))
2619 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2622 return Ffuncall (nargs
, args
);
2627 GCPRO3 (sym
, val
, globals
);
2630 CONSP (val
) && ((cond
== to_completion
)
2631 || (cond
== until_success
? NILP (ret
)
2635 if (EQ (XCAR (val
), Qt
))
2637 /* t indicates this hook has a local binding;
2638 it means to run the global binding too. */
2640 for (globals
= Fdefault_value (sym
);
2641 CONSP (globals
) && ((cond
== to_completion
)
2642 || (cond
== until_success
? NILP (ret
)
2644 globals
= XCDR (globals
))
2646 args
[0] = XCAR (globals
);
2647 /* In a global value, t should not occur. If it does, we
2648 must ignore it to avoid an endless loop. */
2649 if (!EQ (args
[0], Qt
))
2650 ret
= Ffuncall (nargs
, args
);
2655 args
[0] = XCAR (val
);
2656 ret
= Ffuncall (nargs
, args
);
2665 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2666 present value of that symbol.
2667 Call each element of FUNLIST,
2668 passing each of them the rest of ARGS.
2669 The caller (or its caller, etc) must gcpro all of ARGS,
2670 except that it isn't necessary to gcpro ARGS[0]. */
2673 run_hook_list_with_args (funlist
, nargs
, args
)
2674 Lisp_Object funlist
;
2680 Lisp_Object globals
;
2681 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2685 GCPRO3 (sym
, val
, globals
);
2687 for (val
= funlist
; CONSP (val
); val
= XCDR (val
))
2689 if (EQ (XCAR (val
), Qt
))
2691 /* t indicates this hook has a local binding;
2692 it means to run the global binding too. */
2694 for (globals
= Fdefault_value (sym
);
2696 globals
= XCDR (globals
))
2698 args
[0] = XCAR (globals
);
2699 /* In a global value, t should not occur. If it does, we
2700 must ignore it to avoid an endless loop. */
2701 if (!EQ (args
[0], Qt
))
2702 Ffuncall (nargs
, args
);
2707 args
[0] = XCAR (val
);
2708 Ffuncall (nargs
, args
);
2715 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2718 run_hook_with_args_2 (hook
, arg1
, arg2
)
2719 Lisp_Object hook
, arg1
, arg2
;
2721 Lisp_Object temp
[3];
2726 Frun_hook_with_args (3, temp
);
2729 /* Apply fn to arg */
2732 Lisp_Object fn
, arg
;
2734 struct gcpro gcpro1
;
2738 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2742 Lisp_Object args
[2];
2746 RETURN_UNGCPRO (Fapply (2, args
));
2748 #else /* not NO_ARG_ARRAY */
2749 RETURN_UNGCPRO (Fapply (2, &fn
));
2750 #endif /* not NO_ARG_ARRAY */
2753 /* Call function fn on no arguments */
2758 struct gcpro gcpro1
;
2761 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2764 /* Call function fn with 1 argument arg1 */
2768 Lisp_Object fn
, arg1
;
2770 struct gcpro gcpro1
;
2772 Lisp_Object args
[2];
2778 RETURN_UNGCPRO (Ffuncall (2, args
));
2779 #else /* not NO_ARG_ARRAY */
2782 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2783 #endif /* not NO_ARG_ARRAY */
2786 /* Call function fn with 2 arguments arg1, arg2 */
2789 call2 (fn
, arg1
, arg2
)
2790 Lisp_Object fn
, arg1
, arg2
;
2792 struct gcpro gcpro1
;
2794 Lisp_Object args
[3];
2800 RETURN_UNGCPRO (Ffuncall (3, args
));
2801 #else /* not NO_ARG_ARRAY */
2804 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2805 #endif /* not NO_ARG_ARRAY */
2808 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2811 call3 (fn
, arg1
, arg2
, arg3
)
2812 Lisp_Object fn
, arg1
, arg2
, arg3
;
2814 struct gcpro gcpro1
;
2816 Lisp_Object args
[4];
2823 RETURN_UNGCPRO (Ffuncall (4, args
));
2824 #else /* not NO_ARG_ARRAY */
2827 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2828 #endif /* not NO_ARG_ARRAY */
2831 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2834 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2835 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2837 struct gcpro gcpro1
;
2839 Lisp_Object args
[5];
2847 RETURN_UNGCPRO (Ffuncall (5, args
));
2848 #else /* not NO_ARG_ARRAY */
2851 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2852 #endif /* not NO_ARG_ARRAY */
2855 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2858 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2859 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2861 struct gcpro gcpro1
;
2863 Lisp_Object args
[6];
2872 RETURN_UNGCPRO (Ffuncall (6, args
));
2873 #else /* not NO_ARG_ARRAY */
2876 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2877 #endif /* not NO_ARG_ARRAY */
2880 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2883 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2884 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2886 struct gcpro gcpro1
;
2888 Lisp_Object args
[7];
2898 RETURN_UNGCPRO (Ffuncall (7, args
));
2899 #else /* not NO_ARG_ARRAY */
2902 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2903 #endif /* not NO_ARG_ARRAY */
2906 /* The caller should GCPRO all the elements of ARGS. */
2908 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2909 doc
: /* Call first argument as a function, passing remaining arguments to it.
2910 Return the value that function returns.
2911 Thus, (funcall 'cons 'x 'y) returns (x . y).
2912 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2917 Lisp_Object fun
, original_fun
;
2919 int numargs
= nargs
- 1;
2920 Lisp_Object lisp_numargs
;
2922 struct backtrace backtrace
;
2923 register Lisp_Object
*internal_args
;
2927 if ((consing_since_gc
> gc_cons_threshold
2928 && consing_since_gc
> gc_relative_threshold
)
2930 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2931 Fgarbage_collect ();
2933 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2935 if (max_lisp_eval_depth
< 100)
2936 max_lisp_eval_depth
= 100;
2937 if (lisp_eval_depth
> max_lisp_eval_depth
)
2938 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2941 backtrace
.next
= backtrace_list
;
2942 backtrace_list
= &backtrace
;
2943 backtrace
.function
= &args
[0];
2944 backtrace
.args
= &args
[1];
2945 backtrace
.nargs
= nargs
- 1;
2946 backtrace
.evalargs
= 0;
2947 backtrace
.debug_on_exit
= 0;
2949 if (debug_on_next_call
)
2950 do_debug_on_call (Qlambda
);
2954 original_fun
= args
[0];
2958 /* Optimize for no indirection. */
2960 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2961 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2962 fun
= indirect_function (fun
);
2966 if (numargs
< XSUBR (fun
)->min_args
2967 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2969 XSETFASTINT (lisp_numargs
, numargs
);
2970 xsignal2 (Qwrong_number_of_arguments
, original_fun
, lisp_numargs
);
2973 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2974 xsignal1 (Qinvalid_function
, original_fun
);
2976 if (XSUBR (fun
)->max_args
== MANY
)
2978 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
2982 if (XSUBR (fun
)->max_args
> numargs
)
2984 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2985 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
2986 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2987 internal_args
[i
] = Qnil
;
2990 internal_args
= args
+ 1;
2991 switch (XSUBR (fun
)->max_args
)
2994 val
= (*XSUBR (fun
)->function
) ();
2997 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
3000 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1]);
3003 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3007 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3008 internal_args
[2], internal_args
[3]);
3011 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3012 internal_args
[2], internal_args
[3],
3016 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3017 internal_args
[2], internal_args
[3],
3018 internal_args
[4], internal_args
[5]);
3021 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3022 internal_args
[2], internal_args
[3],
3023 internal_args
[4], internal_args
[5],
3028 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3029 internal_args
[2], internal_args
[3],
3030 internal_args
[4], internal_args
[5],
3031 internal_args
[6], internal_args
[7]);
3036 /* If a subr takes more than 8 arguments without using MANY
3037 or UNEVALLED, we need to extend this function to support it.
3038 Until this is done, there is no way to call the function. */
3042 if (COMPILEDP (fun
))
3043 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3046 if (EQ (fun
, Qunbound
))
3047 xsignal1 (Qvoid_function
, original_fun
);
3049 xsignal1 (Qinvalid_function
, original_fun
);
3050 funcar
= XCAR (fun
);
3051 if (!SYMBOLP (funcar
))
3052 xsignal1 (Qinvalid_function
, original_fun
);
3053 if (EQ (funcar
, Qlambda
))
3054 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3055 else if (EQ (funcar
, Qautoload
))
3057 do_autoload (fun
, original_fun
);
3062 xsignal1 (Qinvalid_function
, original_fun
);
3067 if (backtrace
.debug_on_exit
)
3068 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
3069 backtrace_list
= backtrace
.next
;
3074 apply_lambda (fun
, args
, eval_flag
)
3075 Lisp_Object fun
, args
;
3078 Lisp_Object args_left
;
3079 Lisp_Object numargs
;
3080 register Lisp_Object
*arg_vector
;
3081 struct gcpro gcpro1
, gcpro2
, gcpro3
;
3083 register Lisp_Object tem
;
3085 numargs
= Flength (args
);
3086 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
3089 GCPRO3 (*arg_vector
, args_left
, fun
);
3092 for (i
= 0; i
< XINT (numargs
);)
3094 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
3095 if (eval_flag
) tem
= Feval (tem
);
3096 arg_vector
[i
++] = tem
;
3104 backtrace_list
->args
= arg_vector
;
3105 backtrace_list
->nargs
= i
;
3107 backtrace_list
->evalargs
= 0;
3108 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
3110 /* Do the debug-on-exit now, while arg_vector still exists. */
3111 if (backtrace_list
->debug_on_exit
)
3112 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
3113 /* Don't do it again when we return to eval. */
3114 backtrace_list
->debug_on_exit
= 0;
3118 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
3119 and return the result of evaluation.
3120 FUN must be either a lambda-expression or a compiled-code object. */
3123 funcall_lambda (fun
, nargs
, arg_vector
)
3126 register Lisp_Object
*arg_vector
;
3128 Lisp_Object val
, syms_left
, next
;
3129 int count
= SPECPDL_INDEX ();
3130 int i
, optional
, rest
;
3134 syms_left
= XCDR (fun
);
3135 if (CONSP (syms_left
))
3136 syms_left
= XCAR (syms_left
);
3138 xsignal1 (Qinvalid_function
, fun
);
3140 else if (COMPILEDP (fun
))
3141 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3145 i
= optional
= rest
= 0;
3146 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3150 next
= XCAR (syms_left
);
3151 if (!SYMBOLP (next
))
3152 xsignal1 (Qinvalid_function
, fun
);
3154 if (EQ (next
, Qand_rest
))
3156 else if (EQ (next
, Qand_optional
))
3160 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
3164 specbind (next
, arg_vector
[i
++]);
3166 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3168 specbind (next
, Qnil
);
3171 if (!NILP (syms_left
))
3172 xsignal1 (Qinvalid_function
, fun
);
3174 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3177 val
= Fprogn (XCDR (XCDR (fun
)));
3180 /* If we have not actually read the bytecode string
3181 and constants vector yet, fetch them from the file. */
3182 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3183 Ffetch_bytecode (fun
);
3184 val
= Fbyte_code (AREF (fun
, COMPILED_BYTECODE
),
3185 AREF (fun
, COMPILED_CONSTANTS
),
3186 AREF (fun
, COMPILED_STACK_DEPTH
));
3189 return unbind_to (count
, val
);
3192 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3194 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3200 if (COMPILEDP (object
) && CONSP (AREF (object
, COMPILED_BYTECODE
)))
3202 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3205 tem
= AREF (object
, COMPILED_BYTECODE
);
3206 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3207 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3209 error ("Invalid byte code");
3211 AREF (object
, COMPILED_BYTECODE
) = XCAR (tem
);
3212 AREF (object
, COMPILED_CONSTANTS
) = XCDR (tem
);
3220 register int count
= SPECPDL_INDEX ();
3221 if (specpdl_size
>= max_specpdl_size
)
3223 if (max_specpdl_size
< 400)
3224 max_specpdl_size
= 400;
3225 if (specpdl_size
>= max_specpdl_size
)
3226 signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil
);
3229 if (specpdl_size
> max_specpdl_size
)
3230 specpdl_size
= max_specpdl_size
;
3231 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
3232 specpdl_ptr
= specpdl
+ count
;
3236 specbind (symbol
, value
)
3237 Lisp_Object symbol
, value
;
3240 Lisp_Object valcontents
;
3242 CHECK_SYMBOL (symbol
);
3243 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3246 /* The most common case is that of a non-constant symbol with a
3247 trivial value. Make that as fast as we can. */
3248 valcontents
= SYMBOL_VALUE (symbol
);
3249 if (!MISCP (valcontents
) && !SYMBOL_CONSTANT_P (symbol
))
3251 specpdl_ptr
->symbol
= symbol
;
3252 specpdl_ptr
->old_value
= valcontents
;
3253 specpdl_ptr
->func
= NULL
;
3255 SET_SYMBOL_VALUE (symbol
, value
);
3259 Lisp_Object valcontents
;
3261 ovalue
= find_symbol_value (symbol
);
3262 specpdl_ptr
->func
= 0;
3263 specpdl_ptr
->old_value
= ovalue
;
3265 valcontents
= XSYMBOL (symbol
)->value
;
3267 if (BUFFER_LOCAL_VALUEP (valcontents
)
3268 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
3269 || BUFFER_OBJFWDP (valcontents
))
3271 Lisp_Object where
, current_buffer
;
3273 current_buffer
= Fcurrent_buffer ();
3275 /* For a local variable, record both the symbol and which
3276 buffer's or frame's value we are saving. */
3277 if (!NILP (Flocal_variable_p (symbol
, Qnil
)))
3278 where
= current_buffer
;
3279 else if (!BUFFER_OBJFWDP (valcontents
)
3280 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
3281 where
= XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
3285 /* We're not using the `unused' slot in the specbinding
3286 structure because this would mean we have to do more
3287 work for simple variables. */
3288 specpdl_ptr
->symbol
= Fcons (symbol
, Fcons (where
, current_buffer
));
3290 /* If SYMBOL is a per-buffer variable which doesn't have a
3291 buffer-local value here, make the `let' change the global
3292 value by changing the value of SYMBOL in all buffers not
3293 having their own value. This is consistent with what
3294 happens with other buffer-local variables. */
3296 && BUFFER_OBJFWDP (valcontents
))
3299 Fset_default (symbol
, value
);
3304 specpdl_ptr
->symbol
= symbol
;
3307 if (BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
))
3308 store_symval_forwarding (symbol
, ovalue
, value
, NULL
);
3310 set_internal (symbol
, value
, 0, 1);
3315 record_unwind_protect (function
, arg
)
3316 Lisp_Object (*function
) P_ ((Lisp_Object
));
3319 eassert (!handling_signal
);
3321 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3323 specpdl_ptr
->func
= function
;
3324 specpdl_ptr
->symbol
= Qnil
;
3325 specpdl_ptr
->old_value
= arg
;
3330 unbind_to (count
, value
)
3334 Lisp_Object quitf
= Vquit_flag
;
3335 struct gcpro gcpro1
, gcpro2
;
3337 GCPRO2 (value
, quitf
);
3340 while (specpdl_ptr
!= specpdl
+ count
)
3342 /* Copy the binding, and decrement specpdl_ptr, before we do
3343 the work to unbind it. We decrement first
3344 so that an error in unbinding won't try to unbind
3345 the same entry again, and we copy the binding first
3346 in case more bindings are made during some of the code we run. */
3348 struct specbinding this_binding
;
3349 this_binding
= *--specpdl_ptr
;
3351 if (this_binding
.func
!= 0)
3352 (*this_binding
.func
) (this_binding
.old_value
);
3353 /* If the symbol is a list, it is really (SYMBOL WHERE
3354 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3355 frame. If WHERE is a buffer or frame, this indicates we
3356 bound a variable that had a buffer-local or frame-local
3357 binding. WHERE nil means that the variable had the default
3358 value when it was bound. CURRENT-BUFFER is the buffer that
3359 was current when the variable was bound. */
3360 else if (CONSP (this_binding
.symbol
))
3362 Lisp_Object symbol
, where
;
3364 symbol
= XCAR (this_binding
.symbol
);
3365 where
= XCAR (XCDR (this_binding
.symbol
));
3368 Fset_default (symbol
, this_binding
.old_value
);
3369 else if (BUFFERP (where
))
3370 set_internal (symbol
, this_binding
.old_value
, XBUFFER (where
), 1);
3372 set_internal (symbol
, this_binding
.old_value
, NULL
, 1);
3376 /* If variable has a trivial value (no forwarding), we can
3377 just set it. No need to check for constant symbols here,
3378 since that was already done by specbind. */
3379 if (!MISCP (SYMBOL_VALUE (this_binding
.symbol
)))
3380 SET_SYMBOL_VALUE (this_binding
.symbol
, this_binding
.old_value
);
3382 set_internal (this_binding
.symbol
, this_binding
.old_value
, 0, 1);
3386 if (NILP (Vquit_flag
) && !NILP (quitf
))
3393 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3394 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3395 The debugger is entered when that frame exits, if the flag is non-nil. */)
3397 Lisp_Object level
, flag
;
3399 register struct backtrace
*backlist
= backtrace_list
;
3402 CHECK_NUMBER (level
);
3404 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
3406 backlist
= backlist
->next
;
3410 backlist
->debug_on_exit
= !NILP (flag
);
3415 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3416 doc
: /* Print a trace of Lisp function calls currently active.
3417 Output stream used is value of `standard-output'. */)
3420 register struct backtrace
*backlist
= backtrace_list
;
3424 extern Lisp_Object Vprint_level
;
3425 struct gcpro gcpro1
;
3427 XSETFASTINT (Vprint_level
, 3);
3434 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
3435 if (backlist
->nargs
== UNEVALLED
)
3437 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
3438 write_string ("\n", -1);
3442 tem
= *backlist
->function
;
3443 Fprin1 (tem
, Qnil
); /* This can QUIT */
3444 write_string ("(", -1);
3445 if (backlist
->nargs
== MANY
)
3447 for (tail
= *backlist
->args
, i
= 0;
3449 tail
= Fcdr (tail
), i
++)
3451 if (i
) write_string (" ", -1);
3452 Fprin1 (Fcar (tail
), Qnil
);
3457 for (i
= 0; i
< backlist
->nargs
; i
++)
3459 if (i
) write_string (" ", -1);
3460 Fprin1 (backlist
->args
[i
], Qnil
);
3463 write_string (")\n", -1);
3465 backlist
= backlist
->next
;
3468 Vprint_level
= Qnil
;
3473 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, NULL
,
3474 doc
: /* Return the function and arguments NFRAMES up from current execution point.
3475 If that frame has not evaluated the arguments yet (or is a special form),
3476 the value is (nil FUNCTION ARG-FORMS...).
3477 If that frame has evaluated its arguments and called its function already,
3478 the value is (t FUNCTION ARG-VALUES...).
3479 A &rest arg is represented as the tail of the list ARG-VALUES.
3480 FUNCTION is whatever was supplied as car of evaluated list,
3481 or a lambda expression for macro calls.
3482 If NFRAMES is more than the number of frames, the value is nil. */)
3484 Lisp_Object nframes
;
3486 register struct backtrace
*backlist
= backtrace_list
;
3490 CHECK_NATNUM (nframes
);
3492 /* Find the frame requested. */
3493 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3494 backlist
= backlist
->next
;
3498 if (backlist
->nargs
== UNEVALLED
)
3499 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3502 if (backlist
->nargs
== MANY
)
3503 tem
= *backlist
->args
;
3505 tem
= Flist (backlist
->nargs
, backlist
->args
);
3507 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3515 register struct backtrace
*backlist
;
3518 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3520 mark_object (*backlist
->function
);
3522 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3525 i
= backlist
->nargs
- 1;
3527 mark_object (backlist
->args
[i
]);
3534 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
3535 doc
: /* *Limit on number of Lisp variable bindings and `unwind-protect's.
3536 If Lisp code tries to increase the total number past this amount,
3537 an error is signaled.
3538 You can safely use a value considerably larger than the default value,
3539 if that proves inconveniently small. However, if you increase it too far,
3540 Emacs could run out of memory trying to make the stack bigger. */);
3542 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
3543 doc
: /* *Limit on depth in `eval', `apply' and `funcall' before error.
3545 This limit serves to catch infinite recursions for you before they cause
3546 actual stack overflow in C, which would be fatal for Emacs.
3547 You can safely make it considerably larger than its default value,
3548 if that proves inconveniently small. However, if you increase it too far,
3549 Emacs could overflow the real C stack, and crash. */);
3551 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
3552 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3553 If the value is t, that means do an ordinary quit.
3554 If the value equals `throw-on-input', that means quit by throwing
3555 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3556 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3557 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3560 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
3561 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3562 Note that `quit-flag' will still be set by typing C-g,
3563 so a quit will be signaled as soon as `inhibit-quit' is nil.
3564 To prevent this happening, set `quit-flag' to nil
3565 before making `inhibit-quit' nil. */);
3566 Vinhibit_quit
= Qnil
;
3568 Qinhibit_quit
= intern ("inhibit-quit");
3569 staticpro (&Qinhibit_quit
);
3571 Qautoload
= intern ("autoload");
3572 staticpro (&Qautoload
);
3574 Qdebug_on_error
= intern ("debug-on-error");
3575 staticpro (&Qdebug_on_error
);
3577 Qmacro
= intern ("macro");
3578 staticpro (&Qmacro
);
3580 Qdeclare
= intern ("declare");
3581 staticpro (&Qdeclare
);
3583 /* Note that the process handling also uses Qexit, but we don't want
3584 to staticpro it twice, so we just do it here. */
3585 Qexit
= intern ("exit");
3588 Qinteractive
= intern ("interactive");
3589 staticpro (&Qinteractive
);
3591 Qcommandp
= intern ("commandp");
3592 staticpro (&Qcommandp
);
3594 Qdefun
= intern ("defun");
3595 staticpro (&Qdefun
);
3597 Qand_rest
= intern ("&rest");
3598 staticpro (&Qand_rest
);
3600 Qand_optional
= intern ("&optional");
3601 staticpro (&Qand_optional
);
3603 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
3604 doc
: /* *Non-nil means errors display a backtrace buffer.
3605 More precisely, this happens for any error that is handled
3606 by the editor command loop.
3607 If the value is a list, an error only means to display a backtrace
3608 if one of its condition symbols appears in the list. */);
3609 Vstack_trace_on_error
= Qnil
;
3611 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
3612 doc
: /* *Non-nil means enter debugger if an error is signaled.
3613 Does not apply to errors handled by `condition-case' or those
3614 matched by `debug-ignored-errors'.
3615 If the value is a list, an error only means to enter the debugger
3616 if one of its condition symbols appears in the list.
3617 When you evaluate an expression interactively, this variable
3618 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3619 See also variable `debug-on-quit'. */);
3620 Vdebug_on_error
= Qnil
;
3622 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
3623 doc
: /* *List of errors for which the debugger should not be called.
3624 Each element may be a condition-name or a regexp that matches error messages.
3625 If any element applies to a given error, that error skips the debugger
3626 and just returns to top level.
3627 This overrides the variable `debug-on-error'.
3628 It does not apply to errors handled by `condition-case'. */);
3629 Vdebug_ignored_errors
= Qnil
;
3631 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
3632 doc
: /* *Non-nil means enter debugger if quit is signaled (C-g, for example).
3633 Does not apply if quit is handled by a `condition-case'. */);
3636 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
3637 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3639 DEFVAR_BOOL ("debugger-may-continue", &debugger_may_continue
,
3640 doc
: /* Non-nil means debugger may continue execution.
3641 This is nil when the debugger is called under circumstances where it
3642 might not be safe to continue. */);
3643 debugger_may_continue
= 1;
3645 DEFVAR_LISP ("debugger", &Vdebugger
,
3646 doc
: /* Function to call to invoke debugger.
3647 If due to frame exit, args are `exit' and the value being returned;
3648 this function's value will be returned instead of that.
3649 If due to error, args are `error' and a list of the args to `signal'.
3650 If due to `apply' or `funcall' entry, one arg, `lambda'.
3651 If due to `eval' entry, one arg, t. */);
3654 DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function
,
3655 doc
: /* If non-nil, this is a function for `signal' to call.
3656 It receives the same arguments that `signal' was given.
3657 The Edebug package uses this to regain control. */);
3658 Vsignal_hook_function
= Qnil
;
3660 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal
,
3661 doc
: /* *Non-nil means call the debugger regardless of condition handlers.
3662 Note that `debug-on-error', `debug-on-quit' and friends
3663 still determine whether to handle the particular condition. */);
3664 Vdebug_on_signal
= Qnil
;
3666 DEFVAR_LISP ("macro-declaration-function", &Vmacro_declaration_function
,
3667 doc
: /* Function to process declarations in a macro definition.
3668 The function will be called with two args MACRO and DECL.
3669 MACRO is the name of the macro being defined.
3670 DECL is a list `(declare ...)' containing the declarations.
3671 The value the function returns is not used. */);
3672 Vmacro_declaration_function
= Qnil
;
3674 Vrun_hooks
= intern ("run-hooks");
3675 staticpro (&Vrun_hooks
);
3677 staticpro (&Vautoload_queue
);
3678 Vautoload_queue
= Qnil
;
3679 staticpro (&Vsignaling_function
);
3680 Vsignaling_function
= Qnil
;
3691 defsubr (&Sfunction
);
3693 defsubr (&Sdefmacro
);
3695 defsubr (&Sdefvaralias
);
3696 defsubr (&Sdefconst
);
3697 defsubr (&Suser_variable_p
);
3701 defsubr (&Smacroexpand
);
3704 defsubr (&Sunwind_protect
);
3705 defsubr (&Scondition_case
);
3707 defsubr (&Sinteractive_p
);
3708 defsubr (&Scalled_interactively_p
);
3709 defsubr (&Scommandp
);
3710 defsubr (&Sautoload
);
3713 defsubr (&Sfuncall
);
3714 defsubr (&Srun_hooks
);
3715 defsubr (&Srun_hook_with_args
);
3716 defsubr (&Srun_hook_with_args_until_success
);
3717 defsubr (&Srun_hook_with_args_until_failure
);
3718 defsubr (&Sfetch_bytecode
);
3719 defsubr (&Sbacktrace_debug
);
3720 defsubr (&Sbacktrace
);
3721 defsubr (&Sbacktrace_frame
);
3724 /* arch-tag: 014a07aa-33ab-4a8f-a3d2-ee8a4a9ff7fb
3725 (do not change this comment) */