1 /* Evaluator for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1987, 1993-1995, 1999-2013 Free Software
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
25 #include "blockinput.h"
28 #include "dispextern.h"
29 #include "frame.h" /* For XFRAME. */
35 /* #if !BYTE_MARK_STACK */
38 /* struct catchtag *catchlist; */
40 /* Chain of condition handlers currently in effect.
41 The elements of this chain are contained in the stack frames
42 of Fcondition_case and internal_condition_case.
43 When an error is signaled (by calling Fsignal, below),
44 this chain is searched for an element that applies. */
46 /* #if !BYTE_MARK_STACK */
49 /* struct handler *handlerlist; */
52 /* Count levels of GCPRO to detect failure to UNGCPRO. */
56 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
;
57 Lisp_Object Qinhibit_quit
;
58 Lisp_Object Qand_rest
;
59 static Lisp_Object Qand_optional
;
60 static Lisp_Object Qinhibit_debugger
;
61 static Lisp_Object Qdeclare
;
62 Lisp_Object Qinternal_interpreter_environment
, Qclosure
;
64 static Lisp_Object Qdebug
;
66 /* This holds either the symbol `run-hooks' or nil.
67 It is nil at an early stage of startup, and when Emacs
70 Lisp_Object Vrun_hooks
;
72 /* Non-nil means record all fset's and provide's, to be undone
73 if the file being autoloaded is not fully loaded.
74 They are recorded by being consed onto the front of Vautoload_queue:
75 (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide. */
77 Lisp_Object Vautoload_queue
;
79 /* Current number of specbindings allocated in specpdl, not counting
80 the dummy entry specpdl[-1]. */
82 /* ptrdiff_t specpdl_size; */
84 /* Pointer to beginning of specpdl. A dummy entry specpdl[-1] exists
85 only so that its address can be taken. */
87 /* union specbinding *specpdl; */
89 /* Pointer to first unused element in specpdl. */
91 /* union specbinding *specpdl_ptr; */
93 /* Depth in Lisp evaluations and function calls. */
95 /* static EMACS_INT lisp_eval_depth; */
97 /* The value of num_nonmacro_input_events as of the last time we
98 started to enter the debugger. If we decide to enter the debugger
99 again when this is still equal to num_nonmacro_input_events, then we
100 know that the debugger itself has an error, and we should just
101 signal the error instead of entering an infinite loop of debugger
104 static EMACS_INT when_entered_debugger
;
106 /* The function from which the last `signal' was called. Set in
108 /* FIXME: We should probably get rid of this! */
109 Lisp_Object Vsignaling_function
;
111 /* If non-nil, Lisp code must not be run since some part of Emacs is
112 in an inconsistent state. Currently, x-create-frame uses this to
113 avoid triggering window-configuration-change-hook while the new
114 frame is half-initialized. */
115 Lisp_Object inhibit_lisp_code
;
117 /* These would ordinarily be static, but they need to be visible to GDB. */
118 bool backtrace_p (union specbinding
*) EXTERNALLY_VISIBLE
;
119 Lisp_Object
*backtrace_args (union specbinding
*) EXTERNALLY_VISIBLE
;
120 Lisp_Object
backtrace_function (union specbinding
*) EXTERNALLY_VISIBLE
;
121 union specbinding
*backtrace_next (union specbinding
*) EXTERNALLY_VISIBLE
;
122 union specbinding
*backtrace_top (void) EXTERNALLY_VISIBLE
;
124 static Lisp_Object
funcall_lambda (Lisp_Object
, ptrdiff_t, Lisp_Object
*);
125 static Lisp_Object
apply_lambda (Lisp_Object fun
, Lisp_Object args
);
128 specpdl_symbol (union specbinding
*pdl
)
130 eassert (pdl
->kind
>= SPECPDL_LET
);
131 return pdl
->let
.symbol
;
135 specpdl_old_value (union specbinding
*pdl
)
137 eassert (pdl
->kind
>= SPECPDL_LET
);
138 return pdl
->let
.old_value
;
142 set_specpdl_old_value (union specbinding
*pdl
, Lisp_Object val
)
144 eassert (pdl
->kind
>= SPECPDL_LET
);
145 pdl
->let
.old_value
= val
;
149 specpdl_where (union specbinding
*pdl
)
151 eassert (pdl
->kind
> SPECPDL_LET
);
152 return pdl
->let
.where
;
156 specpdl_saved_value (union specbinding
*pdl
)
158 eassert (pdl
->kind
>= SPECPDL_LET
);
159 return pdl
->let
.saved_value
;
163 specpdl_arg (union specbinding
*pdl
)
165 eassert (pdl
->kind
== SPECPDL_UNWIND
);
166 return pdl
->unwind
.arg
;
170 backtrace_function (union specbinding
*pdl
)
172 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
173 return pdl
->bt
.function
;
177 backtrace_nargs (union specbinding
*pdl
)
179 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
180 return pdl
->bt
.nargs
;
184 backtrace_args (union specbinding
*pdl
)
186 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
191 backtrace_debug_on_exit (union specbinding
*pdl
)
193 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
194 return pdl
->bt
.debug_on_exit
;
197 /* Functions to modify slots of backtrace records. */
200 set_backtrace_args (union specbinding
*pdl
, Lisp_Object
*args
)
202 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
207 set_backtrace_nargs (union specbinding
*pdl
, ptrdiff_t n
)
209 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
214 set_backtrace_debug_on_exit (union specbinding
*pdl
, bool doe
)
216 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
217 pdl
->bt
.debug_on_exit
= doe
;
220 /* Helper functions to scan the backtrace. */
223 backtrace_p (union specbinding
*pdl
)
224 { return pdl
>= specpdl
; }
229 union specbinding
*pdl
= specpdl_ptr
- 1;
230 while (backtrace_p (pdl
) && pdl
->kind
!= SPECPDL_BACKTRACE
)
236 backtrace_next (union specbinding
*pdl
)
239 while (backtrace_p (pdl
) && pdl
->kind
!= SPECPDL_BACKTRACE
)
246 init_eval_once (void)
249 union specbinding
*pdlvec
= xmalloc ((size
+ 1) * sizeof *specpdl
);
251 specpdl
= specpdl_ptr
= pdlvec
+ 1;
252 /* Don't forget to update docs (lispref node "Local Variables"). */
253 max_specpdl_size
= 1300; /* 1000 is not enough for CEDET's c-by.el. */
254 max_lisp_eval_depth
= 600;
262 specpdl_ptr
= specpdl
;
266 debug_on_next_call
= 0;
271 /* This is less than the initial value of num_nonmacro_input_events. */
272 when_entered_debugger
= -1;
275 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
276 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
278 mark_catchlist (struct catchtag
*catch)
280 for (; catch; catch = catch->next
)
282 mark_object (catch->tag
);
283 mark_object (catch->val
);
288 /* Unwind-protect function used by call_debugger. */
291 restore_stack_limits (Lisp_Object data
)
293 max_specpdl_size
= XINT (XCAR (data
));
294 max_lisp_eval_depth
= XINT (XCDR (data
));
297 /* Call the Lisp debugger, giving it argument ARG. */
300 call_debugger (Lisp_Object arg
)
302 bool debug_while_redisplaying
;
303 ptrdiff_t count
= SPECPDL_INDEX ();
305 EMACS_INT old_max
= max_specpdl_size
;
307 /* Temporarily bump up the stack limits,
308 so the debugger won't run out of stack. */
310 max_specpdl_size
+= 1;
311 record_unwind_protect (restore_stack_limits
,
312 Fcons (make_number (old_max
),
313 make_number (max_lisp_eval_depth
)));
314 max_specpdl_size
= old_max
;
316 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
317 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
319 if (max_specpdl_size
- 100 < SPECPDL_INDEX ())
320 max_specpdl_size
= SPECPDL_INDEX () + 100;
322 #ifdef HAVE_WINDOW_SYSTEM
323 if (display_hourglass_p
)
327 debug_on_next_call
= 0;
328 when_entered_debugger
= num_nonmacro_input_events
;
330 /* Resetting redisplaying_p to 0 makes sure that debug output is
331 displayed if the debugger is invoked during redisplay. */
332 debug_while_redisplaying
= redisplaying_p
;
334 specbind (intern ("debugger-may-continue"),
335 debug_while_redisplaying
? Qnil
: Qt
);
336 specbind (Qinhibit_redisplay
, Qnil
);
337 specbind (Qinhibit_debugger
, Qt
);
339 #if 0 /* Binding this prevents execution of Lisp code during
340 redisplay, which necessarily leads to display problems. */
341 specbind (Qinhibit_eval_during_redisplay
, Qt
);
344 val
= apply1 (Vdebugger
, arg
);
346 /* Interrupting redisplay and resuming it later is not safe under
347 all circumstances. So, when the debugger returns, abort the
348 interrupted redisplay by going back to the top-level. */
349 if (debug_while_redisplaying
)
352 return unbind_to (count
, val
);
356 do_debug_on_call (Lisp_Object code
)
358 debug_on_next_call
= 0;
359 set_backtrace_debug_on_exit (specpdl_ptr
- 1, true);
360 call_debugger (list1 (code
));
363 /* NOTE!!! Every function that can call EVAL must protect its args
364 and temporaries from garbage collection while it needs them.
365 The definition of `For' shows what you have to do. */
367 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
368 doc
: /* Eval args until one of them yields non-nil, then return that value.
369 The remaining args are not evalled at all.
370 If all args return nil, return nil.
371 usage: (or CONDITIONS...) */)
374 register Lisp_Object val
= Qnil
;
381 val
= eval_sub (XCAR (args
));
391 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
392 doc
: /* Eval args until one of them yields nil, then return nil.
393 The remaining args are not evalled at all.
394 If no arg yields nil, return the last arg's value.
395 usage: (and CONDITIONS...) */)
398 register Lisp_Object val
= Qt
;
405 val
= eval_sub (XCAR (args
));
415 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
416 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
417 Returns the value of THEN or the value of the last of the ELSE's.
418 THEN must be one expression, but ELSE... can be zero or more expressions.
419 If COND yields nil, and there are no ELSE's, the value is nil.
420 usage: (if COND THEN ELSE...) */)
427 cond
= eval_sub (XCAR (args
));
431 return eval_sub (Fcar (XCDR (args
)));
432 return Fprogn (XCDR (XCDR (args
)));
435 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
436 doc
: /* Try each clause until one succeeds.
437 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
438 and, if the value is non-nil, this clause succeeds:
439 then the expressions in BODY are evaluated and the last one's
440 value is the value of the cond-form.
441 If no clause succeeds, cond returns nil.
442 If a clause has one element, as in (CONDITION),
443 CONDITION's value if non-nil is returned from the cond-form.
444 usage: (cond CLAUSES...) */)
447 Lisp_Object val
= args
;
453 Lisp_Object clause
= XCAR (args
);
454 val
= eval_sub (Fcar (clause
));
457 if (!NILP (XCDR (clause
)))
458 val
= Fprogn (XCDR (clause
));
468 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
469 doc
: /* Eval BODY forms sequentially and return value of last one.
470 usage: (progn BODY...) */)
473 Lisp_Object val
= Qnil
;
480 val
= eval_sub (XCAR (body
));
488 /* Evaluate BODY sequentially, discarding its value. Suitable for
489 record_unwind_protect. */
492 unwind_body (Lisp_Object body
)
497 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
498 doc
: /* Eval FIRST and BODY sequentially; return value from FIRST.
499 The value of FIRST is saved during the evaluation of the remaining args,
500 whose values are discarded.
501 usage: (prog1 FIRST BODY...) */)
505 Lisp_Object args_left
;
506 struct gcpro gcpro1
, gcpro2
;
512 val
= eval_sub (XCAR (args_left
));
513 while (CONSP (args_left
= XCDR (args_left
)))
514 eval_sub (XCAR (args_left
));
520 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
521 doc
: /* Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
522 The value of FORM2 is saved during the evaluation of the
523 remaining args, whose values are discarded.
524 usage: (prog2 FORM1 FORM2 BODY...) */)
530 eval_sub (XCAR (args
));
532 return Fprog1 (XCDR (args
));
535 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
536 doc
: /* Set each SYM to the value of its VAL.
537 The symbols SYM are variables; they are literal (not evaluated).
538 The values VAL are expressions; they are evaluated.
539 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
540 The second VAL is not computed until after the first SYM is set, and so on;
541 each VAL can use the new value of variables set earlier in the `setq'.
542 The return value of the `setq' form is the value of the last VAL.
543 usage: (setq [SYM VAL]...) */)
546 Lisp_Object val
, sym
, lex_binding
;
551 Lisp_Object args_left
= args
;
557 val
= eval_sub (Fcar (XCDR (args_left
)));
558 sym
= XCAR (args_left
);
560 /* Like for eval_sub, we do not check declared_special here since
561 it's been done when let-binding. */
562 if (!NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
564 && !NILP (lex_binding
565 = Fassq (sym
, Vinternal_interpreter_environment
)))
566 XSETCDR (lex_binding
, val
); /* SYM is lexically bound. */
568 Fset (sym
, val
); /* SYM is dynamically bound. */
570 args_left
= Fcdr (XCDR (args_left
));
572 while (CONSP (args_left
));
580 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
581 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
582 Warning: `quote' does not construct its return value, but just returns
583 the value that was pre-constructed by the Lisp reader (see info node
584 `(elisp)Printed Representation').
585 This means that '(a . b) is not identical to (cons 'a 'b): the former
586 does not cons. Quoting should be reserved for constants that will
587 never be modified by side-effects, unless you like self-modifying code.
588 See the common pitfall in info node `(elisp)Rearrangement' for an example
589 of unexpected results when a quoted object is modified.
590 usage: (quote ARG) */)
593 if (CONSP (XCDR (args
)))
594 xsignal2 (Qwrong_number_of_arguments
, Qquote
, Flength (args
));
598 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
599 doc
: /* Like `quote', but preferred for objects which are functions.
600 In byte compilation, `function' causes its argument to be compiled.
601 `quote' cannot do that.
602 usage: (function ARG) */)
605 Lisp_Object quoted
= XCAR (args
);
607 if (CONSP (XCDR (args
)))
608 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
610 if (!NILP (Vinternal_interpreter_environment
)
612 && EQ (XCAR (quoted
), Qlambda
))
613 /* This is a lambda expression within a lexical environment;
614 return an interpreted closure instead of a simple lambda. */
615 return Fcons (Qclosure
, Fcons (Vinternal_interpreter_environment
,
618 /* Simply quote the argument. */
623 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
624 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
625 Aliased variables always have the same value; setting one sets the other.
626 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
627 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
628 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
629 itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
630 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
631 The return value is BASE-VARIABLE. */)
632 (Lisp_Object new_alias
, Lisp_Object base_variable
, Lisp_Object docstring
)
634 struct Lisp_Symbol
*sym
;
636 CHECK_SYMBOL (new_alias
);
637 CHECK_SYMBOL (base_variable
);
639 sym
= XSYMBOL (new_alias
);
642 /* Not sure why, but why not? */
643 error ("Cannot make a constant an alias");
645 switch (sym
->redirect
)
647 case SYMBOL_FORWARDED
:
648 error ("Cannot make an internal variable an alias");
649 case SYMBOL_LOCALIZED
:
650 error ("Don't know how to make a localized variable an alias");
653 /* http://lists.gnu.org/archive/html/emacs-devel/2008-04/msg00834.html
654 If n_a is bound, but b_v is not, set the value of b_v to n_a,
655 so that old-code that affects n_a before the aliasing is setup
657 if (NILP (Fboundp (base_variable
)))
658 set_internal (base_variable
, find_symbol_value (new_alias
), Qnil
, 1);
661 union specbinding
*p
;
663 for (p
= specpdl_ptr
; p
> specpdl
; )
664 if ((--p
)->kind
>= SPECPDL_LET
665 && (EQ (new_alias
, specpdl_symbol (p
))))
666 error ("Don't know how to make a let-bound variable an alias");
669 sym
->declared_special
= 1;
670 XSYMBOL (base_variable
)->declared_special
= 1;
671 sym
->redirect
= SYMBOL_VARALIAS
;
672 SET_SYMBOL_ALIAS (sym
, XSYMBOL (base_variable
));
673 sym
->constant
= SYMBOL_CONSTANT_P (base_variable
);
674 LOADHIST_ATTACH (new_alias
);
675 /* Even if docstring is nil: remove old docstring. */
676 Fput (new_alias
, Qvariable_documentation
, docstring
);
678 return base_variable
;
681 static union specbinding
*
682 default_toplevel_binding (Lisp_Object symbol
)
684 union specbinding
*binding
= NULL
;
685 union specbinding
*pdl
= specpdl_ptr
;
686 while (pdl
> specpdl
)
688 switch ((--pdl
)->kind
)
690 case SPECPDL_LET_DEFAULT
:
692 if (EQ (specpdl_symbol (pdl
), symbol
))
700 DEFUN ("default-toplevel-value", Fdefault_toplevel_value
, Sdefault_toplevel_value
, 1, 1, 0,
701 doc
: /* Return SYMBOL's toplevel default value.
702 "Toplevel" means outside of any let binding. */)
705 union specbinding
*binding
= default_toplevel_binding (symbol
);
707 = binding
? specpdl_old_value (binding
) : Fdefault_value (symbol
);
708 if (!EQ (value
, Qunbound
))
710 xsignal1 (Qvoid_variable
, symbol
);
713 DEFUN ("set-default-toplevel-value", Fset_default_toplevel_value
,
714 Sset_default_toplevel_value
, 2, 2, 0,
715 doc
: /* Set SYMBOL's toplevel default value to VALUE.
716 "Toplevel" means outside of any let binding. */)
717 (Lisp_Object symbol
, Lisp_Object value
)
719 union specbinding
*binding
= default_toplevel_binding (symbol
);
721 set_specpdl_old_value (binding
, value
);
723 Fset_default (symbol
, value
);
727 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
728 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
729 You are not required to define a variable in order to use it, but
730 defining it lets you supply an initial value and documentation, which
731 can be referred to by the Emacs help facilities and other programming
732 tools. The `defvar' form also declares the variable as \"special\",
733 so that it is always dynamically bound even if `lexical-binding' is t.
735 The optional argument INITVALUE is evaluated, and used to set SYMBOL,
736 only if SYMBOL's value is void. If SYMBOL is buffer-local, its
737 default value is what is set; buffer-local values are not affected.
738 If INITVALUE is missing, SYMBOL's value is not set.
740 If SYMBOL has a local binding, then this form affects the local
741 binding. This is usually not what you want. Thus, if you need to
742 load a file defining variables, with this form or with `defconst' or
743 `defcustom', you should always load that file _outside_ any bindings
744 for these variables. \(`defconst' and `defcustom' behave similarly in
747 The optional argument DOCSTRING is a documentation string for the
750 To define a user option, use `defcustom' instead of `defvar'.
751 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
754 Lisp_Object sym
, tem
, tail
;
761 if (CONSP (XCDR (tail
)) && CONSP (XCDR (XCDR (tail
))))
762 error ("Too many arguments");
764 tem
= Fdefault_boundp (sym
);
766 /* Do it before evaluating the initial value, for self-references. */
767 XSYMBOL (sym
)->declared_special
= 1;
770 Fset_default (sym
, eval_sub (XCAR (tail
)));
772 { /* Check if there is really a global binding rather than just a let
773 binding that shadows the global unboundness of the var. */
774 union specbinding
*binding
= default_toplevel_binding (sym
);
775 if (binding
&& EQ (specpdl_old_value (binding
), Qunbound
))
777 set_specpdl_old_value (binding
, eval_sub (XCAR (tail
)));
784 if (!NILP (Vpurify_flag
))
785 tem
= Fpurecopy (tem
);
786 Fput (sym
, Qvariable_documentation
, tem
);
788 LOADHIST_ATTACH (sym
);
790 else if (!NILP (Vinternal_interpreter_environment
)
791 && !XSYMBOL (sym
)->declared_special
)
792 /* A simple (defvar foo) with lexical scoping does "nothing" except
793 declare that var to be dynamically scoped *locally* (i.e. within
794 the current file or let-block). */
795 Vinternal_interpreter_environment
796 = Fcons (sym
, Vinternal_interpreter_environment
);
799 /* Simple (defvar <var>) should not count as a definition at all.
800 It could get in the way of other definitions, and unloading this
801 package could try to make the variable unbound. */
807 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
808 doc
: /* Define SYMBOL as a constant variable.
809 This declares that neither programs nor users should ever change the
810 value. This constancy is not actually enforced by Emacs Lisp, but
811 SYMBOL is marked as a special variable so that it is never lexically
814 The `defconst' form always sets the value of SYMBOL to the result of
815 evalling INITVALUE. If SYMBOL is buffer-local, its default value is
816 what is set; buffer-local values are not affected. If SYMBOL has a
817 local binding, then this form sets the local binding's value.
818 However, you should normally not make local bindings for variables
819 defined with this form.
821 The optional DOCSTRING specifies the variable's documentation string.
822 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
825 Lisp_Object sym
, tem
;
828 if (CONSP (Fcdr (XCDR (XCDR (args
)))))
829 error ("Too many arguments");
831 tem
= eval_sub (Fcar (XCDR (args
)));
832 if (!NILP (Vpurify_flag
))
833 tem
= Fpurecopy (tem
);
834 Fset_default (sym
, tem
);
835 XSYMBOL (sym
)->declared_special
= 1;
836 tem
= Fcar (XCDR (XCDR (args
)));
839 if (!NILP (Vpurify_flag
))
840 tem
= Fpurecopy (tem
);
841 Fput (sym
, Qvariable_documentation
, tem
);
843 Fput (sym
, Qrisky_local_variable
, Qt
);
844 LOADHIST_ATTACH (sym
);
848 /* Make SYMBOL lexically scoped. */
849 DEFUN ("internal-make-var-non-special", Fmake_var_non_special
,
850 Smake_var_non_special
, 1, 1, 0,
851 doc
: /* Internal function. */)
854 CHECK_SYMBOL (symbol
);
855 XSYMBOL (symbol
)->declared_special
= 0;
860 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
861 doc
: /* Bind variables according to VARLIST then eval BODY.
862 The value of the last form in BODY is returned.
863 Each element of VARLIST is a symbol (which is bound to nil)
864 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
865 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
866 usage: (let* VARLIST BODY...) */)
869 Lisp_Object varlist
, var
, val
, elt
, lexenv
;
870 ptrdiff_t count
= SPECPDL_INDEX ();
871 struct gcpro gcpro1
, gcpro2
, gcpro3
;
873 GCPRO3 (args
, elt
, varlist
);
875 lexenv
= Vinternal_interpreter_environment
;
877 varlist
= XCAR (args
);
878 while (CONSP (varlist
))
882 elt
= XCAR (varlist
);
888 else if (! NILP (Fcdr (Fcdr (elt
))))
889 signal_error ("`let' bindings can have only one value-form", elt
);
893 val
= eval_sub (Fcar (Fcdr (elt
)));
896 if (!NILP (lexenv
) && SYMBOLP (var
)
897 && !XSYMBOL (var
)->declared_special
898 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
899 /* Lexically bind VAR by adding it to the interpreter's binding
903 = Fcons (Fcons (var
, val
), Vinternal_interpreter_environment
);
904 if (EQ (Vinternal_interpreter_environment
, lexenv
))
905 /* Save the old lexical environment on the specpdl stack,
906 but only for the first lexical binding, since we'll never
907 need to revert to one of the intermediate ones. */
908 specbind (Qinternal_interpreter_environment
, newenv
);
910 Vinternal_interpreter_environment
= newenv
;
915 varlist
= XCDR (varlist
);
918 val
= Fprogn (XCDR (args
));
919 return unbind_to (count
, val
);
922 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
923 doc
: /* Bind variables according to VARLIST then eval BODY.
924 The value of the last form in BODY is returned.
925 Each element of VARLIST is a symbol (which is bound to nil)
926 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
927 All the VALUEFORMs are evalled before any symbols are bound.
928 usage: (let VARLIST BODY...) */)
931 Lisp_Object
*temps
, tem
, lexenv
;
932 register Lisp_Object elt
, varlist
;
933 ptrdiff_t count
= SPECPDL_INDEX ();
935 struct gcpro gcpro1
, gcpro2
;
938 varlist
= XCAR (args
);
940 /* Make space to hold the values to give the bound variables. */
941 elt
= Flength (varlist
);
942 SAFE_ALLOCA_LISP (temps
, XFASTINT (elt
));
944 /* Compute the values and store them in `temps'. */
946 GCPRO2 (args
, *temps
);
949 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
952 elt
= XCAR (varlist
);
954 temps
[argnum
++] = Qnil
;
955 else if (! NILP (Fcdr (Fcdr (elt
))))
956 signal_error ("`let' bindings can have only one value-form", elt
);
958 temps
[argnum
++] = eval_sub (Fcar (Fcdr (elt
)));
959 gcpro2
.nvars
= argnum
;
963 lexenv
= Vinternal_interpreter_environment
;
965 varlist
= XCAR (args
);
966 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
970 elt
= XCAR (varlist
);
971 var
= SYMBOLP (elt
) ? elt
: Fcar (elt
);
972 tem
= temps
[argnum
++];
974 if (!NILP (lexenv
) && SYMBOLP (var
)
975 && !XSYMBOL (var
)->declared_special
976 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
977 /* Lexically bind VAR by adding it to the lexenv alist. */
978 lexenv
= Fcons (Fcons (var
, tem
), lexenv
);
980 /* Dynamically bind VAR. */
984 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
985 /* Instantiate a new lexical environment. */
986 specbind (Qinternal_interpreter_environment
, lexenv
);
988 elt
= Fprogn (XCDR (args
));
990 return unbind_to (count
, elt
);
993 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
994 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
995 The order of execution is thus TEST, BODY, TEST, BODY and so on
996 until TEST returns nil.
997 usage: (while TEST BODY...) */)
1000 Lisp_Object test
, body
;
1001 struct gcpro gcpro1
, gcpro2
;
1003 GCPRO2 (test
, body
);
1007 while (!NILP (eval_sub (test
)))
1017 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
1018 doc
: /* Return result of expanding macros at top level of FORM.
1019 If FORM is not a macro call, it is returned unchanged.
1020 Otherwise, the macro is expanded and the expansion is considered
1021 in place of FORM. When a non-macro-call results, it is returned.
1023 The second optional arg ENVIRONMENT specifies an environment of macro
1024 definitions to shadow the loaded ones for use in file byte-compilation. */)
1025 (Lisp_Object form
, Lisp_Object environment
)
1027 /* With cleanups from Hallvard Furuseth. */
1028 register Lisp_Object expander
, sym
, def
, tem
;
1032 /* Come back here each time we expand a macro call,
1033 in case it expands into another macro call. */
1036 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1037 def
= sym
= XCAR (form
);
1039 /* Trace symbols aliases to other symbols
1040 until we get a symbol that is not an alias. */
1041 while (SYMBOLP (def
))
1045 tem
= Fassq (sym
, environment
);
1048 def
= XSYMBOL (sym
)->function
;
1054 /* Right now TEM is the result from SYM in ENVIRONMENT,
1055 and if TEM is nil then DEF is SYM's function definition. */
1058 /* SYM is not mentioned in ENVIRONMENT.
1059 Look at its function definition. */
1060 struct gcpro gcpro1
;
1062 def
= Fautoload_do_load (def
, sym
, Qmacro
);
1065 /* Not defined or definition not suitable. */
1067 if (!EQ (XCAR (def
), Qmacro
))
1069 else expander
= XCDR (def
);
1073 expander
= XCDR (tem
);
1074 if (NILP (expander
))
1078 Lisp_Object newform
= apply1 (expander
, XCDR (form
));
1079 if (EQ (form
, newform
))
1088 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1089 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1090 TAG is evalled to get the tag to use; it must not be nil.
1092 Then the BODY is executed.
1093 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
1094 If no throw happens, `catch' returns the value of the last BODY form.
1095 If a throw happens, it specifies the value to return from `catch'.
1096 usage: (catch TAG BODY...) */)
1099 register Lisp_Object tag
;
1100 struct gcpro gcpro1
;
1103 tag
= eval_sub (XCAR (args
));
1105 return internal_catch (tag
, Fprogn
, XCDR (args
));
1108 /* Set up a catch, then call C function FUNC on argument ARG.
1109 FUNC should return a Lisp_Object.
1110 This is how catches are done from within C code. */
1113 internal_catch (Lisp_Object tag
, Lisp_Object (*func
) (Lisp_Object
), Lisp_Object arg
)
1115 /* This structure is made part of the chain `catchlist'. */
1118 /* Fill in the components of c, and put it on the list. */
1122 c
.f_handlerlist
= handlerlist
;
1123 c
.f_lisp_eval_depth
= lisp_eval_depth
;
1124 c
.pdlcount
= SPECPDL_INDEX ();
1125 c
.poll_suppress_count
= poll_suppress_count
;
1126 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1127 c
.gcpro
= gcprolist
;
1128 c
.byte_stack
= byte_stack_list
;
1132 if (! sys_setjmp (c
.jmp
))
1133 c
.val
= (*func
) (arg
);
1135 /* Throw works by a longjmp that comes right here. */
1140 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1141 jump to that CATCH, returning VALUE as the value of that catch.
1143 This is the guts of Fthrow and Fsignal; they differ only in the way
1144 they choose the catch tag to throw to. A catch tag for a
1145 condition-case form has a TAG of Qnil.
1147 Before each catch is discarded, unbind all special bindings and
1148 execute all unwind-protect clauses made above that catch. Unwind
1149 the handler stack as we go, so that the proper handlers are in
1150 effect for each unwind-protect clause we run. At the end, restore
1151 some static info saved in CATCH, and longjmp to the location
1154 This is used for correct unwinding in Fthrow and Fsignal. */
1156 static _Noreturn
void
1157 unwind_to_catch (struct catchtag
*catch, Lisp_Object value
)
1161 /* Save the value in the tag. */
1164 /* Restore certain special C variables. */
1165 set_poll_suppress_count (catch->poll_suppress_count
);
1166 unblock_input_to (catch->interrupt_input_blocked
);
1171 last_time
= catchlist
== catch;
1173 /* Unwind the specpdl stack, and then restore the proper set of
1175 unbind_to (catchlist
->pdlcount
, Qnil
);
1176 handlerlist
= catchlist
->f_handlerlist
;
1177 catchlist
= catchlist
->next
;
1179 while (! last_time
);
1181 byte_stack_list
= catch->byte_stack
;
1182 gcprolist
= catch->gcpro
;
1184 gcpro_level
= gcprolist
? gcprolist
->level
+ 1 : 0;
1186 lisp_eval_depth
= catch->f_lisp_eval_depth
;
1188 sys_longjmp (catch->jmp
, 1);
1191 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1192 doc
: /* Throw to the catch for TAG and return VALUE from it.
1193 Both TAG and VALUE are evalled. */)
1194 (register Lisp_Object tag
, Lisp_Object value
)
1196 register struct catchtag
*c
;
1199 for (c
= catchlist
; c
; c
= c
->next
)
1201 if (EQ (c
->tag
, tag
))
1202 unwind_to_catch (c
, value
);
1204 xsignal2 (Qno_catch
, tag
, value
);
1208 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1209 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1210 If BODYFORM completes normally, its value is returned
1211 after executing the UNWINDFORMS.
1212 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1213 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1217 ptrdiff_t count
= SPECPDL_INDEX ();
1219 record_unwind_protect (unwind_body
, XCDR (args
));
1220 val
= eval_sub (XCAR (args
));
1221 return unbind_to (count
, val
);
1224 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1225 doc
: /* Regain control when an error is signaled.
1226 Executes BODYFORM and returns its value if no error happens.
1227 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1228 where the BODY is made of Lisp expressions.
1230 A handler is applicable to an error
1231 if CONDITION-NAME is one of the error's condition names.
1232 If an error happens, the first applicable handler is run.
1234 The car of a handler may be a list of condition names instead of a
1235 single condition name; then it handles all of them. If the special
1236 condition name `debug' is present in this list, it allows another
1237 condition in the list to run the debugger if `debug-on-error' and the
1238 other usual mechanisms says it should (otherwise, `condition-case'
1239 suppresses the debugger).
1241 When a handler handles an error, control returns to the `condition-case'
1242 and it executes the handler's BODY...
1243 with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
1244 \(If VAR is nil, the handler can't access that information.)
1245 Then the value of the last BODY form is returned from the `condition-case'
1248 See also the function `signal' for more info.
1249 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1252 Lisp_Object var
= XCAR (args
);
1253 Lisp_Object bodyform
= XCAR (XCDR (args
));
1254 Lisp_Object handlers
= XCDR (XCDR (args
));
1256 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1259 /* Like Fcondition_case, but the args are separate
1260 rather than passed in a list. Used by Fbyte_code. */
1263 internal_lisp_condition_case (volatile Lisp_Object var
, Lisp_Object bodyform
,
1264 Lisp_Object handlers
)
1272 for (val
= handlers
; CONSP (val
); val
= XCDR (val
))
1278 && (SYMBOLP (XCAR (tem
))
1279 || CONSP (XCAR (tem
))))))
1280 error ("Invalid condition handler: %s",
1281 SDATA (Fprin1_to_string (tem
, Qt
)));
1286 c
.f_handlerlist
= handlerlist
;
1287 c
.f_lisp_eval_depth
= lisp_eval_depth
;
1288 c
.pdlcount
= SPECPDL_INDEX ();
1289 c
.poll_suppress_count
= poll_suppress_count
;
1290 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1291 c
.gcpro
= gcprolist
;
1292 c
.byte_stack
= byte_stack_list
;
1293 if (sys_setjmp (c
.jmp
))
1296 specbind (h
.var
, c
.val
);
1297 val
= Fprogn (Fcdr (h
.chosen_clause
));
1299 /* Note that this just undoes the binding of h.var; whoever
1300 longjumped to us unwound the stack to c.pdlcount before
1302 unbind_to (c
.pdlcount
, Qnil
);
1309 h
.handler
= handlers
;
1310 h
.next
= handlerlist
;
1314 val
= eval_sub (bodyform
);
1316 handlerlist
= h
.next
;
1320 /* Call the function BFUN with no arguments, catching errors within it
1321 according to HANDLERS. If there is an error, call HFUN with
1322 one argument which is the data that describes the error:
1325 HANDLERS can be a list of conditions to catch.
1326 If HANDLERS is Qt, catch all errors.
1327 If HANDLERS is Qerror, catch all errors
1328 but allow the debugger to run if that is enabled. */
1331 internal_condition_case (Lisp_Object (*bfun
) (void), Lisp_Object handlers
,
1332 Lisp_Object (*hfun
) (Lisp_Object
))
1340 c
.f_handlerlist
= handlerlist
;
1341 c
.f_lisp_eval_depth
= lisp_eval_depth
;
1342 c
.pdlcount
= SPECPDL_INDEX ();
1343 c
.poll_suppress_count
= poll_suppress_count
;
1344 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1345 c
.gcpro
= gcprolist
;
1346 c
.byte_stack
= byte_stack_list
;
1347 if (sys_setjmp (c
.jmp
))
1349 return (*hfun
) (c
.val
);
1353 h
.handler
= handlers
;
1355 h
.next
= handlerlist
;
1361 handlerlist
= h
.next
;
1365 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1368 internal_condition_case_1 (Lisp_Object (*bfun
) (Lisp_Object
), Lisp_Object arg
,
1369 Lisp_Object handlers
, Lisp_Object (*hfun
) (Lisp_Object
))
1377 c
.f_handlerlist
= handlerlist
;
1378 c
.f_lisp_eval_depth
= lisp_eval_depth
;
1379 c
.pdlcount
= SPECPDL_INDEX ();
1380 c
.poll_suppress_count
= poll_suppress_count
;
1381 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1382 c
.gcpro
= gcprolist
;
1383 c
.byte_stack
= byte_stack_list
;
1384 if (sys_setjmp (c
.jmp
))
1386 return (*hfun
) (c
.val
);
1390 h
.handler
= handlers
;
1392 h
.next
= handlerlist
;
1396 val
= (*bfun
) (arg
);
1398 handlerlist
= h
.next
;
1402 /* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as
1406 internal_condition_case_2 (Lisp_Object (*bfun
) (Lisp_Object
, Lisp_Object
),
1409 Lisp_Object handlers
,
1410 Lisp_Object (*hfun
) (Lisp_Object
))
1418 c
.f_handlerlist
= handlerlist
;
1419 c
.f_lisp_eval_depth
= lisp_eval_depth
;
1420 c
.pdlcount
= SPECPDL_INDEX ();
1421 c
.poll_suppress_count
= poll_suppress_count
;
1422 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1423 c
.gcpro
= gcprolist
;
1424 c
.byte_stack
= byte_stack_list
;
1425 if (sys_setjmp (c
.jmp
))
1427 return (*hfun
) (c
.val
);
1431 h
.handler
= handlers
;
1433 h
.next
= handlerlist
;
1437 val
= (*bfun
) (arg1
, arg2
);
1439 handlerlist
= h
.next
;
1443 /* Like internal_condition_case but call BFUN with NARGS as first,
1444 and ARGS as second argument. */
1447 internal_condition_case_n (Lisp_Object (*bfun
) (ptrdiff_t, Lisp_Object
*),
1450 Lisp_Object handlers
,
1451 Lisp_Object (*hfun
) (Lisp_Object err
,
1461 c
.f_handlerlist
= handlerlist
;
1462 c
.f_lisp_eval_depth
= lisp_eval_depth
;
1463 c
.pdlcount
= SPECPDL_INDEX ();
1464 c
.poll_suppress_count
= poll_suppress_count
;
1465 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1466 c
.gcpro
= gcprolist
;
1467 c
.byte_stack
= byte_stack_list
;
1468 if (sys_setjmp (c
.jmp
))
1470 return (*hfun
) (c
.val
, nargs
, args
);
1474 h
.handler
= handlers
;
1476 h
.next
= handlerlist
;
1480 val
= (*bfun
) (nargs
, args
);
1482 handlerlist
= h
.next
;
1487 static Lisp_Object
find_handler_clause (Lisp_Object
, Lisp_Object
);
1488 static bool maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
,
1492 process_quit_flag (void)
1494 Lisp_Object flag
= Vquit_flag
;
1496 if (EQ (flag
, Qkill_emacs
))
1498 if (EQ (Vthrow_on_input
, flag
))
1499 Fthrow (Vthrow_on_input
, Qt
);
1500 Fsignal (Qquit
, Qnil
);
1503 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1504 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1505 This function does not return.
1507 An error symbol is a symbol with an `error-conditions' property
1508 that is a list of condition names.
1509 A handler for any of those names will get to handle this signal.
1510 The symbol `error' should normally be one of them.
1512 DATA should be a list. Its elements are printed as part of the error message.
1513 See Info anchor `(elisp)Definition of signal' for some details on how this
1514 error message is constructed.
1515 If the signal is handled, DATA is made available to the handler.
1516 See also the function `condition-case'. */)
1517 (Lisp_Object error_symbol
, Lisp_Object data
)
1519 /* When memory is full, ERROR-SYMBOL is nil,
1520 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1521 That is a special case--don't do this in other situations. */
1522 Lisp_Object conditions
;
1524 Lisp_Object real_error_symbol
1525 = (NILP (error_symbol
) ? Fcar (data
) : error_symbol
);
1526 register Lisp_Object clause
= Qnil
;
1531 if (gc_in_progress
|| waiting_for_input
)
1534 #if 0 /* rms: I don't know why this was here,
1535 but it is surely wrong for an error that is handled. */
1536 #ifdef HAVE_WINDOW_SYSTEM
1537 if (display_hourglass_p
)
1538 cancel_hourglass ();
1542 /* This hook is used by edebug. */
1543 if (! NILP (Vsignal_hook_function
)
1544 && ! NILP (error_symbol
))
1546 /* Edebug takes care of restoring these variables when it exits. */
1547 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1548 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1550 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1551 max_specpdl_size
= SPECPDL_INDEX () + 40;
1553 call2 (Vsignal_hook_function
, error_symbol
, data
);
1556 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1558 /* Remember from where signal was called. Skip over the frame for
1559 `signal' itself. If a frame for `error' follows, skip that,
1560 too. Don't do this when ERROR_SYMBOL is nil, because that
1561 is a memory-full error. */
1562 Vsignaling_function
= Qnil
;
1563 if (!NILP (error_symbol
))
1565 union specbinding
*pdl
= backtrace_next (backtrace_top ());
1566 if (backtrace_p (pdl
) && EQ (backtrace_function (pdl
), Qerror
))
1567 pdl
= backtrace_next (pdl
);
1568 if (backtrace_p (pdl
))
1569 Vsignaling_function
= backtrace_function (pdl
);
1572 for (h
= handlerlist
; h
; h
= h
->next
)
1574 clause
= find_handler_clause (h
->handler
, conditions
);
1579 if (/* Don't run the debugger for a memory-full error.
1580 (There is no room in memory to do that!) */
1581 !NILP (error_symbol
)
1582 && (!NILP (Vdebug_on_signal
)
1583 /* If no handler is present now, try to run the debugger. */
1585 /* A `debug' symbol in the handler list disables the normal
1586 suppression of the debugger. */
1587 || (CONSP (clause
) && CONSP (XCAR (clause
))
1588 && !NILP (Fmemq (Qdebug
, XCAR (clause
))))
1589 /* Special handler that means "print a message and run debugger
1591 || EQ (h
->handler
, Qerror
)))
1593 bool debugger_called
1594 = maybe_call_debugger (conditions
, error_symbol
, data
);
1595 /* We can't return values to code which signaled an error, but we
1596 can continue code which has signaled a quit. */
1597 if (debugger_called
&& EQ (real_error_symbol
, Qquit
))
1603 Lisp_Object unwind_data
1604 = (NILP (error_symbol
) ? data
: Fcons (error_symbol
, data
));
1606 h
->chosen_clause
= clause
;
1607 unwind_to_catch (h
->tag
, unwind_data
);
1612 Fthrow (Qtop_level
, Qt
);
1615 if (! NILP (error_symbol
))
1616 data
= Fcons (error_symbol
, data
);
1618 string
= Ferror_message_string (data
);
1619 fatal ("%s", SDATA (string
));
1622 /* Internal version of Fsignal that never returns.
1623 Used for anything but Qquit (which can return from Fsignal). */
1626 xsignal (Lisp_Object error_symbol
, Lisp_Object data
)
1628 Fsignal (error_symbol
, data
);
1632 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1635 xsignal0 (Lisp_Object error_symbol
)
1637 xsignal (error_symbol
, Qnil
);
1641 xsignal1 (Lisp_Object error_symbol
, Lisp_Object arg
)
1643 xsignal (error_symbol
, list1 (arg
));
1647 xsignal2 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
)
1649 xsignal (error_symbol
, list2 (arg1
, arg2
));
1653 xsignal3 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
1655 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1658 /* Signal `error' with message S, and additional arg ARG.
1659 If ARG is not a genuine list, make it a one-element list. */
1662 signal_error (const char *s
, Lisp_Object arg
)
1664 Lisp_Object tortoise
, hare
;
1666 hare
= tortoise
= arg
;
1667 while (CONSP (hare
))
1674 tortoise
= XCDR (tortoise
);
1676 if (EQ (hare
, tortoise
))
1683 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1687 /* Return true if LIST is a non-nil atom or
1688 a list containing one of CONDITIONS. */
1691 wants_debugger (Lisp_Object list
, Lisp_Object conditions
)
1698 while (CONSP (conditions
))
1700 Lisp_Object
this, tail
;
1701 this = XCAR (conditions
);
1702 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1703 if (EQ (XCAR (tail
), this))
1705 conditions
= XCDR (conditions
);
1710 /* Return true if an error with condition-symbols CONDITIONS,
1711 and described by SIGNAL-DATA, should skip the debugger
1712 according to debugger-ignored-errors. */
1715 skip_debugger (Lisp_Object conditions
, Lisp_Object data
)
1718 bool first_string
= 1;
1719 Lisp_Object error_message
;
1721 error_message
= Qnil
;
1722 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1724 if (STRINGP (XCAR (tail
)))
1728 error_message
= Ferror_message_string (data
);
1732 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1737 Lisp_Object contail
;
1739 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1740 if (EQ (XCAR (tail
), XCAR (contail
)))
1748 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1749 SIG and DATA describe the signal. There are two ways to pass them:
1750 = SIG is the error symbol, and DATA is the rest of the data.
1751 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1752 This is for memory-full errors only. */
1754 maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
, Lisp_Object data
)
1756 Lisp_Object combined_data
;
1758 combined_data
= Fcons (sig
, data
);
1761 /* Don't try to run the debugger with interrupts blocked.
1762 The editing loop would return anyway. */
1763 ! input_blocked_p ()
1764 && NILP (Vinhibit_debugger
)
1765 /* Does user want to enter debugger for this kind of error? */
1768 : wants_debugger (Vdebug_on_error
, conditions
))
1769 && ! skip_debugger (conditions
, combined_data
)
1770 /* RMS: What's this for? */
1771 && when_entered_debugger
< num_nonmacro_input_events
)
1773 call_debugger (list2 (Qerror
, combined_data
));
1781 find_handler_clause (Lisp_Object handlers
, Lisp_Object conditions
)
1783 register Lisp_Object h
;
1785 /* t is used by handlers for all conditions, set up by C code. */
1786 if (EQ (handlers
, Qt
))
1789 /* error is used similarly, but means print an error message
1790 and run the debugger if that is enabled. */
1791 if (EQ (handlers
, Qerror
))
1794 for (h
= handlers
; CONSP (h
); h
= XCDR (h
))
1796 Lisp_Object handler
= XCAR (h
);
1797 Lisp_Object condit
, tem
;
1799 if (!CONSP (handler
))
1801 condit
= XCAR (handler
);
1802 /* Handle a single condition name in handler HANDLER. */
1803 if (SYMBOLP (condit
))
1805 tem
= Fmemq (Fcar (handler
), conditions
);
1809 /* Handle a list of condition names in handler HANDLER. */
1810 else if (CONSP (condit
))
1813 for (tail
= condit
; CONSP (tail
); tail
= XCDR (tail
))
1815 tem
= Fmemq (XCAR (tail
), conditions
);
1826 /* Dump an error message; called like vprintf. */
1828 verror (const char *m
, va_list ap
)
1831 ptrdiff_t size
= sizeof buf
;
1832 ptrdiff_t size_max
= STRING_BYTES_BOUND
+ 1;
1837 used
= evxprintf (&buffer
, &size
, buf
, size_max
, m
, ap
);
1838 string
= make_string (buffer
, used
);
1842 xsignal1 (Qerror
, string
);
1846 /* Dump an error message; called like printf. */
1850 error (const char *m
, ...)
1857 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
1858 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
1859 This means it contains a description for how to read arguments to give it.
1860 The value is nil for an invalid function or a symbol with no function
1863 Interactively callable functions include strings and vectors (treated
1864 as keyboard macros), lambda-expressions that contain a top-level call
1865 to `interactive', autoload definitions made by `autoload' with non-nil
1866 fourth argument, and some of the built-in functions of Lisp.
1868 Also, a symbol satisfies `commandp' if its function definition does so.
1870 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
1871 then strings and vectors are not accepted. */)
1872 (Lisp_Object function
, Lisp_Object for_call_interactively
)
1874 register Lisp_Object fun
;
1875 register Lisp_Object funcar
;
1876 Lisp_Object if_prop
= Qnil
;
1880 fun
= indirect_function (fun
); /* Check cycles. */
1884 /* Check an `interactive-form' property if present, analogous to the
1885 function-documentation property. */
1887 while (SYMBOLP (fun
))
1889 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
1892 fun
= Fsymbol_function (fun
);
1895 /* Emacs primitives are interactive if their DEFUN specifies an
1896 interactive spec. */
1898 return XSUBR (fun
)->intspec
? Qt
: if_prop
;
1900 /* Bytecode objects are interactive if they are long enough to
1901 have an element whose index is COMPILED_INTERACTIVE, which is
1902 where the interactive spec is stored. */
1903 else if (COMPILEDP (fun
))
1904 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
1907 /* Strings and vectors are keyboard macros. */
1908 if (STRINGP (fun
) || VECTORP (fun
))
1909 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
1911 /* Lists may represent commands. */
1914 funcar
= XCAR (fun
);
1915 if (EQ (funcar
, Qclosure
))
1916 return (!NILP (Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
)))))
1918 else if (EQ (funcar
, Qlambda
))
1919 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
1920 else if (EQ (funcar
, Qautoload
))
1921 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
1926 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1927 doc
: /* Define FUNCTION to autoload from FILE.
1928 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
1929 Third arg DOCSTRING is documentation for the function.
1930 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
1931 Fifth arg TYPE indicates the type of the object:
1932 nil or omitted says FUNCTION is a function,
1933 `keymap' says FUNCTION is really a keymap, and
1934 `macro' or t says FUNCTION is really a macro.
1935 Third through fifth args give info about the real definition.
1936 They default to nil.
1937 If FUNCTION is already defined other than as an autoload,
1938 this does nothing and returns nil. */)
1939 (Lisp_Object function
, Lisp_Object file
, Lisp_Object docstring
, Lisp_Object interactive
, Lisp_Object type
)
1941 CHECK_SYMBOL (function
);
1942 CHECK_STRING (file
);
1944 /* If function is defined and not as an autoload, don't override. */
1945 if (!NILP (XSYMBOL (function
)->function
)
1946 && !AUTOLOADP (XSYMBOL (function
)->function
))
1949 if (!NILP (Vpurify_flag
) && EQ (docstring
, make_number (0)))
1950 /* `read1' in lread.c has found the docstring starting with "\
1951 and assumed the docstring will be provided by Snarf-documentation, so it
1952 passed us 0 instead. But that leads to accidental sharing in purecopy's
1953 hash-consing, so we use a (hopefully) unique integer instead. */
1954 docstring
= make_number (XHASH (function
));
1955 return Fdefalias (function
,
1956 list5 (Qautoload
, file
, docstring
, interactive
, type
),
1961 un_autoload (Lisp_Object oldqueue
)
1963 Lisp_Object queue
, first
, second
;
1965 /* Queue to unwind is current value of Vautoload_queue.
1966 oldqueue is the shadowed value to leave in Vautoload_queue. */
1967 queue
= Vautoload_queue
;
1968 Vautoload_queue
= oldqueue
;
1969 while (CONSP (queue
))
1971 first
= XCAR (queue
);
1972 second
= Fcdr (first
);
1973 first
= Fcar (first
);
1974 if (EQ (first
, make_number (0)))
1977 Ffset (first
, second
);
1978 queue
= XCDR (queue
);
1982 /* Load an autoloaded function.
1983 FUNNAME is the symbol which is the function's name.
1984 FUNDEF is the autoload definition (a list). */
1986 DEFUN ("autoload-do-load", Fautoload_do_load
, Sautoload_do_load
, 1, 3, 0,
1987 doc
: /* Load FUNDEF which should be an autoload.
1988 If non-nil, FUNNAME should be the symbol whose function value is FUNDEF,
1989 in which case the function returns the new autoloaded function value.
1990 If equal to `macro', MACRO-ONLY specifies that FUNDEF should only be loaded if
1991 it is defines a macro. */)
1992 (Lisp_Object fundef
, Lisp_Object funname
, Lisp_Object macro_only
)
1994 ptrdiff_t count
= SPECPDL_INDEX ();
1995 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1997 if (!CONSP (fundef
) || !EQ (Qautoload
, XCAR (fundef
)))
2000 if (EQ (macro_only
, Qmacro
))
2002 Lisp_Object kind
= Fnth (make_number (4), fundef
);
2003 if (! (EQ (kind
, Qt
) || EQ (kind
, Qmacro
)))
2007 /* This is to make sure that loadup.el gives a clear picture
2008 of what files are preloaded and when. */
2009 if (! NILP (Vpurify_flag
))
2010 error ("Attempt to autoload %s while preparing to dump",
2011 SDATA (SYMBOL_NAME (funname
)));
2013 CHECK_SYMBOL (funname
);
2014 GCPRO3 (funname
, fundef
, macro_only
);
2016 /* Preserve the match data. */
2017 record_unwind_save_match_data ();
2019 /* If autoloading gets an error (which includes the error of failing
2020 to define the function being called), we use Vautoload_queue
2021 to undo function definitions and `provide' calls made by
2022 the function. We do this in the specific case of autoloading
2023 because autoloading is not an explicit request "load this file",
2024 but rather a request to "call this function".
2026 The value saved here is to be restored into Vautoload_queue. */
2027 record_unwind_protect (un_autoload
, Vautoload_queue
);
2028 Vautoload_queue
= Qt
;
2029 /* If `macro_only', assume this autoload to be a "best-effort",
2030 so don't signal an error if autoloading fails. */
2031 Fload (Fcar (Fcdr (fundef
)), macro_only
, Qt
, Qnil
, Qt
);
2033 /* Once loading finishes, don't undo it. */
2034 Vautoload_queue
= Qt
;
2035 unbind_to (count
, Qnil
);
2043 Lisp_Object fun
= Findirect_function (funname
, Qnil
);
2045 if (!NILP (Fequal (fun
, fundef
)))
2046 error ("Autoloading failed to define function %s",
2047 SDATA (SYMBOL_NAME (funname
)));
2054 DEFUN ("eval", Feval
, Seval
, 1, 2, 0,
2055 doc
: /* Evaluate FORM and return its value.
2056 If LEXICAL is t, evaluate using lexical scoping. */)
2057 (Lisp_Object form
, Lisp_Object lexical
)
2059 ptrdiff_t count
= SPECPDL_INDEX ();
2060 specbind (Qinternal_interpreter_environment
,
2061 CONSP (lexical
) || NILP (lexical
) ? lexical
: list1 (Qt
));
2062 return unbind_to (count
, eval_sub (form
));
2065 /* Grow the specpdl stack by one entry.
2066 The caller should have already initialized the entry.
2067 Signal an error on stack overflow.
2069 Make sure that there is always one unused entry past the top of the
2070 stack, so that the just-initialized entry is safely unwound if
2071 memory exhausted and an error is signaled here. Also, allocate a
2072 never-used entry just before the bottom of the stack; sometimes its
2073 address is taken. */
2080 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2082 ptrdiff_t count
= SPECPDL_INDEX ();
2083 ptrdiff_t max_size
= min (max_specpdl_size
, PTRDIFF_MAX
- 1000);
2084 union specbinding
*pdlvec
= specpdl
- 1;
2085 ptrdiff_t pdlvecsize
= specpdl_size
+ 1;
2086 if (max_size
<= specpdl_size
)
2088 if (max_specpdl_size
< 400)
2089 max_size
= max_specpdl_size
= 400;
2090 if (max_size
<= specpdl_size
)
2091 signal_error ("Variable binding depth exceeds max-specpdl-size",
2094 pdlvec
= xpalloc (pdlvec
, &pdlvecsize
, 1, max_size
+ 1, sizeof *specpdl
);
2095 specpdl
= pdlvec
+ 1;
2096 specpdl_size
= pdlvecsize
- 1;
2097 specpdl_ptr
= specpdl
+ count
;
2102 record_in_backtrace (Lisp_Object function
, Lisp_Object
*args
, ptrdiff_t nargs
)
2104 eassert (nargs
>= UNEVALLED
);
2105 specpdl_ptr
->bt
.kind
= SPECPDL_BACKTRACE
;
2106 specpdl_ptr
->bt
.debug_on_exit
= false;
2107 specpdl_ptr
->bt
.function
= function
;
2108 specpdl_ptr
->bt
.args
= args
;
2109 specpdl_ptr
->bt
.nargs
= nargs
;
2113 /* Eval a sub-expression of the current expression (i.e. in the same
2116 eval_sub (Lisp_Object form
)
2118 Lisp_Object fun
, val
, original_fun
, original_args
;
2120 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2124 /* Look up its binding in the lexical environment.
2125 We do not pay attention to the declared_special flag here, since we
2126 already did that when let-binding the variable. */
2127 Lisp_Object lex_binding
2128 = !NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
2129 ? Fassq (form
, Vinternal_interpreter_environment
)
2131 if (CONSP (lex_binding
))
2132 return XCDR (lex_binding
);
2134 return Fsymbol_value (form
);
2146 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2148 if (max_lisp_eval_depth
< 100)
2149 max_lisp_eval_depth
= 100;
2150 if (lisp_eval_depth
> max_lisp_eval_depth
)
2151 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2154 original_fun
= XCAR (form
);
2155 original_args
= XCDR (form
);
2157 /* This also protects them from gc. */
2158 record_in_backtrace (original_fun
, &original_args
, UNEVALLED
);
2160 if (debug_on_next_call
)
2161 do_debug_on_call (Qt
);
2163 /* At this point, only original_fun and original_args
2164 have values that will be used below. */
2167 /* Optimize for no indirection. */
2169 if (SYMBOLP (fun
) && !NILP (fun
)
2170 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2171 fun
= indirect_function (fun
);
2175 Lisp_Object numargs
;
2176 Lisp_Object argvals
[8];
2177 Lisp_Object args_left
;
2178 register int i
, maxargs
;
2180 args_left
= original_args
;
2181 numargs
= Flength (args_left
);
2185 if (XINT (numargs
) < XSUBR (fun
)->min_args
2186 || (XSUBR (fun
)->max_args
>= 0
2187 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2188 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2190 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2191 val
= (XSUBR (fun
)->function
.aUNEVALLED
) (args_left
);
2192 else if (XSUBR (fun
)->max_args
== MANY
)
2194 /* Pass a vector of evaluated arguments. */
2196 ptrdiff_t argnum
= 0;
2199 SAFE_ALLOCA_LISP (vals
, XINT (numargs
));
2201 GCPRO3 (args_left
, fun
, fun
);
2205 while (!NILP (args_left
))
2207 vals
[argnum
++] = eval_sub (Fcar (args_left
));
2208 args_left
= Fcdr (args_left
);
2209 gcpro3
.nvars
= argnum
;
2212 set_backtrace_args (specpdl_ptr
- 1, vals
);
2213 set_backtrace_nargs (specpdl_ptr
- 1, XINT (numargs
));
2215 val
= (XSUBR (fun
)->function
.aMANY
) (XINT (numargs
), vals
);
2221 GCPRO3 (args_left
, fun
, fun
);
2222 gcpro3
.var
= argvals
;
2225 maxargs
= XSUBR (fun
)->max_args
;
2226 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
2228 argvals
[i
] = eval_sub (Fcar (args_left
));
2234 set_backtrace_args (specpdl_ptr
- 1, argvals
);
2235 set_backtrace_nargs (specpdl_ptr
- 1, XINT (numargs
));
2240 val
= (XSUBR (fun
)->function
.a0 ());
2243 val
= (XSUBR (fun
)->function
.a1 (argvals
[0]));
2246 val
= (XSUBR (fun
)->function
.a2 (argvals
[0], argvals
[1]));
2249 val
= (XSUBR (fun
)->function
.a3
2250 (argvals
[0], argvals
[1], argvals
[2]));
2253 val
= (XSUBR (fun
)->function
.a4
2254 (argvals
[0], argvals
[1], argvals
[2], argvals
[3]));
2257 val
= (XSUBR (fun
)->function
.a5
2258 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2262 val
= (XSUBR (fun
)->function
.a6
2263 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2264 argvals
[4], argvals
[5]));
2267 val
= (XSUBR (fun
)->function
.a7
2268 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2269 argvals
[4], argvals
[5], argvals
[6]));
2273 val
= (XSUBR (fun
)->function
.a8
2274 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2275 argvals
[4], argvals
[5], argvals
[6], argvals
[7]));
2279 /* Someone has created a subr that takes more arguments than
2280 is supported by this code. We need to either rewrite the
2281 subr to use a different argument protocol, or add more
2282 cases to this switch. */
2287 else if (COMPILEDP (fun
))
2288 val
= apply_lambda (fun
, original_args
);
2292 xsignal1 (Qvoid_function
, original_fun
);
2294 xsignal1 (Qinvalid_function
, original_fun
);
2295 funcar
= XCAR (fun
);
2296 if (!SYMBOLP (funcar
))
2297 xsignal1 (Qinvalid_function
, original_fun
);
2298 if (EQ (funcar
, Qautoload
))
2300 Fautoload_do_load (fun
, original_fun
, Qnil
);
2303 if (EQ (funcar
, Qmacro
))
2305 ptrdiff_t count
= SPECPDL_INDEX ();
2307 /* Bind lexical-binding during expansion of the macro, so the
2308 macro can know reliably if the code it outputs will be
2309 interpreted using lexical-binding or not. */
2310 specbind (Qlexical_binding
,
2311 NILP (Vinternal_interpreter_environment
) ? Qnil
: Qt
);
2312 exp
= apply1 (Fcdr (fun
), original_args
);
2313 unbind_to (count
, Qnil
);
2314 val
= eval_sub (exp
);
2316 else if (EQ (funcar
, Qlambda
)
2317 || EQ (funcar
, Qclosure
))
2318 val
= apply_lambda (fun
, original_args
);
2320 xsignal1 (Qinvalid_function
, original_fun
);
2325 if (backtrace_debug_on_exit (specpdl_ptr
- 1))
2326 val
= call_debugger (list2 (Qexit
, val
));
2332 DEFUN ("apply", Fapply
, Sapply
, 1, MANY
, 0,
2333 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2334 Then return the value FUNCTION returns.
2335 Thus, (apply '+ 1 2 '(3 4)) returns 10.
2336 usage: (apply FUNCTION &rest ARGUMENTS) */)
2337 (ptrdiff_t nargs
, Lisp_Object
*args
)
2341 register Lisp_Object spread_arg
;
2342 register Lisp_Object
*funcall_args
;
2343 Lisp_Object fun
, retval
;
2344 struct gcpro gcpro1
;
2349 spread_arg
= args
[nargs
- 1];
2350 CHECK_LIST (spread_arg
);
2352 numargs
= XINT (Flength (spread_arg
));
2355 return Ffuncall (nargs
- 1, args
);
2356 else if (numargs
== 1)
2358 args
[nargs
- 1] = XCAR (spread_arg
);
2359 return Ffuncall (nargs
, args
);
2362 numargs
+= nargs
- 2;
2364 /* Optimize for no indirection. */
2365 if (SYMBOLP (fun
) && !NILP (fun
)
2366 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2367 fun
= indirect_function (fun
);
2370 /* Let funcall get the error. */
2377 if (numargs
< XSUBR (fun
)->min_args
2378 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2379 goto funcall
; /* Let funcall get the error. */
2380 else if (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
> numargs
)
2382 /* Avoid making funcall cons up a yet another new vector of arguments
2383 by explicitly supplying nil's for optional values. */
2384 SAFE_ALLOCA_LISP (funcall_args
, 1 + XSUBR (fun
)->max_args
);
2385 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2386 funcall_args
[++i
] = Qnil
;
2387 GCPRO1 (*funcall_args
);
2388 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2392 /* We add 1 to numargs because funcall_args includes the
2393 function itself as well as its arguments. */
2396 SAFE_ALLOCA_LISP (funcall_args
, 1 + numargs
);
2397 GCPRO1 (*funcall_args
);
2398 gcpro1
.nvars
= 1 + numargs
;
2401 memcpy (funcall_args
, args
, nargs
* word_size
);
2402 /* Spread the last arg we got. Its first element goes in
2403 the slot that it used to occupy, hence this value of I. */
2405 while (!NILP (spread_arg
))
2407 funcall_args
[i
++] = XCAR (spread_arg
);
2408 spread_arg
= XCDR (spread_arg
);
2411 /* By convention, the caller needs to gcpro Ffuncall's args. */
2412 retval
= Ffuncall (gcpro1
.nvars
, funcall_args
);
2419 /* Run hook variables in various ways. */
2422 funcall_nil (ptrdiff_t nargs
, Lisp_Object
*args
)
2424 Ffuncall (nargs
, args
);
2428 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2429 doc
: /* Run each hook in HOOKS.
2430 Each argument should be a symbol, a hook variable.
2431 These symbols are processed in the order specified.
2432 If a hook symbol has a non-nil value, that value may be a function
2433 or a list of functions to be called to run the hook.
2434 If the value is a function, it is called with no arguments.
2435 If it is a list, the elements are called, in order, with no arguments.
2437 Major modes should not use this function directly to run their mode
2438 hook; they should use `run-mode-hooks' instead.
2440 Do not use `make-local-variable' to make a hook variable buffer-local.
2441 Instead, use `add-hook' and specify t for the LOCAL argument.
2442 usage: (run-hooks &rest HOOKS) */)
2443 (ptrdiff_t nargs
, Lisp_Object
*args
)
2445 Lisp_Object hook
[1];
2448 for (i
= 0; i
< nargs
; i
++)
2451 run_hook_with_args (1, hook
, funcall_nil
);
2457 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2458 Srun_hook_with_args
, 1, MANY
, 0,
2459 doc
: /* Run HOOK with the specified arguments ARGS.
2460 HOOK should be a symbol, a hook variable. The value of HOOK
2461 may be nil, a function, or a list of functions. Call each
2462 function in order with arguments ARGS. The final return value
2465 Do not use `make-local-variable' to make a hook variable buffer-local.
2466 Instead, use `add-hook' and specify t for the LOCAL argument.
2467 usage: (run-hook-with-args HOOK &rest ARGS) */)
2468 (ptrdiff_t nargs
, Lisp_Object
*args
)
2470 return run_hook_with_args (nargs
, args
, funcall_nil
);
2473 /* NB this one still documents a specific non-nil return value.
2474 (As did run-hook-with-args and run-hook-with-args-until-failure
2475 until they were changed in 24.1.) */
2476 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2477 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2478 doc
: /* Run HOOK with the specified arguments ARGS.
2479 HOOK should be a symbol, a hook variable. The value of HOOK
2480 may be nil, a function, or a list of functions. Call each
2481 function in order with arguments ARGS, stopping at the first
2482 one that returns non-nil, and return that value. Otherwise (if
2483 all functions return nil, or if there are no functions to call),
2486 Do not use `make-local-variable' to make a hook variable buffer-local.
2487 Instead, use `add-hook' and specify t for the LOCAL argument.
2488 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2489 (ptrdiff_t nargs
, Lisp_Object
*args
)
2491 return run_hook_with_args (nargs
, args
, Ffuncall
);
2495 funcall_not (ptrdiff_t nargs
, Lisp_Object
*args
)
2497 return NILP (Ffuncall (nargs
, args
)) ? Qt
: Qnil
;
2500 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2501 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2502 doc
: /* Run HOOK with the specified arguments ARGS.
2503 HOOK should be a symbol, a hook variable. The value of HOOK
2504 may be nil, a function, or a list of functions. Call each
2505 function in order with arguments ARGS, stopping at the first
2506 one that returns nil, and return nil. Otherwise (if all functions
2507 return non-nil, or if there are no functions to call), return non-nil
2508 \(do not rely on the precise return value in this case).
2510 Do not use `make-local-variable' to make a hook variable buffer-local.
2511 Instead, use `add-hook' and specify t for the LOCAL argument.
2512 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2513 (ptrdiff_t nargs
, Lisp_Object
*args
)
2515 return NILP (run_hook_with_args (nargs
, args
, funcall_not
)) ? Qt
: Qnil
;
2519 run_hook_wrapped_funcall (ptrdiff_t nargs
, Lisp_Object
*args
)
2521 Lisp_Object tmp
= args
[0], ret
;
2524 ret
= Ffuncall (nargs
, args
);
2530 DEFUN ("run-hook-wrapped", Frun_hook_wrapped
, Srun_hook_wrapped
, 2, MANY
, 0,
2531 doc
: /* Run HOOK, passing each function through WRAP-FUNCTION.
2532 I.e. instead of calling each function FUN directly with arguments ARGS,
2533 it calls WRAP-FUNCTION with arguments FUN and ARGS.
2534 As soon as a call to WRAP-FUNCTION returns non-nil, `run-hook-wrapped'
2535 aborts and returns that value.
2536 usage: (run-hook-wrapped HOOK WRAP-FUNCTION &rest ARGS) */)
2537 (ptrdiff_t nargs
, Lisp_Object
*args
)
2539 return run_hook_with_args (nargs
, args
, run_hook_wrapped_funcall
);
2542 /* ARGS[0] should be a hook symbol.
2543 Call each of the functions in the hook value, passing each of them
2544 as arguments all the rest of ARGS (all NARGS - 1 elements).
2545 FUNCALL specifies how to call each function on the hook.
2546 The caller (or its caller, etc) must gcpro all of ARGS,
2547 except that it isn't necessary to gcpro ARGS[0]. */
2550 run_hook_with_args (ptrdiff_t nargs
, Lisp_Object
*args
,
2551 Lisp_Object (*funcall
) (ptrdiff_t nargs
, Lisp_Object
*args
))
2553 Lisp_Object sym
, val
, ret
= Qnil
;
2554 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2556 /* If we are dying or still initializing,
2557 don't do anything--it would probably crash if we tried. */
2558 if (NILP (Vrun_hooks
))
2562 val
= find_symbol_value (sym
);
2564 if (EQ (val
, Qunbound
) || NILP (val
))
2566 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2569 return funcall (nargs
, args
);
2573 Lisp_Object global_vals
= Qnil
;
2574 GCPRO3 (sym
, val
, global_vals
);
2577 CONSP (val
) && NILP (ret
);
2580 if (EQ (XCAR (val
), Qt
))
2582 /* t indicates this hook has a local binding;
2583 it means to run the global binding too. */
2584 global_vals
= Fdefault_value (sym
);
2585 if (NILP (global_vals
)) continue;
2587 if (!CONSP (global_vals
) || EQ (XCAR (global_vals
), Qlambda
))
2589 args
[0] = global_vals
;
2590 ret
= funcall (nargs
, args
);
2595 CONSP (global_vals
) && NILP (ret
);
2596 global_vals
= XCDR (global_vals
))
2598 args
[0] = XCAR (global_vals
);
2599 /* In a global value, t should not occur. If it does, we
2600 must ignore it to avoid an endless loop. */
2601 if (!EQ (args
[0], Qt
))
2602 ret
= funcall (nargs
, args
);
2608 args
[0] = XCAR (val
);
2609 ret
= funcall (nargs
, args
);
2618 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2621 run_hook_with_args_2 (Lisp_Object hook
, Lisp_Object arg1
, Lisp_Object arg2
)
2623 Lisp_Object temp
[3];
2628 Frun_hook_with_args (3, temp
);
2631 /* Apply fn to arg. */
2633 apply1 (Lisp_Object fn
, Lisp_Object arg
)
2635 struct gcpro gcpro1
;
2639 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2642 Lisp_Object args
[2];
2646 RETURN_UNGCPRO (Fapply (2, args
));
2650 /* Call function fn on no arguments. */
2652 call0 (Lisp_Object fn
)
2654 struct gcpro gcpro1
;
2657 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2660 /* Call function fn with 1 argument arg1. */
2663 call1 (Lisp_Object fn
, Lisp_Object arg1
)
2665 struct gcpro gcpro1
;
2666 Lisp_Object args
[2];
2672 RETURN_UNGCPRO (Ffuncall (2, args
));
2675 /* Call function fn with 2 arguments arg1, arg2. */
2678 call2 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
)
2680 struct gcpro gcpro1
;
2681 Lisp_Object args
[3];
2687 RETURN_UNGCPRO (Ffuncall (3, args
));
2690 /* Call function fn with 3 arguments arg1, arg2, arg3. */
2693 call3 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2695 struct gcpro gcpro1
;
2696 Lisp_Object args
[4];
2703 RETURN_UNGCPRO (Ffuncall (4, args
));
2706 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
2709 call4 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2712 struct gcpro gcpro1
;
2713 Lisp_Object args
[5];
2721 RETURN_UNGCPRO (Ffuncall (5, args
));
2724 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
2727 call5 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2728 Lisp_Object arg4
, Lisp_Object arg5
)
2730 struct gcpro gcpro1
;
2731 Lisp_Object args
[6];
2740 RETURN_UNGCPRO (Ffuncall (6, args
));
2743 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
2746 call6 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2747 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
)
2749 struct gcpro gcpro1
;
2750 Lisp_Object args
[7];
2760 RETURN_UNGCPRO (Ffuncall (7, args
));
2763 /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
2766 call7 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2767 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
)
2769 struct gcpro gcpro1
;
2770 Lisp_Object args
[8];
2781 RETURN_UNGCPRO (Ffuncall (8, args
));
2784 /* The caller should GCPRO all the elements of ARGS. */
2786 DEFUN ("functionp", Ffunctionp
, Sfunctionp
, 1, 1, 0,
2787 doc
: /* Non-nil if OBJECT is a function. */)
2788 (Lisp_Object object
)
2790 if (FUNCTIONP (object
))
2795 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2796 doc
: /* Call first argument as a function, passing remaining arguments to it.
2797 Return the value that function returns.
2798 Thus, (funcall 'cons 'x 'y) returns (x . y).
2799 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2800 (ptrdiff_t nargs
, Lisp_Object
*args
)
2802 Lisp_Object fun
, original_fun
;
2804 ptrdiff_t numargs
= nargs
- 1;
2805 Lisp_Object lisp_numargs
;
2807 register Lisp_Object
*internal_args
;
2812 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2814 if (max_lisp_eval_depth
< 100)
2815 max_lisp_eval_depth
= 100;
2816 if (lisp_eval_depth
> max_lisp_eval_depth
)
2817 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2820 /* This also GCPROs them. */
2821 record_in_backtrace (args
[0], &args
[1], nargs
- 1);
2823 /* Call GC after setting up the backtrace, so the latter GCPROs the args. */
2826 if (debug_on_next_call
)
2827 do_debug_on_call (Qlambda
);
2831 original_fun
= args
[0];
2835 /* Optimize for no indirection. */
2837 if (SYMBOLP (fun
) && !NILP (fun
)
2838 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2839 fun
= indirect_function (fun
);
2843 if (numargs
< XSUBR (fun
)->min_args
2844 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2846 XSETFASTINT (lisp_numargs
, numargs
);
2847 xsignal2 (Qwrong_number_of_arguments
, original_fun
, lisp_numargs
);
2850 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2851 xsignal1 (Qinvalid_function
, original_fun
);
2853 else if (XSUBR (fun
)->max_args
== MANY
)
2854 val
= (XSUBR (fun
)->function
.aMANY
) (numargs
, args
+ 1);
2857 if (XSUBR (fun
)->max_args
> numargs
)
2859 internal_args
= alloca (XSUBR (fun
)->max_args
2860 * sizeof *internal_args
);
2861 memcpy (internal_args
, args
+ 1, numargs
* word_size
);
2862 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2863 internal_args
[i
] = Qnil
;
2866 internal_args
= args
+ 1;
2867 switch (XSUBR (fun
)->max_args
)
2870 val
= (XSUBR (fun
)->function
.a0 ());
2873 val
= (XSUBR (fun
)->function
.a1 (internal_args
[0]));
2876 val
= (XSUBR (fun
)->function
.a2
2877 (internal_args
[0], internal_args
[1]));
2880 val
= (XSUBR (fun
)->function
.a3
2881 (internal_args
[0], internal_args
[1], internal_args
[2]));
2884 val
= (XSUBR (fun
)->function
.a4
2885 (internal_args
[0], internal_args
[1], internal_args
[2],
2889 val
= (XSUBR (fun
)->function
.a5
2890 (internal_args
[0], internal_args
[1], internal_args
[2],
2891 internal_args
[3], internal_args
[4]));
2894 val
= (XSUBR (fun
)->function
.a6
2895 (internal_args
[0], internal_args
[1], internal_args
[2],
2896 internal_args
[3], internal_args
[4], internal_args
[5]));
2899 val
= (XSUBR (fun
)->function
.a7
2900 (internal_args
[0], internal_args
[1], internal_args
[2],
2901 internal_args
[3], internal_args
[4], internal_args
[5],
2906 val
= (XSUBR (fun
)->function
.a8
2907 (internal_args
[0], internal_args
[1], internal_args
[2],
2908 internal_args
[3], internal_args
[4], internal_args
[5],
2909 internal_args
[6], internal_args
[7]));
2914 /* If a subr takes more than 8 arguments without using MANY
2915 or UNEVALLED, we need to extend this function to support it.
2916 Until this is done, there is no way to call the function. */
2921 else if (COMPILEDP (fun
))
2922 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2926 xsignal1 (Qvoid_function
, original_fun
);
2928 xsignal1 (Qinvalid_function
, original_fun
);
2929 funcar
= XCAR (fun
);
2930 if (!SYMBOLP (funcar
))
2931 xsignal1 (Qinvalid_function
, original_fun
);
2932 if (EQ (funcar
, Qlambda
)
2933 || EQ (funcar
, Qclosure
))
2934 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2935 else if (EQ (funcar
, Qautoload
))
2937 Fautoload_do_load (fun
, original_fun
, Qnil
);
2942 xsignal1 (Qinvalid_function
, original_fun
);
2946 if (backtrace_debug_on_exit (specpdl_ptr
- 1))
2947 val
= call_debugger (list2 (Qexit
, val
));
2953 apply_lambda (Lisp_Object fun
, Lisp_Object args
)
2955 Lisp_Object args_left
;
2958 register Lisp_Object
*arg_vector
;
2959 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2960 register Lisp_Object tem
;
2963 numargs
= XFASTINT (Flength (args
));
2964 SAFE_ALLOCA_LISP (arg_vector
, numargs
);
2967 GCPRO3 (*arg_vector
, args_left
, fun
);
2970 for (i
= 0; i
< numargs
; )
2972 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2973 tem
= eval_sub (tem
);
2974 arg_vector
[i
++] = tem
;
2980 set_backtrace_args (specpdl_ptr
- 1, arg_vector
);
2981 set_backtrace_nargs (specpdl_ptr
- 1, i
);
2982 tem
= funcall_lambda (fun
, numargs
, arg_vector
);
2984 /* Do the debug-on-exit now, while arg_vector still exists. */
2985 if (backtrace_debug_on_exit (specpdl_ptr
- 1))
2987 /* Don't do it again when we return to eval. */
2988 set_backtrace_debug_on_exit (specpdl_ptr
- 1, false);
2989 tem
= call_debugger (list2 (Qexit
, tem
));
2995 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2996 and return the result of evaluation.
2997 FUN must be either a lambda-expression or a compiled-code object. */
3000 funcall_lambda (Lisp_Object fun
, ptrdiff_t nargs
,
3001 register Lisp_Object
*arg_vector
)
3003 Lisp_Object val
, syms_left
, next
, lexenv
;
3004 ptrdiff_t count
= SPECPDL_INDEX ();
3006 bool optional
, rest
;
3010 if (EQ (XCAR (fun
), Qclosure
))
3012 fun
= XCDR (fun
); /* Drop `closure'. */
3013 lexenv
= XCAR (fun
);
3014 CHECK_LIST_CONS (fun
, fun
);
3018 syms_left
= XCDR (fun
);
3019 if (CONSP (syms_left
))
3020 syms_left
= XCAR (syms_left
);
3022 xsignal1 (Qinvalid_function
, fun
);
3024 else if (COMPILEDP (fun
))
3026 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3027 if (INTEGERP (syms_left
))
3028 /* A byte-code object with a non-nil `push args' slot means we
3029 shouldn't bind any arguments, instead just call the byte-code
3030 interpreter directly; it will push arguments as necessary.
3032 Byte-code objects with either a non-existent, or a nil value for
3033 the `push args' slot (the default), have dynamically-bound
3034 arguments, and use the argument-binding code below instead (as do
3035 all interpreted functions, even lexically bound ones). */
3037 /* If we have not actually read the bytecode string
3038 and constants vector yet, fetch them from the file. */
3039 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3040 Ffetch_bytecode (fun
);
3041 return exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
3042 AREF (fun
, COMPILED_CONSTANTS
),
3043 AREF (fun
, COMPILED_STACK_DEPTH
),
3052 i
= optional
= rest
= 0;
3053 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3057 next
= XCAR (syms_left
);
3058 if (!SYMBOLP (next
))
3059 xsignal1 (Qinvalid_function
, fun
);
3061 if (EQ (next
, Qand_rest
))
3063 else if (EQ (next
, Qand_optional
))
3070 arg
= Flist (nargs
- i
, &arg_vector
[i
]);
3074 arg
= arg_vector
[i
++];
3076 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3080 /* Bind the argument. */
3081 if (!NILP (lexenv
) && SYMBOLP (next
))
3082 /* Lexically bind NEXT by adding it to the lexenv alist. */
3083 lexenv
= Fcons (Fcons (next
, arg
), lexenv
);
3085 /* Dynamically bind NEXT. */
3086 specbind (next
, arg
);
3090 if (!NILP (syms_left
))
3091 xsignal1 (Qinvalid_function
, fun
);
3093 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3095 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
3096 /* Instantiate a new lexical environment. */
3097 specbind (Qinternal_interpreter_environment
, lexenv
);
3100 val
= Fprogn (XCDR (XCDR (fun
)));
3103 /* If we have not actually read the bytecode string
3104 and constants vector yet, fetch them from the file. */
3105 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3106 Ffetch_bytecode (fun
);
3107 val
= exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
3108 AREF (fun
, COMPILED_CONSTANTS
),
3109 AREF (fun
, COMPILED_STACK_DEPTH
),
3113 return unbind_to (count
, val
);
3116 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3118 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3119 (Lisp_Object object
)
3123 if (COMPILEDP (object
) && CONSP (AREF (object
, COMPILED_BYTECODE
)))
3125 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3128 tem
= AREF (object
, COMPILED_BYTECODE
);
3129 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3130 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3132 error ("Invalid byte code");
3134 ASET (object
, COMPILED_BYTECODE
, XCAR (tem
));
3135 ASET (object
, COMPILED_CONSTANTS
, XCDR (tem
));
3140 /* Return true if SYMBOL currently has a let-binding
3141 which was made in the buffer that is now current. */
3144 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
3146 union specbinding
*p
;
3147 Lisp_Object buf
= Fcurrent_buffer ();
3149 for (p
= specpdl_ptr
; p
> specpdl
; )
3150 if ((--p
)->kind
> SPECPDL_LET
)
3152 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (specpdl_symbol (p
));
3153 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
3154 if (symbol
== let_bound_symbol
3155 && EQ (specpdl_where (p
), buf
))
3163 let_shadows_global_binding_p (Lisp_Object symbol
)
3165 union specbinding
*p
;
3167 for (p
= specpdl_ptr
; p
> specpdl
; )
3168 if ((--p
)->kind
>= SPECPDL_LET
&& EQ (specpdl_symbol (p
), symbol
))
3175 binding_symbol (union specbinding
*bind
)
3177 if (!CONSP (specpdl_symbol (bind
)))
3178 return specpdl_symbol (bind
);
3179 return XCAR (specpdl_symbol (bind
));
3183 do_specbind (struct Lisp_Symbol
*sym
, union specbinding
*bind
,
3186 switch (sym
->redirect
)
3188 case SYMBOL_PLAINVAL
:
3190 SET_SYMBOL_VAL (sym
, value
);
3192 set_internal (specpdl_symbol (bind
), value
, Qnil
, 1);
3195 case SYMBOL_LOCALIZED
:
3196 case SYMBOL_FORWARDED
:
3197 if ((sym
->redirect
== SYMBOL_LOCALIZED
3198 || BUFFER_OBJFWDP (SYMBOL_FWD (sym
)))
3199 && CONSP (specpdl_symbol (bind
)))
3203 where
= XCAR (XCDR (specpdl_symbol (bind
)));
3205 && sym
->redirect
== SYMBOL_FORWARDED
)
3207 Fset_default (XCAR (specpdl_symbol (bind
)), value
);
3212 set_internal (binding_symbol (bind
), value
, Qnil
, 1);
3220 /* `specpdl_ptr->symbol' is a field which describes which variable is
3221 let-bound, so it can be properly undone when we unbind_to.
3222 It can have the following two shapes:
3223 - SYMBOL : if it's a plain symbol, it means that we have let-bound
3224 a symbol that is not buffer-local (at least at the time
3225 the let binding started). Note also that it should not be
3226 aliased (i.e. when let-binding V1 that's aliased to V2, we want
3228 - (SYMBOL WHERE . BUFFER) : this means that it is a let-binding for
3229 variable SYMBOL which can be buffer-local. WHERE tells us
3230 which buffer is affected (or nil if the let-binding affects the
3231 global value of the variable) and BUFFER tells us which buffer was
3232 current (i.e. if WHERE is non-nil, then BUFFER==WHERE, otherwise
3233 BUFFER did not yet have a buffer-local value). */
3236 specbind (Lisp_Object symbol
, Lisp_Object value
)
3238 struct Lisp_Symbol
*sym
;
3240 CHECK_SYMBOL (symbol
);
3241 sym
= XSYMBOL (symbol
);
3244 switch (sym
->redirect
)
3246 case SYMBOL_VARALIAS
:
3247 sym
= indirect_variable (sym
); XSETSYMBOL (symbol
, sym
); goto start
;
3248 case SYMBOL_PLAINVAL
:
3249 /* The most common case is that of a non-constant symbol with a
3250 trivial value. Make that as fast as we can. */
3251 specpdl_ptr
->let
.kind
= SPECPDL_LET
;
3252 specpdl_ptr
->let
.symbol
= symbol
;
3253 specpdl_ptr
->let
.old_value
= SYMBOL_VAL (sym
);
3254 specpdl_ptr
->let
.saved_value
= Qnil
;
3256 do_specbind (sym
, specpdl_ptr
- 1, value
);
3258 case SYMBOL_LOCALIZED
:
3259 if (SYMBOL_BLV (sym
)->frame_local
)
3260 error ("Frame-local vars cannot be let-bound");
3261 case SYMBOL_FORWARDED
:
3263 Lisp_Object ovalue
= find_symbol_value (symbol
);
3264 specpdl_ptr
->let
.kind
= SPECPDL_LET_LOCAL
;
3265 specpdl_ptr
->let
.symbol
= symbol
;
3266 specpdl_ptr
->let
.old_value
= ovalue
;
3267 specpdl_ptr
->let
.where
= Fcurrent_buffer ();
3268 specpdl_ptr
->let
.saved_value
= Qnil
;
3270 eassert (sym
->redirect
!= SYMBOL_LOCALIZED
3271 || (EQ (SYMBOL_BLV (sym
)->where
, Fcurrent_buffer ())));
3273 if (sym
->redirect
== SYMBOL_LOCALIZED
)
3275 if (!blv_found (SYMBOL_BLV (sym
)))
3276 specpdl_ptr
->let
.kind
= SPECPDL_LET_DEFAULT
;
3278 else if (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)))
3280 /* If SYMBOL is a per-buffer variable which doesn't have a
3281 buffer-local value here, make the `let' change the global
3282 value by changing the value of SYMBOL in all buffers not
3283 having their own value. This is consistent with what
3284 happens with other buffer-local variables. */
3285 if (NILP (Flocal_variable_p (symbol
, Qnil
)))
3287 specpdl_ptr
->let
.kind
= SPECPDL_LET_DEFAULT
;
3289 do_specbind (sym
, specpdl_ptr
- 1, value
);
3294 specpdl_ptr
->let
.kind
= SPECPDL_LET
;
3297 do_specbind (sym
, specpdl_ptr
- 1, value
);
3300 default: emacs_abort ();
3304 /* Push unwind-protect entries of various types. */
3307 record_unwind_protect (void (*function
) (Lisp_Object
), Lisp_Object arg
)
3309 specpdl_ptr
->unwind
.kind
= SPECPDL_UNWIND
;
3310 specpdl_ptr
->unwind
.func
= function
;
3311 specpdl_ptr
->unwind
.arg
= arg
;
3316 record_unwind_protect_ptr (void (*function
) (void *), void *arg
)
3318 specpdl_ptr
->unwind_ptr
.kind
= SPECPDL_UNWIND_PTR
;
3319 specpdl_ptr
->unwind_ptr
.func
= function
;
3320 specpdl_ptr
->unwind_ptr
.arg
= arg
;
3325 record_unwind_protect_int (void (*function
) (int), int arg
)
3327 specpdl_ptr
->unwind_int
.kind
= SPECPDL_UNWIND_INT
;
3328 specpdl_ptr
->unwind_int
.func
= function
;
3329 specpdl_ptr
->unwind_int
.arg
= arg
;
3334 record_unwind_protect_void (void (*function
) (void))
3336 specpdl_ptr
->unwind_void
.kind
= SPECPDL_UNWIND_VOID
;
3337 specpdl_ptr
->unwind_void
.func
= function
;
3342 rebind_for_thread_switch (void)
3344 union specbinding
*bind
;
3346 for (bind
= specpdl
; bind
!= specpdl_ptr
; ++bind
)
3348 if (bind
->kind
>= SPECPDL_LET
)
3350 Lisp_Object value
= specpdl_saved_value (bind
);
3352 bind
->let
.saved_value
= Qnil
;
3353 do_specbind (XSYMBOL (binding_symbol (bind
)), bind
, value
);
3359 do_one_unbind (union specbinding
*this_binding
, int unwinding
)
3361 eassert (unwinding
|| this_binding
->kind
>= SPECPDL_LET
);
3362 switch (this_binding
->kind
)
3364 case SPECPDL_UNWIND
:
3365 this_binding
->unwind
.func (this_binding
->unwind
.arg
);
3367 case SPECPDL_UNWIND_PTR
:
3368 this_binding
->unwind_ptr
.func (this_binding
->unwind_ptr
.arg
);
3370 case SPECPDL_UNWIND_INT
:
3371 this_binding
->unwind_int
.func (this_binding
->unwind_int
.arg
);
3373 case SPECPDL_UNWIND_VOID
:
3374 this_binding
->unwind_void
.func ();
3376 case SPECPDL_BACKTRACE
:
3379 { /* If variable has a trivial value (no forwarding), we can
3380 just set it. No need to check for constant symbols here,
3381 since that was already done by specbind. */
3382 struct Lisp_Symbol
*sym
= XSYMBOL (specpdl_symbol (this_binding
));
3383 if (sym
->redirect
== SYMBOL_PLAINVAL
)
3385 SET_SYMBOL_VAL (sym
, specpdl_old_value (this_binding
));
3390 NOTE: we only ever come here if make_local_foo was used for
3391 the first time on this var within this let. */
3394 case SPECPDL_LET_DEFAULT
:
3395 Fset_default (specpdl_symbol (this_binding
),
3396 specpdl_old_value (this_binding
));
3398 case SPECPDL_LET_LOCAL
:
3400 Lisp_Object symbol
= specpdl_symbol (this_binding
);
3401 Lisp_Object where
= specpdl_where (this_binding
);
3402 Lisp_Object old_value
= specpdl_old_value (this_binding
);
3403 eassert (BUFFERP (where
));
3405 /* If this was a local binding, reset the value in the appropriate
3406 buffer, but only if that buffer's binding still exists. */
3407 if (!NILP (Flocal_variable_p (symbol
, where
)))
3408 set_internal (symbol
, old_value
, where
, 1);
3418 /* Push an unwind-protect entry that does nothing, so that
3419 set_unwind_protect_ptr can overwrite it later. */
3422 record_unwind_protect_nothing (void)
3424 record_unwind_protect_void (do_nothing
);
3427 /* Clear the unwind-protect entry COUNT, so that it does nothing.
3428 It need not be at the top of the stack. */
3431 clear_unwind_protect (ptrdiff_t count
)
3433 union specbinding
*p
= specpdl
+ count
;
3434 p
->unwind_void
.kind
= SPECPDL_UNWIND_VOID
;
3435 p
->unwind_void
.func
= do_nothing
;
3438 /* Set the unwind-protect entry COUNT so that it invokes FUNC (ARG).
3439 It need not be at the top of the stack. Discard the entry's
3440 previous value without invoking it. */
3443 set_unwind_protect (ptrdiff_t count
, void (*func
) (Lisp_Object
),
3446 union specbinding
*p
= specpdl
+ count
;
3447 p
->unwind
.kind
= SPECPDL_UNWIND
;
3448 p
->unwind
.func
= func
;
3449 p
->unwind
.arg
= arg
;
3453 set_unwind_protect_ptr (ptrdiff_t count
, void (*func
) (void *), void *arg
)
3455 union specbinding
*p
= specpdl
+ count
;
3456 p
->unwind_ptr
.kind
= SPECPDL_UNWIND_PTR
;
3457 p
->unwind_ptr
.func
= func
;
3458 p
->unwind_ptr
.arg
= arg
;
3461 /* Pop and execute entries from the unwind-protect stack until the
3462 depth COUNT is reached. Return VALUE. */
3465 unbind_to (ptrdiff_t count
, Lisp_Object value
)
3467 Lisp_Object quitf
= Vquit_flag
;
3468 struct gcpro gcpro1
, gcpro2
;
3470 GCPRO2 (value
, quitf
);
3473 while (specpdl_ptr
!= specpdl
+ count
)
3475 /* Copy the binding, and decrement specpdl_ptr, before we do
3476 the work to unbind it. We decrement first
3477 so that an error in unbinding won't try to unbind
3478 the same entry again, and we copy the binding first
3479 in case more bindings are made during some of the code we run. */
3481 union specbinding this_binding
;
3482 this_binding
= *--specpdl_ptr
;
3484 do_one_unbind (&this_binding
, 1);
3487 if (NILP (Vquit_flag
) && !NILP (quitf
))
3495 unbind_for_thread_switch (void)
3497 union specbinding
*bind
;
3499 for (bind
= specpdl_ptr
; bind
!= specpdl
; --bind
)
3501 if (bind
->kind
>= SPECPDL_LET
)
3503 bind
->let
.saved_value
= find_symbol_value (binding_symbol (bind
));
3504 do_one_unbind (bind
, 0);
3509 DEFUN ("special-variable-p", Fspecial_variable_p
, Sspecial_variable_p
, 1, 1, 0,
3510 doc
: /* Return non-nil if SYMBOL's global binding has been declared special.
3511 A special variable is one that will be bound dynamically, even in a
3512 context where binding is lexical by default. */)
3513 (Lisp_Object symbol
)
3515 CHECK_SYMBOL (symbol
);
3516 return XSYMBOL (symbol
)->declared_special
? Qt
: Qnil
;
3520 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3521 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3522 The debugger is entered when that frame exits, if the flag is non-nil. */)
3523 (Lisp_Object level
, Lisp_Object flag
)
3525 union specbinding
*pdl
= backtrace_top ();
3526 register EMACS_INT i
;
3528 CHECK_NUMBER (level
);
3530 for (i
= 0; backtrace_p (pdl
) && i
< XINT (level
); i
++)
3531 pdl
= backtrace_next (pdl
);
3533 if (backtrace_p (pdl
))
3534 set_backtrace_debug_on_exit (pdl
, !NILP (flag
));
3539 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3540 doc
: /* Print a trace of Lisp function calls currently active.
3541 Output stream used is value of `standard-output'. */)
3544 union specbinding
*pdl
= backtrace_top ();
3546 Lisp_Object old_print_level
= Vprint_level
;
3548 if (NILP (Vprint_level
))
3549 XSETFASTINT (Vprint_level
, 8);
3551 while (backtrace_p (pdl
))
3553 write_string (backtrace_debug_on_exit (pdl
) ? "* " : " ", 2);
3554 if (backtrace_nargs (pdl
) == UNEVALLED
)
3556 Fprin1 (Fcons (backtrace_function (pdl
), *backtrace_args (pdl
)),
3558 write_string ("\n", -1);
3562 tem
= backtrace_function (pdl
);
3563 Fprin1 (tem
, Qnil
); /* This can QUIT. */
3564 write_string ("(", -1);
3567 for (i
= 0; i
< backtrace_nargs (pdl
); i
++)
3569 if (i
) write_string (" ", -1);
3570 Fprin1 (backtrace_args (pdl
)[i
], Qnil
);
3573 write_string (")\n", -1);
3575 pdl
= backtrace_next (pdl
);
3578 Vprint_level
= old_print_level
;
3582 static union specbinding
*
3583 get_backtrace_frame (Lisp_Object nframes
, Lisp_Object base
)
3585 union specbinding
*pdl
= backtrace_top ();
3586 register EMACS_INT i
;
3588 CHECK_NATNUM (nframes
);
3591 { /* Skip up to `base'. */
3592 base
= Findirect_function (base
, Qt
);
3593 while (backtrace_p (pdl
)
3594 && !EQ (base
, Findirect_function (backtrace_function (pdl
), Qt
)))
3595 pdl
= backtrace_next (pdl
);
3598 /* Find the frame requested. */
3599 for (i
= XFASTINT (nframes
); i
> 0 && backtrace_p (pdl
); i
--)
3600 pdl
= backtrace_next (pdl
);
3605 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 2, NULL
,
3606 doc
: /* Return the function and arguments NFRAMES up from current execution point.
3607 If that frame has not evaluated the arguments yet (or is a special form),
3608 the value is (nil FUNCTION ARG-FORMS...).
3609 If that frame has evaluated its arguments and called its function already,
3610 the value is (t FUNCTION ARG-VALUES...).
3611 A &rest arg is represented as the tail of the list ARG-VALUES.
3612 FUNCTION is whatever was supplied as car of evaluated list,
3613 or a lambda expression for macro calls.
3614 If NFRAMES is more than the number of frames, the value is nil.
3615 If BASE is non-nil, it should be a function and NFRAMES counts from its
3616 nearest activation frame. */)
3617 (Lisp_Object nframes
, Lisp_Object base
)
3619 union specbinding
*pdl
= get_backtrace_frame (nframes
, base
);
3621 if (!backtrace_p (pdl
))
3623 if (backtrace_nargs (pdl
) == UNEVALLED
)
3625 Fcons (backtrace_function (pdl
), *backtrace_args (pdl
)));
3628 Lisp_Object tem
= Flist (backtrace_nargs (pdl
), backtrace_args (pdl
));
3630 return Fcons (Qt
, Fcons (backtrace_function (pdl
), tem
));
3634 /* For backtrace-eval, we want to temporarily unwind the last few elements of
3635 the specpdl stack, and then rewind them. We store the pre-unwind values
3636 directly in the pre-existing specpdl elements (i.e. we swap the current
3637 value and the old value stored in the specpdl), kind of like the inplace
3638 pointer-reversal trick. As it turns out, the rewind does the same as the
3639 unwind, except it starts from the other end of the specpdl stack, so we use
3640 the same function for both unwind and rewind. */
3642 backtrace_eval_unrewind (int distance
)
3644 union specbinding
*tmp
= specpdl_ptr
;
3647 { /* It's a rewind rather than unwind. */
3648 tmp
+= distance
- 1;
3650 distance
= -distance
;
3653 for (; distance
> 0; distance
--)
3659 /* FIXME: Ideally we'd like to "temporarily unwind" (some of) those
3660 unwind_protect, but the problem is that we don't know how to
3661 rewind them afterwards. */
3662 case SPECPDL_UNWIND
:
3663 case SPECPDL_UNWIND_PTR
:
3664 case SPECPDL_UNWIND_INT
:
3665 case SPECPDL_UNWIND_VOID
:
3666 case SPECPDL_BACKTRACE
:
3669 { /* If variable has a trivial value (no forwarding), we can
3670 just set it. No need to check for constant symbols here,
3671 since that was already done by specbind. */
3672 struct Lisp_Symbol
*sym
= XSYMBOL (specpdl_symbol (tmp
));
3673 if (sym
->redirect
== SYMBOL_PLAINVAL
)
3675 Lisp_Object old_value
= specpdl_old_value (tmp
);
3676 set_specpdl_old_value (tmp
, SYMBOL_VAL (sym
));
3677 SET_SYMBOL_VAL (sym
, old_value
);
3682 NOTE: we only ever come here if make_local_foo was used for
3683 the first time on this var within this let. */
3686 case SPECPDL_LET_DEFAULT
:
3688 Lisp_Object sym
= specpdl_symbol (tmp
);
3689 Lisp_Object old_value
= specpdl_old_value (tmp
);
3690 set_specpdl_old_value (tmp
, Fdefault_value (sym
));
3691 Fset_default (sym
, old_value
);
3694 case SPECPDL_LET_LOCAL
:
3696 Lisp_Object symbol
= specpdl_symbol (tmp
);
3697 Lisp_Object where
= specpdl_where (tmp
);
3698 Lisp_Object old_value
= specpdl_old_value (tmp
);
3699 eassert (BUFFERP (where
));
3701 /* If this was a local binding, reset the value in the appropriate
3702 buffer, but only if that buffer's binding still exists. */
3703 if (!NILP (Flocal_variable_p (symbol
, where
)))
3705 set_specpdl_old_value
3706 (tmp
, Fbuffer_local_value (symbol
, where
));
3707 set_internal (symbol
, old_value
, where
, 1);
3715 DEFUN ("backtrace-eval", Fbacktrace_eval
, Sbacktrace_eval
, 2, 3, NULL
,
3716 doc
: /* Evaluate EXP in the context of some activation frame.
3717 NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */)
3718 (Lisp_Object exp
, Lisp_Object nframes
, Lisp_Object base
)
3720 union specbinding
*pdl
= get_backtrace_frame (nframes
, base
);
3721 ptrdiff_t count
= SPECPDL_INDEX ();
3722 ptrdiff_t distance
= specpdl_ptr
- pdl
;
3723 eassert (distance
>= 0);
3725 if (!backtrace_p (pdl
))
3726 error ("Activation frame not found!");
3728 backtrace_eval_unrewind (distance
);
3729 record_unwind_protect_int (backtrace_eval_unrewind
, -distance
);
3731 /* Use eval_sub rather than Feval since the main motivation behind
3732 backtrace-eval is to be able to get/set the value of lexical variables
3733 from the debugger. */
3734 return unbind_to (count
, eval_sub (exp
));
3738 mark_specpdl (union specbinding
*first
, union specbinding
*ptr
)
3740 union specbinding
*pdl
;
3741 for (pdl
= first
; pdl
!= ptr
; pdl
++)
3745 case SPECPDL_UNWIND
:
3746 mark_object (specpdl_arg (pdl
));
3749 case SPECPDL_BACKTRACE
:
3751 ptrdiff_t nargs
= backtrace_nargs (pdl
);
3752 mark_object (backtrace_function (pdl
));
3753 if (nargs
== UNEVALLED
)
3756 mark_object (backtrace_args (pdl
)[nargs
]);
3760 case SPECPDL_LET_DEFAULT
:
3761 case SPECPDL_LET_LOCAL
:
3762 mark_object (specpdl_where (pdl
));
3765 mark_object (specpdl_symbol (pdl
));
3766 mark_object (specpdl_old_value (pdl
));
3767 mark_object (specpdl_saved_value (pdl
));
3774 get_backtrace (Lisp_Object array
)
3776 union specbinding
*pdl
= backtrace_next (backtrace_top ());
3777 ptrdiff_t i
= 0, asize
= ASIZE (array
);
3779 /* Copy the backtrace contents into working memory. */
3780 for (; i
< asize
; i
++)
3782 if (backtrace_p (pdl
))
3784 ASET (array
, i
, backtrace_function (pdl
));
3785 pdl
= backtrace_next (pdl
);
3788 ASET (array
, i
, Qnil
);
3792 Lisp_Object
backtrace_top_function (void)
3794 union specbinding
*pdl
= backtrace_top ();
3795 return (backtrace_p (pdl
) ? backtrace_function (pdl
) : Qnil
);
3801 DEFVAR_INT ("max-specpdl-size", max_specpdl_size
,
3802 doc
: /* Limit on number of Lisp variable bindings and `unwind-protect's.
3803 If Lisp code tries to increase the total number past this amount,
3804 an error is signaled.
3805 You can safely use a value considerably larger than the default value,
3806 if that proves inconveniently small. However, if you increase it too far,
3807 Emacs could run out of memory trying to make the stack bigger. */);
3809 DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth
,
3810 doc
: /* Limit on depth in `eval', `apply' and `funcall' before error.
3812 This limit serves to catch infinite recursions for you before they cause
3813 actual stack overflow in C, which would be fatal for Emacs.
3814 You can safely make it considerably larger than its default value,
3815 if that proves inconveniently small. However, if you increase it too far,
3816 Emacs could overflow the real C stack, and crash. */);
3818 DEFVAR_LISP ("quit-flag", Vquit_flag
,
3819 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3820 If the value is t, that means do an ordinary quit.
3821 If the value equals `throw-on-input', that means quit by throwing
3822 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3823 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3824 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3827 DEFVAR_LISP ("inhibit-quit", Vinhibit_quit
,
3828 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3829 Note that `quit-flag' will still be set by typing C-g,
3830 so a quit will be signaled as soon as `inhibit-quit' is nil.
3831 To prevent this happening, set `quit-flag' to nil
3832 before making `inhibit-quit' nil. */);
3833 Vinhibit_quit
= Qnil
;
3835 DEFSYM (Qinhibit_quit
, "inhibit-quit");
3836 DEFSYM (Qautoload
, "autoload");
3837 DEFSYM (Qinhibit_debugger
, "inhibit-debugger");
3838 DEFSYM (Qmacro
, "macro");
3839 DEFSYM (Qdeclare
, "declare");
3841 /* Note that the process handling also uses Qexit, but we don't want
3842 to staticpro it twice, so we just do it here. */
3843 DEFSYM (Qexit
, "exit");
3845 DEFSYM (Qinteractive
, "interactive");
3846 DEFSYM (Qcommandp
, "commandp");
3847 DEFSYM (Qand_rest
, "&rest");
3848 DEFSYM (Qand_optional
, "&optional");
3849 DEFSYM (Qclosure
, "closure");
3850 DEFSYM (Qdebug
, "debug");
3852 DEFVAR_LISP ("inhibit-debugger", Vinhibit_debugger
,
3853 doc
: /* Non-nil means never enter the debugger.
3854 Normally set while the debugger is already active, to avoid recursive
3856 Vinhibit_debugger
= Qnil
;
3858 DEFVAR_LISP ("debug-on-error", Vdebug_on_error
,
3859 doc
: /* Non-nil means enter debugger if an error is signaled.
3860 Does not apply to errors handled by `condition-case' or those
3861 matched by `debug-ignored-errors'.
3862 If the value is a list, an error only means to enter the debugger
3863 if one of its condition symbols appears in the list.
3864 When you evaluate an expression interactively, this variable
3865 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3866 The command `toggle-debug-on-error' toggles this.
3867 See also the variable `debug-on-quit' and `inhibit-debugger'. */);
3868 Vdebug_on_error
= Qnil
;
3870 DEFVAR_LISP ("debug-ignored-errors", Vdebug_ignored_errors
,
3871 doc
: /* List of errors for which the debugger should not be called.
3872 Each element may be a condition-name or a regexp that matches error messages.
3873 If any element applies to a given error, that error skips the debugger
3874 and just returns to top level.
3875 This overrides the variable `debug-on-error'.
3876 It does not apply to errors handled by `condition-case'. */);
3877 Vdebug_ignored_errors
= Qnil
;
3879 DEFVAR_BOOL ("debug-on-quit", debug_on_quit
,
3880 doc
: /* Non-nil means enter debugger if quit is signaled (C-g, for example).
3881 Does not apply if quit is handled by a `condition-case'. */);
3884 DEFVAR_BOOL ("debug-on-next-call", debug_on_next_call
,
3885 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3887 DEFVAR_BOOL ("debugger-may-continue", debugger_may_continue
,
3888 doc
: /* Non-nil means debugger may continue execution.
3889 This is nil when the debugger is called under circumstances where it
3890 might not be safe to continue. */);
3891 debugger_may_continue
= 1;
3893 DEFVAR_LISP ("debugger", Vdebugger
,
3894 doc
: /* Function to call to invoke debugger.
3895 If due to frame exit, args are `exit' and the value being returned;
3896 this function's value will be returned instead of that.
3897 If due to error, args are `error' and a list of the args to `signal'.
3898 If due to `apply' or `funcall' entry, one arg, `lambda'.
3899 If due to `eval' entry, one arg, t. */);
3902 DEFVAR_LISP ("signal-hook-function", Vsignal_hook_function
,
3903 doc
: /* If non-nil, this is a function for `signal' to call.
3904 It receives the same arguments that `signal' was given.
3905 The Edebug package uses this to regain control. */);
3906 Vsignal_hook_function
= Qnil
;
3908 DEFVAR_LISP ("debug-on-signal", Vdebug_on_signal
,
3909 doc
: /* Non-nil means call the debugger regardless of condition handlers.
3910 Note that `debug-on-error', `debug-on-quit' and friends
3911 still determine whether to handle the particular condition. */);
3912 Vdebug_on_signal
= Qnil
;
3914 /* When lexical binding is being used,
3915 Vinternal_interpreter_environment is non-nil, and contains an alist
3916 of lexically-bound variable, or (t), indicating an empty
3917 environment. The lisp name of this variable would be
3918 `internal-interpreter-environment' if it weren't hidden.
3919 Every element of this list can be either a cons (VAR . VAL)
3920 specifying a lexical binding, or a single symbol VAR indicating
3921 that this variable should use dynamic scoping. */
3922 DEFSYM (Qinternal_interpreter_environment
,
3923 "internal-interpreter-environment");
3924 DEFVAR_LISP ("internal-interpreter-environment",
3925 Vinternal_interpreter_environment
,
3926 doc
: /* If non-nil, the current lexical environment of the lisp interpreter.
3927 When lexical binding is not being used, this variable is nil.
3928 A value of `(t)' indicates an empty environment, otherwise it is an
3929 alist of active lexical bindings. */);
3930 Vinternal_interpreter_environment
= Qnil
;
3931 /* Don't export this variable to Elisp, so no one can mess with it
3932 (Just imagine if someone makes it buffer-local). */
3933 Funintern (Qinternal_interpreter_environment
, Qnil
);
3935 DEFSYM (Vrun_hooks
, "run-hooks");
3937 staticpro (&Vautoload_queue
);
3938 Vautoload_queue
= Qnil
;
3939 staticpro (&Vsignaling_function
);
3940 Vsignaling_function
= Qnil
;
3942 inhibit_lisp_code
= Qnil
;
3953 defsubr (&Sfunction
);
3954 defsubr (&Sdefault_toplevel_value
);
3955 defsubr (&Sset_default_toplevel_value
);
3957 defsubr (&Sdefvaralias
);
3958 defsubr (&Sdefconst
);
3959 defsubr (&Smake_var_non_special
);
3963 defsubr (&Smacroexpand
);
3966 defsubr (&Sunwind_protect
);
3967 defsubr (&Scondition_case
);
3969 defsubr (&Scommandp
);
3970 defsubr (&Sautoload
);
3971 defsubr (&Sautoload_do_load
);
3974 defsubr (&Sfuncall
);
3975 defsubr (&Srun_hooks
);
3976 defsubr (&Srun_hook_with_args
);
3977 defsubr (&Srun_hook_with_args_until_success
);
3978 defsubr (&Srun_hook_with_args_until_failure
);
3979 defsubr (&Srun_hook_wrapped
);
3980 defsubr (&Sfetch_bytecode
);
3981 defsubr (&Sbacktrace_debug
);
3982 defsubr (&Sbacktrace
);
3983 defsubr (&Sbacktrace_frame
);
3984 defsubr (&Sbacktrace_eval
);
3985 defsubr (&Sspecial_variable_p
);
3986 defsubr (&Sfunctionp
);