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. */
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. */
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 specpdl_where (union specbinding
*pdl
)
144 eassert (pdl
->kind
> SPECPDL_LET
);
145 return pdl
->let
.where
;
149 specpdl_arg (union specbinding
*pdl
)
151 eassert (pdl
->kind
== SPECPDL_UNWIND
);
152 return pdl
->unwind
.arg
;
156 backtrace_function (union specbinding
*pdl
)
158 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
159 return pdl
->bt
.function
;
163 backtrace_nargs (union specbinding
*pdl
)
165 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
166 return pdl
->bt
.nargs
;
170 backtrace_args (union specbinding
*pdl
)
172 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
177 backtrace_debug_on_exit (union specbinding
*pdl
)
179 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
180 return pdl
->bt
.debug_on_exit
;
183 /* Functions to modify slots of backtrace records. */
186 set_backtrace_args (union specbinding
*pdl
, Lisp_Object
*args
)
188 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
193 set_backtrace_nargs (union specbinding
*pdl
, ptrdiff_t n
)
195 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
200 set_backtrace_debug_on_exit (union specbinding
*pdl
, bool doe
)
202 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
203 pdl
->bt
.debug_on_exit
= doe
;
206 /* Helper functions to scan the backtrace. */
209 backtrace_p (union specbinding
*pdl
)
210 { return pdl
>= specpdl
; }
215 union specbinding
*pdl
= specpdl_ptr
- 1;
216 while (backtrace_p (pdl
) && pdl
->kind
!= SPECPDL_BACKTRACE
)
222 backtrace_next (union specbinding
*pdl
)
225 while (backtrace_p (pdl
) && pdl
->kind
!= SPECPDL_BACKTRACE
)
232 init_eval_once (void)
235 union specbinding
*pdlvec
= xmalloc ((size
+ 1) * sizeof *specpdl
);
237 specpdl
= specpdl_ptr
= pdlvec
+ 1;
238 /* Don't forget to update docs (lispref node "Local Variables"). */
239 max_specpdl_size
= 1300; /* 1000 is not enough for CEDET's c-by.el. */
240 max_lisp_eval_depth
= 600;
248 specpdl_ptr
= specpdl
;
252 debug_on_next_call
= 0;
257 /* This is less than the initial value of num_nonmacro_input_events. */
258 when_entered_debugger
= -1;
261 /* Unwind-protect function used by call_debugger. */
264 restore_stack_limits (Lisp_Object data
)
266 max_specpdl_size
= XINT (XCAR (data
));
267 max_lisp_eval_depth
= XINT (XCDR (data
));
270 /* Call the Lisp debugger, giving it argument ARG. */
273 call_debugger (Lisp_Object arg
)
275 bool debug_while_redisplaying
;
276 ptrdiff_t count
= SPECPDL_INDEX ();
278 EMACS_INT old_max
= max_specpdl_size
;
280 /* Temporarily bump up the stack limits,
281 so the debugger won't run out of stack. */
283 max_specpdl_size
+= 1;
284 record_unwind_protect (restore_stack_limits
,
285 Fcons (make_number (old_max
),
286 make_number (max_lisp_eval_depth
)));
287 max_specpdl_size
= old_max
;
289 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
290 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
292 if (max_specpdl_size
- 100 < SPECPDL_INDEX ())
293 max_specpdl_size
= SPECPDL_INDEX () + 100;
295 #ifdef HAVE_WINDOW_SYSTEM
296 if (display_hourglass_p
)
300 debug_on_next_call
= 0;
301 when_entered_debugger
= num_nonmacro_input_events
;
303 /* Resetting redisplaying_p to 0 makes sure that debug output is
304 displayed if the debugger is invoked during redisplay. */
305 debug_while_redisplaying
= redisplaying_p
;
307 specbind (intern ("debugger-may-continue"),
308 debug_while_redisplaying
? Qnil
: Qt
);
309 specbind (Qinhibit_redisplay
, Qnil
);
310 specbind (Qinhibit_debugger
, Qt
);
312 #if 0 /* Binding this prevents execution of Lisp code during
313 redisplay, which necessarily leads to display problems. */
314 specbind (Qinhibit_eval_during_redisplay
, Qt
);
317 val
= apply1 (Vdebugger
, arg
);
319 /* Interrupting redisplay and resuming it later is not safe under
320 all circumstances. So, when the debugger returns, abort the
321 interrupted redisplay by going back to the top-level. */
322 if (debug_while_redisplaying
)
325 return unbind_to (count
, val
);
329 do_debug_on_call (Lisp_Object code
)
331 debug_on_next_call
= 0;
332 set_backtrace_debug_on_exit (specpdl_ptr
- 1, true);
333 call_debugger (list1 (code
));
336 /* NOTE!!! Every function that can call EVAL must protect its args
337 and temporaries from garbage collection while it needs them.
338 The definition of `For' shows what you have to do. */
340 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
341 doc
: /* Eval args until one of them yields non-nil, then return that value.
342 The remaining args are not evalled at all.
343 If all args return nil, return nil.
344 usage: (or CONDITIONS...) */)
347 register Lisp_Object val
= Qnil
;
354 val
= eval_sub (XCAR (args
));
364 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
365 doc
: /* Eval args until one of them yields nil, then return nil.
366 The remaining args are not evalled at all.
367 If no arg yields nil, return the last arg's value.
368 usage: (and CONDITIONS...) */)
371 register Lisp_Object val
= Qt
;
378 val
= eval_sub (XCAR (args
));
388 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
389 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
390 Returns the value of THEN or the value of the last of the ELSE's.
391 THEN must be one expression, but ELSE... can be zero or more expressions.
392 If COND yields nil, and there are no ELSE's, the value is nil.
393 usage: (if COND THEN ELSE...) */)
396 register Lisp_Object cond
;
400 cond
= eval_sub (Fcar (args
));
404 return eval_sub (Fcar (Fcdr (args
)));
405 return Fprogn (Fcdr (Fcdr (args
)));
408 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
409 doc
: /* Try each clause until one succeeds.
410 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
411 and, if the value is non-nil, this clause succeeds:
412 then the expressions in BODY are evaluated and the last one's
413 value is the value of the cond-form.
414 If no clause succeeds, cond returns nil.
415 If a clause has one element, as in (CONDITION),
416 CONDITION's value if non-nil is returned from the cond-form.
417 usage: (cond CLAUSES...) */)
420 register Lisp_Object clause
, val
;
427 clause
= Fcar (args
);
428 val
= eval_sub (Fcar (clause
));
431 if (!EQ (XCDR (clause
), Qnil
))
432 val
= Fprogn (XCDR (clause
));
442 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
443 doc
: /* Eval BODY forms sequentially and return value of last one.
444 usage: (progn BODY...) */)
447 Lisp_Object val
= Qnil
;
454 val
= eval_sub (XCAR (body
));
462 /* Evaluate BODY sequentially, discarding its value. Suitable for
463 record_unwind_protect. */
466 unwind_body (Lisp_Object body
)
471 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
472 doc
: /* Eval FIRST and BODY sequentially; return value from FIRST.
473 The value of FIRST is saved during the evaluation of the remaining args,
474 whose values are discarded.
475 usage: (prog1 FIRST BODY...) */)
479 register Lisp_Object args_left
;
480 struct gcpro gcpro1
, gcpro2
;
486 val
= eval_sub (XCAR (args_left
));
487 while (CONSP (args_left
= XCDR (args_left
)))
488 eval_sub (XCAR (args_left
));
494 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
495 doc
: /* Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
496 The value of FORM2 is saved during the evaluation of the
497 remaining args, whose values are discarded.
498 usage: (prog2 FORM1 FORM2 BODY...) */)
504 eval_sub (XCAR (args
));
506 return Fprog1 (XCDR (args
));
509 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
510 doc
: /* Set each SYM to the value of its VAL.
511 The symbols SYM are variables; they are literal (not evaluated).
512 The values VAL are expressions; they are evaluated.
513 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
514 The second VAL is not computed until after the first SYM is set, and so on;
515 each VAL can use the new value of variables set earlier in the `setq'.
516 The return value of the `setq' form is the value of the last VAL.
517 usage: (setq [SYM VAL]...) */)
520 register Lisp_Object args_left
;
521 register Lisp_Object val
, sym
, lex_binding
;
532 val
= eval_sub (Fcar (Fcdr (args_left
)));
533 sym
= Fcar (args_left
);
535 /* Like for eval_sub, we do not check declared_special here since
536 it's been done when let-binding. */
537 if (!NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
539 && !NILP (lex_binding
540 = Fassq (sym
, Vinternal_interpreter_environment
)))
541 XSETCDR (lex_binding
, val
); /* SYM is lexically bound. */
543 Fset (sym
, val
); /* SYM is dynamically bound. */
545 args_left
= Fcdr (Fcdr (args_left
));
547 while (!NILP (args_left
));
553 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
554 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
555 Warning: `quote' does not construct its return value, but just returns
556 the value that was pre-constructed by the Lisp reader (see info node
557 `(elisp)Printed Representation').
558 This means that '(a . b) is not identical to (cons 'a 'b): the former
559 does not cons. Quoting should be reserved for constants that will
560 never be modified by side-effects, unless you like self-modifying code.
561 See the common pitfall in info node `(elisp)Rearrangement' for an example
562 of unexpected results when a quoted object is modified.
563 usage: (quote ARG) */)
566 if (!NILP (Fcdr (args
)))
567 xsignal2 (Qwrong_number_of_arguments
, Qquote
, Flength (args
));
571 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
572 doc
: /* Like `quote', but preferred for objects which are functions.
573 In byte compilation, `function' causes its argument to be compiled.
574 `quote' cannot do that.
575 usage: (function ARG) */)
578 Lisp_Object quoted
= XCAR (args
);
580 if (!NILP (Fcdr (args
)))
581 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
583 if (!NILP (Vinternal_interpreter_environment
)
585 && EQ (XCAR (quoted
), Qlambda
))
586 /* This is a lambda expression within a lexical environment;
587 return an interpreted closure instead of a simple lambda. */
588 return Fcons (Qclosure
, Fcons (Vinternal_interpreter_environment
,
591 /* Simply quote the argument. */
596 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
597 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
598 Aliased variables always have the same value; setting one sets the other.
599 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
600 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
601 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
602 itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
603 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
604 The return value is BASE-VARIABLE. */)
605 (Lisp_Object new_alias
, Lisp_Object base_variable
, Lisp_Object docstring
)
607 struct Lisp_Symbol
*sym
;
609 CHECK_SYMBOL (new_alias
);
610 CHECK_SYMBOL (base_variable
);
612 sym
= XSYMBOL (new_alias
);
615 /* Not sure why, but why not? */
616 error ("Cannot make a constant an alias");
618 switch (sym
->redirect
)
620 case SYMBOL_FORWARDED
:
621 error ("Cannot make an internal variable an alias");
622 case SYMBOL_LOCALIZED
:
623 error ("Don't know how to make a localized variable an alias");
626 /* http://lists.gnu.org/archive/html/emacs-devel/2008-04/msg00834.html
627 If n_a is bound, but b_v is not, set the value of b_v to n_a,
628 so that old-code that affects n_a before the aliasing is setup
630 if (NILP (Fboundp (base_variable
)))
631 set_internal (base_variable
, find_symbol_value (new_alias
), Qnil
, 1);
634 union specbinding
*p
;
636 for (p
= specpdl_ptr
; p
> specpdl
; )
637 if ((--p
)->kind
>= SPECPDL_LET
638 && (EQ (new_alias
, specpdl_symbol (p
))))
639 error ("Don't know how to make a let-bound variable an alias");
642 sym
->declared_special
= 1;
643 XSYMBOL (base_variable
)->declared_special
= 1;
644 sym
->redirect
= SYMBOL_VARALIAS
;
645 SET_SYMBOL_ALIAS (sym
, XSYMBOL (base_variable
));
646 sym
->constant
= SYMBOL_CONSTANT_P (base_variable
);
647 LOADHIST_ATTACH (new_alias
);
648 /* Even if docstring is nil: remove old docstring. */
649 Fput (new_alias
, Qvariable_documentation
, docstring
);
651 return base_variable
;
655 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
656 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
657 You are not required to define a variable in order to use it, but
658 defining it lets you supply an initial value and documentation, which
659 can be referred to by the Emacs help facilities and other programming
660 tools. The `defvar' form also declares the variable as \"special\",
661 so that it is always dynamically bound even if `lexical-binding' is t.
663 The optional argument INITVALUE is evaluated, and used to set SYMBOL,
664 only if SYMBOL's value is void. If SYMBOL is buffer-local, its
665 default value is what is set; buffer-local values are not affected.
666 If INITVALUE is missing, SYMBOL's value is not set.
668 If SYMBOL has a local binding, then this form affects the local
669 binding. This is usually not what you want. Thus, if you need to
670 load a file defining variables, with this form or with `defconst' or
671 `defcustom', you should always load that file _outside_ any bindings
672 for these variables. \(`defconst' and `defcustom' behave similarly in
675 The optional argument DOCSTRING is a documentation string for the
678 To define a user option, use `defcustom' instead of `defvar'.
679 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
682 register Lisp_Object sym
, tem
, tail
;
686 if (!NILP (Fcdr (Fcdr (tail
))))
687 error ("Too many arguments");
689 tem
= Fdefault_boundp (sym
);
692 /* Do it before evaluating the initial value, for self-references. */
693 XSYMBOL (sym
)->declared_special
= 1;
696 Fset_default (sym
, eval_sub (Fcar (tail
)));
698 { /* Check if there is really a global binding rather than just a let
699 binding that shadows the global unboundness of the var. */
700 union specbinding
*pdl
= specpdl_ptr
;
701 while (pdl
> specpdl
)
703 if ((--pdl
)->kind
>= SPECPDL_LET
704 && EQ (specpdl_symbol (pdl
), sym
)
705 && EQ (specpdl_old_value (pdl
), Qunbound
))
708 ("Warning: defvar ignored because %s is let-bound",
709 SYMBOL_NAME (sym
), 1);
718 if (!NILP (Vpurify_flag
))
719 tem
= Fpurecopy (tem
);
720 Fput (sym
, Qvariable_documentation
, tem
);
722 LOADHIST_ATTACH (sym
);
724 else if (!NILP (Vinternal_interpreter_environment
)
725 && !XSYMBOL (sym
)->declared_special
)
726 /* A simple (defvar foo) with lexical scoping does "nothing" except
727 declare that var to be dynamically scoped *locally* (i.e. within
728 the current file or let-block). */
729 Vinternal_interpreter_environment
730 = Fcons (sym
, Vinternal_interpreter_environment
);
733 /* Simple (defvar <var>) should not count as a definition at all.
734 It could get in the way of other definitions, and unloading this
735 package could try to make the variable unbound. */
741 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
742 doc
: /* Define SYMBOL as a constant variable.
743 This declares that neither programs nor users should ever change the
744 value. This constancy is not actually enforced by Emacs Lisp, but
745 SYMBOL is marked as a special variable so that it is never lexically
748 The `defconst' form always sets the value of SYMBOL to the result of
749 evalling INITVALUE. If SYMBOL is buffer-local, its default value is
750 what is set; buffer-local values are not affected. If SYMBOL has a
751 local binding, then this form sets the local binding's value.
752 However, you should normally not make local bindings for variables
753 defined with this form.
755 The optional DOCSTRING specifies the variable's documentation string.
756 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
759 register Lisp_Object sym
, tem
;
762 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
763 error ("Too many arguments");
765 tem
= eval_sub (Fcar (Fcdr (args
)));
766 if (!NILP (Vpurify_flag
))
767 tem
= Fpurecopy (tem
);
768 Fset_default (sym
, tem
);
769 XSYMBOL (sym
)->declared_special
= 1;
770 tem
= Fcar (Fcdr (Fcdr (args
)));
773 if (!NILP (Vpurify_flag
))
774 tem
= Fpurecopy (tem
);
775 Fput (sym
, Qvariable_documentation
, tem
);
777 Fput (sym
, Qrisky_local_variable
, Qt
);
778 LOADHIST_ATTACH (sym
);
782 /* Make SYMBOL lexically scoped. */
783 DEFUN ("internal-make-var-non-special", Fmake_var_non_special
,
784 Smake_var_non_special
, 1, 1, 0,
785 doc
: /* Internal function. */)
788 CHECK_SYMBOL (symbol
);
789 XSYMBOL (symbol
)->declared_special
= 0;
794 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
795 doc
: /* Bind variables according to VARLIST then eval BODY.
796 The value of the last form in BODY is returned.
797 Each element of VARLIST is a symbol (which is bound to nil)
798 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
799 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
800 usage: (let* VARLIST BODY...) */)
803 Lisp_Object varlist
, var
, val
, elt
, lexenv
;
804 ptrdiff_t count
= SPECPDL_INDEX ();
805 struct gcpro gcpro1
, gcpro2
, gcpro3
;
807 GCPRO3 (args
, elt
, varlist
);
809 lexenv
= Vinternal_interpreter_environment
;
811 varlist
= Fcar (args
);
812 while (CONSP (varlist
))
816 elt
= XCAR (varlist
);
822 else if (! NILP (Fcdr (Fcdr (elt
))))
823 signal_error ("`let' bindings can have only one value-form", elt
);
827 val
= eval_sub (Fcar (Fcdr (elt
)));
830 if (!NILP (lexenv
) && SYMBOLP (var
)
831 && !XSYMBOL (var
)->declared_special
832 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
833 /* Lexically bind VAR by adding it to the interpreter's binding
837 = Fcons (Fcons (var
, val
), Vinternal_interpreter_environment
);
838 if (EQ (Vinternal_interpreter_environment
, lexenv
))
839 /* Save the old lexical environment on the specpdl stack,
840 but only for the first lexical binding, since we'll never
841 need to revert to one of the intermediate ones. */
842 specbind (Qinternal_interpreter_environment
, newenv
);
844 Vinternal_interpreter_environment
= newenv
;
849 varlist
= XCDR (varlist
);
852 val
= Fprogn (Fcdr (args
));
853 return unbind_to (count
, val
);
856 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
857 doc
: /* Bind variables according to VARLIST then eval BODY.
858 The value of the last form in BODY is returned.
859 Each element of VARLIST is a symbol (which is bound to nil)
860 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
861 All the VALUEFORMs are evalled before any symbols are bound.
862 usage: (let VARLIST BODY...) */)
865 Lisp_Object
*temps
, tem
, lexenv
;
866 register Lisp_Object elt
, varlist
;
867 ptrdiff_t count
= SPECPDL_INDEX ();
869 struct gcpro gcpro1
, gcpro2
;
872 varlist
= Fcar (args
);
874 /* Make space to hold the values to give the bound variables. */
875 elt
= Flength (varlist
);
876 SAFE_ALLOCA_LISP (temps
, XFASTINT (elt
));
878 /* Compute the values and store them in `temps'. */
880 GCPRO2 (args
, *temps
);
883 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
886 elt
= XCAR (varlist
);
888 temps
[argnum
++] = Qnil
;
889 else if (! NILP (Fcdr (Fcdr (elt
))))
890 signal_error ("`let' bindings can have only one value-form", elt
);
892 temps
[argnum
++] = eval_sub (Fcar (Fcdr (elt
)));
893 gcpro2
.nvars
= argnum
;
897 lexenv
= Vinternal_interpreter_environment
;
899 varlist
= Fcar (args
);
900 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
904 elt
= XCAR (varlist
);
905 var
= SYMBOLP (elt
) ? elt
: Fcar (elt
);
906 tem
= temps
[argnum
++];
908 if (!NILP (lexenv
) && SYMBOLP (var
)
909 && !XSYMBOL (var
)->declared_special
910 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
911 /* Lexically bind VAR by adding it to the lexenv alist. */
912 lexenv
= Fcons (Fcons (var
, tem
), lexenv
);
914 /* Dynamically bind VAR. */
918 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
919 /* Instantiate a new lexical environment. */
920 specbind (Qinternal_interpreter_environment
, lexenv
);
922 elt
= Fprogn (Fcdr (args
));
924 return unbind_to (count
, elt
);
927 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
928 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
929 The order of execution is thus TEST, BODY, TEST, BODY and so on
930 until TEST returns nil.
931 usage: (while TEST BODY...) */)
934 Lisp_Object test
, body
;
935 struct gcpro gcpro1
, gcpro2
;
941 while (!NILP (eval_sub (test
)))
951 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
952 doc
: /* Return result of expanding macros at top level of FORM.
953 If FORM is not a macro call, it is returned unchanged.
954 Otherwise, the macro is expanded and the expansion is considered
955 in place of FORM. When a non-macro-call results, it is returned.
957 The second optional arg ENVIRONMENT specifies an environment of macro
958 definitions to shadow the loaded ones for use in file byte-compilation. */)
959 (Lisp_Object form
, Lisp_Object environment
)
961 /* With cleanups from Hallvard Furuseth. */
962 register Lisp_Object expander
, sym
, def
, tem
;
966 /* Come back here each time we expand a macro call,
967 in case it expands into another macro call. */
970 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
971 def
= sym
= XCAR (form
);
973 /* Trace symbols aliases to other symbols
974 until we get a symbol that is not an alias. */
975 while (SYMBOLP (def
))
979 tem
= Fassq (sym
, environment
);
982 def
= XSYMBOL (sym
)->function
;
988 /* Right now TEM is the result from SYM in ENVIRONMENT,
989 and if TEM is nil then DEF is SYM's function definition. */
992 /* SYM is not mentioned in ENVIRONMENT.
993 Look at its function definition. */
996 def
= Fautoload_do_load (def
, sym
, Qmacro
);
999 /* Not defined or definition not suitable. */
1001 if (!EQ (XCAR (def
), Qmacro
))
1003 else expander
= XCDR (def
);
1007 expander
= XCDR (tem
);
1008 if (NILP (expander
))
1012 Lisp_Object newform
= apply1 (expander
, XCDR (form
));
1013 if (EQ (form
, newform
))
1022 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1023 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1024 TAG is evalled to get the tag to use; it must not be nil.
1026 Then the BODY is executed.
1027 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
1028 If no throw happens, `catch' returns the value of the last BODY form.
1029 If a throw happens, it specifies the value to return from `catch'.
1030 usage: (catch TAG BODY...) */)
1033 register Lisp_Object tag
;
1034 struct gcpro gcpro1
;
1037 tag
= eval_sub (Fcar (args
));
1039 return internal_catch (tag
, Fprogn
, Fcdr (args
));
1042 /* Set up a catch, then call C function FUNC on argument ARG.
1043 FUNC should return a Lisp_Object.
1044 This is how catches are done from within C code. */
1047 internal_catch (Lisp_Object tag
, Lisp_Object (*func
) (Lisp_Object
), Lisp_Object arg
)
1049 /* This structure is made part of the chain `catchlist'. */
1052 /* Fill in the components of c, and put it on the list. */
1056 c
.handlerlist
= handlerlist
;
1057 c
.lisp_eval_depth
= lisp_eval_depth
;
1058 c
.pdlcount
= SPECPDL_INDEX ();
1059 c
.poll_suppress_count
= poll_suppress_count
;
1060 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1061 c
.gcpro
= gcprolist
;
1062 c
.byte_stack
= byte_stack_list
;
1066 if (! sys_setjmp (c
.jmp
))
1067 c
.val
= (*func
) (arg
);
1069 /* Throw works by a longjmp that comes right here. */
1074 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1075 jump to that CATCH, returning VALUE as the value of that catch.
1077 This is the guts of Fthrow and Fsignal; they differ only in the way
1078 they choose the catch tag to throw to. A catch tag for a
1079 condition-case form has a TAG of Qnil.
1081 Before each catch is discarded, unbind all special bindings and
1082 execute all unwind-protect clauses made above that catch. Unwind
1083 the handler stack as we go, so that the proper handlers are in
1084 effect for each unwind-protect clause we run. At the end, restore
1085 some static info saved in CATCH, and longjmp to the location
1088 This is used for correct unwinding in Fthrow and Fsignal. */
1090 static _Noreturn
void
1091 unwind_to_catch (struct catchtag
*catch, Lisp_Object value
)
1095 /* Save the value in the tag. */
1098 /* Restore certain special C variables. */
1099 set_poll_suppress_count (catch->poll_suppress_count
);
1100 unblock_input_to (catch->interrupt_input_blocked
);
1105 last_time
= catchlist
== catch;
1107 /* Unwind the specpdl stack, and then restore the proper set of
1109 unbind_to (catchlist
->pdlcount
, Qnil
);
1110 handlerlist
= catchlist
->handlerlist
;
1111 catchlist
= catchlist
->next
;
1113 while (! last_time
);
1115 byte_stack_list
= catch->byte_stack
;
1116 gcprolist
= catch->gcpro
;
1118 gcpro_level
= gcprolist
? gcprolist
->level
+ 1 : 0;
1120 lisp_eval_depth
= catch->lisp_eval_depth
;
1122 sys_longjmp (catch->jmp
, 1);
1125 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1126 doc
: /* Throw to the catch for TAG and return VALUE from it.
1127 Both TAG and VALUE are evalled. */)
1128 (register Lisp_Object tag
, Lisp_Object value
)
1130 register struct catchtag
*c
;
1133 for (c
= catchlist
; c
; c
= c
->next
)
1135 if (EQ (c
->tag
, tag
))
1136 unwind_to_catch (c
, value
);
1138 xsignal2 (Qno_catch
, tag
, value
);
1142 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1143 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1144 If BODYFORM completes normally, its value is returned
1145 after executing the UNWINDFORMS.
1146 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1147 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1151 ptrdiff_t count
= SPECPDL_INDEX ();
1153 record_unwind_protect (unwind_body
, Fcdr (args
));
1154 val
= eval_sub (Fcar (args
));
1155 return unbind_to (count
, val
);
1158 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1159 doc
: /* Regain control when an error is signaled.
1160 Executes BODYFORM and returns its value if no error happens.
1161 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1162 where the BODY is made of Lisp expressions.
1164 A handler is applicable to an error
1165 if CONDITION-NAME is one of the error's condition names.
1166 If an error happens, the first applicable handler is run.
1168 The car of a handler may be a list of condition names instead of a
1169 single condition name; then it handles all of them. If the special
1170 condition name `debug' is present in this list, it allows another
1171 condition in the list to run the debugger if `debug-on-error' and the
1172 other usual mechanisms says it should (otherwise, `condition-case'
1173 suppresses the debugger).
1175 When a handler handles an error, control returns to the `condition-case'
1176 and it executes the handler's BODY...
1177 with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
1178 \(If VAR is nil, the handler can't access that information.)
1179 Then the value of the last BODY form is returned from the `condition-case'
1182 See also the function `signal' for more info.
1183 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1186 Lisp_Object var
= Fcar (args
);
1187 Lisp_Object bodyform
= Fcar (Fcdr (args
));
1188 Lisp_Object handlers
= Fcdr (Fcdr (args
));
1190 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1193 /* Like Fcondition_case, but the args are separate
1194 rather than passed in a list. Used by Fbyte_code. */
1197 internal_lisp_condition_case (volatile Lisp_Object var
, Lisp_Object bodyform
,
1198 Lisp_Object handlers
)
1206 for (val
= handlers
; CONSP (val
); val
= XCDR (val
))
1212 && (SYMBOLP (XCAR (tem
))
1213 || CONSP (XCAR (tem
))))))
1214 error ("Invalid condition handler: %s",
1215 SDATA (Fprin1_to_string (tem
, Qt
)));
1220 c
.handlerlist
= handlerlist
;
1221 c
.lisp_eval_depth
= lisp_eval_depth
;
1222 c
.pdlcount
= SPECPDL_INDEX ();
1223 c
.poll_suppress_count
= poll_suppress_count
;
1224 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1225 c
.gcpro
= gcprolist
;
1226 c
.byte_stack
= byte_stack_list
;
1227 if (sys_setjmp (c
.jmp
))
1230 specbind (h
.var
, c
.val
);
1231 val
= Fprogn (Fcdr (h
.chosen_clause
));
1233 /* Note that this just undoes the binding of h.var; whoever
1234 longjumped to us unwound the stack to c.pdlcount before
1236 unbind_to (c
.pdlcount
, Qnil
);
1243 h
.handler
= handlers
;
1244 h
.next
= handlerlist
;
1248 val
= eval_sub (bodyform
);
1250 handlerlist
= h
.next
;
1254 /* Call the function BFUN with no arguments, catching errors within it
1255 according to HANDLERS. If there is an error, call HFUN with
1256 one argument which is the data that describes the error:
1259 HANDLERS can be a list of conditions to catch.
1260 If HANDLERS is Qt, catch all errors.
1261 If HANDLERS is Qerror, catch all errors
1262 but allow the debugger to run if that is enabled. */
1265 internal_condition_case (Lisp_Object (*bfun
) (void), Lisp_Object handlers
,
1266 Lisp_Object (*hfun
) (Lisp_Object
))
1274 c
.handlerlist
= handlerlist
;
1275 c
.lisp_eval_depth
= lisp_eval_depth
;
1276 c
.pdlcount
= SPECPDL_INDEX ();
1277 c
.poll_suppress_count
= poll_suppress_count
;
1278 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1279 c
.gcpro
= gcprolist
;
1280 c
.byte_stack
= byte_stack_list
;
1281 if (sys_setjmp (c
.jmp
))
1283 return (*hfun
) (c
.val
);
1287 h
.handler
= handlers
;
1289 h
.next
= handlerlist
;
1295 handlerlist
= h
.next
;
1299 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1302 internal_condition_case_1 (Lisp_Object (*bfun
) (Lisp_Object
), Lisp_Object arg
,
1303 Lisp_Object handlers
, Lisp_Object (*hfun
) (Lisp_Object
))
1311 c
.handlerlist
= handlerlist
;
1312 c
.lisp_eval_depth
= lisp_eval_depth
;
1313 c
.pdlcount
= SPECPDL_INDEX ();
1314 c
.poll_suppress_count
= poll_suppress_count
;
1315 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1316 c
.gcpro
= gcprolist
;
1317 c
.byte_stack
= byte_stack_list
;
1318 if (sys_setjmp (c
.jmp
))
1320 return (*hfun
) (c
.val
);
1324 h
.handler
= handlers
;
1326 h
.next
= handlerlist
;
1330 val
= (*bfun
) (arg
);
1332 handlerlist
= h
.next
;
1336 /* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as
1340 internal_condition_case_2 (Lisp_Object (*bfun
) (Lisp_Object
, Lisp_Object
),
1343 Lisp_Object handlers
,
1344 Lisp_Object (*hfun
) (Lisp_Object
))
1352 c
.handlerlist
= handlerlist
;
1353 c
.lisp_eval_depth
= lisp_eval_depth
;
1354 c
.pdlcount
= SPECPDL_INDEX ();
1355 c
.poll_suppress_count
= poll_suppress_count
;
1356 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1357 c
.gcpro
= gcprolist
;
1358 c
.byte_stack
= byte_stack_list
;
1359 if (sys_setjmp (c
.jmp
))
1361 return (*hfun
) (c
.val
);
1365 h
.handler
= handlers
;
1367 h
.next
= handlerlist
;
1371 val
= (*bfun
) (arg1
, arg2
);
1373 handlerlist
= h
.next
;
1377 /* Like internal_condition_case but call BFUN with NARGS as first,
1378 and ARGS as second argument. */
1381 internal_condition_case_n (Lisp_Object (*bfun
) (ptrdiff_t, Lisp_Object
*),
1384 Lisp_Object handlers
,
1385 Lisp_Object (*hfun
) (Lisp_Object err
,
1395 c
.handlerlist
= handlerlist
;
1396 c
.lisp_eval_depth
= lisp_eval_depth
;
1397 c
.pdlcount
= SPECPDL_INDEX ();
1398 c
.poll_suppress_count
= poll_suppress_count
;
1399 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1400 c
.gcpro
= gcprolist
;
1401 c
.byte_stack
= byte_stack_list
;
1402 if (sys_setjmp (c
.jmp
))
1404 return (*hfun
) (c
.val
, nargs
, args
);
1408 h
.handler
= handlers
;
1410 h
.next
= handlerlist
;
1414 val
= (*bfun
) (nargs
, args
);
1416 handlerlist
= h
.next
;
1421 static Lisp_Object
find_handler_clause (Lisp_Object
, Lisp_Object
);
1422 static bool maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
,
1426 process_quit_flag (void)
1428 Lisp_Object flag
= Vquit_flag
;
1430 if (EQ (flag
, Qkill_emacs
))
1432 if (EQ (Vthrow_on_input
, flag
))
1433 Fthrow (Vthrow_on_input
, Qt
);
1434 Fsignal (Qquit
, Qnil
);
1437 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1438 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1439 This function does not return.
1441 An error symbol is a symbol with an `error-conditions' property
1442 that is a list of condition names.
1443 A handler for any of those names will get to handle this signal.
1444 The symbol `error' should normally be one of them.
1446 DATA should be a list. Its elements are printed as part of the error message.
1447 See Info anchor `(elisp)Definition of signal' for some details on how this
1448 error message is constructed.
1449 If the signal is handled, DATA is made available to the handler.
1450 See also the function `condition-case'. */)
1451 (Lisp_Object error_symbol
, Lisp_Object data
)
1453 /* When memory is full, ERROR-SYMBOL is nil,
1454 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1455 That is a special case--don't do this in other situations. */
1456 Lisp_Object conditions
;
1458 Lisp_Object real_error_symbol
1459 = (NILP (error_symbol
) ? Fcar (data
) : error_symbol
);
1460 register Lisp_Object clause
= Qnil
;
1465 if (gc_in_progress
|| waiting_for_input
)
1468 #if 0 /* rms: I don't know why this was here,
1469 but it is surely wrong for an error that is handled. */
1470 #ifdef HAVE_WINDOW_SYSTEM
1471 if (display_hourglass_p
)
1472 cancel_hourglass ();
1476 /* This hook is used by edebug. */
1477 if (! NILP (Vsignal_hook_function
)
1478 && ! NILP (error_symbol
))
1480 /* Edebug takes care of restoring these variables when it exits. */
1481 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1482 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1484 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1485 max_specpdl_size
= SPECPDL_INDEX () + 40;
1487 call2 (Vsignal_hook_function
, error_symbol
, data
);
1490 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1492 /* Remember from where signal was called. Skip over the frame for
1493 `signal' itself. If a frame for `error' follows, skip that,
1494 too. Don't do this when ERROR_SYMBOL is nil, because that
1495 is a memory-full error. */
1496 Vsignaling_function
= Qnil
;
1497 if (!NILP (error_symbol
))
1499 union specbinding
*pdl
= backtrace_next (backtrace_top ());
1500 if (backtrace_p (pdl
) && EQ (backtrace_function (pdl
), Qerror
))
1501 pdl
= backtrace_next (pdl
);
1502 if (backtrace_p (pdl
))
1503 Vsignaling_function
= backtrace_function (pdl
);
1506 for (h
= handlerlist
; h
; h
= h
->next
)
1508 clause
= find_handler_clause (h
->handler
, conditions
);
1513 if (/* Don't run the debugger for a memory-full error.
1514 (There is no room in memory to do that!) */
1515 !NILP (error_symbol
)
1516 && (!NILP (Vdebug_on_signal
)
1517 /* If no handler is present now, try to run the debugger. */
1519 /* A `debug' symbol in the handler list disables the normal
1520 suppression of the debugger. */
1521 || (CONSP (clause
) && CONSP (XCAR (clause
))
1522 && !NILP (Fmemq (Qdebug
, XCAR (clause
))))
1523 /* Special handler that means "print a message and run debugger
1525 || EQ (h
->handler
, Qerror
)))
1527 bool debugger_called
1528 = maybe_call_debugger (conditions
, error_symbol
, data
);
1529 /* We can't return values to code which signaled an error, but we
1530 can continue code which has signaled a quit. */
1531 if (debugger_called
&& EQ (real_error_symbol
, Qquit
))
1537 Lisp_Object unwind_data
1538 = (NILP (error_symbol
) ? data
: Fcons (error_symbol
, data
));
1540 h
->chosen_clause
= clause
;
1541 unwind_to_catch (h
->tag
, unwind_data
);
1546 Fthrow (Qtop_level
, Qt
);
1549 if (! NILP (error_symbol
))
1550 data
= Fcons (error_symbol
, data
);
1552 string
= Ferror_message_string (data
);
1553 fatal ("%s", SDATA (string
));
1556 /* Internal version of Fsignal that never returns.
1557 Used for anything but Qquit (which can return from Fsignal). */
1560 xsignal (Lisp_Object error_symbol
, Lisp_Object data
)
1562 Fsignal (error_symbol
, data
);
1566 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1569 xsignal0 (Lisp_Object error_symbol
)
1571 xsignal (error_symbol
, Qnil
);
1575 xsignal1 (Lisp_Object error_symbol
, Lisp_Object arg
)
1577 xsignal (error_symbol
, list1 (arg
));
1581 xsignal2 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
)
1583 xsignal (error_symbol
, list2 (arg1
, arg2
));
1587 xsignal3 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
1589 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1592 /* Signal `error' with message S, and additional arg ARG.
1593 If ARG is not a genuine list, make it a one-element list. */
1596 signal_error (const char *s
, Lisp_Object arg
)
1598 Lisp_Object tortoise
, hare
;
1600 hare
= tortoise
= arg
;
1601 while (CONSP (hare
))
1608 tortoise
= XCDR (tortoise
);
1610 if (EQ (hare
, tortoise
))
1617 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1621 /* Return true if LIST is a non-nil atom or
1622 a list containing one of CONDITIONS. */
1625 wants_debugger (Lisp_Object list
, Lisp_Object conditions
)
1632 while (CONSP (conditions
))
1634 Lisp_Object
this, tail
;
1635 this = XCAR (conditions
);
1636 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1637 if (EQ (XCAR (tail
), this))
1639 conditions
= XCDR (conditions
);
1644 /* Return true if an error with condition-symbols CONDITIONS,
1645 and described by SIGNAL-DATA, should skip the debugger
1646 according to debugger-ignored-errors. */
1649 skip_debugger (Lisp_Object conditions
, Lisp_Object data
)
1652 bool first_string
= 1;
1653 Lisp_Object error_message
;
1655 error_message
= Qnil
;
1656 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1658 if (STRINGP (XCAR (tail
)))
1662 error_message
= Ferror_message_string (data
);
1666 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1671 Lisp_Object contail
;
1673 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1674 if (EQ (XCAR (tail
), XCAR (contail
)))
1682 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1683 SIG and DATA describe the signal. There are two ways to pass them:
1684 = SIG is the error symbol, and DATA is the rest of the data.
1685 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1686 This is for memory-full errors only. */
1688 maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
, Lisp_Object data
)
1690 Lisp_Object combined_data
;
1692 combined_data
= Fcons (sig
, data
);
1695 /* Don't try to run the debugger with interrupts blocked.
1696 The editing loop would return anyway. */
1697 ! input_blocked_p ()
1698 && NILP (Vinhibit_debugger
)
1699 /* Does user want to enter debugger for this kind of error? */
1702 : wants_debugger (Vdebug_on_error
, conditions
))
1703 && ! skip_debugger (conditions
, combined_data
)
1704 /* RMS: What's this for? */
1705 && when_entered_debugger
< num_nonmacro_input_events
)
1707 call_debugger (list2 (Qerror
, combined_data
));
1715 find_handler_clause (Lisp_Object handlers
, Lisp_Object conditions
)
1717 register Lisp_Object h
;
1719 /* t is used by handlers for all conditions, set up by C code. */
1720 if (EQ (handlers
, Qt
))
1723 /* error is used similarly, but means print an error message
1724 and run the debugger if that is enabled. */
1725 if (EQ (handlers
, Qerror
))
1728 for (h
= handlers
; CONSP (h
); h
= XCDR (h
))
1730 Lisp_Object handler
= XCAR (h
);
1731 Lisp_Object condit
, tem
;
1733 if (!CONSP (handler
))
1735 condit
= XCAR (handler
);
1736 /* Handle a single condition name in handler HANDLER. */
1737 if (SYMBOLP (condit
))
1739 tem
= Fmemq (Fcar (handler
), conditions
);
1743 /* Handle a list of condition names in handler HANDLER. */
1744 else if (CONSP (condit
))
1747 for (tail
= condit
; CONSP (tail
); tail
= XCDR (tail
))
1749 tem
= Fmemq (XCAR (tail
), conditions
);
1760 /* Dump an error message; called like vprintf. */
1762 verror (const char *m
, va_list ap
)
1765 ptrdiff_t size
= sizeof buf
;
1766 ptrdiff_t size_max
= STRING_BYTES_BOUND
+ 1;
1771 used
= evxprintf (&buffer
, &size
, buf
, size_max
, m
, ap
);
1772 string
= make_string (buffer
, used
);
1776 xsignal1 (Qerror
, string
);
1780 /* Dump an error message; called like printf. */
1784 error (const char *m
, ...)
1791 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
1792 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
1793 This means it contains a description for how to read arguments to give it.
1794 The value is nil for an invalid function or a symbol with no function
1797 Interactively callable functions include strings and vectors (treated
1798 as keyboard macros), lambda-expressions that contain a top-level call
1799 to `interactive', autoload definitions made by `autoload' with non-nil
1800 fourth argument, and some of the built-in functions of Lisp.
1802 Also, a symbol satisfies `commandp' if its function definition does so.
1804 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
1805 then strings and vectors are not accepted. */)
1806 (Lisp_Object function
, Lisp_Object for_call_interactively
)
1808 register Lisp_Object fun
;
1809 register Lisp_Object funcar
;
1810 Lisp_Object if_prop
= Qnil
;
1814 fun
= indirect_function (fun
); /* Check cycles. */
1818 /* Check an `interactive-form' property if present, analogous to the
1819 function-documentation property. */
1821 while (SYMBOLP (fun
))
1823 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
1826 fun
= Fsymbol_function (fun
);
1829 /* Emacs primitives are interactive if their DEFUN specifies an
1830 interactive spec. */
1832 return XSUBR (fun
)->intspec
? Qt
: if_prop
;
1834 /* Bytecode objects are interactive if they are long enough to
1835 have an element whose index is COMPILED_INTERACTIVE, which is
1836 where the interactive spec is stored. */
1837 else if (COMPILEDP (fun
))
1838 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
1841 /* Strings and vectors are keyboard macros. */
1842 if (STRINGP (fun
) || VECTORP (fun
))
1843 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
1845 /* Lists may represent commands. */
1848 funcar
= XCAR (fun
);
1849 if (EQ (funcar
, Qclosure
))
1850 return (!NILP (Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
)))))
1852 else if (EQ (funcar
, Qlambda
))
1853 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
1854 else if (EQ (funcar
, Qautoload
))
1855 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
1860 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1861 doc
: /* Define FUNCTION to autoload from FILE.
1862 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
1863 Third arg DOCSTRING is documentation for the function.
1864 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
1865 Fifth arg TYPE indicates the type of the object:
1866 nil or omitted says FUNCTION is a function,
1867 `keymap' says FUNCTION is really a keymap, and
1868 `macro' or t says FUNCTION is really a macro.
1869 Third through fifth args give info about the real definition.
1870 They default to nil.
1871 If FUNCTION is already defined other than as an autoload,
1872 this does nothing and returns nil. */)
1873 (Lisp_Object function
, Lisp_Object file
, Lisp_Object docstring
, Lisp_Object interactive
, Lisp_Object type
)
1875 CHECK_SYMBOL (function
);
1876 CHECK_STRING (file
);
1878 /* If function is defined and not as an autoload, don't override. */
1879 if (!NILP (XSYMBOL (function
)->function
)
1880 && !AUTOLOADP (XSYMBOL (function
)->function
))
1883 if (!NILP (Vpurify_flag
) && EQ (docstring
, make_number (0)))
1884 /* `read1' in lread.c has found the docstring starting with "\
1885 and assumed the docstring will be provided by Snarf-documentation, so it
1886 passed us 0 instead. But that leads to accidental sharing in purecopy's
1887 hash-consing, so we use a (hopefully) unique integer instead. */
1888 docstring
= make_number (XHASH (function
));
1889 return Fdefalias (function
,
1890 list5 (Qautoload
, file
, docstring
, interactive
, type
),
1895 un_autoload (Lisp_Object oldqueue
)
1897 Lisp_Object queue
, first
, second
;
1899 /* Queue to unwind is current value of Vautoload_queue.
1900 oldqueue is the shadowed value to leave in Vautoload_queue. */
1901 queue
= Vautoload_queue
;
1902 Vautoload_queue
= oldqueue
;
1903 while (CONSP (queue
))
1905 first
= XCAR (queue
);
1906 second
= Fcdr (first
);
1907 first
= Fcar (first
);
1908 if (EQ (first
, make_number (0)))
1911 Ffset (first
, second
);
1912 queue
= XCDR (queue
);
1916 /* Load an autoloaded function.
1917 FUNNAME is the symbol which is the function's name.
1918 FUNDEF is the autoload definition (a list). */
1920 DEFUN ("autoload-do-load", Fautoload_do_load
, Sautoload_do_load
, 1, 3, 0,
1921 doc
: /* Load FUNDEF which should be an autoload.
1922 If non-nil, FUNNAME should be the symbol whose function value is FUNDEF,
1923 in which case the function returns the new autoloaded function value.
1924 If equal to `macro', MACRO-ONLY specifies that FUNDEF should only be loaded if
1925 it is defines a macro. */)
1926 (Lisp_Object fundef
, Lisp_Object funname
, Lisp_Object macro_only
)
1928 ptrdiff_t count
= SPECPDL_INDEX ();
1929 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1931 if (!CONSP (fundef
) || !EQ (Qautoload
, XCAR (fundef
)))
1934 if (EQ (macro_only
, Qmacro
))
1936 Lisp_Object kind
= Fnth (make_number (4), fundef
);
1937 if (! (EQ (kind
, Qt
) || EQ (kind
, Qmacro
)))
1941 /* This is to make sure that loadup.el gives a clear picture
1942 of what files are preloaded and when. */
1943 if (! NILP (Vpurify_flag
))
1944 error ("Attempt to autoload %s while preparing to dump",
1945 SDATA (SYMBOL_NAME (funname
)));
1947 CHECK_SYMBOL (funname
);
1948 GCPRO3 (funname
, fundef
, macro_only
);
1950 /* Preserve the match data. */
1951 record_unwind_save_match_data ();
1953 /* If autoloading gets an error (which includes the error of failing
1954 to define the function being called), we use Vautoload_queue
1955 to undo function definitions and `provide' calls made by
1956 the function. We do this in the specific case of autoloading
1957 because autoloading is not an explicit request "load this file",
1958 but rather a request to "call this function".
1960 The value saved here is to be restored into Vautoload_queue. */
1961 record_unwind_protect (un_autoload
, Vautoload_queue
);
1962 Vautoload_queue
= Qt
;
1963 /* If `macro_only', assume this autoload to be a "best-effort",
1964 so don't signal an error if autoloading fails. */
1965 Fload (Fcar (Fcdr (fundef
)), macro_only
, Qt
, Qnil
, Qt
);
1967 /* Once loading finishes, don't undo it. */
1968 Vautoload_queue
= Qt
;
1969 unbind_to (count
, Qnil
);
1977 Lisp_Object fun
= Findirect_function (funname
, Qnil
);
1979 if (!NILP (Fequal (fun
, fundef
)))
1980 error ("Autoloading failed to define function %s",
1981 SDATA (SYMBOL_NAME (funname
)));
1988 DEFUN ("eval", Feval
, Seval
, 1, 2, 0,
1989 doc
: /* Evaluate FORM and return its value.
1990 If LEXICAL is t, evaluate using lexical scoping. */)
1991 (Lisp_Object form
, Lisp_Object lexical
)
1993 ptrdiff_t count
= SPECPDL_INDEX ();
1994 specbind (Qinternal_interpreter_environment
,
1995 CONSP (lexical
) || NILP (lexical
) ? lexical
: list1 (Qt
));
1996 return unbind_to (count
, eval_sub (form
));
1999 /* Grow the specpdl stack by one entry.
2000 The caller should have already initialized the entry.
2001 Signal an error on stack overflow.
2003 Make sure that there is always one unused entry past the top of the
2004 stack, so that the just-initialized entry is safely unwound if
2005 memory exhausted and an error is signaled here. Also, allocate a
2006 never-used entry just before the bottom of the stack; sometimes its
2007 address is taken. */
2014 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2016 ptrdiff_t count
= SPECPDL_INDEX ();
2017 ptrdiff_t max_size
= min (max_specpdl_size
, PTRDIFF_MAX
- 1000);
2018 union specbinding
*pdlvec
= specpdl
- 1;
2019 ptrdiff_t pdlvecsize
= specpdl_size
+ 1;
2020 if (max_size
<= specpdl_size
)
2022 if (max_specpdl_size
< 400)
2023 max_size
= max_specpdl_size
= 400;
2024 if (max_size
<= specpdl_size
)
2025 signal_error ("Variable binding depth exceeds max-specpdl-size",
2028 pdlvec
= xpalloc (pdlvec
, &pdlvecsize
, 1, max_size
+ 1, sizeof *specpdl
);
2029 specpdl
= pdlvec
+ 1;
2030 specpdl_size
= pdlvecsize
- 1;
2031 specpdl_ptr
= specpdl
+ count
;
2036 record_in_backtrace (Lisp_Object function
, Lisp_Object
*args
, ptrdiff_t nargs
)
2038 eassert (nargs
>= UNEVALLED
);
2039 specpdl_ptr
->bt
.kind
= SPECPDL_BACKTRACE
;
2040 specpdl_ptr
->bt
.debug_on_exit
= false;
2041 specpdl_ptr
->bt
.function
= function
;
2042 specpdl_ptr
->bt
.args
= args
;
2043 specpdl_ptr
->bt
.nargs
= nargs
;
2047 /* Eval a sub-expression of the current expression (i.e. in the same
2050 eval_sub (Lisp_Object form
)
2052 Lisp_Object fun
, val
, original_fun
, original_args
;
2054 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2058 /* Look up its binding in the lexical environment.
2059 We do not pay attention to the declared_special flag here, since we
2060 already did that when let-binding the variable. */
2061 Lisp_Object lex_binding
2062 = !NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
2063 ? Fassq (form
, Vinternal_interpreter_environment
)
2065 if (CONSP (lex_binding
))
2066 return XCDR (lex_binding
);
2068 return Fsymbol_value (form
);
2080 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2082 if (max_lisp_eval_depth
< 100)
2083 max_lisp_eval_depth
= 100;
2084 if (lisp_eval_depth
> max_lisp_eval_depth
)
2085 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2088 original_fun
= XCAR (form
);
2089 original_args
= XCDR (form
);
2091 /* This also protects them from gc. */
2092 record_in_backtrace (original_fun
, &original_args
, UNEVALLED
);
2094 if (debug_on_next_call
)
2095 do_debug_on_call (Qt
);
2097 /* At this point, only original_fun and original_args
2098 have values that will be used below. */
2101 /* Optimize for no indirection. */
2103 if (SYMBOLP (fun
) && !NILP (fun
)
2104 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2105 fun
= indirect_function (fun
);
2109 Lisp_Object numargs
;
2110 Lisp_Object argvals
[8];
2111 Lisp_Object args_left
;
2112 register int i
, maxargs
;
2114 args_left
= original_args
;
2115 numargs
= Flength (args_left
);
2119 if (XINT (numargs
) < XSUBR (fun
)->min_args
2120 || (XSUBR (fun
)->max_args
>= 0
2121 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2122 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2124 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2125 val
= (XSUBR (fun
)->function
.aUNEVALLED
) (args_left
);
2126 else if (XSUBR (fun
)->max_args
== MANY
)
2128 /* Pass a vector of evaluated arguments. */
2130 ptrdiff_t argnum
= 0;
2133 SAFE_ALLOCA_LISP (vals
, XINT (numargs
));
2135 GCPRO3 (args_left
, fun
, fun
);
2139 while (!NILP (args_left
))
2141 vals
[argnum
++] = eval_sub (Fcar (args_left
));
2142 args_left
= Fcdr (args_left
);
2143 gcpro3
.nvars
= argnum
;
2146 set_backtrace_args (specpdl_ptr
- 1, vals
);
2147 set_backtrace_nargs (specpdl_ptr
- 1, XINT (numargs
));
2149 val
= (XSUBR (fun
)->function
.aMANY
) (XINT (numargs
), vals
);
2155 GCPRO3 (args_left
, fun
, fun
);
2156 gcpro3
.var
= argvals
;
2159 maxargs
= XSUBR (fun
)->max_args
;
2160 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
2162 argvals
[i
] = eval_sub (Fcar (args_left
));
2168 set_backtrace_args (specpdl_ptr
- 1, argvals
);
2169 set_backtrace_nargs (specpdl_ptr
- 1, XINT (numargs
));
2174 val
= (XSUBR (fun
)->function
.a0 ());
2177 val
= (XSUBR (fun
)->function
.a1 (argvals
[0]));
2180 val
= (XSUBR (fun
)->function
.a2 (argvals
[0], argvals
[1]));
2183 val
= (XSUBR (fun
)->function
.a3
2184 (argvals
[0], argvals
[1], argvals
[2]));
2187 val
= (XSUBR (fun
)->function
.a4
2188 (argvals
[0], argvals
[1], argvals
[2], argvals
[3]));
2191 val
= (XSUBR (fun
)->function
.a5
2192 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2196 val
= (XSUBR (fun
)->function
.a6
2197 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2198 argvals
[4], argvals
[5]));
2201 val
= (XSUBR (fun
)->function
.a7
2202 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2203 argvals
[4], argvals
[5], argvals
[6]));
2207 val
= (XSUBR (fun
)->function
.a8
2208 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2209 argvals
[4], argvals
[5], argvals
[6], argvals
[7]));
2213 /* Someone has created a subr that takes more arguments than
2214 is supported by this code. We need to either rewrite the
2215 subr to use a different argument protocol, or add more
2216 cases to this switch. */
2221 else if (COMPILEDP (fun
))
2222 val
= apply_lambda (fun
, original_args
);
2226 xsignal1 (Qvoid_function
, original_fun
);
2228 xsignal1 (Qinvalid_function
, original_fun
);
2229 funcar
= XCAR (fun
);
2230 if (!SYMBOLP (funcar
))
2231 xsignal1 (Qinvalid_function
, original_fun
);
2232 if (EQ (funcar
, Qautoload
))
2234 Fautoload_do_load (fun
, original_fun
, Qnil
);
2237 if (EQ (funcar
, Qmacro
))
2239 ptrdiff_t count
= SPECPDL_INDEX ();
2241 /* Bind lexical-binding during expansion of the macro, so the
2242 macro can know reliably if the code it outputs will be
2243 interpreted using lexical-binding or not. */
2244 specbind (Qlexical_binding
,
2245 NILP (Vinternal_interpreter_environment
) ? Qnil
: Qt
);
2246 exp
= apply1 (Fcdr (fun
), original_args
);
2247 unbind_to (count
, Qnil
);
2248 val
= eval_sub (exp
);
2250 else if (EQ (funcar
, Qlambda
)
2251 || EQ (funcar
, Qclosure
))
2252 val
= apply_lambda (fun
, original_args
);
2254 xsignal1 (Qinvalid_function
, original_fun
);
2259 if (backtrace_debug_on_exit (specpdl_ptr
- 1))
2260 val
= call_debugger (list2 (Qexit
, val
));
2266 DEFUN ("apply", Fapply
, Sapply
, 1, MANY
, 0,
2267 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2268 Then return the value FUNCTION returns.
2269 Thus, (apply '+ 1 2 '(3 4)) returns 10.
2270 usage: (apply FUNCTION &rest ARGUMENTS) */)
2271 (ptrdiff_t nargs
, Lisp_Object
*args
)
2275 register Lisp_Object spread_arg
;
2276 register Lisp_Object
*funcall_args
;
2277 Lisp_Object fun
, retval
;
2278 struct gcpro gcpro1
;
2283 spread_arg
= args
[nargs
- 1];
2284 CHECK_LIST (spread_arg
);
2286 numargs
= XINT (Flength (spread_arg
));
2289 return Ffuncall (nargs
- 1, args
);
2290 else if (numargs
== 1)
2292 args
[nargs
- 1] = XCAR (spread_arg
);
2293 return Ffuncall (nargs
, args
);
2296 numargs
+= nargs
- 2;
2298 /* Optimize for no indirection. */
2299 if (SYMBOLP (fun
) && !NILP (fun
)
2300 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2301 fun
= indirect_function (fun
);
2304 /* Let funcall get the error. */
2311 if (numargs
< XSUBR (fun
)->min_args
2312 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2313 goto funcall
; /* Let funcall get the error. */
2314 else if (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
> numargs
)
2316 /* Avoid making funcall cons up a yet another new vector of arguments
2317 by explicitly supplying nil's for optional values. */
2318 SAFE_ALLOCA_LISP (funcall_args
, 1 + XSUBR (fun
)->max_args
);
2319 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2320 funcall_args
[++i
] = Qnil
;
2321 GCPRO1 (*funcall_args
);
2322 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2326 /* We add 1 to numargs because funcall_args includes the
2327 function itself as well as its arguments. */
2330 SAFE_ALLOCA_LISP (funcall_args
, 1 + numargs
);
2331 GCPRO1 (*funcall_args
);
2332 gcpro1
.nvars
= 1 + numargs
;
2335 memcpy (funcall_args
, args
, nargs
* word_size
);
2336 /* Spread the last arg we got. Its first element goes in
2337 the slot that it used to occupy, hence this value of I. */
2339 while (!NILP (spread_arg
))
2341 funcall_args
[i
++] = XCAR (spread_arg
);
2342 spread_arg
= XCDR (spread_arg
);
2345 /* By convention, the caller needs to gcpro Ffuncall's args. */
2346 retval
= Ffuncall (gcpro1
.nvars
, funcall_args
);
2353 /* Run hook variables in various ways. */
2356 funcall_nil (ptrdiff_t nargs
, Lisp_Object
*args
)
2358 Ffuncall (nargs
, args
);
2362 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2363 doc
: /* Run each hook in HOOKS.
2364 Each argument should be a symbol, a hook variable.
2365 These symbols are processed in the order specified.
2366 If a hook symbol has a non-nil value, that value may be a function
2367 or a list of functions to be called to run the hook.
2368 If the value is a function, it is called with no arguments.
2369 If it is a list, the elements are called, in order, with no arguments.
2371 Major modes should not use this function directly to run their mode
2372 hook; they should use `run-mode-hooks' instead.
2374 Do not use `make-local-variable' to make a hook variable buffer-local.
2375 Instead, use `add-hook' and specify t for the LOCAL argument.
2376 usage: (run-hooks &rest HOOKS) */)
2377 (ptrdiff_t nargs
, Lisp_Object
*args
)
2379 Lisp_Object hook
[1];
2382 for (i
= 0; i
< nargs
; i
++)
2385 run_hook_with_args (1, hook
, funcall_nil
);
2391 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2392 Srun_hook_with_args
, 1, MANY
, 0,
2393 doc
: /* Run HOOK with the specified arguments ARGS.
2394 HOOK should be a symbol, a hook variable. The value of HOOK
2395 may be nil, a function, or a list of functions. Call each
2396 function in order with arguments ARGS. The final return value
2399 Do not use `make-local-variable' to make a hook variable buffer-local.
2400 Instead, use `add-hook' and specify t for the LOCAL argument.
2401 usage: (run-hook-with-args HOOK &rest ARGS) */)
2402 (ptrdiff_t nargs
, Lisp_Object
*args
)
2404 return run_hook_with_args (nargs
, args
, funcall_nil
);
2407 /* NB this one still documents a specific non-nil return value.
2408 (As did run-hook-with-args and run-hook-with-args-until-failure
2409 until they were changed in 24.1.) */
2410 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2411 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2412 doc
: /* Run HOOK with the specified arguments ARGS.
2413 HOOK should be a symbol, a hook variable. The value of HOOK
2414 may be nil, a function, or a list of functions. Call each
2415 function in order with arguments ARGS, stopping at the first
2416 one that returns non-nil, and return that value. Otherwise (if
2417 all functions return nil, or if there are no functions to call),
2420 Do not use `make-local-variable' to make a hook variable buffer-local.
2421 Instead, use `add-hook' and specify t for the LOCAL argument.
2422 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2423 (ptrdiff_t nargs
, Lisp_Object
*args
)
2425 return run_hook_with_args (nargs
, args
, Ffuncall
);
2429 funcall_not (ptrdiff_t nargs
, Lisp_Object
*args
)
2431 return NILP (Ffuncall (nargs
, args
)) ? Qt
: Qnil
;
2434 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2435 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2436 doc
: /* Run HOOK with the specified arguments ARGS.
2437 HOOK should be a symbol, a hook variable. The value of HOOK
2438 may be nil, a function, or a list of functions. Call each
2439 function in order with arguments ARGS, stopping at the first
2440 one that returns nil, and return nil. Otherwise (if all functions
2441 return non-nil, or if there are no functions to call), return non-nil
2442 \(do not rely on the precise return value in this case).
2444 Do not use `make-local-variable' to make a hook variable buffer-local.
2445 Instead, use `add-hook' and specify t for the LOCAL argument.
2446 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2447 (ptrdiff_t nargs
, Lisp_Object
*args
)
2449 return NILP (run_hook_with_args (nargs
, args
, funcall_not
)) ? Qt
: Qnil
;
2453 run_hook_wrapped_funcall (ptrdiff_t nargs
, Lisp_Object
*args
)
2455 Lisp_Object tmp
= args
[0], ret
;
2458 ret
= Ffuncall (nargs
, args
);
2464 DEFUN ("run-hook-wrapped", Frun_hook_wrapped
, Srun_hook_wrapped
, 2, MANY
, 0,
2465 doc
: /* Run HOOK, passing each function through WRAP-FUNCTION.
2466 I.e. instead of calling each function FUN directly with arguments ARGS,
2467 it calls WRAP-FUNCTION with arguments FUN and ARGS.
2468 As soon as a call to WRAP-FUNCTION returns non-nil, `run-hook-wrapped'
2469 aborts and returns that value.
2470 usage: (run-hook-wrapped HOOK WRAP-FUNCTION &rest ARGS) */)
2471 (ptrdiff_t nargs
, Lisp_Object
*args
)
2473 return run_hook_with_args (nargs
, args
, run_hook_wrapped_funcall
);
2476 /* ARGS[0] should be a hook symbol.
2477 Call each of the functions in the hook value, passing each of them
2478 as arguments all the rest of ARGS (all NARGS - 1 elements).
2479 FUNCALL specifies how to call each function on the hook.
2480 The caller (or its caller, etc) must gcpro all of ARGS,
2481 except that it isn't necessary to gcpro ARGS[0]. */
2484 run_hook_with_args (ptrdiff_t nargs
, Lisp_Object
*args
,
2485 Lisp_Object (*funcall
) (ptrdiff_t nargs
, Lisp_Object
*args
))
2487 Lisp_Object sym
, val
, ret
= Qnil
;
2488 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2490 /* If we are dying or still initializing,
2491 don't do anything--it would probably crash if we tried. */
2492 if (NILP (Vrun_hooks
))
2496 val
= find_symbol_value (sym
);
2498 if (EQ (val
, Qunbound
) || NILP (val
))
2500 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2503 return funcall (nargs
, args
);
2507 Lisp_Object global_vals
= Qnil
;
2508 GCPRO3 (sym
, val
, global_vals
);
2511 CONSP (val
) && NILP (ret
);
2514 if (EQ (XCAR (val
), Qt
))
2516 /* t indicates this hook has a local binding;
2517 it means to run the global binding too. */
2518 global_vals
= Fdefault_value (sym
);
2519 if (NILP (global_vals
)) continue;
2521 if (!CONSP (global_vals
) || EQ (XCAR (global_vals
), Qlambda
))
2523 args
[0] = global_vals
;
2524 ret
= funcall (nargs
, args
);
2529 CONSP (global_vals
) && NILP (ret
);
2530 global_vals
= XCDR (global_vals
))
2532 args
[0] = XCAR (global_vals
);
2533 /* In a global value, t should not occur. If it does, we
2534 must ignore it to avoid an endless loop. */
2535 if (!EQ (args
[0], Qt
))
2536 ret
= funcall (nargs
, args
);
2542 args
[0] = XCAR (val
);
2543 ret
= funcall (nargs
, args
);
2552 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2555 run_hook_with_args_2 (Lisp_Object hook
, Lisp_Object arg1
, Lisp_Object arg2
)
2557 Lisp_Object temp
[3];
2562 Frun_hook_with_args (3, temp
);
2565 /* Apply fn to arg. */
2567 apply1 (Lisp_Object fn
, Lisp_Object arg
)
2569 struct gcpro gcpro1
;
2573 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2576 Lisp_Object args
[2];
2580 RETURN_UNGCPRO (Fapply (2, args
));
2584 /* Call function fn on no arguments. */
2586 call0 (Lisp_Object fn
)
2588 struct gcpro gcpro1
;
2591 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2594 /* Call function fn with 1 argument arg1. */
2597 call1 (Lisp_Object fn
, Lisp_Object arg1
)
2599 struct gcpro gcpro1
;
2600 Lisp_Object args
[2];
2606 RETURN_UNGCPRO (Ffuncall (2, args
));
2609 /* Call function fn with 2 arguments arg1, arg2. */
2612 call2 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
)
2614 struct gcpro gcpro1
;
2615 Lisp_Object args
[3];
2621 RETURN_UNGCPRO (Ffuncall (3, args
));
2624 /* Call function fn with 3 arguments arg1, arg2, arg3. */
2627 call3 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2629 struct gcpro gcpro1
;
2630 Lisp_Object args
[4];
2637 RETURN_UNGCPRO (Ffuncall (4, args
));
2640 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
2643 call4 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2646 struct gcpro gcpro1
;
2647 Lisp_Object args
[5];
2655 RETURN_UNGCPRO (Ffuncall (5, args
));
2658 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
2661 call5 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2662 Lisp_Object arg4
, Lisp_Object arg5
)
2664 struct gcpro gcpro1
;
2665 Lisp_Object args
[6];
2674 RETURN_UNGCPRO (Ffuncall (6, args
));
2677 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
2680 call6 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2681 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
)
2683 struct gcpro gcpro1
;
2684 Lisp_Object args
[7];
2694 RETURN_UNGCPRO (Ffuncall (7, args
));
2697 /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
2700 call7 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2701 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
)
2703 struct gcpro gcpro1
;
2704 Lisp_Object args
[8];
2715 RETURN_UNGCPRO (Ffuncall (8, args
));
2718 /* The caller should GCPRO all the elements of ARGS. */
2720 DEFUN ("functionp", Ffunctionp
, Sfunctionp
, 1, 1, 0,
2721 doc
: /* Non-nil if OBJECT is a function. */)
2722 (Lisp_Object object
)
2724 if (FUNCTIONP (object
))
2729 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2730 doc
: /* Call first argument as a function, passing remaining arguments to it.
2731 Return the value that function returns.
2732 Thus, (funcall 'cons 'x 'y) returns (x . y).
2733 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2734 (ptrdiff_t nargs
, Lisp_Object
*args
)
2736 Lisp_Object fun
, original_fun
;
2738 ptrdiff_t numargs
= nargs
- 1;
2739 Lisp_Object lisp_numargs
;
2741 register Lisp_Object
*internal_args
;
2746 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2748 if (max_lisp_eval_depth
< 100)
2749 max_lisp_eval_depth
= 100;
2750 if (lisp_eval_depth
> max_lisp_eval_depth
)
2751 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2754 /* This also GCPROs them. */
2755 record_in_backtrace (args
[0], &args
[1], nargs
- 1);
2757 /* Call GC after setting up the backtrace, so the latter GCPROs the args. */
2760 if (debug_on_next_call
)
2761 do_debug_on_call (Qlambda
);
2765 original_fun
= args
[0];
2769 /* Optimize for no indirection. */
2771 if (SYMBOLP (fun
) && !NILP (fun
)
2772 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2773 fun
= indirect_function (fun
);
2777 if (numargs
< XSUBR (fun
)->min_args
2778 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2780 XSETFASTINT (lisp_numargs
, numargs
);
2781 xsignal2 (Qwrong_number_of_arguments
, original_fun
, lisp_numargs
);
2784 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2785 xsignal1 (Qinvalid_function
, original_fun
);
2787 else if (XSUBR (fun
)->max_args
== MANY
)
2788 val
= (XSUBR (fun
)->function
.aMANY
) (numargs
, args
+ 1);
2791 if (XSUBR (fun
)->max_args
> numargs
)
2793 internal_args
= alloca (XSUBR (fun
)->max_args
2794 * sizeof *internal_args
);
2795 memcpy (internal_args
, args
+ 1, numargs
* word_size
);
2796 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2797 internal_args
[i
] = Qnil
;
2800 internal_args
= args
+ 1;
2801 switch (XSUBR (fun
)->max_args
)
2804 val
= (XSUBR (fun
)->function
.a0 ());
2807 val
= (XSUBR (fun
)->function
.a1 (internal_args
[0]));
2810 val
= (XSUBR (fun
)->function
.a2
2811 (internal_args
[0], internal_args
[1]));
2814 val
= (XSUBR (fun
)->function
.a3
2815 (internal_args
[0], internal_args
[1], internal_args
[2]));
2818 val
= (XSUBR (fun
)->function
.a4
2819 (internal_args
[0], internal_args
[1], internal_args
[2],
2823 val
= (XSUBR (fun
)->function
.a5
2824 (internal_args
[0], internal_args
[1], internal_args
[2],
2825 internal_args
[3], internal_args
[4]));
2828 val
= (XSUBR (fun
)->function
.a6
2829 (internal_args
[0], internal_args
[1], internal_args
[2],
2830 internal_args
[3], internal_args
[4], internal_args
[5]));
2833 val
= (XSUBR (fun
)->function
.a7
2834 (internal_args
[0], internal_args
[1], internal_args
[2],
2835 internal_args
[3], internal_args
[4], internal_args
[5],
2840 val
= (XSUBR (fun
)->function
.a8
2841 (internal_args
[0], internal_args
[1], internal_args
[2],
2842 internal_args
[3], internal_args
[4], internal_args
[5],
2843 internal_args
[6], internal_args
[7]));
2848 /* If a subr takes more than 8 arguments without using MANY
2849 or UNEVALLED, we need to extend this function to support it.
2850 Until this is done, there is no way to call the function. */
2855 else if (COMPILEDP (fun
))
2856 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2860 xsignal1 (Qvoid_function
, original_fun
);
2862 xsignal1 (Qinvalid_function
, original_fun
);
2863 funcar
= XCAR (fun
);
2864 if (!SYMBOLP (funcar
))
2865 xsignal1 (Qinvalid_function
, original_fun
);
2866 if (EQ (funcar
, Qlambda
)
2867 || EQ (funcar
, Qclosure
))
2868 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2869 else if (EQ (funcar
, Qautoload
))
2871 Fautoload_do_load (fun
, original_fun
, Qnil
);
2876 xsignal1 (Qinvalid_function
, original_fun
);
2880 if (backtrace_debug_on_exit (specpdl_ptr
- 1))
2881 val
= call_debugger (list2 (Qexit
, val
));
2887 apply_lambda (Lisp_Object fun
, Lisp_Object args
)
2889 Lisp_Object args_left
;
2892 register Lisp_Object
*arg_vector
;
2893 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2894 register Lisp_Object tem
;
2897 numargs
= XFASTINT (Flength (args
));
2898 SAFE_ALLOCA_LISP (arg_vector
, numargs
);
2901 GCPRO3 (*arg_vector
, args_left
, fun
);
2904 for (i
= 0; i
< numargs
; )
2906 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2907 tem
= eval_sub (tem
);
2908 arg_vector
[i
++] = tem
;
2914 set_backtrace_args (specpdl_ptr
- 1, arg_vector
);
2915 set_backtrace_nargs (specpdl_ptr
- 1, i
);
2916 tem
= funcall_lambda (fun
, numargs
, arg_vector
);
2918 /* Do the debug-on-exit now, while arg_vector still exists. */
2919 if (backtrace_debug_on_exit (specpdl_ptr
- 1))
2921 /* Don't do it again when we return to eval. */
2922 set_backtrace_debug_on_exit (specpdl_ptr
- 1, false);
2923 tem
= call_debugger (list2 (Qexit
, tem
));
2929 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2930 and return the result of evaluation.
2931 FUN must be either a lambda-expression or a compiled-code object. */
2934 funcall_lambda (Lisp_Object fun
, ptrdiff_t nargs
,
2935 register Lisp_Object
*arg_vector
)
2937 Lisp_Object val
, syms_left
, next
, lexenv
;
2938 ptrdiff_t count
= SPECPDL_INDEX ();
2940 bool optional
, rest
;
2944 if (EQ (XCAR (fun
), Qclosure
))
2946 fun
= XCDR (fun
); /* Drop `closure'. */
2947 lexenv
= XCAR (fun
);
2948 CHECK_LIST_CONS (fun
, fun
);
2952 syms_left
= XCDR (fun
);
2953 if (CONSP (syms_left
))
2954 syms_left
= XCAR (syms_left
);
2956 xsignal1 (Qinvalid_function
, fun
);
2958 else if (COMPILEDP (fun
))
2960 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
2961 if (INTEGERP (syms_left
))
2962 /* A byte-code object with a non-nil `push args' slot means we
2963 shouldn't bind any arguments, instead just call the byte-code
2964 interpreter directly; it will push arguments as necessary.
2966 Byte-code objects with either a non-existent, or a nil value for
2967 the `push args' slot (the default), have dynamically-bound
2968 arguments, and use the argument-binding code below instead (as do
2969 all interpreted functions, even lexically bound ones). */
2971 /* If we have not actually read the bytecode string
2972 and constants vector yet, fetch them from the file. */
2973 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
2974 Ffetch_bytecode (fun
);
2975 return exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
2976 AREF (fun
, COMPILED_CONSTANTS
),
2977 AREF (fun
, COMPILED_STACK_DEPTH
),
2986 i
= optional
= rest
= 0;
2987 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
2991 next
= XCAR (syms_left
);
2992 if (!SYMBOLP (next
))
2993 xsignal1 (Qinvalid_function
, fun
);
2995 if (EQ (next
, Qand_rest
))
2997 else if (EQ (next
, Qand_optional
))
3004 arg
= Flist (nargs
- i
, &arg_vector
[i
]);
3008 arg
= arg_vector
[i
++];
3010 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3014 /* Bind the argument. */
3015 if (!NILP (lexenv
) && SYMBOLP (next
))
3016 /* Lexically bind NEXT by adding it to the lexenv alist. */
3017 lexenv
= Fcons (Fcons (next
, arg
), lexenv
);
3019 /* Dynamically bind NEXT. */
3020 specbind (next
, arg
);
3024 if (!NILP (syms_left
))
3025 xsignal1 (Qinvalid_function
, fun
);
3027 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3029 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
3030 /* Instantiate a new lexical environment. */
3031 specbind (Qinternal_interpreter_environment
, lexenv
);
3034 val
= Fprogn (XCDR (XCDR (fun
)));
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 val
= exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
3042 AREF (fun
, COMPILED_CONSTANTS
),
3043 AREF (fun
, COMPILED_STACK_DEPTH
),
3047 return unbind_to (count
, val
);
3050 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3052 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3053 (Lisp_Object object
)
3057 if (COMPILEDP (object
) && CONSP (AREF (object
, COMPILED_BYTECODE
)))
3059 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3062 tem
= AREF (object
, COMPILED_BYTECODE
);
3063 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3064 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3066 error ("Invalid byte code");
3068 ASET (object
, COMPILED_BYTECODE
, XCAR (tem
));
3069 ASET (object
, COMPILED_CONSTANTS
, XCDR (tem
));
3074 /* Return true if SYMBOL currently has a let-binding
3075 which was made in the buffer that is now current. */
3078 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
3080 union specbinding
*p
;
3081 Lisp_Object buf
= Fcurrent_buffer ();
3083 for (p
= specpdl_ptr
; p
> specpdl
; )
3084 if ((--p
)->kind
> SPECPDL_LET
)
3086 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (specpdl_symbol (p
));
3087 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
3088 if (symbol
== let_bound_symbol
3089 && EQ (specpdl_where (p
), buf
))
3097 let_shadows_global_binding_p (Lisp_Object symbol
)
3099 union specbinding
*p
;
3101 for (p
= specpdl_ptr
; p
> specpdl
; )
3102 if ((--p
)->kind
>= SPECPDL_LET
&& EQ (specpdl_symbol (p
), symbol
))
3108 /* `specpdl_ptr->symbol' is a field which describes which variable is
3109 let-bound, so it can be properly undone when we unbind_to.
3110 It can have the following two shapes:
3111 - SYMBOL : if it's a plain symbol, it means that we have let-bound
3112 a symbol that is not buffer-local (at least at the time
3113 the let binding started). Note also that it should not be
3114 aliased (i.e. when let-binding V1 that's aliased to V2, we want
3116 - (SYMBOL WHERE . BUFFER) : this means that it is a let-binding for
3117 variable SYMBOL which can be buffer-local. WHERE tells us
3118 which buffer is affected (or nil if the let-binding affects the
3119 global value of the variable) and BUFFER tells us which buffer was
3120 current (i.e. if WHERE is non-nil, then BUFFER==WHERE, otherwise
3121 BUFFER did not yet have a buffer-local value). */
3124 specbind (Lisp_Object symbol
, Lisp_Object value
)
3126 struct Lisp_Symbol
*sym
;
3128 CHECK_SYMBOL (symbol
);
3129 sym
= XSYMBOL (symbol
);
3132 switch (sym
->redirect
)
3134 case SYMBOL_VARALIAS
:
3135 sym
= indirect_variable (sym
); XSETSYMBOL (symbol
, sym
); goto start
;
3136 case SYMBOL_PLAINVAL
:
3137 /* The most common case is that of a non-constant symbol with a
3138 trivial value. Make that as fast as we can. */
3139 specpdl_ptr
->let
.kind
= SPECPDL_LET
;
3140 specpdl_ptr
->let
.symbol
= symbol
;
3141 specpdl_ptr
->let
.old_value
= SYMBOL_VAL (sym
);
3144 SET_SYMBOL_VAL (sym
, value
);
3146 set_internal (symbol
, value
, Qnil
, 1);
3148 case SYMBOL_LOCALIZED
:
3149 if (SYMBOL_BLV (sym
)->frame_local
)
3150 error ("Frame-local vars cannot be let-bound");
3151 case SYMBOL_FORWARDED
:
3153 Lisp_Object ovalue
= find_symbol_value (symbol
);
3154 specpdl_ptr
->let
.kind
= SPECPDL_LET_LOCAL
;
3155 specpdl_ptr
->let
.symbol
= symbol
;
3156 specpdl_ptr
->let
.old_value
= ovalue
;
3157 specpdl_ptr
->let
.where
= Fcurrent_buffer ();
3159 eassert (sym
->redirect
!= SYMBOL_LOCALIZED
3160 || (EQ (SYMBOL_BLV (sym
)->where
, Fcurrent_buffer ())));
3162 if (sym
->redirect
== SYMBOL_LOCALIZED
)
3164 if (!blv_found (SYMBOL_BLV (sym
)))
3165 specpdl_ptr
->let
.kind
= SPECPDL_LET_DEFAULT
;
3167 else if (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)))
3169 /* If SYMBOL is a per-buffer variable which doesn't have a
3170 buffer-local value here, make the `let' change the global
3171 value by changing the value of SYMBOL in all buffers not
3172 having their own value. This is consistent with what
3173 happens with other buffer-local variables. */
3174 if (NILP (Flocal_variable_p (symbol
, Qnil
)))
3176 specpdl_ptr
->let
.kind
= SPECPDL_LET_DEFAULT
;
3178 Fset_default (symbol
, value
);
3183 specpdl_ptr
->let
.kind
= SPECPDL_LET
;
3186 set_internal (symbol
, value
, Qnil
, 1);
3189 default: emacs_abort ();
3193 /* Push unwind-protect entries of various types. */
3196 record_unwind_protect (void (*function
) (Lisp_Object
), Lisp_Object arg
)
3198 specpdl_ptr
->unwind
.kind
= SPECPDL_UNWIND
;
3199 specpdl_ptr
->unwind
.func
= function
;
3200 specpdl_ptr
->unwind
.arg
= arg
;
3205 record_unwind_protect_ptr (void (*function
) (void *), void *arg
)
3207 specpdl_ptr
->unwind_ptr
.kind
= SPECPDL_UNWIND_PTR
;
3208 specpdl_ptr
->unwind_ptr
.func
= function
;
3209 specpdl_ptr
->unwind_ptr
.arg
= arg
;
3214 record_unwind_protect_int (void (*function
) (int), int arg
)
3216 specpdl_ptr
->unwind_int
.kind
= SPECPDL_UNWIND_INT
;
3217 specpdl_ptr
->unwind_int
.func
= function
;
3218 specpdl_ptr
->unwind_int
.arg
= arg
;
3223 record_unwind_protect_void (void (*function
) (void))
3225 specpdl_ptr
->unwind_void
.kind
= SPECPDL_UNWIND_VOID
;
3226 specpdl_ptr
->unwind_void
.func
= function
;
3234 /* Push an unwind-protect entry that does nothing, so that
3235 set_unwind_protect_ptr can overwrite it later. */
3238 record_unwind_protect_nothing (void)
3240 record_unwind_protect_void (do_nothing
);
3243 /* Clear the unwind-protect entry COUNT, so that it does nothing.
3244 It need not be at the top of the stack. */
3247 clear_unwind_protect (ptrdiff_t count
)
3249 union specbinding
*p
= specpdl
+ count
;
3250 p
->unwind_void
.kind
= SPECPDL_UNWIND_VOID
;
3251 p
->unwind_void
.func
= do_nothing
;
3254 /* Set the unwind-protect entry COUNT so that it invokes FUNC (ARG).
3255 It need not be at the top of the stack. Discard the entry's
3256 previous value without invoking it. */
3259 set_unwind_protect_ptr (ptrdiff_t count
, void (*func
) (void *), void *arg
)
3261 union specbinding
*p
= specpdl
+ count
;
3262 p
->unwind_ptr
.kind
= SPECPDL_UNWIND_PTR
;
3263 p
->unwind_ptr
.func
= func
;
3264 p
->unwind_ptr
.arg
= arg
;
3267 /* Pop and execute entries from the unwind-protect stack until the
3268 depth COUNT is reached. Return VALUE. */
3271 unbind_to (ptrdiff_t count
, Lisp_Object value
)
3273 Lisp_Object quitf
= Vquit_flag
;
3274 struct gcpro gcpro1
, gcpro2
;
3276 GCPRO2 (value
, quitf
);
3279 while (specpdl_ptr
!= specpdl
+ count
)
3281 /* Decrement specpdl_ptr before we do the work to unbind it, so
3282 that an error in unbinding won't try to unbind the same entry
3283 again. Take care to copy any parts of the binding needed
3284 before invoking any code that can make more bindings. */
3288 switch (specpdl_ptr
->kind
)
3290 case SPECPDL_UNWIND
:
3291 specpdl_ptr
->unwind
.func (specpdl_ptr
->unwind
.arg
);
3293 case SPECPDL_UNWIND_PTR
:
3294 specpdl_ptr
->unwind_ptr
.func (specpdl_ptr
->unwind_ptr
.arg
);
3296 case SPECPDL_UNWIND_INT
:
3297 specpdl_ptr
->unwind_int
.func (specpdl_ptr
->unwind_int
.arg
);
3299 case SPECPDL_UNWIND_VOID
:
3300 specpdl_ptr
->unwind_void
.func ();
3303 /* If variable has a trivial value (no forwarding), we can
3304 just set it. No need to check for constant symbols here,
3305 since that was already done by specbind. */
3306 if (XSYMBOL (specpdl_symbol (specpdl_ptr
))->redirect
3308 SET_SYMBOL_VAL (XSYMBOL (specpdl_symbol (specpdl_ptr
)),
3309 specpdl_old_value (specpdl_ptr
));
3311 /* NOTE: we only ever come here if make_local_foo was used for
3312 the first time on this var within this let. */
3313 Fset_default (specpdl_symbol (specpdl_ptr
),
3314 specpdl_old_value (specpdl_ptr
));
3316 case SPECPDL_BACKTRACE
:
3318 case SPECPDL_LET_LOCAL
:
3319 case SPECPDL_LET_DEFAULT
:
3320 { /* If the symbol is a list, it is really (SYMBOL WHERE
3321 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3322 frame. If WHERE is a buffer or frame, this indicates we
3323 bound a variable that had a buffer-local or frame-local
3324 binding. WHERE nil means that the variable had the default
3325 value when it was bound. CURRENT-BUFFER is the buffer that
3326 was current when the variable was bound. */
3327 Lisp_Object symbol
= specpdl_symbol (specpdl_ptr
);
3328 Lisp_Object where
= specpdl_where (specpdl_ptr
);
3329 Lisp_Object old_value
= specpdl_old_value (specpdl_ptr
);
3330 eassert (BUFFERP (where
));
3332 if (specpdl_ptr
->kind
== SPECPDL_LET_DEFAULT
)
3333 Fset_default (symbol
, old_value
);
3334 /* If this was a local binding, reset the value in the appropriate
3335 buffer, but only if that buffer's binding still exists. */
3336 else if (!NILP (Flocal_variable_p (symbol
, where
)))
3337 set_internal (symbol
, old_value
, where
, 1);
3343 if (NILP (Vquit_flag
) && !NILP (quitf
))
3350 DEFUN ("special-variable-p", Fspecial_variable_p
, Sspecial_variable_p
, 1, 1, 0,
3351 doc
: /* Return non-nil if SYMBOL's global binding has been declared special.
3352 A special variable is one that will be bound dynamically, even in a
3353 context where binding is lexical by default. */)
3354 (Lisp_Object symbol
)
3356 CHECK_SYMBOL (symbol
);
3357 return XSYMBOL (symbol
)->declared_special
? Qt
: Qnil
;
3361 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3362 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3363 The debugger is entered when that frame exits, if the flag is non-nil. */)
3364 (Lisp_Object level
, Lisp_Object flag
)
3366 union specbinding
*pdl
= backtrace_top ();
3367 register EMACS_INT i
;
3369 CHECK_NUMBER (level
);
3371 for (i
= 0; backtrace_p (pdl
) && i
< XINT (level
); i
++)
3372 pdl
= backtrace_next (pdl
);
3374 if (backtrace_p (pdl
))
3375 set_backtrace_debug_on_exit (pdl
, !NILP (flag
));
3380 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3381 doc
: /* Print a trace of Lisp function calls currently active.
3382 Output stream used is value of `standard-output'. */)
3385 union specbinding
*pdl
= backtrace_top ();
3387 Lisp_Object old_print_level
= Vprint_level
;
3389 if (NILP (Vprint_level
))
3390 XSETFASTINT (Vprint_level
, 8);
3392 while (backtrace_p (pdl
))
3394 write_string (backtrace_debug_on_exit (pdl
) ? "* " : " ", 2);
3395 if (backtrace_nargs (pdl
) == UNEVALLED
)
3397 Fprin1 (Fcons (backtrace_function (pdl
), *backtrace_args (pdl
)),
3399 write_string ("\n", -1);
3403 tem
= backtrace_function (pdl
);
3404 Fprin1 (tem
, Qnil
); /* This can QUIT. */
3405 write_string ("(", -1);
3408 for (i
= 0; i
< backtrace_nargs (pdl
); i
++)
3410 if (i
) write_string (" ", -1);
3411 Fprin1 (backtrace_args (pdl
)[i
], Qnil
);
3414 write_string (")\n", -1);
3416 pdl
= backtrace_next (pdl
);
3419 Vprint_level
= old_print_level
;
3423 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, NULL
,
3424 doc
: /* Return the function and arguments NFRAMES up from current execution point.
3425 If that frame has not evaluated the arguments yet (or is a special form),
3426 the value is (nil FUNCTION ARG-FORMS...).
3427 If that frame has evaluated its arguments and called its function already,
3428 the value is (t FUNCTION ARG-VALUES...).
3429 A &rest arg is represented as the tail of the list ARG-VALUES.
3430 FUNCTION is whatever was supplied as car of evaluated list,
3431 or a lambda expression for macro calls.
3432 If NFRAMES is more than the number of frames, the value is nil. */)
3433 (Lisp_Object nframes
)
3435 union specbinding
*pdl
= backtrace_top ();
3436 register EMACS_INT i
;
3438 CHECK_NATNUM (nframes
);
3440 /* Find the frame requested. */
3441 for (i
= 0; backtrace_p (pdl
) && i
< XFASTINT (nframes
); i
++)
3442 pdl
= backtrace_next (pdl
);
3444 if (!backtrace_p (pdl
))
3446 if (backtrace_nargs (pdl
) == UNEVALLED
)
3448 Fcons (backtrace_function (pdl
), *backtrace_args (pdl
)));
3451 Lisp_Object tem
= Flist (backtrace_nargs (pdl
), backtrace_args (pdl
));
3453 return Fcons (Qt
, Fcons (backtrace_function (pdl
), tem
));
3461 union specbinding
*pdl
;
3462 for (pdl
= specpdl
; pdl
!= specpdl_ptr
; pdl
++)
3466 case SPECPDL_UNWIND
:
3467 mark_object (specpdl_arg (pdl
));
3470 case SPECPDL_BACKTRACE
:
3472 ptrdiff_t nargs
= backtrace_nargs (pdl
);
3473 mark_object (backtrace_function (pdl
));
3474 if (nargs
== UNEVALLED
)
3477 mark_object (backtrace_args (pdl
)[nargs
]);
3481 case SPECPDL_LET_DEFAULT
:
3482 case SPECPDL_LET_LOCAL
:
3483 mark_object (specpdl_where (pdl
));
3486 mark_object (specpdl_symbol (pdl
));
3487 mark_object (specpdl_old_value (pdl
));
3494 get_backtrace (Lisp_Object array
)
3496 union specbinding
*pdl
= backtrace_next (backtrace_top ());
3497 ptrdiff_t i
= 0, asize
= ASIZE (array
);
3499 /* Copy the backtrace contents into working memory. */
3500 for (; i
< asize
; i
++)
3502 if (backtrace_p (pdl
))
3504 ASET (array
, i
, backtrace_function (pdl
));
3505 pdl
= backtrace_next (pdl
);
3508 ASET (array
, i
, Qnil
);
3512 Lisp_Object
backtrace_top_function (void)
3514 union specbinding
*pdl
= backtrace_top ();
3515 return (backtrace_p (pdl
) ? backtrace_function (pdl
) : Qnil
);
3521 DEFVAR_INT ("max-specpdl-size", max_specpdl_size
,
3522 doc
: /* Limit on number of Lisp variable bindings and `unwind-protect's.
3523 If Lisp code tries to increase the total number past this amount,
3524 an error is signaled.
3525 You can safely use a value considerably larger than the default value,
3526 if that proves inconveniently small. However, if you increase it too far,
3527 Emacs could run out of memory trying to make the stack bigger. */);
3529 DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth
,
3530 doc
: /* Limit on depth in `eval', `apply' and `funcall' before error.
3532 This limit serves to catch infinite recursions for you before they cause
3533 actual stack overflow in C, which would be fatal for Emacs.
3534 You can safely make it considerably larger than its default value,
3535 if that proves inconveniently small. However, if you increase it too far,
3536 Emacs could overflow the real C stack, and crash. */);
3538 DEFVAR_LISP ("quit-flag", Vquit_flag
,
3539 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3540 If the value is t, that means do an ordinary quit.
3541 If the value equals `throw-on-input', that means quit by throwing
3542 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3543 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3544 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3547 DEFVAR_LISP ("inhibit-quit", Vinhibit_quit
,
3548 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3549 Note that `quit-flag' will still be set by typing C-g,
3550 so a quit will be signaled as soon as `inhibit-quit' is nil.
3551 To prevent this happening, set `quit-flag' to nil
3552 before making `inhibit-quit' nil. */);
3553 Vinhibit_quit
= Qnil
;
3555 DEFSYM (Qinhibit_quit
, "inhibit-quit");
3556 DEFSYM (Qautoload
, "autoload");
3557 DEFSYM (Qinhibit_debugger
, "inhibit-debugger");
3558 DEFSYM (Qmacro
, "macro");
3559 DEFSYM (Qdeclare
, "declare");
3561 /* Note that the process handling also uses Qexit, but we don't want
3562 to staticpro it twice, so we just do it here. */
3563 DEFSYM (Qexit
, "exit");
3565 DEFSYM (Qinteractive
, "interactive");
3566 DEFSYM (Qcommandp
, "commandp");
3567 DEFSYM (Qand_rest
, "&rest");
3568 DEFSYM (Qand_optional
, "&optional");
3569 DEFSYM (Qclosure
, "closure");
3570 DEFSYM (Qdebug
, "debug");
3572 DEFVAR_LISP ("inhibit-debugger", Vinhibit_debugger
,
3573 doc
: /* Non-nil means never enter the debugger.
3574 Normally set while the debugger is already active, to avoid recursive
3576 Vinhibit_debugger
= Qnil
;
3578 DEFVAR_LISP ("debug-on-error", Vdebug_on_error
,
3579 doc
: /* Non-nil means enter debugger if an error is signaled.
3580 Does not apply to errors handled by `condition-case' or those
3581 matched by `debug-ignored-errors'.
3582 If the value is a list, an error only means to enter the debugger
3583 if one of its condition symbols appears in the list.
3584 When you evaluate an expression interactively, this variable
3585 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3586 The command `toggle-debug-on-error' toggles this.
3587 See also the variable `debug-on-quit' and `inhibit-debugger'. */);
3588 Vdebug_on_error
= Qnil
;
3590 DEFVAR_LISP ("debug-ignored-errors", Vdebug_ignored_errors
,
3591 doc
: /* List of errors for which the debugger should not be called.
3592 Each element may be a condition-name or a regexp that matches error messages.
3593 If any element applies to a given error, that error skips the debugger
3594 and just returns to top level.
3595 This overrides the variable `debug-on-error'.
3596 It does not apply to errors handled by `condition-case'. */);
3597 Vdebug_ignored_errors
= Qnil
;
3599 DEFVAR_BOOL ("debug-on-quit", debug_on_quit
,
3600 doc
: /* Non-nil means enter debugger if quit is signaled (C-g, for example).
3601 Does not apply if quit is handled by a `condition-case'. */);
3604 DEFVAR_BOOL ("debug-on-next-call", debug_on_next_call
,
3605 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3607 DEFVAR_BOOL ("debugger-may-continue", debugger_may_continue
,
3608 doc
: /* Non-nil means debugger may continue execution.
3609 This is nil when the debugger is called under circumstances where it
3610 might not be safe to continue. */);
3611 debugger_may_continue
= 1;
3613 DEFVAR_LISP ("debugger", Vdebugger
,
3614 doc
: /* Function to call to invoke debugger.
3615 If due to frame exit, args are `exit' and the value being returned;
3616 this function's value will be returned instead of that.
3617 If due to error, args are `error' and a list of the args to `signal'.
3618 If due to `apply' or `funcall' entry, one arg, `lambda'.
3619 If due to `eval' entry, one arg, t. */);
3622 DEFVAR_LISP ("signal-hook-function", Vsignal_hook_function
,
3623 doc
: /* If non-nil, this is a function for `signal' to call.
3624 It receives the same arguments that `signal' was given.
3625 The Edebug package uses this to regain control. */);
3626 Vsignal_hook_function
= Qnil
;
3628 DEFVAR_LISP ("debug-on-signal", Vdebug_on_signal
,
3629 doc
: /* Non-nil means call the debugger regardless of condition handlers.
3630 Note that `debug-on-error', `debug-on-quit' and friends
3631 still determine whether to handle the particular condition. */);
3632 Vdebug_on_signal
= Qnil
;
3634 /* When lexical binding is being used,
3635 Vinternal_interpreter_environment is non-nil, and contains an alist
3636 of lexically-bound variable, or (t), indicating an empty
3637 environment. The lisp name of this variable would be
3638 `internal-interpreter-environment' if it weren't hidden.
3639 Every element of this list can be either a cons (VAR . VAL)
3640 specifying a lexical binding, or a single symbol VAR indicating
3641 that this variable should use dynamic scoping. */
3642 DEFSYM (Qinternal_interpreter_environment
,
3643 "internal-interpreter-environment");
3644 DEFVAR_LISP ("internal-interpreter-environment",
3645 Vinternal_interpreter_environment
,
3646 doc
: /* If non-nil, the current lexical environment of the lisp interpreter.
3647 When lexical binding is not being used, this variable is nil.
3648 A value of `(t)' indicates an empty environment, otherwise it is an
3649 alist of active lexical bindings. */);
3650 Vinternal_interpreter_environment
= Qnil
;
3651 /* Don't export this variable to Elisp, so no one can mess with it
3652 (Just imagine if someone makes it buffer-local). */
3653 Funintern (Qinternal_interpreter_environment
, Qnil
);
3655 DEFSYM (Vrun_hooks
, "run-hooks");
3657 staticpro (&Vautoload_queue
);
3658 Vautoload_queue
= Qnil
;
3659 staticpro (&Vsignaling_function
);
3660 Vsignaling_function
= Qnil
;
3662 inhibit_lisp_code
= Qnil
;
3673 defsubr (&Sfunction
);
3675 defsubr (&Sdefvaralias
);
3676 defsubr (&Sdefconst
);
3677 defsubr (&Smake_var_non_special
);
3681 defsubr (&Smacroexpand
);
3684 defsubr (&Sunwind_protect
);
3685 defsubr (&Scondition_case
);
3687 defsubr (&Scommandp
);
3688 defsubr (&Sautoload
);
3689 defsubr (&Sautoload_do_load
);
3692 defsubr (&Sfuncall
);
3693 defsubr (&Srun_hooks
);
3694 defsubr (&Srun_hook_with_args
);
3695 defsubr (&Srun_hook_with_args_until_success
);
3696 defsubr (&Srun_hook_with_args_until_failure
);
3697 defsubr (&Srun_hook_wrapped
);
3698 defsubr (&Sfetch_bytecode
);
3699 defsubr (&Sbacktrace_debug
);
3700 defsubr (&Sbacktrace
);
3701 defsubr (&Sbacktrace_frame
);
3702 defsubr (&Sspecial_variable_p
);
3703 defsubr (&Sfunctionp
);