1 /* Evaluator for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1999, 2000, 2001,
3 2002, 2003, 2004, 2005, 2006, 2007, 2008
4 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
24 #include "blockinput.h"
27 #include "dispextern.h"
34 /* This definition is duplicated in alloc.c and keyboard.c */
35 /* Putting it in lisp.h makes cc bomb out! */
39 struct backtrace
*next
;
40 Lisp_Object
*function
;
41 Lisp_Object
*args
; /* Points to vector of args. */
42 int nargs
; /* Length of vector.
43 If nargs is UNEVALLED, args points to slot holding
44 list of unevalled args */
46 /* Nonzero means call value of debugger when done with this operation. */
50 struct backtrace
*backtrace_list
;
52 /* This structure helps implement the `catch' and `throw' control
53 structure. A struct catchtag contains all the information needed
54 to restore the state of the interpreter after a non-local jump.
56 Handlers for error conditions (represented by `struct handler'
57 structures) just point to a catch tag to do the cleanup required
60 catchtag structures are chained together in the C calling stack;
61 the `next' member points to the next outer catchtag.
63 A call like (throw TAG VAL) searches for a catchtag whose `tag'
64 member is TAG, and then unbinds to it. The `val' member is used to
65 hold VAL while the stack is unwound; `val' is returned as the value
68 All the other members are concerned with restoring the interpreter
75 struct catchtag
*next
;
78 struct backtrace
*backlist
;
79 struct handler
*handlerlist
;
82 int poll_suppress_count
;
83 int interrupt_input_blocked
;
84 struct byte_stack
*byte_stack
;
87 struct catchtag
*catchlist
;
90 /* Count levels of GCPRO to detect failure to UNGCPRO. */
94 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
95 Lisp_Object Qinhibit_quit
, Vinhibit_quit
, Vquit_flag
;
96 Lisp_Object Qand_rest
, Qand_optional
;
97 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 extern Lisp_Object Qfunction
;
206 static Lisp_Object funcall_lambda
P_ ((Lisp_Object
, int, Lisp_Object
*));
207 static void unwind_to_catch
P_ ((struct catchtag
*, Lisp_Object
)) NO_RETURN
;
210 /* "gcc -O3" enables automatic function inlining, which optimizes out
211 the arguments for the invocations of these functions, whereas they
212 expect these values on the stack. */
213 Lisp_Object
apply1 () __attribute__((noinline
));
214 Lisp_Object
call2 () __attribute__((noinline
));
221 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
222 specpdl_ptr
= specpdl
;
223 /* Don't forget to update docs (lispref node "Local Variables"). */
224 max_specpdl_size
= 1000;
225 max_lisp_eval_depth
= 400;
233 specpdl_ptr
= specpdl
;
238 debug_on_next_call
= 0;
243 /* This is less than the initial value of num_nonmacro_input_events. */
244 when_entered_debugger
= -1;
247 /* unwind-protect function used by call_debugger. */
250 restore_stack_limits (data
)
253 max_specpdl_size
= XINT (XCAR (data
));
254 max_lisp_eval_depth
= XINT (XCDR (data
));
258 /* Call the Lisp debugger, giving it argument ARG. */
264 int debug_while_redisplaying
;
265 int count
= SPECPDL_INDEX ();
267 int old_max
= max_specpdl_size
;
269 /* Temporarily bump up the stack limits,
270 so the debugger won't run out of stack. */
272 max_specpdl_size
+= 1;
273 record_unwind_protect (restore_stack_limits
,
274 Fcons (make_number (old_max
),
275 make_number (max_lisp_eval_depth
)));
276 max_specpdl_size
= old_max
;
278 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
279 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
281 if (SPECPDL_INDEX () + 100 > max_specpdl_size
)
282 max_specpdl_size
= SPECPDL_INDEX () + 100;
284 #ifdef HAVE_WINDOW_SYSTEM
285 if (display_hourglass_p
)
289 debug_on_next_call
= 0;
290 when_entered_debugger
= num_nonmacro_input_events
;
292 /* Resetting redisplaying_p to 0 makes sure that debug output is
293 displayed if the debugger is invoked during redisplay. */
294 debug_while_redisplaying
= redisplaying_p
;
296 specbind (intern ("debugger-may-continue"),
297 debug_while_redisplaying
? Qnil
: Qt
);
298 specbind (Qinhibit_redisplay
, Qnil
);
299 specbind (Qdebug_on_error
, Qnil
);
301 #if 0 /* Binding this prevents execution of Lisp code during
302 redisplay, which necessarily leads to display problems. */
303 specbind (Qinhibit_eval_during_redisplay
, Qt
);
306 val
= apply1 (Vdebugger
, arg
);
308 /* Interrupting redisplay and resuming it later is not safe under
309 all circumstances. So, when the debugger returns, abort the
310 interrupted redisplay by going back to the top-level. */
311 if (debug_while_redisplaying
)
314 return unbind_to (count
, val
);
318 do_debug_on_call (code
)
321 debug_on_next_call
= 0;
322 backtrace_list
->debug_on_exit
= 1;
323 call_debugger (Fcons (code
, Qnil
));
326 /* NOTE!!! Every function that can call EVAL must protect its args
327 and temporaries from garbage collection while it needs them.
328 The definition of `For' shows what you have to do. */
330 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
331 doc
: /* Eval args until one of them yields non-nil, then return that value.
332 The remaining args are not evalled at all.
333 If all args return nil, return nil.
334 usage: (or CONDITIONS...) */)
338 register Lisp_Object val
= Qnil
;
345 val
= Feval (XCAR (args
));
355 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
356 doc
: /* Eval args until one of them yields nil, then return nil.
357 The remaining args are not evalled at all.
358 If no arg yields nil, return the last arg's value.
359 usage: (and CONDITIONS...) */)
363 register Lisp_Object val
= Qt
;
370 val
= Feval (XCAR (args
));
380 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
381 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
382 Returns the value of THEN or the value of the last of the ELSE's.
383 THEN must be one expression, but ELSE... can be zero or more expressions.
384 If COND yields nil, and there are no ELSE's, the value is nil.
385 usage: (if COND THEN ELSE...) */)
389 register Lisp_Object cond
;
393 cond
= Feval (Fcar (args
));
397 return Feval (Fcar (Fcdr (args
)));
398 return Fprogn (Fcdr (Fcdr (args
)));
401 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
402 doc
: /* Try each clause until one succeeds.
403 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
404 and, if the value is non-nil, this clause succeeds:
405 then the expressions in BODY are evaluated and the last one's
406 value is the value of the cond-form.
407 If no clause succeeds, cond returns nil.
408 If a clause has one element, as in (CONDITION),
409 CONDITION's value if non-nil is returned from the cond-form.
410 usage: (cond CLAUSES...) */)
414 register Lisp_Object clause
, val
;
421 clause
= Fcar (args
);
422 val
= Feval (Fcar (clause
));
425 if (!EQ (XCDR (clause
), Qnil
))
426 val
= Fprogn (XCDR (clause
));
436 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
437 doc
: /* Eval BODY forms sequentially and return value of last one.
438 usage: (progn BODY...) */)
442 register Lisp_Object val
= Qnil
;
449 val
= Feval (XCAR (args
));
457 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
458 doc
: /* Eval FIRST and BODY sequentially; value from FIRST.
459 The value of FIRST is saved during the evaluation of the remaining args,
460 whose values are discarded.
461 usage: (prog1 FIRST BODY...) */)
466 register Lisp_Object args_left
;
467 struct gcpro gcpro1
, gcpro2
;
468 register int argnum
= 0;
480 val
= Feval (Fcar (args_left
));
482 Feval (Fcar (args_left
));
483 args_left
= Fcdr (args_left
);
485 while (!NILP(args_left
));
491 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
492 doc
: /* Eval FORM1, FORM2 and BODY sequentially; value from FORM2.
493 The value of FORM2 is saved during the evaluation of the
494 remaining args, whose values are discarded.
495 usage: (prog2 FORM1 FORM2 BODY...) */)
500 register Lisp_Object args_left
;
501 struct gcpro gcpro1
, gcpro2
;
502 register int argnum
= -1;
516 val
= Feval (Fcar (args_left
));
518 Feval (Fcar (args_left
));
519 args_left
= Fcdr (args_left
);
521 while (!NILP (args_left
));
527 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
528 doc
: /* Set each SYM to the value of its VAL.
529 The symbols SYM are variables; they are literal (not evaluated).
530 The values VAL are expressions; they are evaluated.
531 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
532 The second VAL is not computed until after the first SYM is set, and so on;
533 each VAL can use the new value of variables set earlier in the `setq'.
534 The return value of the `setq' form is the value of the last VAL.
535 usage: (setq [SYM VAL]...) */)
539 register Lisp_Object args_left
;
540 register Lisp_Object val
, sym
;
551 val
= Feval (Fcar (Fcdr (args_left
)));
552 sym
= Fcar (args_left
);
554 args_left
= Fcdr (Fcdr (args_left
));
556 while (!NILP(args_left
));
562 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
563 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
564 usage: (quote ARG) */)
568 if (!NILP (Fcdr (args
)))
569 xsignal2 (Qwrong_number_of_arguments
, Qquote
, Flength (args
));
573 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
574 doc
: /* Like `quote', but preferred for objects which are functions.
575 In byte compilation, `function' causes its argument to be compiled.
576 `quote' cannot do that.
577 usage: (function ARG) */)
581 if (!NILP (Fcdr (args
)))
582 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
587 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
588 doc
: /* Return t if the function was run directly by user input.
589 This means that the function was called with `call-interactively'
590 \(which includes being called as the binding of a key)
591 and input is currently coming from the keyboard (not in keyboard macro),
592 and Emacs is not running in batch mode (`noninteractive' is nil).
594 The only known proper use of `interactive-p' is in deciding whether to
595 display a helpful message, or how to display it. If you're thinking
596 of using it for any other purpose, it is quite likely that you're
597 making a mistake. Think: what do you want to do when the command is
598 called from a keyboard macro?
600 If you want to test whether your function was called with
601 `call-interactively', the way to do that is by adding an extra
602 optional argument, and making the `interactive' spec specify non-nil
603 unconditionally for that argument. (`p' is a good way to do this.) */)
606 return (INTERACTIVE
&& interactive_p (1)) ? Qt
: Qnil
;
610 DEFUN ("called-interactively-p", Fcalled_interactively_p
, Scalled_interactively_p
, 0, 0, 0,
611 doc
: /* Return t if the function using this was called with `call-interactively'.
612 This is used for implementing advice and other function-modifying
615 The cleanest way to test whether your function was called with
616 `call-interactively' is by adding an extra optional argument,
617 and making the `interactive' spec specify non-nil unconditionally
618 for that argument. (`p' is a good way to do this.) */)
621 return interactive_p (1) ? Qt
: Qnil
;
625 /* Return 1 if function in which this appears was called using
628 EXCLUDE_SUBRS_P non-zero means always return 0 if the function
629 called is a built-in. */
632 interactive_p (exclude_subrs_p
)
635 struct backtrace
*btp
;
638 btp
= backtrace_list
;
640 /* If this isn't a byte-compiled function, there may be a frame at
641 the top for Finteractive_p. If so, skip it. */
642 fun
= Findirect_function (*btp
->function
, Qnil
);
643 if (SUBRP (fun
) && (XSUBR (fun
) == &Sinteractive_p
644 || XSUBR (fun
) == &Scalled_interactively_p
))
647 /* If we're running an Emacs 18-style byte-compiled function, there
648 may be a frame for Fbytecode at the top level. In any version of
649 Emacs there can be Fbytecode frames for subexpressions evaluated
650 inside catch and condition-case. Skip past them.
652 If this isn't a byte-compiled function, then we may now be
653 looking at several frames for special forms. Skip past them. */
655 && (EQ (*btp
->function
, Qbytecode
)
656 || btp
->nargs
== UNEVALLED
))
659 /* btp now points at the frame of the innermost function that isn't
660 a special form, ignoring frames for Finteractive_p and/or
661 Fbytecode at the top. If this frame is for a built-in function
662 (such as load or eval-region) return nil. */
663 fun
= Findirect_function (*btp
->function
, Qnil
);
664 if (exclude_subrs_p
&& SUBRP (fun
))
667 /* btp points to the frame of a Lisp function that called interactive-p.
668 Return t if that function was called interactively. */
669 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
675 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
676 doc
: /* Define NAME as a function.
677 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
678 See also the function `interactive'.
679 usage: (defun NAME ARGLIST [DOCSTRING] BODY...) */)
683 register Lisp_Object fn_name
;
684 register Lisp_Object defn
;
686 fn_name
= Fcar (args
);
687 CHECK_SYMBOL (fn_name
);
688 defn
= Fcons (Qlambda
, Fcdr (args
));
689 if (!NILP (Vpurify_flag
))
690 defn
= Fpurecopy (defn
);
691 if (CONSP (XSYMBOL (fn_name
)->function
)
692 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
693 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
694 Ffset (fn_name
, defn
);
695 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
699 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
700 doc
: /* Define NAME as a macro.
701 The actual definition looks like
702 (macro lambda ARGLIST [DOCSTRING] [DECL] BODY...).
703 When the macro is called, as in (NAME ARGS...),
704 the function (lambda ARGLIST BODY...) is applied to
705 the list ARGS... as it appears in the expression,
706 and the result should be a form to be evaluated instead of the original.
708 DECL is a declaration, optional, which can specify how to indent
709 calls to this macro and how Edebug should handle it. It looks like this:
711 The elements can look like this:
713 Set NAME's `lisp-indent-function' property to INDENT.
716 Set NAME's `edebug-form-spec' property to DEBUG. (This is
717 equivalent to writing a `def-edebug-spec' for the macro.)
718 usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */)
722 register Lisp_Object fn_name
;
723 register Lisp_Object defn
;
724 Lisp_Object lambda_list
, doc
, tail
;
726 fn_name
= Fcar (args
);
727 CHECK_SYMBOL (fn_name
);
728 lambda_list
= Fcar (Fcdr (args
));
729 tail
= Fcdr (Fcdr (args
));
732 if (STRINGP (Fcar (tail
)))
738 while (CONSP (Fcar (tail
))
739 && EQ (Fcar (Fcar (tail
)), Qdeclare
))
741 if (!NILP (Vmacro_declaration_function
))
745 call2 (Vmacro_declaration_function
, fn_name
, Fcar (tail
));
753 tail
= Fcons (lambda_list
, tail
);
755 tail
= Fcons (lambda_list
, Fcons (doc
, tail
));
756 defn
= Fcons (Qmacro
, Fcons (Qlambda
, tail
));
758 if (!NILP (Vpurify_flag
))
759 defn
= Fpurecopy (defn
);
760 if (CONSP (XSYMBOL (fn_name
)->function
)
761 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
762 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
763 Ffset (fn_name
, defn
);
764 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
769 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
770 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
771 Aliased variables always have the same value; setting one sets the other.
772 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
773 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
774 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
775 itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
776 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
777 The return value is BASE-VARIABLE. */)
778 (new_alias
, base_variable
, docstring
)
779 Lisp_Object new_alias
, base_variable
, docstring
;
781 struct Lisp_Symbol
*sym
;
783 CHECK_SYMBOL (new_alias
);
784 CHECK_SYMBOL (base_variable
);
786 if (SYMBOL_CONSTANT_P (new_alias
))
787 error ("Cannot make a constant an alias");
789 sym
= XSYMBOL (new_alias
);
790 /* http://lists.gnu.org/archive/html/emacs-devel/2008-04/msg00834.html
791 If n_a is bound, but b_v is not, set the value of b_v to n_a.
792 This is for the sake of define-obsolete-variable-alias and user
794 if (NILP (Fboundp (base_variable
)) && !NILP (Fboundp (new_alias
)))
795 XSYMBOL(base_variable
)->value
= sym
->value
;
796 sym
->indirect_variable
= 1;
797 sym
->value
= base_variable
;
798 sym
->constant
= SYMBOL_CONSTANT_P (base_variable
);
799 LOADHIST_ATTACH (new_alias
);
800 if (!NILP (docstring
))
801 Fput (new_alias
, Qvariable_documentation
, docstring
);
803 Fput (new_alias
, Qvariable_documentation
, Qnil
);
805 return base_variable
;
809 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
810 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
811 You are not required to define a variable in order to use it,
812 but the definition can supply documentation and an initial value
813 in a way that tags can recognize.
815 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.
816 If SYMBOL is buffer-local, its default value is what is set;
817 buffer-local values are not affected.
818 INITVALUE and DOCSTRING are optional.
819 If DOCSTRING starts with *, this variable is identified as a user option.
820 This means that M-x set-variable recognizes it.
821 See also `user-variable-p'.
822 If INITVALUE is missing, SYMBOL's value is not set.
824 If SYMBOL has a local binding, then this form affects the local
825 binding. This is usually not what you want. Thus, if you need to
826 load a file defining variables, with this form or with `defconst' or
827 `defcustom', you should always load that file _outside_ any bindings
828 for these variables. \(`defconst' and `defcustom' behave similarly in
830 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
834 register Lisp_Object sym
, tem
, tail
;
838 if (!NILP (Fcdr (Fcdr (tail
))))
839 error ("Too many arguments");
841 tem
= Fdefault_boundp (sym
);
844 if (SYMBOL_CONSTANT_P (sym
))
846 /* For upward compatibility, allow (defvar :foo (quote :foo)). */
847 Lisp_Object tem
= Fcar (tail
);
849 && EQ (XCAR (tem
), Qquote
)
850 && CONSP (XCDR (tem
))
851 && EQ (XCAR (XCDR (tem
)), sym
)))
852 error ("Constant symbol `%s' specified in defvar",
853 SDATA (SYMBOL_NAME (sym
)));
857 Fset_default (sym
, Feval (Fcar (tail
)));
859 { /* Check if there is really a global binding rather than just a let
860 binding that shadows the global unboundness of the var. */
861 volatile struct specbinding
*pdl
= specpdl_ptr
;
862 while (--pdl
>= specpdl
)
864 if (EQ (pdl
->symbol
, sym
) && !pdl
->func
865 && EQ (pdl
->old_value
, Qunbound
))
867 message_with_string ("Warning: defvar ignored because %s is let-bound",
868 SYMBOL_NAME (sym
), 1);
877 if (!NILP (Vpurify_flag
))
878 tem
= Fpurecopy (tem
);
879 Fput (sym
, Qvariable_documentation
, tem
);
881 LOADHIST_ATTACH (sym
);
884 /* Simple (defvar <var>) should not count as a definition at all.
885 It could get in the way of other definitions, and unloading this
886 package could try to make the variable unbound. */
892 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
893 doc
: /* Define SYMBOL as a constant variable.
894 The intent is that neither programs nor users should ever change this value.
895 Always sets the value of SYMBOL to the result of evalling INITVALUE.
896 If SYMBOL is buffer-local, its default value is what is set;
897 buffer-local values are not affected.
898 DOCSTRING is optional.
900 If SYMBOL has a local binding, then this form sets the local binding's
901 value. However, you should normally not make local bindings for
902 variables defined with this form.
903 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
907 register Lisp_Object sym
, tem
;
910 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
911 error ("Too many arguments");
913 tem
= Feval (Fcar (Fcdr (args
)));
914 if (!NILP (Vpurify_flag
))
915 tem
= Fpurecopy (tem
);
916 Fset_default (sym
, tem
);
917 tem
= Fcar (Fcdr (Fcdr (args
)));
920 if (!NILP (Vpurify_flag
))
921 tem
= Fpurecopy (tem
);
922 Fput (sym
, Qvariable_documentation
, tem
);
924 Fput (sym
, Qrisky_local_variable
, Qt
);
925 LOADHIST_ATTACH (sym
);
929 /* Error handler used in Fuser_variable_p. */
931 user_variable_p_eh (ignore
)
937 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
938 doc
: /* Return t if VARIABLE is intended to be set and modified by users.
939 \(The alternative is a variable used internally in a Lisp program.)
940 A variable is a user variable if
941 \(1) the first character of its documentation is `*', or
942 \(2) it is customizable (its property list contains a non-nil value
943 of `standard-value' or `custom-autoload'), or
944 \(3) it is an alias for another user variable.
945 Return nil if VARIABLE is an alias and there is a loop in the
946 chain of symbols. */)
948 Lisp_Object variable
;
950 Lisp_Object documentation
;
952 if (!SYMBOLP (variable
))
955 /* If indirect and there's an alias loop, don't check anything else. */
956 if (XSYMBOL (variable
)->indirect_variable
957 && NILP (internal_condition_case_1 (indirect_variable
, variable
,
958 Qt
, user_variable_p_eh
)))
963 documentation
= Fget (variable
, Qvariable_documentation
);
964 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
966 if (STRINGP (documentation
)
967 && ((unsigned char) SREF (documentation
, 0) == '*'))
969 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
970 if (CONSP (documentation
)
971 && STRINGP (XCAR (documentation
))
972 && INTEGERP (XCDR (documentation
))
973 && XINT (XCDR (documentation
)) < 0)
975 /* Customizable? See `custom-variable-p'. */
976 if ((!NILP (Fget (variable
, intern ("standard-value"))))
977 || (!NILP (Fget (variable
, intern ("custom-autoload")))))
980 if (!XSYMBOL (variable
)->indirect_variable
)
983 /* An indirect variable? Let's follow the chain. */
984 variable
= XSYMBOL (variable
)->value
;
988 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
989 doc
: /* Bind variables according to VARLIST then eval BODY.
990 The value of the last form in BODY is returned.
991 Each element of VARLIST is a symbol (which is bound to nil)
992 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
993 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
994 usage: (let* VARLIST BODY...) */)
998 Lisp_Object varlist
, val
, elt
;
999 int count
= SPECPDL_INDEX ();
1000 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1002 GCPRO3 (args
, elt
, varlist
);
1004 varlist
= Fcar (args
);
1005 while (!NILP (varlist
))
1008 elt
= Fcar (varlist
);
1010 specbind (elt
, Qnil
);
1011 else if (! NILP (Fcdr (Fcdr (elt
))))
1012 signal_error ("`let' bindings can have only one value-form", elt
);
1015 val
= Feval (Fcar (Fcdr (elt
)));
1016 specbind (Fcar (elt
), val
);
1018 varlist
= Fcdr (varlist
);
1021 val
= Fprogn (Fcdr (args
));
1022 return unbind_to (count
, val
);
1025 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
1026 doc
: /* Bind variables according to VARLIST then eval BODY.
1027 The value of the last form in BODY is returned.
1028 Each element of VARLIST is a symbol (which is bound to nil)
1029 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
1030 All the VALUEFORMs are evalled before any symbols are bound.
1031 usage: (let VARLIST BODY...) */)
1035 Lisp_Object
*temps
, tem
;
1036 register Lisp_Object elt
, varlist
;
1037 int count
= SPECPDL_INDEX ();
1038 register int argnum
;
1039 struct gcpro gcpro1
, gcpro2
;
1041 varlist
= Fcar (args
);
1043 /* Make space to hold the values to give the bound variables */
1044 elt
= Flength (varlist
);
1045 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
1047 /* Compute the values and store them in `temps' */
1049 GCPRO2 (args
, *temps
);
1052 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
1055 elt
= XCAR (varlist
);
1057 temps
[argnum
++] = Qnil
;
1058 else if (! NILP (Fcdr (Fcdr (elt
))))
1059 signal_error ("`let' bindings can have only one value-form", elt
);
1061 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
1062 gcpro2
.nvars
= argnum
;
1066 varlist
= Fcar (args
);
1067 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
1069 elt
= XCAR (varlist
);
1070 tem
= temps
[argnum
++];
1072 specbind (elt
, tem
);
1074 specbind (Fcar (elt
), tem
);
1077 elt
= Fprogn (Fcdr (args
));
1078 return unbind_to (count
, elt
);
1081 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
1082 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
1083 The order of execution is thus TEST, BODY, TEST, BODY and so on
1084 until TEST returns nil.
1085 usage: (while TEST BODY...) */)
1089 Lisp_Object test
, body
;
1090 struct gcpro gcpro1
, gcpro2
;
1092 GCPRO2 (test
, body
);
1096 while (!NILP (Feval (test
)))
1106 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
1107 doc
: /* Return result of expanding macros at top level of FORM.
1108 If FORM is not a macro call, it is returned unchanged.
1109 Otherwise, the macro is expanded and the expansion is considered
1110 in place of FORM. When a non-macro-call results, it is returned.
1112 The second optional arg ENVIRONMENT specifies an environment of macro
1113 definitions to shadow the loaded ones for use in file byte-compilation. */)
1116 Lisp_Object environment
;
1118 /* With cleanups from Hallvard Furuseth. */
1119 register Lisp_Object expander
, sym
, def
, tem
;
1123 /* Come back here each time we expand a macro call,
1124 in case it expands into another macro call. */
1127 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1128 def
= sym
= XCAR (form
);
1130 /* Trace symbols aliases to other symbols
1131 until we get a symbol that is not an alias. */
1132 while (SYMBOLP (def
))
1136 tem
= Fassq (sym
, environment
);
1139 def
= XSYMBOL (sym
)->function
;
1140 if (!EQ (def
, Qunbound
))
1145 /* Right now TEM is the result from SYM in ENVIRONMENT,
1146 and if TEM is nil then DEF is SYM's function definition. */
1149 /* SYM is not mentioned in ENVIRONMENT.
1150 Look at its function definition. */
1151 if (EQ (def
, Qunbound
) || !CONSP (def
))
1152 /* Not defined or definition not suitable */
1154 if (EQ (XCAR (def
), Qautoload
))
1156 /* Autoloading function: will it be a macro when loaded? */
1157 tem
= Fnth (make_number (4), def
);
1158 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
1159 /* Yes, load it and try again. */
1161 struct gcpro gcpro1
;
1163 do_autoload (def
, sym
);
1170 else if (!EQ (XCAR (def
), Qmacro
))
1172 else expander
= XCDR (def
);
1176 expander
= XCDR (tem
);
1177 if (NILP (expander
))
1180 form
= apply1 (expander
, XCDR (form
));
1185 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1186 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1187 TAG is evalled to get the tag to use; it must not be nil.
1189 Then the BODY is executed.
1190 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
1191 If no throw happens, `catch' returns the value of the last BODY form.
1192 If a throw happens, it specifies the value to return from `catch'.
1193 usage: (catch TAG BODY...) */)
1197 register Lisp_Object tag
;
1198 struct gcpro gcpro1
;
1201 tag
= Feval (Fcar (args
));
1203 return internal_catch (tag
, Fprogn
, Fcdr (args
));
1206 /* Set up a catch, then call C function FUNC on argument ARG.
1207 FUNC should return a Lisp_Object.
1208 This is how catches are done from within C code. */
1211 internal_catch (tag
, func
, arg
)
1213 Lisp_Object (*func
) ();
1216 /* This structure is made part of the chain `catchlist'. */
1219 /* Fill in the components of c, and put it on the list. */
1223 c
.backlist
= backtrace_list
;
1224 c
.handlerlist
= handlerlist
;
1225 c
.lisp_eval_depth
= lisp_eval_depth
;
1226 c
.pdlcount
= SPECPDL_INDEX ();
1227 c
.poll_suppress_count
= poll_suppress_count
;
1228 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1229 c
.gcpro
= gcprolist
;
1230 c
.byte_stack
= byte_stack_list
;
1234 if (! _setjmp (c
.jmp
))
1235 c
.val
= (*func
) (arg
);
1237 /* Throw works by a longjmp that comes right here. */
1242 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1243 jump to that CATCH, returning VALUE as the value of that catch.
1245 This is the guts Fthrow and Fsignal; they differ only in the way
1246 they choose the catch tag to throw to. A catch tag for a
1247 condition-case form has a TAG of Qnil.
1249 Before each catch is discarded, unbind all special bindings and
1250 execute all unwind-protect clauses made above that catch. Unwind
1251 the handler stack as we go, so that the proper handlers are in
1252 effect for each unwind-protect clause we run. At the end, restore
1253 some static info saved in CATCH, and longjmp to the location
1256 This is used for correct unwinding in Fthrow and Fsignal. */
1259 unwind_to_catch (catch, value
)
1260 struct catchtag
*catch;
1263 register int last_time
;
1265 /* Save the value in the tag. */
1268 /* Restore certain special C variables. */
1269 set_poll_suppress_count (catch->poll_suppress_count
);
1270 UNBLOCK_INPUT_TO (catch->interrupt_input_blocked
);
1271 handling_signal
= 0;
1276 last_time
= catchlist
== catch;
1278 /* Unwind the specpdl stack, and then restore the proper set of
1280 unbind_to (catchlist
->pdlcount
, Qnil
);
1281 handlerlist
= catchlist
->handlerlist
;
1282 catchlist
= catchlist
->next
;
1284 while (! last_time
);
1287 /* If x_catch_errors was done, turn it off now.
1288 (First we give unbind_to a chance to do that.) */
1289 #if 0 /* This would disable x_catch_errors after x_connection_closed.
1290 * The catch must remain in effect during that delicate
1291 * state. --lorentey */
1292 x_fully_uncatch_errors ();
1296 byte_stack_list
= catch->byte_stack
;
1297 gcprolist
= catch->gcpro
;
1300 gcpro_level
= gcprolist
->level
+ 1;
1304 backtrace_list
= catch->backlist
;
1305 lisp_eval_depth
= catch->lisp_eval_depth
;
1307 _longjmp (catch->jmp
, 1);
1310 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1311 doc
: /* Throw to the catch for TAG and return VALUE from it.
1312 Both TAG and VALUE are evalled. */)
1314 register Lisp_Object tag
, value
;
1316 register struct catchtag
*c
;
1319 for (c
= catchlist
; c
; c
= c
->next
)
1321 if (EQ (c
->tag
, tag
))
1322 unwind_to_catch (c
, value
);
1324 xsignal2 (Qno_catch
, tag
, value
);
1328 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1329 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1330 If BODYFORM completes normally, its value is returned
1331 after executing the UNWINDFORMS.
1332 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1333 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1338 int count
= SPECPDL_INDEX ();
1340 record_unwind_protect (Fprogn
, Fcdr (args
));
1341 val
= Feval (Fcar (args
));
1342 return unbind_to (count
, val
);
1345 /* Chain of condition handlers currently in effect.
1346 The elements of this chain are contained in the stack frames
1347 of Fcondition_case and internal_condition_case.
1348 When an error is signaled (by calling Fsignal, below),
1349 this chain is searched for an element that applies. */
1351 struct handler
*handlerlist
;
1353 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1354 doc
: /* Regain control when an error is signaled.
1355 Executes BODYFORM and returns its value if no error happens.
1356 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1357 where the BODY is made of Lisp expressions.
1359 A handler is applicable to an error
1360 if CONDITION-NAME is one of the error's condition names.
1361 If an error happens, the first applicable handler is run.
1363 The car of a handler may be a list of condition names
1364 instead of a single condition name. Then it handles all of them.
1366 When a handler handles an error, control returns to the `condition-case'
1367 and it executes the handler's BODY...
1368 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA) from the error.
1369 (If VAR is nil, the handler can't access that information.)
1370 Then the value of the last BODY form is returned from the `condition-case'
1373 See also the function `signal' for more info.
1374 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1378 register Lisp_Object bodyform
, handlers
;
1379 volatile Lisp_Object var
;
1382 bodyform
= Fcar (Fcdr (args
));
1383 handlers
= Fcdr (Fcdr (args
));
1385 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1388 /* Like Fcondition_case, but the args are separate
1389 rather than passed in a list. Used by Fbyte_code. */
1392 internal_lisp_condition_case (var
, bodyform
, handlers
)
1393 volatile Lisp_Object var
;
1394 Lisp_Object bodyform
, handlers
;
1402 for (val
= handlers
; CONSP (val
); val
= XCDR (val
))
1408 && (SYMBOLP (XCAR (tem
))
1409 || CONSP (XCAR (tem
))))))
1410 error ("Invalid condition handler", tem
);
1415 c
.backlist
= backtrace_list
;
1416 c
.handlerlist
= handlerlist
;
1417 c
.lisp_eval_depth
= lisp_eval_depth
;
1418 c
.pdlcount
= SPECPDL_INDEX ();
1419 c
.poll_suppress_count
= poll_suppress_count
;
1420 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1421 c
.gcpro
= gcprolist
;
1422 c
.byte_stack
= byte_stack_list
;
1423 if (_setjmp (c
.jmp
))
1426 specbind (h
.var
, c
.val
);
1427 val
= Fprogn (Fcdr (h
.chosen_clause
));
1429 /* Note that this just undoes the binding of h.var; whoever
1430 longjumped to us unwound the stack to c.pdlcount before
1432 unbind_to (c
.pdlcount
, Qnil
);
1439 h
.handler
= handlers
;
1440 h
.next
= handlerlist
;
1444 val
= Feval (bodyform
);
1446 handlerlist
= h
.next
;
1450 /* Call the function BFUN with no arguments, catching errors within it
1451 according to HANDLERS. If there is an error, call HFUN with
1452 one argument which is the data that describes the error:
1455 HANDLERS can be a list of conditions to catch.
1456 If HANDLERS is Qt, catch all errors.
1457 If HANDLERS is Qerror, catch all errors
1458 but allow the debugger to run if that is enabled. */
1461 internal_condition_case (bfun
, handlers
, hfun
)
1462 Lisp_Object (*bfun
) ();
1463 Lisp_Object handlers
;
1464 Lisp_Object (*hfun
) ();
1470 /* Since Fsignal will close off all calls to x_catch_errors,
1471 we will get the wrong results if some are not closed now. */
1473 if (x_catching_errors ())
1479 c
.backlist
= backtrace_list
;
1480 c
.handlerlist
= handlerlist
;
1481 c
.lisp_eval_depth
= lisp_eval_depth
;
1482 c
.pdlcount
= SPECPDL_INDEX ();
1483 c
.poll_suppress_count
= poll_suppress_count
;
1484 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1485 c
.gcpro
= gcprolist
;
1486 c
.byte_stack
= byte_stack_list
;
1487 if (_setjmp (c
.jmp
))
1489 return (*hfun
) (c
.val
);
1493 h
.handler
= handlers
;
1495 h
.next
= handlerlist
;
1501 handlerlist
= h
.next
;
1505 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1508 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1509 Lisp_Object (*bfun
) ();
1511 Lisp_Object handlers
;
1512 Lisp_Object (*hfun
) ();
1518 /* Since Fsignal will close off all calls to x_catch_errors,
1519 we will get the wrong results if some are not closed now. */
1521 if (x_catching_errors ())
1527 c
.backlist
= backtrace_list
;
1528 c
.handlerlist
= handlerlist
;
1529 c
.lisp_eval_depth
= lisp_eval_depth
;
1530 c
.pdlcount
= SPECPDL_INDEX ();
1531 c
.poll_suppress_count
= poll_suppress_count
;
1532 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1533 c
.gcpro
= gcprolist
;
1534 c
.byte_stack
= byte_stack_list
;
1535 if (_setjmp (c
.jmp
))
1537 return (*hfun
) (c
.val
);
1541 h
.handler
= handlers
;
1543 h
.next
= handlerlist
;
1547 val
= (*bfun
) (arg
);
1549 handlerlist
= h
.next
;
1554 /* Like internal_condition_case but call BFUN with NARGS as first,
1555 and ARGS as second argument. */
1558 internal_condition_case_2 (bfun
, nargs
, args
, handlers
, hfun
)
1559 Lisp_Object (*bfun
) ();
1562 Lisp_Object handlers
;
1563 Lisp_Object (*hfun
) ();
1569 /* Since Fsignal will close off all calls to x_catch_errors,
1570 we will get the wrong results if some are not closed now. */
1572 if (x_catching_errors ())
1578 c
.backlist
= backtrace_list
;
1579 c
.handlerlist
= handlerlist
;
1580 c
.lisp_eval_depth
= lisp_eval_depth
;
1581 c
.pdlcount
= SPECPDL_INDEX ();
1582 c
.poll_suppress_count
= poll_suppress_count
;
1583 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1584 c
.gcpro
= gcprolist
;
1585 c
.byte_stack
= byte_stack_list
;
1586 if (_setjmp (c
.jmp
))
1588 return (*hfun
) (c
.val
);
1592 h
.handler
= handlers
;
1594 h
.next
= handlerlist
;
1598 val
= (*bfun
) (nargs
, args
);
1600 handlerlist
= h
.next
;
1605 static Lisp_Object find_handler_clause
P_ ((Lisp_Object
, Lisp_Object
,
1606 Lisp_Object
, Lisp_Object
));
1608 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1609 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1610 This function does not return.
1612 An error symbol is a symbol with an `error-conditions' property
1613 that is a list of condition names.
1614 A handler for any of those names will get to handle this signal.
1615 The symbol `error' should normally be one of them.
1617 DATA should be a list. Its elements are printed as part of the error message.
1618 See Info anchor `(elisp)Definition of signal' for some details on how this
1619 error message is constructed.
1620 If the signal is handled, DATA is made available to the handler.
1621 See also the function `condition-case'. */)
1622 (error_symbol
, data
)
1623 Lisp_Object error_symbol
, data
;
1625 /* When memory is full, ERROR-SYMBOL is nil,
1626 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1627 That is a special case--don't do this in other situations. */
1628 register struct handler
*allhandlers
= handlerlist
;
1629 Lisp_Object conditions
;
1630 extern int gc_in_progress
;
1631 extern int waiting_for_input
;
1633 Lisp_Object real_error_symbol
;
1634 struct backtrace
*bp
;
1636 immediate_quit
= handling_signal
= 0;
1638 if (gc_in_progress
|| waiting_for_input
)
1641 if (NILP (error_symbol
))
1642 real_error_symbol
= Fcar (data
);
1644 real_error_symbol
= error_symbol
;
1646 #if 0 /* rms: I don't know why this was here,
1647 but it is surely wrong for an error that is handled. */
1648 #ifdef HAVE_WINDOW_SYSTEM
1649 if (display_hourglass_p
)
1650 cancel_hourglass ();
1654 /* This hook is used by edebug. */
1655 if (! NILP (Vsignal_hook_function
)
1656 && ! NILP (error_symbol
))
1658 /* Edebug takes care of restoring these variables when it exits. */
1659 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1660 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1662 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1663 max_specpdl_size
= SPECPDL_INDEX () + 40;
1665 call2 (Vsignal_hook_function
, error_symbol
, data
);
1668 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1670 /* Remember from where signal was called. Skip over the frame for
1671 `signal' itself. If a frame for `error' follows, skip that,
1672 too. Don't do this when ERROR_SYMBOL is nil, because that
1673 is a memory-full error. */
1674 Vsignaling_function
= Qnil
;
1675 if (backtrace_list
&& !NILP (error_symbol
))
1677 bp
= backtrace_list
->next
;
1678 if (bp
&& bp
->function
&& EQ (*bp
->function
, Qerror
))
1680 if (bp
&& bp
->function
)
1681 Vsignaling_function
= *bp
->function
;
1684 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1686 register Lisp_Object clause
;
1688 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1689 error_symbol
, data
);
1691 if (EQ (clause
, Qlambda
))
1693 /* We can't return values to code which signaled an error, but we
1694 can continue code which has signaled a quit. */
1695 if (EQ (real_error_symbol
, Qquit
))
1698 error ("Cannot return from the debugger in an error");
1703 Lisp_Object unwind_data
;
1704 struct handler
*h
= handlerlist
;
1706 handlerlist
= allhandlers
;
1708 if (NILP (error_symbol
))
1711 unwind_data
= Fcons (error_symbol
, data
);
1712 h
->chosen_clause
= clause
;
1713 unwind_to_catch (h
->tag
, unwind_data
);
1717 handlerlist
= allhandlers
;
1718 /* If no handler is present now, try to run the debugger,
1719 and if that fails, throw to top level. */
1720 find_handler_clause (Qerror
, conditions
, error_symbol
, data
);
1722 Fthrow (Qtop_level
, Qt
);
1724 if (! NILP (error_symbol
))
1725 data
= Fcons (error_symbol
, data
);
1727 string
= Ferror_message_string (data
);
1728 fatal ("%s", SDATA (string
), 0);
1731 /* Internal version of Fsignal that never returns.
1732 Used for anything but Qquit (which can return from Fsignal). */
1735 xsignal (error_symbol
, data
)
1736 Lisp_Object error_symbol
, data
;
1738 Fsignal (error_symbol
, data
);
1742 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1745 xsignal0 (error_symbol
)
1746 Lisp_Object error_symbol
;
1748 xsignal (error_symbol
, Qnil
);
1752 xsignal1 (error_symbol
, arg
)
1753 Lisp_Object error_symbol
, arg
;
1755 xsignal (error_symbol
, list1 (arg
));
1759 xsignal2 (error_symbol
, arg1
, arg2
)
1760 Lisp_Object error_symbol
, arg1
, arg2
;
1762 xsignal (error_symbol
, list2 (arg1
, arg2
));
1766 xsignal3 (error_symbol
, arg1
, arg2
, arg3
)
1767 Lisp_Object error_symbol
, arg1
, arg2
, arg3
;
1769 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1772 /* Signal `error' with message S, and additional arg ARG.
1773 If ARG is not a genuine list, make it a one-element list. */
1776 signal_error (s
, arg
)
1780 Lisp_Object tortoise
, hare
;
1782 hare
= tortoise
= arg
;
1783 while (CONSP (hare
))
1790 tortoise
= XCDR (tortoise
);
1792 if (EQ (hare
, tortoise
))
1797 arg
= Fcons (arg
, Qnil
); /* Make it a list. */
1799 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1803 /* Return nonzero if LIST is a non-nil atom or
1804 a list containing one of CONDITIONS. */
1807 wants_debugger (list
, conditions
)
1808 Lisp_Object list
, conditions
;
1815 while (CONSP (conditions
))
1817 Lisp_Object
this, tail
;
1818 this = XCAR (conditions
);
1819 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1820 if (EQ (XCAR (tail
), this))
1822 conditions
= XCDR (conditions
);
1827 /* Return 1 if an error with condition-symbols CONDITIONS,
1828 and described by SIGNAL-DATA, should skip the debugger
1829 according to debugger-ignored-errors. */
1832 skip_debugger (conditions
, data
)
1833 Lisp_Object conditions
, data
;
1836 int first_string
= 1;
1837 Lisp_Object error_message
;
1839 error_message
= Qnil
;
1840 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1842 if (STRINGP (XCAR (tail
)))
1846 error_message
= Ferror_message_string (data
);
1850 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1855 Lisp_Object contail
;
1857 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1858 if (EQ (XCAR (tail
), XCAR (contail
)))
1866 /* Value of Qlambda means we have called debugger and user has continued.
1867 There are two ways to pass SIG and DATA:
1868 = SIG is the error symbol, and DATA is the rest of the data.
1869 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1870 This is for memory-full errors only.
1872 We need to increase max_specpdl_size temporarily around
1873 anything we do that can push on the specpdl, so as not to get
1874 a second error here in case we're handling specpdl overflow. */
1877 find_handler_clause (handlers
, conditions
, sig
, data
)
1878 Lisp_Object handlers
, conditions
, sig
, data
;
1880 register Lisp_Object h
;
1881 register Lisp_Object tem
;
1882 int debugger_called
= 0;
1883 int debugger_considered
= 0;
1885 /* t is used by handlers for all conditions, set up by C code. */
1886 if (EQ (handlers
, Qt
))
1889 /* Don't run the debugger for a memory-full error.
1890 (There is no room in memory to do that!) */
1892 debugger_considered
= 1;
1894 /* error is used similarly, but means print an error message
1895 and run the debugger if that is enabled. */
1896 if (EQ (handlers
, Qerror
)
1897 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1898 there is a handler. */
1900 if (!NILP (sig
) && wants_debugger (Vstack_trace_on_error
, conditions
))
1904 internal_with_output_to_temp_buffer ("*Backtrace*",
1905 (Lisp_Object (*) (Lisp_Object
)) Fbacktrace
,
1908 internal_with_output_to_temp_buffer ("*Backtrace*",
1914 if (!debugger_considered
)
1916 debugger_considered
= 1;
1917 debugger_called
= maybe_call_debugger (conditions
, sig
, data
);
1920 /* If there is no handler, return saying whether we ran the debugger. */
1921 if (EQ (handlers
, Qerror
))
1923 if (debugger_called
)
1929 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1931 Lisp_Object handler
, condit
;
1934 if (!CONSP (handler
))
1936 condit
= Fcar (handler
);
1937 /* Handle a single condition name in handler HANDLER. */
1938 if (SYMBOLP (condit
))
1940 tem
= Fmemq (Fcar (handler
), conditions
);
1944 /* Handle a list of condition names in handler HANDLER. */
1945 else if (CONSP (condit
))
1948 for (tail
= condit
; CONSP (tail
); tail
= XCDR (tail
))
1950 tem
= Fmemq (Fcar (tail
), conditions
);
1953 /* This handler is going to apply.
1954 Does it allow the debugger to run first? */
1955 if (! debugger_considered
&& !NILP (Fmemq (Qdebug
, condit
)))
1956 maybe_call_debugger (conditions
, sig
, data
);
1966 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1967 SIG and DATA describe the signal, as in find_handler_clause. */
1970 maybe_call_debugger (conditions
, sig
, data
)
1971 Lisp_Object conditions
, sig
, data
;
1973 Lisp_Object combined_data
;
1975 combined_data
= Fcons (sig
, data
);
1978 /* Don't try to run the debugger with interrupts blocked.
1979 The editing loop would return anyway. */
1981 /* Does user wants to enter debugger for this kind of error? */
1984 : wants_debugger (Vdebug_on_error
, conditions
))
1985 && ! skip_debugger (conditions
, combined_data
)
1986 /* rms: what's this for? */
1987 && when_entered_debugger
< num_nonmacro_input_events
)
1989 call_debugger (Fcons (Qerror
, Fcons (combined_data
, Qnil
)));
1996 /* dump an error message; called like printf */
2000 error (m
, a1
, a2
, a3
)
2020 int used
= doprnt (buffer
, size
, m
, m
+ mlen
, 3, args
);
2025 buffer
= (char *) xrealloc (buffer
, size
);
2028 buffer
= (char *) xmalloc (size
);
2033 string
= build_string (buffer
);
2037 xsignal1 (Qerror
, string
);
2040 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
2041 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
2042 This means it contains a description for how to read arguments to give it.
2043 The value is nil for an invalid function or a symbol with no function
2046 Interactively callable functions include strings and vectors (treated
2047 as keyboard macros), lambda-expressions that contain a top-level call
2048 to `interactive', autoload definitions made by `autoload' with non-nil
2049 fourth argument, and some of the built-in functions of Lisp.
2051 Also, a symbol satisfies `commandp' if its function definition does so.
2053 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
2054 then strings and vectors are not accepted. */)
2055 (function
, for_call_interactively
)
2056 Lisp_Object function
, for_call_interactively
;
2058 register Lisp_Object fun
;
2059 register Lisp_Object funcar
;
2060 Lisp_Object if_prop
= Qnil
;
2064 fun
= indirect_function (fun
); /* Check cycles. */
2065 if (NILP (fun
) || EQ (fun
, Qunbound
))
2068 /* Check an `interactive-form' property if present, analogous to the
2069 function-documentation property. */
2071 while (SYMBOLP (fun
))
2073 Lisp_Object tmp
= Fget (fun
, intern ("interactive-form"));
2076 fun
= Fsymbol_function (fun
);
2079 /* Emacs primitives are interactive if their DEFUN specifies an
2080 interactive spec. */
2082 return XSUBR (fun
)->intspec
? Qt
: if_prop
;
2084 /* Bytecode objects are interactive if they are long enough to
2085 have an element whose index is COMPILED_INTERACTIVE, which is
2086 where the interactive spec is stored. */
2087 else if (COMPILEDP (fun
))
2088 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
2091 /* Strings and vectors are keyboard macros. */
2092 if (STRINGP (fun
) || VECTORP (fun
))
2093 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
2095 /* Lists may represent commands. */
2098 funcar
= XCAR (fun
);
2099 if (EQ (funcar
, Qlambda
))
2100 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
2101 if (EQ (funcar
, Qautoload
))
2102 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
2108 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
2109 doc
: /* Define FUNCTION to autoload from FILE.
2110 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
2111 Third arg DOCSTRING is documentation for the function.
2112 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
2113 Fifth arg TYPE indicates the type of the object:
2114 nil or omitted says FUNCTION is a function,
2115 `keymap' says FUNCTION is really a keymap, and
2116 `macro' or t says FUNCTION is really a macro.
2117 Third through fifth args give info about the real definition.
2118 They default to nil.
2119 If FUNCTION is already defined other than as an autoload,
2120 this does nothing and returns nil. */)
2121 (function
, file
, docstring
, interactive
, type
)
2122 Lisp_Object function
, file
, docstring
, interactive
, type
;
2125 Lisp_Object args
[4];
2128 CHECK_SYMBOL (function
);
2129 CHECK_STRING (file
);
2131 /* If function is defined and not as an autoload, don't override */
2132 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
2133 && !(CONSP (XSYMBOL (function
)->function
)
2134 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
2137 if (NILP (Vpurify_flag
))
2138 /* Only add entries after dumping, because the ones before are
2139 not useful and else we get loads of them from the loaddefs.el. */
2140 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
2144 args
[1] = docstring
;
2145 args
[2] = interactive
;
2148 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
2149 #else /* NO_ARG_ARRAY */
2150 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
2151 #endif /* not NO_ARG_ARRAY */
2155 un_autoload (oldqueue
)
2156 Lisp_Object oldqueue
;
2158 register Lisp_Object queue
, first
, second
;
2160 /* Queue to unwind is current value of Vautoload_queue.
2161 oldqueue is the shadowed value to leave in Vautoload_queue. */
2162 queue
= Vautoload_queue
;
2163 Vautoload_queue
= oldqueue
;
2164 while (CONSP (queue
))
2166 first
= XCAR (queue
);
2167 second
= Fcdr (first
);
2168 first
= Fcar (first
);
2169 if (EQ (first
, make_number (0)))
2172 Ffset (first
, second
);
2173 queue
= XCDR (queue
);
2178 /* Load an autoloaded function.
2179 FUNNAME is the symbol which is the function's name.
2180 FUNDEF is the autoload definition (a list). */
2183 do_autoload (fundef
, funname
)
2184 Lisp_Object fundef
, funname
;
2186 int count
= SPECPDL_INDEX ();
2188 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2190 /* This is to make sure that loadup.el gives a clear picture
2191 of what files are preloaded and when. */
2192 if (! NILP (Vpurify_flag
))
2193 error ("Attempt to autoload %s while preparing to dump",
2194 SDATA (SYMBOL_NAME (funname
)));
2197 CHECK_SYMBOL (funname
);
2198 GCPRO3 (fun
, funname
, fundef
);
2200 /* Preserve the match data. */
2201 record_unwind_save_match_data ();
2203 /* If autoloading gets an error (which includes the error of failing
2204 to define the function being called), we use Vautoload_queue
2205 to undo function definitions and `provide' calls made by
2206 the function. We do this in the specific case of autoloading
2207 because autoloading is not an explicit request "load this file",
2208 but rather a request to "call this function".
2210 The value saved here is to be restored into Vautoload_queue. */
2211 record_unwind_protect (un_autoload
, Vautoload_queue
);
2212 Vautoload_queue
= Qt
;
2213 Fload (Fcar (Fcdr (fundef
)), Qnil
, Qt
, Qnil
, Qt
);
2215 /* Once loading finishes, don't undo it. */
2216 Vautoload_queue
= Qt
;
2217 unbind_to (count
, Qnil
);
2219 fun
= Findirect_function (fun
, Qnil
);
2221 if (!NILP (Fequal (fun
, fundef
)))
2222 error ("Autoloading failed to define function %s",
2223 SDATA (SYMBOL_NAME (funname
)));
2228 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
2229 doc
: /* Evaluate FORM and return its value. */)
2233 Lisp_Object fun
, val
, original_fun
, original_args
;
2235 struct backtrace backtrace
;
2236 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2238 if (handling_signal
)
2242 return Fsymbol_value (form
);
2247 if ((consing_since_gc
> gc_cons_threshold
2248 && consing_since_gc
> gc_relative_threshold
)
2250 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2253 Fgarbage_collect ();
2257 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2259 if (max_lisp_eval_depth
< 100)
2260 max_lisp_eval_depth
= 100;
2261 if (lisp_eval_depth
> max_lisp_eval_depth
)
2262 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2265 original_fun
= Fcar (form
);
2266 original_args
= Fcdr (form
);
2268 backtrace
.next
= backtrace_list
;
2269 backtrace_list
= &backtrace
;
2270 backtrace
.function
= &original_fun
; /* This also protects them from gc */
2271 backtrace
.args
= &original_args
;
2272 backtrace
.nargs
= UNEVALLED
;
2273 backtrace
.evalargs
= 1;
2274 backtrace
.debug_on_exit
= 0;
2276 if (debug_on_next_call
)
2277 do_debug_on_call (Qt
);
2279 /* At this point, only original_fun and original_args
2280 have values that will be used below */
2283 /* Optimize for no indirection. */
2285 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2286 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2287 fun
= indirect_function (fun
);
2291 Lisp_Object numargs
;
2292 Lisp_Object argvals
[8];
2293 Lisp_Object args_left
;
2294 register int i
, maxargs
;
2296 args_left
= original_args
;
2297 numargs
= Flength (args_left
);
2301 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
2302 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2303 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2305 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2307 backtrace
.evalargs
= 0;
2308 val
= (*XSUBR (fun
)->function
) (args_left
);
2312 if (XSUBR (fun
)->max_args
== MANY
)
2314 /* Pass a vector of evaluated arguments */
2316 register int argnum
= 0;
2318 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2320 GCPRO3 (args_left
, fun
, fun
);
2324 while (!NILP (args_left
))
2326 vals
[argnum
++] = Feval (Fcar (args_left
));
2327 args_left
= Fcdr (args_left
);
2328 gcpro3
.nvars
= argnum
;
2331 backtrace
.args
= vals
;
2332 backtrace
.nargs
= XINT (numargs
);
2334 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
2339 GCPRO3 (args_left
, fun
, fun
);
2340 gcpro3
.var
= argvals
;
2343 maxargs
= XSUBR (fun
)->max_args
;
2344 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
2346 argvals
[i
] = Feval (Fcar (args_left
));
2352 backtrace
.args
= argvals
;
2353 backtrace
.nargs
= XINT (numargs
);
2358 val
= (*XSUBR (fun
)->function
) ();
2361 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
2364 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
2367 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2371 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2372 argvals
[2], argvals
[3]);
2375 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2376 argvals
[3], argvals
[4]);
2379 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2380 argvals
[3], argvals
[4], argvals
[5]);
2383 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2384 argvals
[3], argvals
[4], argvals
[5],
2389 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2390 argvals
[3], argvals
[4], argvals
[5],
2391 argvals
[6], argvals
[7]);
2395 /* Someone has created a subr that takes more arguments than
2396 is supported by this code. We need to either rewrite the
2397 subr to use a different argument protocol, or add more
2398 cases to this switch. */
2402 if (COMPILEDP (fun
))
2403 val
= apply_lambda (fun
, original_args
, 1);
2406 if (EQ (fun
, Qunbound
))
2407 xsignal1 (Qvoid_function
, original_fun
);
2409 xsignal1 (Qinvalid_function
, original_fun
);
2410 funcar
= XCAR (fun
);
2411 if (!SYMBOLP (funcar
))
2412 xsignal1 (Qinvalid_function
, original_fun
);
2413 if (EQ (funcar
, Qautoload
))
2415 do_autoload (fun
, original_fun
);
2418 if (EQ (funcar
, Qmacro
))
2419 val
= Feval (apply1 (Fcdr (fun
), original_args
));
2420 else if (EQ (funcar
, Qlambda
))
2421 val
= apply_lambda (fun
, original_args
, 1);
2423 xsignal1 (Qinvalid_function
, original_fun
);
2429 if (backtrace
.debug_on_exit
)
2430 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2431 backtrace_list
= backtrace
.next
;
2436 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
2437 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2438 Then return the value FUNCTION returns.
2439 Thus, (apply '+ 1 2 '(3 4)) returns 10.
2440 usage: (apply FUNCTION &rest ARGUMENTS) */)
2445 register int i
, numargs
;
2446 register Lisp_Object spread_arg
;
2447 register Lisp_Object
*funcall_args
;
2449 struct gcpro gcpro1
;
2453 spread_arg
= args
[nargs
- 1];
2454 CHECK_LIST (spread_arg
);
2456 numargs
= XINT (Flength (spread_arg
));
2459 return Ffuncall (nargs
- 1, args
);
2460 else if (numargs
== 1)
2462 args
[nargs
- 1] = XCAR (spread_arg
);
2463 return Ffuncall (nargs
, args
);
2466 numargs
+= nargs
- 2;
2468 /* Optimize for no indirection. */
2469 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2470 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2471 fun
= indirect_function (fun
);
2472 if (EQ (fun
, Qunbound
))
2474 /* Let funcall get the error */
2481 if (numargs
< XSUBR (fun
)->min_args
2482 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2483 goto funcall
; /* Let funcall get the error */
2484 else if (XSUBR (fun
)->max_args
> numargs
)
2486 /* Avoid making funcall cons up a yet another new vector of arguments
2487 by explicitly supplying nil's for optional values */
2488 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
2489 * sizeof (Lisp_Object
));
2490 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2491 funcall_args
[++i
] = Qnil
;
2492 GCPRO1 (*funcall_args
);
2493 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2497 /* We add 1 to numargs because funcall_args includes the
2498 function itself as well as its arguments. */
2501 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
2502 * sizeof (Lisp_Object
));
2503 GCPRO1 (*funcall_args
);
2504 gcpro1
.nvars
= 1 + numargs
;
2507 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
2508 /* Spread the last arg we got. Its first element goes in
2509 the slot that it used to occupy, hence this value of I. */
2511 while (!NILP (spread_arg
))
2513 funcall_args
[i
++] = XCAR (spread_arg
);
2514 spread_arg
= XCDR (spread_arg
);
2517 /* By convention, the caller needs to gcpro Ffuncall's args. */
2518 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
2521 /* Run hook variables in various ways. */
2523 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
2524 static Lisp_Object run_hook_with_args
P_ ((int, Lisp_Object
*,
2525 enum run_hooks_condition
));
2527 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2528 doc
: /* Run each hook in HOOKS.
2529 Each argument should be a symbol, a hook variable.
2530 These symbols are processed in the order specified.
2531 If a hook symbol has a non-nil value, that value may be a function
2532 or a list of functions to be called to run the hook.
2533 If the value is a function, it is called with no arguments.
2534 If it is a list, the elements are called, in order, with no arguments.
2536 Major modes should not use this function directly to run their mode
2537 hook; they should use `run-mode-hooks' instead.
2539 Do not use `make-local-variable' to make a hook variable buffer-local.
2540 Instead, use `add-hook' and specify t for the LOCAL argument.
2541 usage: (run-hooks &rest HOOKS) */)
2546 Lisp_Object hook
[1];
2549 for (i
= 0; i
< nargs
; i
++)
2552 run_hook_with_args (1, hook
, to_completion
);
2558 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2559 Srun_hook_with_args
, 1, MANY
, 0,
2560 doc
: /* Run HOOK with the specified arguments ARGS.
2561 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2562 value, that value may be a function or a list of functions to be
2563 called to run the hook. If the value is a function, it is called with
2564 the given arguments and its return value is returned. If it is a list
2565 of functions, those functions are called, in order,
2566 with the given arguments ARGS.
2567 It is best not to depend on the value returned by `run-hook-with-args',
2570 Do not use `make-local-variable' to make a hook variable buffer-local.
2571 Instead, use `add-hook' and specify t for the LOCAL argument.
2572 usage: (run-hook-with-args HOOK &rest ARGS) */)
2577 return run_hook_with_args (nargs
, args
, to_completion
);
2580 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2581 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2582 doc
: /* Run HOOK with the specified arguments ARGS.
2583 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2584 value, that value may be a function or a list of functions to be
2585 called to run the hook. If the value is a function, it is called with
2586 the given arguments and its return value is returned.
2587 If it is a list of functions, those functions are called, in order,
2588 with the given arguments ARGS, until one of them
2589 returns a non-nil value. Then we return that value.
2590 However, if they all return nil, we return nil.
2592 Do not use `make-local-variable' to make a hook variable buffer-local.
2593 Instead, use `add-hook' and specify t for the LOCAL argument.
2594 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2599 return run_hook_with_args (nargs
, args
, until_success
);
2602 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2603 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2604 doc
: /* Run HOOK with the specified arguments ARGS.
2605 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2606 value, that value may be a function or a list of functions to be
2607 called to run the hook. If the value is a function, it is called with
2608 the given arguments and its return value is returned.
2609 If it is a list of functions, those functions are called, in order,
2610 with the given arguments ARGS, until one of them returns nil.
2611 Then we return nil. However, if they all return non-nil, we return non-nil.
2613 Do not use `make-local-variable' to make a hook variable buffer-local.
2614 Instead, use `add-hook' and specify t for the LOCAL argument.
2615 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2620 return run_hook_with_args (nargs
, args
, until_failure
);
2623 /* ARGS[0] should be a hook symbol.
2624 Call each of the functions in the hook value, passing each of them
2625 as arguments all the rest of ARGS (all NARGS - 1 elements).
2626 COND specifies a condition to test after each call
2627 to decide whether to stop.
2628 The caller (or its caller, etc) must gcpro all of ARGS,
2629 except that it isn't necessary to gcpro ARGS[0]. */
2632 run_hook_with_args (nargs
, args
, cond
)
2635 enum run_hooks_condition cond
;
2637 Lisp_Object sym
, val
, ret
;
2638 Lisp_Object globals
;
2639 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2641 /* If we are dying or still initializing,
2642 don't do anything--it would probably crash if we tried. */
2643 if (NILP (Vrun_hooks
))
2647 val
= find_symbol_value (sym
);
2648 ret
= (cond
== until_failure
? Qt
: Qnil
);
2650 if (EQ (val
, Qunbound
) || NILP (val
))
2652 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2655 return Ffuncall (nargs
, args
);
2660 GCPRO3 (sym
, val
, globals
);
2663 CONSP (val
) && ((cond
== to_completion
)
2664 || (cond
== until_success
? NILP (ret
)
2668 if (EQ (XCAR (val
), Qt
))
2670 /* t indicates this hook has a local binding;
2671 it means to run the global binding too. */
2673 for (globals
= Fdefault_value (sym
);
2674 CONSP (globals
) && ((cond
== to_completion
)
2675 || (cond
== until_success
? NILP (ret
)
2677 globals
= XCDR (globals
))
2679 args
[0] = XCAR (globals
);
2680 /* In a global value, t should not occur. If it does, we
2681 must ignore it to avoid an endless loop. */
2682 if (!EQ (args
[0], Qt
))
2683 ret
= Ffuncall (nargs
, args
);
2688 args
[0] = XCAR (val
);
2689 ret
= Ffuncall (nargs
, args
);
2698 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2699 present value of that symbol.
2700 Call each element of FUNLIST,
2701 passing each of them the rest of ARGS.
2702 The caller (or its caller, etc) must gcpro all of ARGS,
2703 except that it isn't necessary to gcpro ARGS[0]. */
2706 run_hook_list_with_args (funlist
, nargs
, args
)
2707 Lisp_Object funlist
;
2713 Lisp_Object globals
;
2714 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2718 GCPRO3 (sym
, val
, globals
);
2720 for (val
= funlist
; CONSP (val
); val
= XCDR (val
))
2722 if (EQ (XCAR (val
), Qt
))
2724 /* t indicates this hook has a local binding;
2725 it means to run the global binding too. */
2727 for (globals
= Fdefault_value (sym
);
2729 globals
= XCDR (globals
))
2731 args
[0] = XCAR (globals
);
2732 /* In a global value, t should not occur. If it does, we
2733 must ignore it to avoid an endless loop. */
2734 if (!EQ (args
[0], Qt
))
2735 Ffuncall (nargs
, args
);
2740 args
[0] = XCAR (val
);
2741 Ffuncall (nargs
, args
);
2748 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2751 run_hook_with_args_2 (hook
, arg1
, arg2
)
2752 Lisp_Object hook
, arg1
, arg2
;
2754 Lisp_Object temp
[3];
2759 Frun_hook_with_args (3, temp
);
2762 /* Apply fn to arg */
2765 Lisp_Object fn
, arg
;
2767 struct gcpro gcpro1
;
2771 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2775 Lisp_Object args
[2];
2779 RETURN_UNGCPRO (Fapply (2, args
));
2781 #else /* not NO_ARG_ARRAY */
2782 RETURN_UNGCPRO (Fapply (2, &fn
));
2783 #endif /* not NO_ARG_ARRAY */
2786 /* Call function fn on no arguments */
2791 struct gcpro gcpro1
;
2794 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2797 /* Call function fn with 1 argument arg1 */
2801 Lisp_Object fn
, arg1
;
2803 struct gcpro gcpro1
;
2805 Lisp_Object args
[2];
2811 RETURN_UNGCPRO (Ffuncall (2, args
));
2812 #else /* not NO_ARG_ARRAY */
2815 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2816 #endif /* not NO_ARG_ARRAY */
2819 /* Call function fn with 2 arguments arg1, arg2 */
2822 call2 (fn
, arg1
, arg2
)
2823 Lisp_Object fn
, arg1
, arg2
;
2825 struct gcpro gcpro1
;
2827 Lisp_Object args
[3];
2833 RETURN_UNGCPRO (Ffuncall (3, args
));
2834 #else /* not NO_ARG_ARRAY */
2837 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2838 #endif /* not NO_ARG_ARRAY */
2841 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2844 call3 (fn
, arg1
, arg2
, arg3
)
2845 Lisp_Object fn
, arg1
, arg2
, arg3
;
2847 struct gcpro gcpro1
;
2849 Lisp_Object args
[4];
2856 RETURN_UNGCPRO (Ffuncall (4, args
));
2857 #else /* not NO_ARG_ARRAY */
2860 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2861 #endif /* not NO_ARG_ARRAY */
2864 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2867 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2868 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2870 struct gcpro gcpro1
;
2872 Lisp_Object args
[5];
2880 RETURN_UNGCPRO (Ffuncall (5, args
));
2881 #else /* not NO_ARG_ARRAY */
2884 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2885 #endif /* not NO_ARG_ARRAY */
2888 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2891 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2892 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2894 struct gcpro gcpro1
;
2896 Lisp_Object args
[6];
2905 RETURN_UNGCPRO (Ffuncall (6, args
));
2906 #else /* not NO_ARG_ARRAY */
2909 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2910 #endif /* not NO_ARG_ARRAY */
2913 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2916 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2917 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2919 struct gcpro gcpro1
;
2921 Lisp_Object args
[7];
2931 RETURN_UNGCPRO (Ffuncall (7, args
));
2932 #else /* not NO_ARG_ARRAY */
2935 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2936 #endif /* not NO_ARG_ARRAY */
2939 /* The caller should GCPRO all the elements of ARGS. */
2941 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2942 doc
: /* Call first argument as a function, passing remaining arguments to it.
2943 Return the value that function returns.
2944 Thus, (funcall 'cons 'x 'y) returns (x . y).
2945 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2950 Lisp_Object fun
, original_fun
;
2952 int numargs
= nargs
- 1;
2953 Lisp_Object lisp_numargs
;
2955 struct backtrace backtrace
;
2956 register Lisp_Object
*internal_args
;
2960 if ((consing_since_gc
> gc_cons_threshold
2961 && consing_since_gc
> gc_relative_threshold
)
2963 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2964 Fgarbage_collect ();
2966 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2968 if (max_lisp_eval_depth
< 100)
2969 max_lisp_eval_depth
= 100;
2970 if (lisp_eval_depth
> max_lisp_eval_depth
)
2971 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2974 backtrace
.next
= backtrace_list
;
2975 backtrace_list
= &backtrace
;
2976 backtrace
.function
= &args
[0];
2977 backtrace
.args
= &args
[1];
2978 backtrace
.nargs
= nargs
- 1;
2979 backtrace
.evalargs
= 0;
2980 backtrace
.debug_on_exit
= 0;
2982 if (debug_on_next_call
)
2983 do_debug_on_call (Qlambda
);
2987 original_fun
= args
[0];
2991 /* Optimize for no indirection. */
2993 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2994 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2995 fun
= indirect_function (fun
);
2999 if (numargs
< XSUBR (fun
)->min_args
3000 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
3002 XSETFASTINT (lisp_numargs
, numargs
);
3003 xsignal2 (Qwrong_number_of_arguments
, original_fun
, lisp_numargs
);
3006 if (XSUBR (fun
)->max_args
== UNEVALLED
)
3007 xsignal1 (Qinvalid_function
, original_fun
);
3009 if (XSUBR (fun
)->max_args
== MANY
)
3011 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
3015 if (XSUBR (fun
)->max_args
> numargs
)
3017 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
3018 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
3019 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
3020 internal_args
[i
] = Qnil
;
3023 internal_args
= args
+ 1;
3024 switch (XSUBR (fun
)->max_args
)
3027 val
= (*XSUBR (fun
)->function
) ();
3030 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
3033 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1]);
3036 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3040 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3041 internal_args
[2], internal_args
[3]);
3044 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3045 internal_args
[2], internal_args
[3],
3049 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3050 internal_args
[2], internal_args
[3],
3051 internal_args
[4], internal_args
[5]);
3054 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3055 internal_args
[2], internal_args
[3],
3056 internal_args
[4], internal_args
[5],
3061 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3062 internal_args
[2], internal_args
[3],
3063 internal_args
[4], internal_args
[5],
3064 internal_args
[6], internal_args
[7]);
3069 /* If a subr takes more than 8 arguments without using MANY
3070 or UNEVALLED, we need to extend this function to support it.
3071 Until this is done, there is no way to call the function. */
3075 if (COMPILEDP (fun
))
3076 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3079 if (EQ (fun
, Qunbound
))
3080 xsignal1 (Qvoid_function
, original_fun
);
3082 xsignal1 (Qinvalid_function
, original_fun
);
3083 funcar
= XCAR (fun
);
3084 if (!SYMBOLP (funcar
))
3085 xsignal1 (Qinvalid_function
, original_fun
);
3086 if (EQ (funcar
, Qlambda
))
3087 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3088 else if (EQ (funcar
, Qautoload
))
3090 do_autoload (fun
, original_fun
);
3095 xsignal1 (Qinvalid_function
, original_fun
);
3100 if (backtrace
.debug_on_exit
)
3101 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
3102 backtrace_list
= backtrace
.next
;
3107 apply_lambda (fun
, args
, eval_flag
)
3108 Lisp_Object fun
, args
;
3111 Lisp_Object args_left
;
3112 Lisp_Object numargs
;
3113 register Lisp_Object
*arg_vector
;
3114 struct gcpro gcpro1
, gcpro2
, gcpro3
;
3116 register Lisp_Object tem
;
3118 numargs
= Flength (args
);
3119 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
3122 GCPRO3 (*arg_vector
, args_left
, fun
);
3125 for (i
= 0; i
< XINT (numargs
);)
3127 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
3128 if (eval_flag
) tem
= Feval (tem
);
3129 arg_vector
[i
++] = tem
;
3137 backtrace_list
->args
= arg_vector
;
3138 backtrace_list
->nargs
= i
;
3140 backtrace_list
->evalargs
= 0;
3141 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
3143 /* Do the debug-on-exit now, while arg_vector still exists. */
3144 if (backtrace_list
->debug_on_exit
)
3145 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
3146 /* Don't do it again when we return to eval. */
3147 backtrace_list
->debug_on_exit
= 0;
3151 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
3152 and return the result of evaluation.
3153 FUN must be either a lambda-expression or a compiled-code object. */
3156 funcall_lambda (fun
, nargs
, arg_vector
)
3159 register Lisp_Object
*arg_vector
;
3161 Lisp_Object val
, syms_left
, next
;
3162 int count
= SPECPDL_INDEX ();
3163 int i
, optional
, rest
;
3167 syms_left
= XCDR (fun
);
3168 if (CONSP (syms_left
))
3169 syms_left
= XCAR (syms_left
);
3171 xsignal1 (Qinvalid_function
, fun
);
3173 else if (COMPILEDP (fun
))
3174 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3178 i
= optional
= rest
= 0;
3179 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3183 next
= XCAR (syms_left
);
3184 if (!SYMBOLP (next
))
3185 xsignal1 (Qinvalid_function
, fun
);
3187 if (EQ (next
, Qand_rest
))
3189 else if (EQ (next
, Qand_optional
))
3193 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
3197 specbind (next
, arg_vector
[i
++]);
3199 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3201 specbind (next
, Qnil
);
3204 if (!NILP (syms_left
))
3205 xsignal1 (Qinvalid_function
, fun
);
3207 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3210 val
= Fprogn (XCDR (XCDR (fun
)));
3213 /* If we have not actually read the bytecode string
3214 and constants vector yet, fetch them from the file. */
3215 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3216 Ffetch_bytecode (fun
);
3217 val
= Fbyte_code (AREF (fun
, COMPILED_BYTECODE
),
3218 AREF (fun
, COMPILED_CONSTANTS
),
3219 AREF (fun
, COMPILED_STACK_DEPTH
));
3222 return unbind_to (count
, val
);
3225 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3227 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3233 if (COMPILEDP (object
) && CONSP (AREF (object
, COMPILED_BYTECODE
)))
3235 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3238 tem
= AREF (object
, COMPILED_BYTECODE
);
3239 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3240 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3242 error ("Invalid byte code");
3244 ASET (object
, COMPILED_BYTECODE
, XCAR (tem
));
3245 ASET (object
, COMPILED_CONSTANTS
, XCDR (tem
));
3253 register int count
= SPECPDL_INDEX ();
3254 if (specpdl_size
>= max_specpdl_size
)
3256 if (max_specpdl_size
< 400)
3257 max_specpdl_size
= 400;
3258 if (specpdl_size
>= max_specpdl_size
)
3259 signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil
);
3262 if (specpdl_size
> max_specpdl_size
)
3263 specpdl_size
= max_specpdl_size
;
3264 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
3265 specpdl_ptr
= specpdl
+ count
;
3269 specbind (symbol
, value
)
3270 Lisp_Object symbol
, value
;
3272 Lisp_Object valcontents
;
3274 CHECK_SYMBOL (symbol
);
3275 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3278 /* The most common case is that of a non-constant symbol with a
3279 trivial value. Make that as fast as we can. */
3280 valcontents
= SYMBOL_VALUE (symbol
);
3281 if (!MISCP (valcontents
) && !SYMBOL_CONSTANT_P (symbol
))
3283 specpdl_ptr
->symbol
= symbol
;
3284 specpdl_ptr
->old_value
= valcontents
;
3285 specpdl_ptr
->func
= NULL
;
3287 SET_SYMBOL_VALUE (symbol
, value
);
3291 Lisp_Object ovalue
= find_symbol_value (symbol
);
3292 specpdl_ptr
->func
= 0;
3293 specpdl_ptr
->old_value
= ovalue
;
3295 valcontents
= XSYMBOL (symbol
)->value
;
3297 if (BUFFER_LOCAL_VALUEP (valcontents
)
3298 || BUFFER_OBJFWDP (valcontents
))
3300 Lisp_Object where
, current_buffer
;
3302 current_buffer
= Fcurrent_buffer ();
3304 /* For a local variable, record both the symbol and which
3305 buffer's or frame's value we are saving. */
3306 if (!NILP (Flocal_variable_p (symbol
, Qnil
)))
3307 where
= current_buffer
;
3308 else if (BUFFER_LOCAL_VALUEP (valcontents
)
3309 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
3310 where
= XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
3314 /* We're not using the `unused' slot in the specbinding
3315 structure because this would mean we have to do more
3316 work for simple variables. */
3317 specpdl_ptr
->symbol
= Fcons (symbol
, Fcons (where
, current_buffer
));
3319 /* If SYMBOL is a per-buffer variable which doesn't have a
3320 buffer-local value here, make the `let' change the global
3321 value by changing the value of SYMBOL in all buffers not
3322 having their own value. This is consistent with what
3323 happens with other buffer-local variables. */
3325 && BUFFER_OBJFWDP (valcontents
))
3328 Fset_default (symbol
, value
);
3333 specpdl_ptr
->symbol
= symbol
;
3337 if (BUFFER_OBJFWDP (ovalue) || KBOARD_OBJFWDP (ovalue))
3338 store_symval_forwarding (symbol, ovalue, value, NULL);
3340 but ovalue comes from find_symbol_value which should never return
3341 such an internal value. */
3342 eassert (!(BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
)));
3343 set_internal (symbol
, value
, 0, 1);
3348 record_unwind_protect (function
, arg
)
3349 Lisp_Object (*function
) P_ ((Lisp_Object
));
3352 eassert (!handling_signal
);
3354 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3356 specpdl_ptr
->func
= function
;
3357 specpdl_ptr
->symbol
= Qnil
;
3358 specpdl_ptr
->old_value
= arg
;
3363 unbind_to (count
, value
)
3367 Lisp_Object quitf
= Vquit_flag
;
3368 struct gcpro gcpro1
, gcpro2
;
3370 GCPRO2 (value
, quitf
);
3373 while (specpdl_ptr
!= specpdl
+ count
)
3375 /* Copy the binding, and decrement specpdl_ptr, before we do
3376 the work to unbind it. We decrement first
3377 so that an error in unbinding won't try to unbind
3378 the same entry again, and we copy the binding first
3379 in case more bindings are made during some of the code we run. */
3381 struct specbinding this_binding
;
3382 this_binding
= *--specpdl_ptr
;
3384 if (this_binding
.func
!= 0)
3385 (*this_binding
.func
) (this_binding
.old_value
);
3386 /* If the symbol is a list, it is really (SYMBOL WHERE
3387 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3388 frame. If WHERE is a buffer or frame, this indicates we
3389 bound a variable that had a buffer-local or frame-local
3390 binding. WHERE nil means that the variable had the default
3391 value when it was bound. CURRENT-BUFFER is the buffer that
3392 was current when the variable was bound. */
3393 else if (CONSP (this_binding
.symbol
))
3395 Lisp_Object symbol
, where
;
3397 symbol
= XCAR (this_binding
.symbol
);
3398 where
= XCAR (XCDR (this_binding
.symbol
));
3401 Fset_default (symbol
, this_binding
.old_value
);
3402 else if (BUFFERP (where
))
3403 set_internal (symbol
, this_binding
.old_value
, XBUFFER (where
), 1);
3405 set_internal (symbol
, this_binding
.old_value
, NULL
, 1);
3409 /* If variable has a trivial value (no forwarding), we can
3410 just set it. No need to check for constant symbols here,
3411 since that was already done by specbind. */
3412 if (!MISCP (SYMBOL_VALUE (this_binding
.symbol
)))
3413 SET_SYMBOL_VALUE (this_binding
.symbol
, this_binding
.old_value
);
3415 set_internal (this_binding
.symbol
, this_binding
.old_value
, 0, 1);
3419 if (NILP (Vquit_flag
) && !NILP (quitf
))
3426 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3427 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3428 The debugger is entered when that frame exits, if the flag is non-nil. */)
3430 Lisp_Object level
, flag
;
3432 register struct backtrace
*backlist
= backtrace_list
;
3435 CHECK_NUMBER (level
);
3437 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
3439 backlist
= backlist
->next
;
3443 backlist
->debug_on_exit
= !NILP (flag
);
3448 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3449 doc
: /* Print a trace of Lisp function calls currently active.
3450 Output stream used is value of `standard-output'. */)
3453 register struct backtrace
*backlist
= backtrace_list
;
3457 extern Lisp_Object Vprint_level
;
3458 struct gcpro gcpro1
;
3460 XSETFASTINT (Vprint_level
, 3);
3467 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
3468 if (backlist
->nargs
== UNEVALLED
)
3470 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
3471 write_string ("\n", -1);
3475 tem
= *backlist
->function
;
3476 Fprin1 (tem
, Qnil
); /* This can QUIT */
3477 write_string ("(", -1);
3478 if (backlist
->nargs
== MANY
)
3480 for (tail
= *backlist
->args
, i
= 0;
3482 tail
= Fcdr (tail
), i
++)
3484 if (i
) write_string (" ", -1);
3485 Fprin1 (Fcar (tail
), Qnil
);
3490 for (i
= 0; i
< backlist
->nargs
; i
++)
3492 if (i
) write_string (" ", -1);
3493 Fprin1 (backlist
->args
[i
], Qnil
);
3496 write_string (")\n", -1);
3498 backlist
= backlist
->next
;
3501 Vprint_level
= Qnil
;
3506 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, NULL
,
3507 doc
: /* Return the function and arguments NFRAMES up from current execution point.
3508 If that frame has not evaluated the arguments yet (or is a special form),
3509 the value is (nil FUNCTION ARG-FORMS...).
3510 If that frame has evaluated its arguments and called its function already,
3511 the value is (t FUNCTION ARG-VALUES...).
3512 A &rest arg is represented as the tail of the list ARG-VALUES.
3513 FUNCTION is whatever was supplied as car of evaluated list,
3514 or a lambda expression for macro calls.
3515 If NFRAMES is more than the number of frames, the value is nil. */)
3517 Lisp_Object nframes
;
3519 register struct backtrace
*backlist
= backtrace_list
;
3523 CHECK_NATNUM (nframes
);
3525 /* Find the frame requested. */
3526 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3527 backlist
= backlist
->next
;
3531 if (backlist
->nargs
== UNEVALLED
)
3532 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3535 if (backlist
->nargs
== MANY
)
3536 tem
= *backlist
->args
;
3538 tem
= Flist (backlist
->nargs
, backlist
->args
);
3540 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3548 register struct backtrace
*backlist
;
3551 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3553 mark_object (*backlist
->function
);
3555 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3558 i
= backlist
->nargs
- 1;
3560 mark_object (backlist
->args
[i
]);
3567 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
3568 doc
: /* *Limit on number of Lisp variable bindings and `unwind-protect's.
3569 If Lisp code tries to increase the total number past this amount,
3570 an error is signaled.
3571 You can safely use a value considerably larger than the default value,
3572 if that proves inconveniently small. However, if you increase it too far,
3573 Emacs could run out of memory trying to make the stack bigger. */);
3575 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
3576 doc
: /* *Limit on depth in `eval', `apply' and `funcall' before error.
3578 This limit serves to catch infinite recursions for you before they cause
3579 actual stack overflow in C, which would be fatal for Emacs.
3580 You can safely make it considerably larger than its default value,
3581 if that proves inconveniently small. However, if you increase it too far,
3582 Emacs could overflow the real C stack, and crash. */);
3584 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
3585 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3586 If the value is t, that means do an ordinary quit.
3587 If the value equals `throw-on-input', that means quit by throwing
3588 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3589 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3590 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3593 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
3594 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3595 Note that `quit-flag' will still be set by typing C-g,
3596 so a quit will be signaled as soon as `inhibit-quit' is nil.
3597 To prevent this happening, set `quit-flag' to nil
3598 before making `inhibit-quit' nil. */);
3599 Vinhibit_quit
= Qnil
;
3601 Qinhibit_quit
= intern ("inhibit-quit");
3602 staticpro (&Qinhibit_quit
);
3604 Qautoload
= intern ("autoload");
3605 staticpro (&Qautoload
);
3607 Qdebug_on_error
= intern ("debug-on-error");
3608 staticpro (&Qdebug_on_error
);
3610 Qmacro
= intern ("macro");
3611 staticpro (&Qmacro
);
3613 Qdeclare
= intern ("declare");
3614 staticpro (&Qdeclare
);
3616 /* Note that the process handling also uses Qexit, but we don't want
3617 to staticpro it twice, so we just do it here. */
3618 Qexit
= intern ("exit");
3621 Qinteractive
= intern ("interactive");
3622 staticpro (&Qinteractive
);
3624 Qcommandp
= intern ("commandp");
3625 staticpro (&Qcommandp
);
3627 Qdefun
= intern ("defun");
3628 staticpro (&Qdefun
);
3630 Qand_rest
= intern ("&rest");
3631 staticpro (&Qand_rest
);
3633 Qand_optional
= intern ("&optional");
3634 staticpro (&Qand_optional
);
3636 Qdebug
= intern ("debug");
3637 staticpro (&Qdebug
);
3639 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
3640 doc
: /* *Non-nil means errors display a backtrace buffer.
3641 More precisely, this happens for any error that is handled
3642 by the editor command loop.
3643 If the value is a list, an error only means to display a backtrace
3644 if one of its condition symbols appears in the list. */);
3645 Vstack_trace_on_error
= Qnil
;
3647 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
3648 doc
: /* *Non-nil means enter debugger if an error is signaled.
3649 Does not apply to errors handled by `condition-case' or those
3650 matched by `debug-ignored-errors'.
3651 If the value is a list, an error only means to enter the debugger
3652 if one of its condition symbols appears in the list.
3653 When you evaluate an expression interactively, this variable
3654 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3655 See also variable `debug-on-quit'. */);
3656 Vdebug_on_error
= Qnil
;
3658 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
3659 doc
: /* *List of errors for which the debugger should not be called.
3660 Each element may be a condition-name or a regexp that matches error messages.
3661 If any element applies to a given error, that error skips the debugger
3662 and just returns to top level.
3663 This overrides the variable `debug-on-error'.
3664 It does not apply to errors handled by `condition-case'. */);
3665 Vdebug_ignored_errors
= Qnil
;
3667 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
3668 doc
: /* *Non-nil means enter debugger if quit is signaled (C-g, for example).
3669 Does not apply if quit is handled by a `condition-case'. */);
3672 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
3673 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3675 DEFVAR_BOOL ("debugger-may-continue", &debugger_may_continue
,
3676 doc
: /* Non-nil means debugger may continue execution.
3677 This is nil when the debugger is called under circumstances where it
3678 might not be safe to continue. */);
3679 debugger_may_continue
= 1;
3681 DEFVAR_LISP ("debugger", &Vdebugger
,
3682 doc
: /* Function to call to invoke debugger.
3683 If due to frame exit, args are `exit' and the value being returned;
3684 this function's value will be returned instead of that.
3685 If due to error, args are `error' and a list of the args to `signal'.
3686 If due to `apply' or `funcall' entry, one arg, `lambda'.
3687 If due to `eval' entry, one arg, t. */);
3690 DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function
,
3691 doc
: /* If non-nil, this is a function for `signal' to call.
3692 It receives the same arguments that `signal' was given.
3693 The Edebug package uses this to regain control. */);
3694 Vsignal_hook_function
= Qnil
;
3696 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal
,
3697 doc
: /* *Non-nil means call the debugger regardless of condition handlers.
3698 Note that `debug-on-error', `debug-on-quit' and friends
3699 still determine whether to handle the particular condition. */);
3700 Vdebug_on_signal
= Qnil
;
3702 DEFVAR_LISP ("macro-declaration-function", &Vmacro_declaration_function
,
3703 doc
: /* Function to process declarations in a macro definition.
3704 The function will be called with two args MACRO and DECL.
3705 MACRO is the name of the macro being defined.
3706 DECL is a list `(declare ...)' containing the declarations.
3707 The value the function returns is not used. */);
3708 Vmacro_declaration_function
= Qnil
;
3710 Vrun_hooks
= intern ("run-hooks");
3711 staticpro (&Vrun_hooks
);
3713 staticpro (&Vautoload_queue
);
3714 Vautoload_queue
= Qnil
;
3715 staticpro (&Vsignaling_function
);
3716 Vsignaling_function
= Qnil
;
3727 defsubr (&Sfunction
);
3729 defsubr (&Sdefmacro
);
3731 defsubr (&Sdefvaralias
);
3732 defsubr (&Sdefconst
);
3733 defsubr (&Suser_variable_p
);
3737 defsubr (&Smacroexpand
);
3740 defsubr (&Sunwind_protect
);
3741 defsubr (&Scondition_case
);
3743 defsubr (&Sinteractive_p
);
3744 defsubr (&Scalled_interactively_p
);
3745 defsubr (&Scommandp
);
3746 defsubr (&Sautoload
);
3749 defsubr (&Sfuncall
);
3750 defsubr (&Srun_hooks
);
3751 defsubr (&Srun_hook_with_args
);
3752 defsubr (&Srun_hook_with_args_until_success
);
3753 defsubr (&Srun_hook_with_args_until_failure
);
3754 defsubr (&Sfetch_bytecode
);
3755 defsubr (&Sbacktrace_debug
);
3756 defsubr (&Sbacktrace
);
3757 defsubr (&Sbacktrace_frame
);
3760 /* arch-tag: 014a07aa-33ab-4a8f-a3d2-ee8a4a9ff7fb
3761 (do not change this comment) */