1 /* Evaluator for GNU Emacs Lisp interpreter.
3 Copyright (C) 1985-1987, 1993-1995, 1999-2019 Free Software Foundation,
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or (at
11 your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
27 #include "blockinput.h"
30 #include "dispextern.h"
33 /* CACHEABLE is ordinarily nothing, except it is 'volatile' if
34 necessary to cajole GCC into not warning incorrectly that a
35 variable should be volatile. */
36 #if defined GCC_LINT || defined lint
37 # define CACHEABLE volatile
39 # define CACHEABLE /* empty */
42 /* Chain of condition and catch handlers currently in effect. */
44 /* struct handler *handlerlist; */
46 /* Non-nil means record all fset's and provide's, to be undone
47 if the file being autoloaded is not fully loaded.
48 They are recorded by being consed onto the front of Vautoload_queue:
49 (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide. */
51 Lisp_Object Vautoload_queue
;
53 /* This holds either the symbol `run-hooks' or nil.
54 It is nil at an early stage of startup, and when Emacs
56 Lisp_Object Vrun_hooks
;
58 /* The commented-out variables below are macros defined in thread.h. */
60 /* Current number of specbindings allocated in specpdl, not counting
61 the dummy entry specpdl[-1]. */
63 /* ptrdiff_t specpdl_size; */
65 /* Pointer to beginning of specpdl. A dummy entry specpdl[-1] exists
66 only so that its address can be taken. */
68 /* union specbinding *specpdl; */
70 /* Pointer to first unused element in specpdl. */
72 /* union specbinding *specpdl_ptr; */
74 /* Depth in Lisp evaluations and function calls. */
76 /* static EMACS_INT lisp_eval_depth; */
78 /* The value of num_nonmacro_input_events as of the last time we
79 started to enter the debugger. If we decide to enter the debugger
80 again when this is still equal to num_nonmacro_input_events, then we
81 know that the debugger itself has an error, and we should just
82 signal the error instead of entering an infinite loop of debugger
85 static EMACS_INT when_entered_debugger
;
87 /* The function from which the last `signal' was called. Set in
89 /* FIXME: We should probably get rid of this! */
90 Lisp_Object Vsignaling_function
;
92 /* If non-nil, Lisp code must not be run since some part of Emacs is in
93 an inconsistent state. Currently unused. */
94 Lisp_Object inhibit_lisp_code
;
96 /* These would ordinarily be static, but they need to be visible to GDB. */
97 bool backtrace_p (union specbinding
*) EXTERNALLY_VISIBLE
;
98 Lisp_Object
*backtrace_args (union specbinding
*) EXTERNALLY_VISIBLE
;
99 Lisp_Object
backtrace_function (union specbinding
*) EXTERNALLY_VISIBLE
;
100 union specbinding
*backtrace_next (union specbinding
*) EXTERNALLY_VISIBLE
;
101 union specbinding
*backtrace_top (void) EXTERNALLY_VISIBLE
;
103 static Lisp_Object
funcall_lambda (Lisp_Object
, ptrdiff_t, Lisp_Object
*);
104 static Lisp_Object
apply_lambda (Lisp_Object
, Lisp_Object
, ptrdiff_t);
105 static Lisp_Object
lambda_arity (Lisp_Object
);
108 specpdl_symbol (union specbinding
*pdl
)
110 eassert (pdl
->kind
>= SPECPDL_LET
);
111 return pdl
->let
.symbol
;
114 static enum specbind_tag
115 specpdl_kind (union specbinding
*pdl
)
117 eassert (pdl
->kind
>= SPECPDL_LET
);
118 return pdl
->let
.kind
;
122 specpdl_old_value (union specbinding
*pdl
)
124 eassert (pdl
->kind
>= SPECPDL_LET
);
125 return pdl
->let
.old_value
;
129 set_specpdl_old_value (union specbinding
*pdl
, Lisp_Object val
)
131 eassert (pdl
->kind
>= SPECPDL_LET
);
132 pdl
->let
.old_value
= val
;
136 specpdl_where (union specbinding
*pdl
)
138 eassert (pdl
->kind
> SPECPDL_LET
);
139 return pdl
->let
.where
;
143 specpdl_saved_value (union specbinding
*pdl
)
145 eassert (pdl
->kind
>= SPECPDL_LET
);
146 return pdl
->let
.saved_value
;
150 specpdl_arg (union specbinding
*pdl
)
152 eassert (pdl
->kind
== SPECPDL_UNWIND
);
153 return pdl
->unwind
.arg
;
157 backtrace_function (union specbinding
*pdl
)
159 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
160 return pdl
->bt
.function
;
164 backtrace_nargs (union specbinding
*pdl
)
166 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
167 return pdl
->bt
.nargs
;
171 backtrace_args (union specbinding
*pdl
)
173 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
178 backtrace_debug_on_exit (union specbinding
*pdl
)
180 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
181 return pdl
->bt
.debug_on_exit
;
184 /* Functions to modify slots of backtrace records. */
187 set_backtrace_args (union specbinding
*pdl
, Lisp_Object
*args
, ptrdiff_t nargs
)
189 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
191 pdl
->bt
.nargs
= nargs
;
195 set_backtrace_debug_on_exit (union specbinding
*pdl
, bool doe
)
197 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
198 pdl
->bt
.debug_on_exit
= doe
;
201 /* Helper functions to scan the backtrace. */
204 backtrace_p (union specbinding
*pdl
)
205 { return pdl
>= specpdl
; }
210 union specbinding
*pdl
= specpdl_ptr
- 1;
211 while (backtrace_p (pdl
) && pdl
->kind
!= SPECPDL_BACKTRACE
)
217 backtrace_next (union specbinding
*pdl
)
220 while (backtrace_p (pdl
) && pdl
->kind
!= SPECPDL_BACKTRACE
)
226 init_eval_once (void)
229 union specbinding
*pdlvec
= xmalloc ((size
+ 1) * sizeof *specpdl
);
231 specpdl
= specpdl_ptr
= pdlvec
+ 1;
232 /* Don't forget to update docs (lispref node "Local Variables"). */
233 max_specpdl_size
= 1300; /* 1000 is not enough for CEDET's c-by.el. */
234 max_lisp_eval_depth
= 800;
239 /* static struct handler handlerlist_sentinel; */
244 specpdl_ptr
= specpdl
;
245 { /* Put a dummy catcher at top-level so that handlerlist is never NULL.
246 This is important since handlerlist->nextfree holds the freelist
247 which would otherwise leak every time we unwind back to top-level. */
248 handlerlist_sentinel
= xzalloc (sizeof (struct handler
));
249 handlerlist
= handlerlist_sentinel
->nextfree
= handlerlist_sentinel
;
250 struct handler
*c
= push_handler (Qunbound
, CATCHER
);
251 eassert (c
== handlerlist_sentinel
);
252 handlerlist_sentinel
->nextfree
= NULL
;
253 handlerlist_sentinel
->next
= NULL
;
256 debug_on_next_call
= 0;
258 /* This is less than the initial value of num_nonmacro_input_events. */
259 when_entered_debugger
= -1;
262 /* Unwind-protect function used by call_debugger. */
265 restore_stack_limits (Lisp_Object data
)
267 max_specpdl_size
= XINT (XCAR (data
));
268 max_lisp_eval_depth
= XINT (XCDR (data
));
271 static void grow_specpdl (void);
273 /* Call the Lisp debugger, giving it argument ARG. */
276 call_debugger (Lisp_Object arg
)
278 bool debug_while_redisplaying
;
279 ptrdiff_t count
= SPECPDL_INDEX ();
281 EMACS_INT old_depth
= max_lisp_eval_depth
;
282 /* Do not allow max_specpdl_size less than actual depth (Bug#16603). */
283 EMACS_INT old_max
= max (max_specpdl_size
, count
);
285 /* The previous value of 40 is too small now that the debugger
286 prints using cl-prin1 instead of prin1. Printing lists nested 8
287 deep (which is the value of print-level used in the debugger)
288 currently requires 77 additional frames. See bug#31919. */
289 if (lisp_eval_depth
+ 100 > max_lisp_eval_depth
)
290 max_lisp_eval_depth
= lisp_eval_depth
+ 100;
292 /* While debugging Bug#16603, previous value of 100 was found
293 too small to avoid specpdl overflow in the debugger itself. */
294 if (max_specpdl_size
- 200 < count
)
295 max_specpdl_size
= count
+ 200;
297 if (old_max
== count
)
299 /* We can enter the debugger due to specpdl overflow (Bug#16603). */
304 /* Restore limits after leaving the debugger. */
305 record_unwind_protect (restore_stack_limits
,
306 Fcons (make_number (old_max
),
307 make_number (old_depth
)));
309 #ifdef HAVE_WINDOW_SYSTEM
310 if (display_hourglass_p
)
314 debug_on_next_call
= 0;
315 when_entered_debugger
= num_nonmacro_input_events
;
317 /* Resetting redisplaying_p to 0 makes sure that debug output is
318 displayed if the debugger is invoked during redisplay. */
319 debug_while_redisplaying
= redisplaying_p
;
321 specbind (intern ("debugger-may-continue"),
322 debug_while_redisplaying
? Qnil
: Qt
);
323 specbind (Qinhibit_redisplay
, Qnil
);
324 specbind (Qinhibit_debugger
, Qt
);
326 /* If we are debugging an error while `inhibit-changing-match-data'
327 is bound to non-nil (e.g., within a call to `string-match-p'),
328 then make sure debugger code can still use match data. */
329 specbind (Qinhibit_changing_match_data
, Qnil
);
331 #if 0 /* Binding this prevents execution of Lisp code during
332 redisplay, which necessarily leads to display problems. */
333 specbind (Qinhibit_eval_during_redisplay
, Qt
);
336 val
= apply1 (Vdebugger
, arg
);
338 /* Interrupting redisplay and resuming it later is not safe under
339 all circumstances. So, when the debugger returns, abort the
340 interrupted redisplay by going back to the top-level. */
341 if (debug_while_redisplaying
)
344 return unbind_to (count
, val
);
348 do_debug_on_call (Lisp_Object code
, ptrdiff_t count
)
350 debug_on_next_call
= 0;
351 set_backtrace_debug_on_exit (specpdl
+ count
, true);
352 call_debugger (list1 (code
));
355 /* NOTE!!! Every function that can call EVAL must protect its args
356 and temporaries from garbage collection while it needs them.
357 The definition of `For' shows what you have to do. */
359 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
360 doc
: /* Eval args until one of them yields non-nil, then return that value.
361 The remaining args are not evalled at all.
362 If all args return nil, return nil.
363 usage: (or CONDITIONS...) */)
366 Lisp_Object val
= Qnil
;
370 Lisp_Object arg
= XCAR (args
);
372 val
= eval_sub (arg
);
380 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
381 doc
: /* Eval args until one of them yields nil, then return nil.
382 The remaining args are not evalled at all.
383 If no arg yields nil, return the last arg's value.
384 usage: (and CONDITIONS...) */)
387 Lisp_Object val
= Qt
;
391 Lisp_Object arg
= XCAR (args
);
393 val
= eval_sub (arg
);
401 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
402 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
403 Returns the value of THEN or the value of the last of the ELSE's.
404 THEN must be one expression, but ELSE... can be zero or more expressions.
405 If COND yields nil, and there are no ELSE's, the value is nil.
406 usage: (if COND THEN ELSE...) */)
411 cond
= eval_sub (XCAR (args
));
414 return eval_sub (Fcar (XCDR (args
)));
415 return Fprogn (Fcdr (XCDR (args
)));
418 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
419 doc
: /* Try each clause until one succeeds.
420 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
421 and, if the value is non-nil, this clause succeeds:
422 then the expressions in BODY are evaluated and the last one's
423 value is the value of the cond-form.
424 If a clause has one element, as in (CONDITION), then the cond-form
425 returns CONDITION's value, if that is non-nil.
426 If no clause succeeds, cond returns nil.
427 usage: (cond CLAUSES...) */)
430 Lisp_Object val
= args
;
434 Lisp_Object clause
= XCAR (args
);
435 val
= eval_sub (Fcar (clause
));
438 if (!NILP (XCDR (clause
)))
439 val
= Fprogn (XCDR (clause
));
448 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
449 doc
: /* Eval BODY forms sequentially and return value of last one.
450 usage: (progn BODY...) */)
453 Lisp_Object val
= Qnil
;
457 Lisp_Object form
= XCAR (body
);
459 val
= eval_sub (form
);
465 /* Evaluate BODY sequentially, discarding its value. */
468 prog_ignore (Lisp_Object body
)
473 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
474 doc
: /* Eval FIRST and BODY sequentially; return value from FIRST.
475 The value of FIRST is saved during the evaluation of the remaining args,
476 whose values are discarded.
477 usage: (prog1 FIRST BODY...) */)
480 Lisp_Object val
= eval_sub (XCAR (args
));
481 prog_ignore (XCDR (args
));
485 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
486 doc
: /* Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
487 The value of FORM2 is saved during the evaluation of the
488 remaining args, whose values are discarded.
489 usage: (prog2 FORM1 FORM2 BODY...) */)
492 eval_sub (XCAR (args
));
493 return Fprog1 (XCDR (args
));
496 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
497 doc
: /* Set each SYM to the value of its VAL.
498 The symbols SYM are variables; they are literal (not evaluated).
499 The values VAL are expressions; they are evaluated.
500 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
501 The second VAL is not computed until after the first SYM is set, and so on;
502 each VAL can use the new value of variables set earlier in the `setq'.
503 The return value of the `setq' form is the value of the last VAL.
504 usage: (setq [SYM VAL]...) */)
507 Lisp_Object val
= args
, tail
= args
;
509 for (EMACS_INT nargs
= 0; CONSP (tail
); nargs
+= 2)
511 Lisp_Object sym
= XCAR (tail
), lex_binding
;
514 xsignal2 (Qwrong_number_of_arguments
, Qsetq
, make_number (nargs
+ 1));
515 Lisp_Object arg
= XCAR (tail
);
517 val
= eval_sub (arg
);
518 /* Like for eval_sub, we do not check declared_special here since
519 it's been done when let-binding. */
520 if (!NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
522 && !NILP (lex_binding
523 = Fassq (sym
, Vinternal_interpreter_environment
)))
524 XSETCDR (lex_binding
, val
); /* SYM is lexically bound. */
526 Fset (sym
, val
); /* SYM is dynamically bound. */
532 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
533 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
534 Warning: `quote' does not construct its return value, but just returns
535 the value that was pre-constructed by the Lisp reader (see info node
536 `(elisp)Printed Representation').
537 This means that \\='(a . b) is not identical to (cons \\='a \\='b): the former
538 does not cons. Quoting should be reserved for constants that will
539 never be modified by side-effects, unless you like self-modifying code.
540 See the common pitfall in info node `(elisp)Rearrangement' for an example
541 of unexpected results when a quoted object is modified.
542 usage: (quote ARG) */)
545 if (!NILP (XCDR (args
)))
546 xsignal2 (Qwrong_number_of_arguments
, Qquote
, Flength (args
));
550 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
551 doc
: /* Like `quote', but preferred for objects which are functions.
552 In byte compilation, `function' causes its argument to be compiled.
553 `quote' cannot do that.
554 usage: (function ARG) */)
557 Lisp_Object quoted
= XCAR (args
);
559 if (!NILP (XCDR (args
)))
560 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
562 if (!NILP (Vinternal_interpreter_environment
)
564 && EQ (XCAR (quoted
), Qlambda
))
565 { /* This is a lambda expression within a lexical environment;
566 return an interpreted closure instead of a simple lambda. */
567 Lisp_Object cdr
= XCDR (quoted
);
568 Lisp_Object tmp
= cdr
;
570 && (tmp
= XCDR (tmp
), CONSP (tmp
))
571 && (tmp
= XCAR (tmp
), CONSP (tmp
))
572 && (EQ (QCdocumentation
, XCAR (tmp
))))
573 { /* Handle the special (:documentation <form>) to build the docstring
575 Lisp_Object docstring
= eval_sub (Fcar (XCDR (tmp
)));
576 CHECK_STRING (docstring
);
577 cdr
= Fcons (XCAR (cdr
), Fcons (docstring
, XCDR (XCDR (cdr
))));
579 return Fcons (Qclosure
, Fcons (Vinternal_interpreter_environment
,
583 /* Simply quote the argument. */
588 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
589 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
590 Aliased variables always have the same value; setting one sets the other.
591 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
592 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
593 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
594 itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
595 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
596 The return value is BASE-VARIABLE. */)
597 (Lisp_Object new_alias
, Lisp_Object base_variable
, Lisp_Object docstring
)
599 struct Lisp_Symbol
*sym
;
601 CHECK_SYMBOL (new_alias
);
602 CHECK_SYMBOL (base_variable
);
604 if (SYMBOL_CONSTANT_P (new_alias
))
605 /* Making it an alias effectively changes its value. */
606 error ("Cannot make a constant an alias");
608 sym
= XSYMBOL (new_alias
);
610 switch (sym
->u
.s
.redirect
)
612 case SYMBOL_FORWARDED
:
613 error ("Cannot make an internal variable an alias");
614 case SYMBOL_LOCALIZED
:
615 error ("Don't know how to make a localized variable an alias");
616 case SYMBOL_PLAINVAL
:
617 case SYMBOL_VARALIAS
:
623 /* https://lists.gnu.org/r/emacs-devel/2008-04/msg00834.html
624 If n_a is bound, but b_v is not, set the value of b_v to n_a,
625 so that old-code that affects n_a before the aliasing is setup
627 if (NILP (Fboundp (base_variable
)))
628 set_internal (base_variable
, find_symbol_value (new_alias
),
629 Qnil
, SET_INTERNAL_BIND
);
631 union specbinding
*p
;
633 for (p
= specpdl_ptr
; p
> specpdl
; )
634 if ((--p
)->kind
>= SPECPDL_LET
635 && (EQ (new_alias
, specpdl_symbol (p
))))
636 error ("Don't know how to make a let-bound variable an alias");
639 if (sym
->u
.s
.trapped_write
== SYMBOL_TRAPPED_WRITE
)
640 notify_variable_watchers (new_alias
, base_variable
, Qdefvaralias
, Qnil
);
642 sym
->u
.s
.declared_special
= true;
643 XSYMBOL (base_variable
)->u
.s
.declared_special
= true;
644 sym
->u
.s
.redirect
= SYMBOL_VARALIAS
;
645 SET_SYMBOL_ALIAS (sym
, XSYMBOL (base_variable
));
646 sym
->u
.s
.trapped_write
= XSYMBOL (base_variable
)->u
.s
.trapped_write
;
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
;
654 static union specbinding
*
655 default_toplevel_binding (Lisp_Object symbol
)
657 union specbinding
*binding
= NULL
;
658 union specbinding
*pdl
= specpdl_ptr
;
659 while (pdl
> specpdl
)
661 switch ((--pdl
)->kind
)
663 case SPECPDL_LET_DEFAULT
:
665 if (EQ (specpdl_symbol (pdl
), symbol
))
670 case SPECPDL_UNWIND_PTR
:
671 case SPECPDL_UNWIND_INT
:
672 case SPECPDL_UNWIND_VOID
:
673 case SPECPDL_BACKTRACE
:
674 case SPECPDL_LET_LOCAL
:
684 DEFUN ("default-toplevel-value", Fdefault_toplevel_value
, Sdefault_toplevel_value
, 1, 1, 0,
685 doc
: /* Return SYMBOL's toplevel default value.
686 "Toplevel" means outside of any let binding. */)
689 union specbinding
*binding
= default_toplevel_binding (symbol
);
691 = binding
? specpdl_old_value (binding
) : Fdefault_value (symbol
);
692 if (!EQ (value
, Qunbound
))
694 xsignal1 (Qvoid_variable
, symbol
);
697 DEFUN ("set-default-toplevel-value", Fset_default_toplevel_value
,
698 Sset_default_toplevel_value
, 2, 2, 0,
699 doc
: /* Set SYMBOL's toplevel default value to VALUE.
700 "Toplevel" means outside of any let binding. */)
701 (Lisp_Object symbol
, Lisp_Object value
)
703 union specbinding
*binding
= default_toplevel_binding (symbol
);
705 set_specpdl_old_value (binding
, value
);
707 Fset_default (symbol
, value
);
711 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
712 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
713 You are not required to define a variable in order to use it, but
714 defining it lets you supply an initial value and documentation, which
715 can be referred to by the Emacs help facilities and other programming
716 tools. The `defvar' form also declares the variable as \"special\",
717 so that it is always dynamically bound even if `lexical-binding' is t.
719 If SYMBOL's value is void and the optional argument INITVALUE is
720 provided, INITVALUE is evaluated and the result used to set SYMBOL's
721 value. If SYMBOL is buffer-local, its default value is what is set;
722 buffer-local values are not affected. If INITVALUE is missing,
723 SYMBOL's value is not set.
725 If SYMBOL has a local binding, then this form affects the local
726 binding. This is usually not what you want. Thus, if you need to
727 load a file defining variables, with this form or with `defconst' or
728 `defcustom', you should always load that file _outside_ any bindings
729 for these variables. (`defconst' and `defcustom' behave similarly in
732 The optional argument DOCSTRING is a documentation string for the
735 To define a user option, use `defcustom' instead of `defvar'.
736 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
739 Lisp_Object sym
, tem
, tail
;
746 if (!NILP (XCDR (tail
)) && !NILP (XCDR (XCDR (tail
))))
747 error ("Too many arguments");
749 tem
= Fdefault_boundp (sym
);
751 /* Do it before evaluating the initial value, for self-references. */
752 XSYMBOL (sym
)->u
.s
.declared_special
= true;
755 Fset_default (sym
, eval_sub (XCAR (tail
)));
757 { /* Check if there is really a global binding rather than just a let
758 binding that shadows the global unboundness of the var. */
759 union specbinding
*binding
= default_toplevel_binding (sym
);
760 if (binding
&& EQ (specpdl_old_value (binding
), Qunbound
))
762 set_specpdl_old_value (binding
, eval_sub (XCAR (tail
)));
769 if (!NILP (Vpurify_flag
))
770 tem
= Fpurecopy (tem
);
771 Fput (sym
, Qvariable_documentation
, tem
);
773 LOADHIST_ATTACH (sym
);
775 else if (!NILP (Vinternal_interpreter_environment
)
776 && (SYMBOLP (sym
) && !XSYMBOL (sym
)->u
.s
.declared_special
))
777 /* A simple (defvar foo) with lexical scoping does "nothing" except
778 declare that var to be dynamically scoped *locally* (i.e. within
779 the current file or let-block). */
780 Vinternal_interpreter_environment
781 = Fcons (sym
, Vinternal_interpreter_environment
);
784 /* Simple (defvar <var>) should not count as a definition at all.
785 It could get in the way of other definitions, and unloading this
786 package could try to make the variable unbound. */
792 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
793 doc
: /* Define SYMBOL as a constant variable.
794 This declares that neither programs nor users should ever change the
795 value. This constancy is not actually enforced by Emacs Lisp, but
796 SYMBOL is marked as a special variable so that it is never lexically
799 The `defconst' form always sets the value of SYMBOL to the result of
800 evalling INITVALUE. If SYMBOL is buffer-local, its default value is
801 what is set; buffer-local values are not affected. If SYMBOL has a
802 local binding, then this form sets the local binding's value.
803 However, you should normally not make local bindings for variables
804 defined with this form.
806 The optional DOCSTRING specifies the variable's documentation string.
807 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
810 Lisp_Object sym
, tem
;
813 Lisp_Object docstring
= Qnil
;
814 if (!NILP (XCDR (XCDR (args
))))
816 if (!NILP (XCDR (XCDR (XCDR (args
)))))
817 error ("Too many arguments");
818 docstring
= XCAR (XCDR (XCDR (args
)));
821 tem
= eval_sub (XCAR (XCDR (args
)));
822 if (!NILP (Vpurify_flag
))
823 tem
= Fpurecopy (tem
);
824 Fset_default (sym
, tem
);
825 XSYMBOL (sym
)->u
.s
.declared_special
= true;
826 if (!NILP (docstring
))
828 if (!NILP (Vpurify_flag
))
829 docstring
= Fpurecopy (docstring
);
830 Fput (sym
, Qvariable_documentation
, docstring
);
832 Fput (sym
, Qrisky_local_variable
, Qt
);
833 LOADHIST_ATTACH (sym
);
837 /* Make SYMBOL lexically scoped. */
838 DEFUN ("internal-make-var-non-special", Fmake_var_non_special
,
839 Smake_var_non_special
, 1, 1, 0,
840 doc
: /* Internal function. */)
843 CHECK_SYMBOL (symbol
);
844 XSYMBOL (symbol
)->u
.s
.declared_special
= false;
849 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
850 doc
: /* Bind variables according to VARLIST then eval BODY.
851 The value of the last form in BODY is returned.
852 Each element of VARLIST is a symbol (which is bound to nil)
853 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
854 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
855 usage: (let* VARLIST BODY...) */)
858 Lisp_Object var
, val
, elt
, lexenv
;
859 ptrdiff_t count
= SPECPDL_INDEX ();
861 lexenv
= Vinternal_interpreter_environment
;
863 Lisp_Object varlist
= XCAR (args
);
864 while (CONSP (varlist
))
868 elt
= XCAR (varlist
);
869 varlist
= XCDR (varlist
);
878 if (! NILP (Fcdr (XCDR (elt
))))
879 signal_error ("`let' bindings can have only one value-form", elt
);
880 val
= eval_sub (Fcar (XCDR (elt
)));
883 if (!NILP (lexenv
) && SYMBOLP (var
)
884 && !XSYMBOL (var
)->u
.s
.declared_special
885 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
886 /* Lexically bind VAR by adding it to the interpreter's binding
890 = Fcons (Fcons (var
, val
), Vinternal_interpreter_environment
);
891 if (EQ (Vinternal_interpreter_environment
, lexenv
))
892 /* Save the old lexical environment on the specpdl stack,
893 but only for the first lexical binding, since we'll never
894 need to revert to one of the intermediate ones. */
895 specbind (Qinternal_interpreter_environment
, newenv
);
897 Vinternal_interpreter_environment
= newenv
;
902 CHECK_LIST_END (varlist
, XCAR (args
));
904 val
= Fprogn (XCDR (args
));
905 return unbind_to (count
, val
);
908 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
909 doc
: /* Bind variables according to VARLIST then eval BODY.
910 The value of the last form in BODY is returned.
911 Each element of VARLIST is a symbol (which is bound to nil)
912 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
913 All the VALUEFORMs are evalled before any symbols are bound.
914 usage: (let VARLIST BODY...) */)
917 Lisp_Object
*temps
, tem
, lexenv
;
918 Lisp_Object elt
, varlist
;
919 ptrdiff_t count
= SPECPDL_INDEX ();
923 varlist
= XCAR (args
);
924 CHECK_LIST (varlist
);
926 /* Make space to hold the values to give the bound variables. */
927 EMACS_INT varlist_len
= XFASTINT (Flength (varlist
));
928 SAFE_ALLOCA_LISP (temps
, varlist_len
);
929 ptrdiff_t nvars
= varlist_len
;
931 /* Compute the values and store them in `temps'. */
933 for (argnum
= 0; argnum
< nvars
&& CONSP (varlist
); argnum
++)
936 elt
= XCAR (varlist
);
937 varlist
= XCDR (varlist
);
939 temps
[argnum
] = Qnil
;
940 else if (! NILP (Fcdr (Fcdr (elt
))))
941 signal_error ("`let' bindings can have only one value-form", elt
);
943 temps
[argnum
] = eval_sub (Fcar (Fcdr (elt
)));
947 lexenv
= Vinternal_interpreter_environment
;
949 varlist
= XCAR (args
);
950 for (argnum
= 0; argnum
< nvars
&& CONSP (varlist
); argnum
++)
954 elt
= XCAR (varlist
);
955 varlist
= XCDR (varlist
);
956 var
= SYMBOLP (elt
) ? elt
: Fcar (elt
);
959 if (!NILP (lexenv
) && SYMBOLP (var
)
960 && !XSYMBOL (var
)->u
.s
.declared_special
961 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
962 /* Lexically bind VAR by adding it to the lexenv alist. */
963 lexenv
= Fcons (Fcons (var
, tem
), lexenv
);
965 /* Dynamically bind VAR. */
969 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
970 /* Instantiate a new lexical environment. */
971 specbind (Qinternal_interpreter_environment
, lexenv
);
973 elt
= Fprogn (XCDR (args
));
975 return unbind_to (count
, elt
);
978 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
979 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
980 The order of execution is thus TEST, BODY, TEST, BODY and so on
981 until TEST returns nil.
982 usage: (while TEST BODY...) */)
985 Lisp_Object test
, body
;
989 while (!NILP (eval_sub (test
)))
998 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
999 doc
: /* Return result of expanding macros at top level of FORM.
1000 If FORM is not a macro call, it is returned unchanged.
1001 Otherwise, the macro is expanded and the expansion is considered
1002 in place of FORM. When a non-macro-call results, it is returned.
1004 The second optional arg ENVIRONMENT specifies an environment of macro
1005 definitions to shadow the loaded ones for use in file byte-compilation. */)
1006 (Lisp_Object form
, Lisp_Object environment
)
1008 /* With cleanups from Hallvard Furuseth. */
1009 register Lisp_Object expander
, sym
, def
, tem
;
1013 /* Come back here each time we expand a macro call,
1014 in case it expands into another macro call. */
1017 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1018 def
= sym
= XCAR (form
);
1020 /* Trace symbols aliases to other symbols
1021 until we get a symbol that is not an alias. */
1022 while (SYMBOLP (def
))
1026 tem
= Fassq (sym
, environment
);
1029 def
= XSYMBOL (sym
)->u
.s
.function
;
1035 /* Right now TEM is the result from SYM in ENVIRONMENT,
1036 and if TEM is nil then DEF is SYM's function definition. */
1039 /* SYM is not mentioned in ENVIRONMENT.
1040 Look at its function definition. */
1041 def
= Fautoload_do_load (def
, sym
, Qmacro
);
1043 /* Not defined or definition not suitable. */
1045 if (!EQ (XCAR (def
), Qmacro
))
1047 else expander
= XCDR (def
);
1051 expander
= XCDR (tem
);
1052 if (NILP (expander
))
1056 Lisp_Object newform
= apply1 (expander
, XCDR (form
));
1057 if (EQ (form
, newform
))
1066 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1067 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1068 TAG is evalled to get the tag to use; it must not be nil.
1070 Then the BODY is executed.
1071 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
1072 If no throw happens, `catch' returns the value of the last BODY form.
1073 If a throw happens, it specifies the value to return from `catch'.
1074 usage: (catch TAG BODY...) */)
1077 Lisp_Object tag
= eval_sub (XCAR (args
));
1078 return internal_catch (tag
, Fprogn
, XCDR (args
));
1081 /* Assert that E is true, but do not evaluate E. Use this instead of
1082 eassert (E) when E contains variables that might be clobbered by a
1085 #define clobbered_eassert(E) verify (sizeof (E) != 0)
1087 /* Set up a catch, then call C function FUNC on argument ARG.
1088 FUNC should return a Lisp_Object.
1089 This is how catches are done from within C code. */
1092 internal_catch (Lisp_Object tag
,
1093 Lisp_Object (*func
) (Lisp_Object
), Lisp_Object arg
)
1095 /* This structure is made part of the chain `catchlist'. */
1096 struct handler
*c
= push_handler (tag
, CATCHER
);
1099 if (! sys_setjmp (c
->jmp
))
1101 Lisp_Object val
= func (arg
);
1102 eassert (handlerlist
== c
);
1103 handlerlist
= c
->next
;
1107 { /* Throw works by a longjmp that comes right here. */
1108 Lisp_Object val
= handlerlist
->val
;
1109 clobbered_eassert (handlerlist
== c
);
1110 handlerlist
= handlerlist
->next
;
1115 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1116 jump to that CATCH, returning VALUE as the value of that catch.
1118 This is the guts of Fthrow and Fsignal; they differ only in the way
1119 they choose the catch tag to throw to. A catch tag for a
1120 condition-case form has a TAG of Qnil.
1122 Before each catch is discarded, unbind all special bindings and
1123 execute all unwind-protect clauses made above that catch. Unwind
1124 the handler stack as we go, so that the proper handlers are in
1125 effect for each unwind-protect clause we run. At the end, restore
1126 some static info saved in CATCH, and longjmp to the location
1129 This is used for correct unwinding in Fthrow and Fsignal. */
1131 static _Noreturn
void
1132 unwind_to_catch (struct handler
*catch, Lisp_Object value
)
1136 eassert (catch->next
);
1138 /* Save the value in the tag. */
1141 /* Restore certain special C variables. */
1142 set_poll_suppress_count (catch->poll_suppress_count
);
1143 unblock_input_to (catch->interrupt_input_blocked
);
1147 /* Unwind the specpdl stack, and then restore the proper set of
1149 unbind_to (handlerlist
->pdlcount
, Qnil
);
1150 last_time
= handlerlist
== catch;
1152 handlerlist
= handlerlist
->next
;
1154 while (! last_time
);
1156 eassert (handlerlist
== catch);
1158 lisp_eval_depth
= catch->f_lisp_eval_depth
;
1160 sys_longjmp (catch->jmp
, 1);
1163 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1164 doc
: /* Throw to the catch for TAG and return VALUE from it.
1165 Both TAG and VALUE are evalled. */
1166 attributes
: noreturn
)
1167 (register Lisp_Object tag
, Lisp_Object value
)
1172 for (c
= handlerlist
; c
; c
= c
->next
)
1174 if (c
->type
== CATCHER_ALL
)
1175 unwind_to_catch (c
, Fcons (tag
, value
));
1176 if (c
->type
== CATCHER
&& EQ (c
->tag_or_ch
, tag
))
1177 unwind_to_catch (c
, value
);
1179 xsignal2 (Qno_catch
, tag
, value
);
1183 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1184 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1185 If BODYFORM completes normally, its value is returned
1186 after executing the UNWINDFORMS.
1187 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1188 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1192 ptrdiff_t count
= SPECPDL_INDEX ();
1194 record_unwind_protect (prog_ignore
, XCDR (args
));
1195 val
= eval_sub (XCAR (args
));
1196 return unbind_to (count
, val
);
1199 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1200 doc
: /* Regain control when an error is signaled.
1201 Executes BODYFORM and returns its value if no error happens.
1202 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1203 where the BODY is made of Lisp expressions.
1205 A handler is applicable to an error
1206 if CONDITION-NAME is one of the error's condition names.
1207 If an error happens, the first applicable handler is run.
1209 The car of a handler may be a list of condition names instead of a
1210 single condition name; then it handles all of them. If the special
1211 condition name `debug' is present in this list, it allows another
1212 condition in the list to run the debugger if `debug-on-error' and the
1213 other usual mechanisms says it should (otherwise, `condition-case'
1214 suppresses the debugger).
1216 When a handler handles an error, control returns to the `condition-case'
1217 and it executes the handler's BODY...
1218 with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
1219 \(If VAR is nil, the handler can't access that information.)
1220 Then the value of the last BODY form is returned from the `condition-case'
1223 See also the function `signal' for more info.
1224 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1227 Lisp_Object var
= XCAR (args
);
1228 Lisp_Object bodyform
= XCAR (XCDR (args
));
1229 Lisp_Object handlers
= XCDR (XCDR (args
));
1231 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1234 /* Like Fcondition_case, but the args are separate
1235 rather than passed in a list. Used by Fbyte_code. */
1238 internal_lisp_condition_case (Lisp_Object var
, Lisp_Object bodyform
,
1239 Lisp_Object handlers
)
1241 struct handler
*oldhandlerlist
= handlerlist
;
1242 ptrdiff_t CACHEABLE clausenb
= 0;
1246 for (Lisp_Object tail
= handlers
; CONSP (tail
); tail
= XCDR (tail
))
1248 Lisp_Object tem
= XCAR (tail
);
1252 && (SYMBOLP (XCAR (tem
))
1253 || CONSP (XCAR (tem
))))))
1254 error ("Invalid condition handler: %s",
1255 SDATA (Fprin1_to_string (tem
, Qt
)));
1258 /* The first clause is the one that should be checked first, so it
1259 should be added to handlerlist last. So build in CLAUSES a table
1260 that contains HANDLERS but in reverse order. CLAUSES is pointer
1261 to volatile to avoid issues with setjmp and local storage.
1262 SAFE_ALLOCA won't work here due to the setjmp, so impose a
1263 MAX_ALLOCA limit. */
1264 if (MAX_ALLOCA
/ word_size
< clausenb
)
1265 memory_full (SIZE_MAX
);
1266 Lisp_Object
volatile *clauses
= alloca (clausenb
* sizeof *clauses
);
1267 clauses
+= clausenb
;
1268 for (Lisp_Object tail
= handlers
; CONSP (tail
); tail
= XCDR (tail
))
1269 *--clauses
= XCAR (tail
);
1270 for (ptrdiff_t i
= 0; i
< clausenb
; i
++)
1272 Lisp_Object clause
= clauses
[i
];
1273 Lisp_Object condition
= CONSP (clause
) ? XCAR (clause
) : Qnil
;
1274 if (!CONSP (condition
))
1275 condition
= list1 (condition
);
1276 struct handler
*c
= push_handler (condition
, CONDITION_CASE
);
1277 if (sys_setjmp (c
->jmp
))
1279 Lisp_Object val
= handlerlist
->val
;
1280 Lisp_Object
volatile *chosen_clause
= clauses
;
1281 for (struct handler
*h
= handlerlist
->next
; h
!= oldhandlerlist
;
1284 Lisp_Object handler_body
= XCDR (*chosen_clause
);
1285 handlerlist
= oldhandlerlist
;
1288 return Fprogn (handler_body
);
1290 Lisp_Object handler_var
= var
;
1291 if (!NILP (Vinternal_interpreter_environment
))
1293 val
= Fcons (Fcons (var
, val
),
1294 Vinternal_interpreter_environment
);
1295 handler_var
= Qinternal_interpreter_environment
;
1298 /* Bind HANDLER_VAR to VAL while evaluating HANDLER_BODY.
1299 The unbind_to undoes just this binding; whoever longjumped
1300 to us unwound the stack to C->pdlcount before throwing. */
1301 ptrdiff_t count
= SPECPDL_INDEX ();
1302 specbind (handler_var
, val
);
1303 return unbind_to (count
, Fprogn (handler_body
));
1307 Lisp_Object result
= eval_sub (bodyform
);
1308 handlerlist
= oldhandlerlist
;
1312 /* Call the function BFUN with no arguments, catching errors within it
1313 according to HANDLERS. If there is an error, call HFUN with
1314 one argument which is the data that describes the error:
1317 HANDLERS can be a list of conditions to catch.
1318 If HANDLERS is Qt, catch all errors.
1319 If HANDLERS is Qerror, catch all errors
1320 but allow the debugger to run if that is enabled. */
1323 internal_condition_case (Lisp_Object (*bfun
) (void), Lisp_Object handlers
,
1324 Lisp_Object (*hfun
) (Lisp_Object
))
1326 struct handler
*c
= push_handler (handlers
, CONDITION_CASE
);
1327 if (sys_setjmp (c
->jmp
))
1329 Lisp_Object val
= handlerlist
->val
;
1330 clobbered_eassert (handlerlist
== c
);
1331 handlerlist
= handlerlist
->next
;
1336 Lisp_Object val
= bfun ();
1337 eassert (handlerlist
== c
);
1338 handlerlist
= c
->next
;
1343 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1346 internal_condition_case_1 (Lisp_Object (*bfun
) (Lisp_Object
), Lisp_Object arg
,
1347 Lisp_Object handlers
,
1348 Lisp_Object (*hfun
) (Lisp_Object
))
1350 struct handler
*c
= push_handler (handlers
, CONDITION_CASE
);
1351 if (sys_setjmp (c
->jmp
))
1353 Lisp_Object val
= handlerlist
->val
;
1354 clobbered_eassert (handlerlist
== c
);
1355 handlerlist
= handlerlist
->next
;
1360 Lisp_Object val
= bfun (arg
);
1361 eassert (handlerlist
== c
);
1362 handlerlist
= c
->next
;
1367 /* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as
1371 internal_condition_case_2 (Lisp_Object (*bfun
) (Lisp_Object
, Lisp_Object
),
1374 Lisp_Object handlers
,
1375 Lisp_Object (*hfun
) (Lisp_Object
))
1377 struct handler
*c
= push_handler (handlers
, CONDITION_CASE
);
1378 if (sys_setjmp (c
->jmp
))
1380 Lisp_Object val
= handlerlist
->val
;
1381 clobbered_eassert (handlerlist
== c
);
1382 handlerlist
= handlerlist
->next
;
1387 Lisp_Object val
= bfun (arg1
, arg2
);
1388 eassert (handlerlist
== c
);
1389 handlerlist
= c
->next
;
1394 /* Like internal_condition_case but call BFUN with NARGS as first,
1395 and ARGS as second argument. */
1398 internal_condition_case_n (Lisp_Object (*bfun
) (ptrdiff_t, Lisp_Object
*),
1401 Lisp_Object handlers
,
1402 Lisp_Object (*hfun
) (Lisp_Object err
,
1406 struct handler
*c
= push_handler (handlers
, CONDITION_CASE
);
1407 if (sys_setjmp (c
->jmp
))
1409 Lisp_Object val
= handlerlist
->val
;
1410 clobbered_eassert (handlerlist
== c
);
1411 handlerlist
= handlerlist
->next
;
1412 return hfun (val
, nargs
, args
);
1416 Lisp_Object val
= bfun (nargs
, args
);
1417 eassert (handlerlist
== c
);
1418 handlerlist
= c
->next
;
1424 push_handler (Lisp_Object tag_ch_val
, enum handlertype handlertype
)
1426 struct handler
*c
= push_handler_nosignal (tag_ch_val
, handlertype
);
1428 memory_full (sizeof *c
);
1433 push_handler_nosignal (Lisp_Object tag_ch_val
, enum handlertype handlertype
)
1435 struct handler
*CACHEABLE c
= handlerlist
->nextfree
;
1438 c
= malloc (sizeof *c
);
1441 if (profiler_memory_running
)
1442 malloc_probe (sizeof *c
);
1444 handlerlist
->nextfree
= c
;
1446 c
->type
= handlertype
;
1447 c
->tag_or_ch
= tag_ch_val
;
1449 c
->next
= handlerlist
;
1450 c
->f_lisp_eval_depth
= lisp_eval_depth
;
1451 c
->pdlcount
= SPECPDL_INDEX ();
1452 c
->poll_suppress_count
= poll_suppress_count
;
1453 c
->interrupt_input_blocked
= interrupt_input_blocked
;
1459 static Lisp_Object
signal_or_quit (Lisp_Object
, Lisp_Object
, bool);
1460 static Lisp_Object
find_handler_clause (Lisp_Object
, Lisp_Object
);
1461 static bool maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
,
1465 process_quit_flag (void)
1467 Lisp_Object flag
= Vquit_flag
;
1469 if (EQ (flag
, Qkill_emacs
))
1471 if (EQ (Vthrow_on_input
, flag
))
1472 Fthrow (Vthrow_on_input
, Qt
);
1476 /* Check quit-flag and quit if it is non-nil. Typing C-g does not
1477 directly cause a quit; it only sets Vquit_flag. So the program
1478 needs to call maybe_quit at times when it is safe to quit. Every
1479 loop that might run for a long time or might not exit ought to call
1480 maybe_quit at least once, at a safe place. Unless that is
1481 impossible, of course. But it is very desirable to avoid creating
1482 loops where maybe_quit is impossible.
1484 If quit-flag is set to `kill-emacs' the SIGINT handler has received
1485 a request to exit Emacs when it is safe to do.
1487 When not quitting, process any pending signals.
1489 If you change this function, also adapt module_should_quit in
1495 if (!NILP (Vquit_flag
) && NILP (Vinhibit_quit
))
1496 process_quit_flag ();
1497 else if (pending_signals
)
1498 process_pending_signals ();
1501 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1502 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1503 This function does not return.
1505 An error symbol is a symbol with an `error-conditions' property
1506 that is a list of condition names. The symbol should be non-nil.
1507 A handler for any of those names will get to handle this signal.
1508 The symbol `error' should normally be one of them.
1510 DATA should be a list. Its elements are printed as part of the error message.
1511 See Info anchor `(elisp)Definition of signal' for some details on how this
1512 error message is constructed.
1513 If the signal is handled, DATA is made available to the handler.
1514 See also the function `condition-case'. */
1515 attributes
: noreturn
)
1516 (Lisp_Object error_symbol
, Lisp_Object data
)
1518 /* If they call us with nonsensical arguments, produce "peculiar error". */
1519 if (NILP (error_symbol
) && NILP (data
))
1520 error_symbol
= Qerror
;
1521 signal_or_quit (error_symbol
, data
, false);
1525 /* Quit, in response to a keyboard quit request. */
1529 return signal_or_quit (Qquit
, Qnil
, true);
1532 /* Signal an error, or quit. ERROR_SYMBOL and DATA are as with Fsignal.
1533 If KEYBOARD_QUIT, this is a quit; ERROR_SYMBOL should be
1534 Qquit and DATA should be Qnil, and this function may return.
1535 Otherwise this function is like Fsignal and does not return. */
1538 signal_or_quit (Lisp_Object error_symbol
, Lisp_Object data
, bool keyboard_quit
)
1540 /* When memory is full, ERROR-SYMBOL is nil,
1541 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1542 That is a special case--don't do this in other situations. */
1543 Lisp_Object conditions
;
1545 Lisp_Object real_error_symbol
1546 = (NILP (error_symbol
) ? Fcar (data
) : error_symbol
);
1547 Lisp_Object clause
= Qnil
;
1550 if (gc_in_progress
|| waiting_for_input
)
1553 #if 0 /* rms: I don't know why this was here,
1554 but it is surely wrong for an error that is handled. */
1555 #ifdef HAVE_WINDOW_SYSTEM
1556 if (display_hourglass_p
)
1557 cancel_hourglass ();
1561 /* This hook is used by edebug. */
1562 if (! NILP (Vsignal_hook_function
)
1563 && ! NILP (error_symbol
)
1564 /* Don't try to call a lisp function if we've already overflowed
1565 the specpdl stack. */
1566 && specpdl_ptr
< specpdl
+ specpdl_size
)
1568 /* Edebug takes care of restoring these variables when it exits. */
1569 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1570 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1572 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1573 max_specpdl_size
= SPECPDL_INDEX () + 40;
1575 call2 (Vsignal_hook_function
, error_symbol
, data
);
1578 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1580 /* Remember from where signal was called. Skip over the frame for
1581 `signal' itself. If a frame for `error' follows, skip that,
1582 too. Don't do this when ERROR_SYMBOL is nil, because that
1583 is a memory-full error. */
1584 Vsignaling_function
= Qnil
;
1585 if (!NILP (error_symbol
))
1587 union specbinding
*pdl
= backtrace_next (backtrace_top ());
1588 if (backtrace_p (pdl
) && EQ (backtrace_function (pdl
), Qerror
))
1589 pdl
= backtrace_next (pdl
);
1590 if (backtrace_p (pdl
))
1591 Vsignaling_function
= backtrace_function (pdl
);
1594 for (h
= handlerlist
; h
; h
= h
->next
)
1596 if (h
->type
!= CONDITION_CASE
)
1598 clause
= find_handler_clause (h
->tag_or_ch
, conditions
);
1603 if (/* Don't run the debugger for a memory-full error.
1604 (There is no room in memory to do that!) */
1605 !NILP (error_symbol
)
1606 && (!NILP (Vdebug_on_signal
)
1607 /* If no handler is present now, try to run the debugger. */
1609 /* A `debug' symbol in the handler list disables the normal
1610 suppression of the debugger. */
1611 || (CONSP (clause
) && !NILP (Fmemq (Qdebug
, clause
)))
1612 /* Special handler that means "print a message and run debugger
1614 || EQ (h
->tag_or_ch
, Qerror
)))
1616 bool debugger_called
1617 = maybe_call_debugger (conditions
, error_symbol
, data
);
1618 /* We can't return values to code which signaled an error, but we
1619 can continue code which has signaled a quit. */
1620 if (keyboard_quit
&& debugger_called
&& EQ (real_error_symbol
, Qquit
))
1626 Lisp_Object unwind_data
1627 = (NILP (error_symbol
) ? data
: Fcons (error_symbol
, data
));
1629 unwind_to_catch (h
, unwind_data
);
1633 if (handlerlist
!= handlerlist_sentinel
)
1634 /* FIXME: This will come right back here if there's no `top-level'
1635 catcher. A better solution would be to abort here, and instead
1636 add a catch-all condition handler so we never come here. */
1637 Fthrow (Qtop_level
, Qt
);
1640 if (! NILP (error_symbol
))
1641 data
= Fcons (error_symbol
, data
);
1643 string
= Ferror_message_string (data
);
1644 fatal ("%s", SDATA (string
));
1647 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1650 xsignal0 (Lisp_Object error_symbol
)
1652 xsignal (error_symbol
, Qnil
);
1656 xsignal1 (Lisp_Object error_symbol
, Lisp_Object arg
)
1658 xsignal (error_symbol
, list1 (arg
));
1662 xsignal2 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
)
1664 xsignal (error_symbol
, list2 (arg1
, arg2
));
1668 xsignal3 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
1670 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1673 /* Signal `error' with message S, and additional arg ARG.
1674 If ARG is not a genuine list, make it a one-element list. */
1677 signal_error (const char *s
, Lisp_Object arg
)
1679 Lisp_Object tortoise
, hare
;
1681 hare
= tortoise
= arg
;
1682 while (CONSP (hare
))
1689 tortoise
= XCDR (tortoise
);
1691 if (EQ (hare
, tortoise
))
1698 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1702 /* Return true if LIST is a non-nil atom or
1703 a list containing one of CONDITIONS. */
1706 wants_debugger (Lisp_Object list
, Lisp_Object conditions
)
1713 while (CONSP (conditions
))
1715 Lisp_Object
this, tail
;
1716 this = XCAR (conditions
);
1717 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1718 if (EQ (XCAR (tail
), this))
1720 conditions
= XCDR (conditions
);
1725 /* Return true if an error with condition-symbols CONDITIONS,
1726 and described by SIGNAL-DATA, should skip the debugger
1727 according to debugger-ignored-errors. */
1730 skip_debugger (Lisp_Object conditions
, Lisp_Object data
)
1733 bool first_string
= 1;
1734 Lisp_Object error_message
;
1736 error_message
= Qnil
;
1737 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1739 if (STRINGP (XCAR (tail
)))
1743 error_message
= Ferror_message_string (data
);
1747 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1752 Lisp_Object contail
;
1754 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1755 if (EQ (XCAR (tail
), XCAR (contail
)))
1763 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1764 SIG and DATA describe the signal. There are two ways to pass them:
1765 = SIG is the error symbol, and DATA is the rest of the data.
1766 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1767 This is for memory-full errors only. */
1769 maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
, Lisp_Object data
)
1771 Lisp_Object combined_data
;
1773 combined_data
= Fcons (sig
, data
);
1776 /* Don't try to run the debugger with interrupts blocked.
1777 The editing loop would return anyway. */
1778 ! input_blocked_p ()
1779 && NILP (Vinhibit_debugger
)
1780 /* Does user want to enter debugger for this kind of error? */
1783 : wants_debugger (Vdebug_on_error
, conditions
))
1784 && ! skip_debugger (conditions
, combined_data
)
1785 /* RMS: What's this for? */
1786 && when_entered_debugger
< num_nonmacro_input_events
)
1788 call_debugger (list2 (Qerror
, combined_data
));
1796 find_handler_clause (Lisp_Object handlers
, Lisp_Object conditions
)
1798 register Lisp_Object h
;
1800 /* t is used by handlers for all conditions, set up by C code. */
1801 if (EQ (handlers
, Qt
))
1804 /* error is used similarly, but means print an error message
1805 and run the debugger if that is enabled. */
1806 if (EQ (handlers
, Qerror
))
1809 for (h
= handlers
; CONSP (h
); h
= XCDR (h
))
1811 Lisp_Object handler
= XCAR (h
);
1812 if (!NILP (Fmemq (handler
, conditions
)))
1820 /* Format and return a string; called like vprintf. */
1822 vformat_string (const char *m
, va_list ap
)
1825 ptrdiff_t size
= sizeof buf
;
1826 ptrdiff_t size_max
= STRING_BYTES_BOUND
+ 1;
1831 used
= evxprintf (&buffer
, &size
, buf
, size_max
, m
, ap
);
1832 string
= make_string (buffer
, used
);
1839 /* Dump an error message; called like vprintf. */
1841 verror (const char *m
, va_list ap
)
1843 xsignal1 (Qerror
, vformat_string (m
, ap
));
1847 /* Dump an error message; called like printf. */
1851 error (const char *m
, ...)
1858 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
1859 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
1860 This means it contains a description for how to read arguments to give it.
1861 The value is nil for an invalid function or a symbol with no function
1864 Interactively callable functions include strings and vectors (treated
1865 as keyboard macros), lambda-expressions that contain a top-level call
1866 to `interactive', autoload definitions made by `autoload' with non-nil
1867 fourth argument, and some of the built-in functions of Lisp.
1869 Also, a symbol satisfies `commandp' if its function definition does so.
1871 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
1872 then strings and vectors are not accepted. */)
1873 (Lisp_Object function
, Lisp_Object for_call_interactively
)
1875 register Lisp_Object fun
;
1876 register Lisp_Object funcar
;
1877 Lisp_Object if_prop
= Qnil
;
1881 fun
= indirect_function (fun
); /* Check cycles. */
1885 /* Check an `interactive-form' property if present, analogous to the
1886 function-documentation property. */
1888 while (SYMBOLP (fun
))
1890 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
1893 fun
= Fsymbol_function (fun
);
1896 /* Emacs primitives are interactive if their DEFUN specifies an
1897 interactive spec. */
1899 return XSUBR (fun
)->intspec
? Qt
: if_prop
;
1901 /* Bytecode objects are interactive if they are long enough to
1902 have an element whose index is COMPILED_INTERACTIVE, which is
1903 where the interactive spec is stored. */
1904 else if (COMPILEDP (fun
))
1905 return (PVSIZE (fun
) > COMPILED_INTERACTIVE
? Qt
: if_prop
);
1907 /* Strings and vectors are keyboard macros. */
1908 if (STRINGP (fun
) || VECTORP (fun
))
1909 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
1911 /* Lists may represent commands. */
1914 funcar
= XCAR (fun
);
1915 if (EQ (funcar
, Qclosure
))
1916 return (!NILP (Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
)))))
1918 else if (EQ (funcar
, Qlambda
))
1919 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
1920 else if (EQ (funcar
, Qautoload
))
1921 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
1926 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1927 doc
: /* Define FUNCTION to autoload from FILE.
1928 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
1929 Third arg DOCSTRING is documentation for the function.
1930 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
1931 Fifth arg TYPE indicates the type of the object:
1932 nil or omitted says FUNCTION is a function,
1933 `keymap' says FUNCTION is really a keymap, and
1934 `macro' or t says FUNCTION is really a macro.
1935 Third through fifth args give info about the real definition.
1936 They default to nil.
1937 If FUNCTION is already defined other than as an autoload,
1938 this does nothing and returns nil. */)
1939 (Lisp_Object function
, Lisp_Object file
, Lisp_Object docstring
, Lisp_Object interactive
, Lisp_Object type
)
1941 CHECK_SYMBOL (function
);
1942 CHECK_STRING (file
);
1944 /* If function is defined and not as an autoload, don't override. */
1945 if (!NILP (XSYMBOL (function
)->u
.s
.function
)
1946 && !AUTOLOADP (XSYMBOL (function
)->u
.s
.function
))
1949 if (!NILP (Vpurify_flag
) && EQ (docstring
, make_number (0)))
1950 /* `read1' in lread.c has found the docstring starting with "\
1951 and assumed the docstring will be provided by Snarf-documentation, so it
1952 passed us 0 instead. But that leads to accidental sharing in purecopy's
1953 hash-consing, so we use a (hopefully) unique integer instead. */
1954 docstring
= make_number (XHASH (function
));
1955 return Fdefalias (function
,
1956 list5 (Qautoload
, file
, docstring
, interactive
, type
),
1961 un_autoload (Lisp_Object oldqueue
)
1963 Lisp_Object queue
, first
, second
;
1965 /* Queue to unwind is current value of Vautoload_queue.
1966 oldqueue is the shadowed value to leave in Vautoload_queue. */
1967 queue
= Vautoload_queue
;
1968 Vautoload_queue
= oldqueue
;
1969 while (CONSP (queue
))
1971 first
= XCAR (queue
);
1972 second
= Fcdr (first
);
1973 first
= Fcar (first
);
1974 if (EQ (first
, make_number (0)))
1977 Ffset (first
, second
);
1978 queue
= XCDR (queue
);
1982 /* Load an autoloaded function.
1983 FUNNAME is the symbol which is the function's name.
1984 FUNDEF is the autoload definition (a list). */
1986 DEFUN ("autoload-do-load", Fautoload_do_load
, Sautoload_do_load
, 1, 3, 0,
1987 doc
: /* Load FUNDEF which should be an autoload.
1988 If non-nil, FUNNAME should be the symbol whose function value is FUNDEF,
1989 in which case the function returns the new autoloaded function value.
1990 If equal to `macro', MACRO-ONLY specifies that FUNDEF should only be loaded if
1991 it defines a macro. */)
1992 (Lisp_Object fundef
, Lisp_Object funname
, Lisp_Object macro_only
)
1994 ptrdiff_t count
= SPECPDL_INDEX ();
1996 if (!CONSP (fundef
) || !EQ (Qautoload
, XCAR (fundef
)))
1999 if (EQ (macro_only
, Qmacro
))
2001 Lisp_Object kind
= Fnth (make_number (4), fundef
);
2002 if (! (EQ (kind
, Qt
) || EQ (kind
, Qmacro
)))
2006 /* This is to make sure that loadup.el gives a clear picture
2007 of what files are preloaded and when. */
2008 if (! NILP (Vpurify_flag
))
2009 error ("Attempt to autoload %s while preparing to dump",
2010 SDATA (SYMBOL_NAME (funname
)));
2012 CHECK_SYMBOL (funname
);
2014 /* Preserve the match data. */
2015 record_unwind_save_match_data ();
2017 /* If autoloading gets an error (which includes the error of failing
2018 to define the function being called), we use Vautoload_queue
2019 to undo function definitions and `provide' calls made by
2020 the function. We do this in the specific case of autoloading
2021 because autoloading is not an explicit request "load this file",
2022 but rather a request to "call this function".
2024 The value saved here is to be restored into Vautoload_queue. */
2025 record_unwind_protect (un_autoload
, Vautoload_queue
);
2026 Vautoload_queue
= Qt
;
2027 /* If `macro_only', assume this autoload to be a "best-effort",
2028 so don't signal an error if autoloading fails. */
2029 Fload (Fcar (Fcdr (fundef
)), macro_only
, Qt
, Qnil
, Qt
);
2031 /* Once loading finishes, don't undo it. */
2032 Vautoload_queue
= Qt
;
2033 unbind_to (count
, Qnil
);
2039 Lisp_Object fun
= Findirect_function (funname
, Qnil
);
2041 if (!NILP (Fequal (fun
, fundef
)))
2042 error ("Autoloading file %s failed to define function %s",
2043 SDATA (Fcar (Fcar (Vload_history
))),
2044 SDATA (SYMBOL_NAME (funname
)));
2051 DEFUN ("eval", Feval
, Seval
, 1, 2, 0,
2052 doc
: /* Evaluate FORM and return its value.
2053 If LEXICAL is t, evaluate using lexical scoping.
2054 LEXICAL can also be an actual lexical environment, in the form of an
2055 alist mapping symbols to their value. */)
2056 (Lisp_Object form
, Lisp_Object lexical
)
2058 ptrdiff_t count
= SPECPDL_INDEX ();
2059 specbind (Qinternal_interpreter_environment
,
2060 CONSP (lexical
) || NILP (lexical
) ? lexical
: list1 (Qt
));
2061 return unbind_to (count
, eval_sub (form
));
2064 /* Grow the specpdl stack by one entry.
2065 The caller should have already initialized the entry.
2066 Signal an error on stack overflow.
2068 Make sure that there is always one unused entry past the top of the
2069 stack, so that the just-initialized entry is safely unwound if
2070 memory exhausted and an error is signaled here. Also, allocate a
2071 never-used entry just before the bottom of the stack; sometimes its
2072 address is taken. */
2079 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2081 ptrdiff_t count
= SPECPDL_INDEX ();
2082 ptrdiff_t max_size
= min (max_specpdl_size
, PTRDIFF_MAX
- 1000);
2083 union specbinding
*pdlvec
= specpdl
- 1;
2084 ptrdiff_t pdlvecsize
= specpdl_size
+ 1;
2085 if (max_size
<= specpdl_size
)
2087 if (max_specpdl_size
< 400)
2088 max_size
= max_specpdl_size
= 400;
2089 if (max_size
<= specpdl_size
)
2090 signal_error ("Variable binding depth exceeds max-specpdl-size",
2093 pdlvec
= xpalloc (pdlvec
, &pdlvecsize
, 1, max_size
+ 1, sizeof *specpdl
);
2094 specpdl
= pdlvec
+ 1;
2095 specpdl_size
= pdlvecsize
- 1;
2096 specpdl_ptr
= specpdl
+ count
;
2101 record_in_backtrace (Lisp_Object function
, Lisp_Object
*args
, ptrdiff_t nargs
)
2103 ptrdiff_t count
= SPECPDL_INDEX ();
2105 eassert (nargs
>= UNEVALLED
);
2106 specpdl_ptr
->bt
.kind
= SPECPDL_BACKTRACE
;
2107 specpdl_ptr
->bt
.debug_on_exit
= false;
2108 specpdl_ptr
->bt
.function
= function
;
2109 current_thread
->stack_top
= specpdl_ptr
->bt
.args
= args
;
2110 specpdl_ptr
->bt
.nargs
= nargs
;
2116 /* Eval a sub-expression of the current expression (i.e. in the same
2119 eval_sub (Lisp_Object form
)
2121 Lisp_Object fun
, val
, original_fun
, original_args
;
2125 /* Declare here, as this array may be accessed by call_debugger near
2126 the end of this function. See Bug#21245. */
2127 Lisp_Object argvals
[8];
2131 /* Look up its binding in the lexical environment.
2132 We do not pay attention to the declared_special flag here, since we
2133 already did that when let-binding the variable. */
2134 Lisp_Object lex_binding
2135 = !NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
2136 ? Fassq (form
, Vinternal_interpreter_environment
)
2138 if (CONSP (lex_binding
))
2139 return XCDR (lex_binding
);
2141 return Fsymbol_value (form
);
2151 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2153 if (max_lisp_eval_depth
< 100)
2154 max_lisp_eval_depth
= 100;
2155 if (lisp_eval_depth
> max_lisp_eval_depth
)
2156 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2159 original_fun
= XCAR (form
);
2160 original_args
= XCDR (form
);
2161 CHECK_LIST (original_args
);
2163 /* This also protects them from gc. */
2164 count
= record_in_backtrace (original_fun
, &original_args
, UNEVALLED
);
2166 if (debug_on_next_call
)
2167 do_debug_on_call (Qt
, count
);
2169 /* At this point, only original_fun and original_args
2170 have values that will be used below. */
2173 /* Optimize for no indirection. */
2176 fun
= Ffunction (Fcons (fun
, Qnil
));
2177 else if (!NILP (fun
) && (fun
= XSYMBOL (fun
)->u
.s
.function
, SYMBOLP (fun
)))
2178 fun
= indirect_function (fun
);
2182 Lisp_Object args_left
= original_args
;
2183 Lisp_Object numargs
= Flength (args_left
);
2187 if (XINT (numargs
) < XSUBR (fun
)->min_args
2188 || (XSUBR (fun
)->max_args
>= 0
2189 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2190 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2192 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2193 val
= (XSUBR (fun
)->function
.aUNEVALLED
) (args_left
);
2194 else if (XSUBR (fun
)->max_args
== MANY
)
2196 /* Pass a vector of evaluated arguments. */
2198 ptrdiff_t argnum
= 0;
2201 SAFE_ALLOCA_LISP (vals
, XINT (numargs
));
2203 while (CONSP (args_left
) && argnum
< XINT (numargs
))
2205 Lisp_Object arg
= XCAR (args_left
);
2206 args_left
= XCDR (args_left
);
2207 vals
[argnum
++] = eval_sub (arg
);
2210 set_backtrace_args (specpdl
+ count
, vals
, argnum
);
2212 val
= XSUBR (fun
)->function
.aMANY (argnum
, vals
);
2216 /* Do the debug-on-exit now, while VALS still exists. */
2217 if (backtrace_debug_on_exit (specpdl
+ count
))
2218 val
= call_debugger (list2 (Qexit
, val
));
2225 int i
, maxargs
= XSUBR (fun
)->max_args
;
2227 for (i
= 0; i
< maxargs
; i
++)
2229 argvals
[i
] = eval_sub (Fcar (args_left
));
2230 args_left
= Fcdr (args_left
);
2233 set_backtrace_args (specpdl
+ count
, argvals
, XINT (numargs
));
2238 val
= (XSUBR (fun
)->function
.a0 ());
2241 val
= (XSUBR (fun
)->function
.a1 (argvals
[0]));
2244 val
= (XSUBR (fun
)->function
.a2 (argvals
[0], argvals
[1]));
2247 val
= (XSUBR (fun
)->function
.a3
2248 (argvals
[0], argvals
[1], argvals
[2]));
2251 val
= (XSUBR (fun
)->function
.a4
2252 (argvals
[0], argvals
[1], argvals
[2], argvals
[3]));
2255 val
= (XSUBR (fun
)->function
.a5
2256 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2260 val
= (XSUBR (fun
)->function
.a6
2261 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2262 argvals
[4], argvals
[5]));
2265 val
= (XSUBR (fun
)->function
.a7
2266 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2267 argvals
[4], argvals
[5], argvals
[6]));
2271 val
= (XSUBR (fun
)->function
.a8
2272 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2273 argvals
[4], argvals
[5], argvals
[6], argvals
[7]));
2277 /* Someone has created a subr that takes more arguments than
2278 is supported by this code. We need to either rewrite the
2279 subr to use a different argument protocol, or add more
2280 cases to this switch. */
2285 else if (COMPILEDP (fun
) || MODULE_FUNCTIONP (fun
))
2286 return apply_lambda (fun
, original_args
, count
);
2290 xsignal1 (Qvoid_function
, original_fun
);
2292 xsignal1 (Qinvalid_function
, original_fun
);
2293 funcar
= XCAR (fun
);
2294 if (!SYMBOLP (funcar
))
2295 xsignal1 (Qinvalid_function
, original_fun
);
2296 if (EQ (funcar
, Qautoload
))
2298 Fautoload_do_load (fun
, original_fun
, Qnil
);
2301 if (EQ (funcar
, Qmacro
))
2303 ptrdiff_t count1
= SPECPDL_INDEX ();
2305 /* Bind lexical-binding during expansion of the macro, so the
2306 macro can know reliably if the code it outputs will be
2307 interpreted using lexical-binding or not. */
2308 specbind (Qlexical_binding
,
2309 NILP (Vinternal_interpreter_environment
) ? Qnil
: Qt
);
2310 exp
= apply1 (Fcdr (fun
), original_args
);
2311 unbind_to (count1
, Qnil
);
2312 val
= eval_sub (exp
);
2314 else if (EQ (funcar
, Qlambda
)
2315 || EQ (funcar
, Qclosure
))
2316 return apply_lambda (fun
, original_args
, count
);
2318 xsignal1 (Qinvalid_function
, original_fun
);
2323 if (backtrace_debug_on_exit (specpdl
+ count
))
2324 val
= call_debugger (list2 (Qexit
, val
));
2330 DEFUN ("apply", Fapply
, Sapply
, 1, MANY
, 0,
2331 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2332 Then return the value FUNCTION returns.
2333 Thus, (apply \\='+ 1 2 \\='(3 4)) returns 10.
2334 usage: (apply FUNCTION &rest ARGUMENTS) */)
2335 (ptrdiff_t nargs
, Lisp_Object
*args
)
2337 ptrdiff_t i
, numargs
, funcall_nargs
;
2338 register Lisp_Object
*funcall_args
= NULL
;
2339 register Lisp_Object spread_arg
= args
[nargs
- 1];
2340 Lisp_Object fun
= args
[0];
2344 CHECK_LIST (spread_arg
);
2346 numargs
= XINT (Flength (spread_arg
));
2349 return Ffuncall (nargs
- 1, args
);
2350 else if (numargs
== 1)
2352 args
[nargs
- 1] = XCAR (spread_arg
);
2353 return Ffuncall (nargs
, args
);
2356 numargs
+= nargs
- 2;
2358 /* Optimize for no indirection. */
2359 if (SYMBOLP (fun
) && !NILP (fun
)
2360 && (fun
= XSYMBOL (fun
)->u
.s
.function
, SYMBOLP (fun
)))
2362 fun
= indirect_function (fun
);
2364 /* Let funcall get the error. */
2368 if (SUBRP (fun
) && XSUBR (fun
)->max_args
> numargs
2369 /* Don't hide an error by adding missing arguments. */
2370 && numargs
>= XSUBR (fun
)->min_args
)
2372 /* Avoid making funcall cons up a yet another new vector of arguments
2373 by explicitly supplying nil's for optional values. */
2374 SAFE_ALLOCA_LISP (funcall_args
, 1 + XSUBR (fun
)->max_args
);
2375 memclear (funcall_args
+ numargs
+ 1,
2376 (XSUBR (fun
)->max_args
- numargs
) * word_size
);
2377 funcall_nargs
= 1 + XSUBR (fun
)->max_args
;
2380 { /* We add 1 to numargs because funcall_args includes the
2381 function itself as well as its arguments. */
2382 SAFE_ALLOCA_LISP (funcall_args
, 1 + numargs
);
2383 funcall_nargs
= 1 + numargs
;
2386 memcpy (funcall_args
, args
, nargs
* word_size
);
2387 /* Spread the last arg we got. Its first element goes in
2388 the slot that it used to occupy, hence this value of I. */
2390 while (!NILP (spread_arg
))
2392 funcall_args
[i
++] = XCAR (spread_arg
);
2393 spread_arg
= XCDR (spread_arg
);
2396 retval
= Ffuncall (funcall_nargs
, funcall_args
);
2402 /* Run hook variables in various ways. */
2405 funcall_nil (ptrdiff_t nargs
, Lisp_Object
*args
)
2407 Ffuncall (nargs
, args
);
2411 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2412 doc
: /* Run each hook in HOOKS.
2413 Each argument should be a symbol, a hook variable.
2414 These symbols are processed in the order specified.
2415 If a hook symbol has a non-nil value, that value may be a function
2416 or a list of functions to be called to run the hook.
2417 If the value is a function, it is called with no arguments.
2418 If it is a list, the elements are called, in order, with no arguments.
2420 Major modes should not use this function directly to run their mode
2421 hook; they should use `run-mode-hooks' instead.
2423 Do not use `make-local-variable' to make a hook variable buffer-local.
2424 Instead, use `add-hook' and specify t for the LOCAL argument.
2425 usage: (run-hooks &rest HOOKS) */)
2426 (ptrdiff_t nargs
, Lisp_Object
*args
)
2430 for (i
= 0; i
< nargs
; i
++)
2436 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2437 Srun_hook_with_args
, 1, MANY
, 0,
2438 doc
: /* Run HOOK with the specified arguments ARGS.
2439 HOOK should be a symbol, a hook variable. The value of HOOK
2440 may be nil, a function, or a list of functions. Call each
2441 function in order with arguments ARGS. The final return value
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 HOOK &rest ARGS) */)
2447 (ptrdiff_t nargs
, Lisp_Object
*args
)
2449 return run_hook_with_args (nargs
, args
, funcall_nil
);
2452 /* NB this one still documents a specific non-nil return value.
2453 (As did run-hook-with-args and run-hook-with-args-until-failure
2454 until they were changed in 24.1.) */
2455 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2456 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2457 doc
: /* Run HOOK with the specified arguments ARGS.
2458 HOOK should be a symbol, a hook variable. The value of HOOK
2459 may be nil, a function, or a list of functions. Call each
2460 function in order with arguments ARGS, stopping at the first
2461 one that returns non-nil, and return that value. Otherwise (if
2462 all functions return nil, or if there are no functions to call),
2465 Do not use `make-local-variable' to make a hook variable buffer-local.
2466 Instead, use `add-hook' and specify t for the LOCAL argument.
2467 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2468 (ptrdiff_t nargs
, Lisp_Object
*args
)
2470 return run_hook_with_args (nargs
, args
, Ffuncall
);
2474 funcall_not (ptrdiff_t nargs
, Lisp_Object
*args
)
2476 return NILP (Ffuncall (nargs
, args
)) ? Qt
: Qnil
;
2479 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2480 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2481 doc
: /* Run HOOK with the specified arguments ARGS.
2482 HOOK should be a symbol, a hook variable. The value of HOOK
2483 may be nil, a function, or a list of functions. Call each
2484 function in order with arguments ARGS, stopping at the first
2485 one that returns nil, and return nil. Otherwise (if all functions
2486 return non-nil, or if there are no functions to call), return non-nil
2487 \(do not rely on the precise return value in this case).
2489 Do not use `make-local-variable' to make a hook variable buffer-local.
2490 Instead, use `add-hook' and specify t for the LOCAL argument.
2491 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2492 (ptrdiff_t nargs
, Lisp_Object
*args
)
2494 return NILP (run_hook_with_args (nargs
, args
, funcall_not
)) ? Qt
: Qnil
;
2498 run_hook_wrapped_funcall (ptrdiff_t nargs
, Lisp_Object
*args
)
2500 Lisp_Object tmp
= args
[0], ret
;
2503 ret
= Ffuncall (nargs
, args
);
2509 DEFUN ("run-hook-wrapped", Frun_hook_wrapped
, Srun_hook_wrapped
, 2, MANY
, 0,
2510 doc
: /* Run HOOK, passing each function through WRAP-FUNCTION.
2511 I.e. instead of calling each function FUN directly with arguments ARGS,
2512 it calls WRAP-FUNCTION with arguments FUN and ARGS.
2513 As soon as a call to WRAP-FUNCTION returns non-nil, `run-hook-wrapped'
2514 aborts and returns that value.
2515 usage: (run-hook-wrapped HOOK WRAP-FUNCTION &rest ARGS) */)
2516 (ptrdiff_t nargs
, Lisp_Object
*args
)
2518 return run_hook_with_args (nargs
, args
, run_hook_wrapped_funcall
);
2521 /* ARGS[0] should be a hook symbol.
2522 Call each of the functions in the hook value, passing each of them
2523 as arguments all the rest of ARGS (all NARGS - 1 elements).
2524 FUNCALL specifies how to call each function on the hook. */
2527 run_hook_with_args (ptrdiff_t nargs
, Lisp_Object
*args
,
2528 Lisp_Object (*funcall
) (ptrdiff_t nargs
, Lisp_Object
*args
))
2530 Lisp_Object sym
, val
, ret
= Qnil
;
2532 /* If we are dying or still initializing,
2533 don't do anything--it would probably crash if we tried. */
2534 if (NILP (Vrun_hooks
))
2538 val
= find_symbol_value (sym
);
2540 if (EQ (val
, Qunbound
) || NILP (val
))
2542 else if (!CONSP (val
) || FUNCTIONP (val
))
2545 return funcall (nargs
, args
);
2549 Lisp_Object global_vals
= Qnil
;
2552 CONSP (val
) && NILP (ret
);
2555 if (EQ (XCAR (val
), Qt
))
2557 /* t indicates this hook has a local binding;
2558 it means to run the global binding too. */
2559 global_vals
= Fdefault_value (sym
);
2560 if (NILP (global_vals
)) continue;
2562 if (!CONSP (global_vals
) || EQ (XCAR (global_vals
), Qlambda
))
2564 args
[0] = global_vals
;
2565 ret
= funcall (nargs
, args
);
2570 CONSP (global_vals
) && NILP (ret
);
2571 global_vals
= XCDR (global_vals
))
2573 args
[0] = XCAR (global_vals
);
2574 /* In a global value, t should not occur. If it does, we
2575 must ignore it to avoid an endless loop. */
2576 if (!EQ (args
[0], Qt
))
2577 ret
= funcall (nargs
, args
);
2583 args
[0] = XCAR (val
);
2584 ret
= funcall (nargs
, args
);
2592 /* Run the hook HOOK, giving each function no args. */
2595 run_hook (Lisp_Object hook
)
2597 Frun_hook_with_args (1, &hook
);
2600 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2603 run_hook_with_args_2 (Lisp_Object hook
, Lisp_Object arg1
, Lisp_Object arg2
)
2605 CALLN (Frun_hook_with_args
, hook
, arg1
, arg2
);
2608 /* Apply fn to arg. */
2610 apply1 (Lisp_Object fn
, Lisp_Object arg
)
2612 return NILP (arg
) ? Ffuncall (1, &fn
) : CALLN (Fapply
, fn
, arg
);
2615 /* Call function fn on no arguments. */
2617 call0 (Lisp_Object fn
)
2619 return Ffuncall (1, &fn
);
2622 /* Call function fn with 1 argument arg1. */
2625 call1 (Lisp_Object fn
, Lisp_Object arg1
)
2627 return CALLN (Ffuncall
, fn
, arg1
);
2630 /* Call function fn with 2 arguments arg1, arg2. */
2633 call2 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
)
2635 return CALLN (Ffuncall
, fn
, arg1
, arg2
);
2638 /* Call function fn with 3 arguments arg1, arg2, arg3. */
2641 call3 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2643 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
);
2646 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
2649 call4 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2652 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
);
2655 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
2658 call5 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2659 Lisp_Object arg4
, Lisp_Object arg5
)
2661 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
);
2664 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
2667 call6 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2668 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
)
2670 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
);
2673 /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
2676 call7 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2677 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
)
2679 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
);
2682 /* Call function fn with 8 arguments arg1, arg2, arg3, arg4, arg5,
2683 arg6, arg7, arg8. */
2686 call8 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2687 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
,
2690 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
, arg8
);
2693 DEFUN ("functionp", Ffunctionp
, Sfunctionp
, 1, 1, 0,
2694 doc
: /* Return t if OBJECT is a function. */)
2695 (Lisp_Object object
)
2697 if (FUNCTIONP (object
))
2703 FUNCTIONP (Lisp_Object object
)
2705 if (SYMBOLP (object
) && !NILP (Ffboundp (object
)))
2707 object
= Findirect_function (object
, Qt
);
2709 if (CONSP (object
) && EQ (XCAR (object
), Qautoload
))
2711 /* Autoloaded symbols are functions, except if they load
2712 macros or keymaps. */
2713 for (int i
= 0; i
< 4 && CONSP (object
); i
++)
2714 object
= XCDR (object
);
2716 return ! (CONSP (object
) && !NILP (XCAR (object
)));
2721 return XSUBR (object
)->max_args
!= UNEVALLED
;
2722 else if (COMPILEDP (object
) || MODULE_FUNCTIONP (object
))
2724 else if (CONSP (object
))
2726 Lisp_Object car
= XCAR (object
);
2727 return EQ (car
, Qlambda
) || EQ (car
, Qclosure
);
2733 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2734 doc
: /* Call first argument as a function, passing remaining arguments to it.
2735 Return the value that function returns.
2736 Thus, (funcall \\='cons \\='x \\='y) returns (x . y).
2737 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2738 (ptrdiff_t nargs
, Lisp_Object
*args
)
2740 Lisp_Object fun
, original_fun
;
2742 ptrdiff_t numargs
= nargs
- 1;
2748 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2750 if (max_lisp_eval_depth
< 100)
2751 max_lisp_eval_depth
= 100;
2752 if (lisp_eval_depth
> max_lisp_eval_depth
)
2753 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2756 count
= record_in_backtrace (args
[0], &args
[1], nargs
- 1);
2760 if (debug_on_next_call
)
2761 do_debug_on_call (Qlambda
, count
);
2765 original_fun
= args
[0];
2769 /* Optimize for no indirection. */
2771 if (SYMBOLP (fun
) && !NILP (fun
)
2772 && (fun
= XSYMBOL (fun
)->u
.s
.function
, SYMBOLP (fun
)))
2773 fun
= indirect_function (fun
);
2776 val
= funcall_subr (XSUBR (fun
), numargs
, args
+ 1);
2777 else if (COMPILEDP (fun
) || MODULE_FUNCTIONP (fun
))
2778 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2782 xsignal1 (Qvoid_function
, original_fun
);
2784 xsignal1 (Qinvalid_function
, original_fun
);
2785 funcar
= XCAR (fun
);
2786 if (!SYMBOLP (funcar
))
2787 xsignal1 (Qinvalid_function
, original_fun
);
2788 if (EQ (funcar
, Qlambda
)
2789 || EQ (funcar
, Qclosure
))
2790 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2791 else if (EQ (funcar
, Qautoload
))
2793 Fautoload_do_load (fun
, original_fun
, Qnil
);
2798 xsignal1 (Qinvalid_function
, original_fun
);
2802 if (backtrace_debug_on_exit (specpdl
+ count
))
2803 val
= call_debugger (list2 (Qexit
, val
));
2809 /* Apply a C subroutine SUBR to the NUMARGS evaluated arguments in ARG_VECTOR
2810 and return the result of evaluation. */
2813 funcall_subr (struct Lisp_Subr
*subr
, ptrdiff_t numargs
, Lisp_Object
*args
)
2815 if (numargs
< subr
->min_args
2816 || (subr
->max_args
>= 0 && subr
->max_args
< numargs
))
2819 XSETSUBR (fun
, subr
);
2820 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (numargs
));
2823 else if (subr
->max_args
== UNEVALLED
)
2826 XSETSUBR (fun
, subr
);
2827 xsignal1 (Qinvalid_function
, fun
);
2830 else if (subr
->max_args
== MANY
)
2831 return (subr
->function
.aMANY
) (numargs
, args
);
2834 Lisp_Object internal_argbuf
[8];
2835 Lisp_Object
*internal_args
;
2836 if (subr
->max_args
> numargs
)
2838 eassert (subr
->max_args
<= ARRAYELTS (internal_argbuf
));
2839 internal_args
= internal_argbuf
;
2840 memcpy (internal_args
, args
, numargs
* word_size
);
2841 memclear (internal_args
+ numargs
,
2842 (subr
->max_args
- numargs
) * word_size
);
2845 internal_args
= args
;
2846 switch (subr
->max_args
)
2849 return (subr
->function
.a0 ());
2851 return (subr
->function
.a1 (internal_args
[0]));
2853 return (subr
->function
.a2
2854 (internal_args
[0], internal_args
[1]));
2856 return (subr
->function
.a3
2857 (internal_args
[0], internal_args
[1], internal_args
[2]));
2859 return (subr
->function
.a4
2860 (internal_args
[0], internal_args
[1], internal_args
[2],
2863 return (subr
->function
.a5
2864 (internal_args
[0], internal_args
[1], internal_args
[2],
2865 internal_args
[3], internal_args
[4]));
2867 return (subr
->function
.a6
2868 (internal_args
[0], internal_args
[1], internal_args
[2],
2869 internal_args
[3], internal_args
[4], internal_args
[5]));
2871 return (subr
->function
.a7
2872 (internal_args
[0], internal_args
[1], internal_args
[2],
2873 internal_args
[3], internal_args
[4], internal_args
[5],
2876 return (subr
->function
.a8
2877 (internal_args
[0], internal_args
[1], internal_args
[2],
2878 internal_args
[3], internal_args
[4], internal_args
[5],
2879 internal_args
[6], internal_args
[7]));
2883 /* If a subr takes more than 8 arguments without using MANY
2884 or UNEVALLED, we need to extend this function to support it.
2885 Until this is done, there is no way to call the function. */
2892 apply_lambda (Lisp_Object fun
, Lisp_Object args
, ptrdiff_t count
)
2894 Lisp_Object args_left
;
2897 Lisp_Object
*arg_vector
;
2901 numargs
= XFASTINT (Flength (args
));
2902 SAFE_ALLOCA_LISP (arg_vector
, numargs
);
2905 for (i
= 0; i
< numargs
; )
2907 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2908 tem
= eval_sub (tem
);
2909 arg_vector
[i
++] = tem
;
2912 set_backtrace_args (specpdl
+ count
, arg_vector
, i
);
2913 tem
= funcall_lambda (fun
, numargs
, arg_vector
);
2917 /* Do the debug-on-exit now, while arg_vector still exists. */
2918 if (backtrace_debug_on_exit (specpdl
+ count
))
2919 tem
= call_debugger (list2 (Qexit
, tem
));
2925 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2926 and return the result of evaluation.
2927 FUN must be either a lambda-expression, a compiled-code object,
2928 or a module function. */
2931 funcall_lambda (Lisp_Object fun
, ptrdiff_t nargs
,
2932 register Lisp_Object
*arg_vector
)
2934 Lisp_Object val
, syms_left
, next
, lexenv
;
2935 ptrdiff_t count
= SPECPDL_INDEX ();
2937 bool optional
, rest
;
2941 if (EQ (XCAR (fun
), Qclosure
))
2943 Lisp_Object cdr
= XCDR (fun
); /* Drop `closure'. */
2945 xsignal1 (Qinvalid_function
, fun
);
2947 lexenv
= XCAR (fun
);
2951 syms_left
= XCDR (fun
);
2952 if (CONSP (syms_left
))
2953 syms_left
= XCAR (syms_left
);
2955 xsignal1 (Qinvalid_function
, fun
);
2957 else if (COMPILEDP (fun
))
2959 ptrdiff_t size
= PVSIZE (fun
);
2960 if (size
<= COMPILED_STACK_DEPTH
)
2961 xsignal1 (Qinvalid_function
, fun
);
2962 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
2963 if (INTEGERP (syms_left
))
2964 /* A byte-code object with an integer args template means we
2965 shouldn't bind any arguments, instead just call the byte-code
2966 interpreter directly; it will push arguments as necessary.
2968 Byte-code objects with a nil args template (the default)
2969 have dynamically-bound arguments, and use the
2970 argument-binding code below instead (as do all interpreted
2971 functions, even lexically bound ones). */
2973 /* If we have not actually read the bytecode string
2974 and constants vector yet, fetch them from the file. */
2975 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
2976 Ffetch_bytecode (fun
);
2977 return exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
2978 AREF (fun
, COMPILED_CONSTANTS
),
2979 AREF (fun
, COMPILED_STACK_DEPTH
),
2986 else if (MODULE_FUNCTIONP (fun
))
2987 return funcall_module (fun
, nargs
, arg_vector
);
2992 i
= optional
= rest
= 0;
2993 bool previous_optional_or_rest
= false;
2994 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
2998 next
= XCAR (syms_left
);
2999 if (!SYMBOLP (next
))
3000 xsignal1 (Qinvalid_function
, fun
);
3002 if (EQ (next
, Qand_rest
))
3004 if (rest
|| previous_optional_or_rest
)
3005 xsignal1 (Qinvalid_function
, fun
);
3007 previous_optional_or_rest
= true;
3009 else if (EQ (next
, Qand_optional
))
3011 if (optional
|| rest
|| previous_optional_or_rest
)
3012 xsignal1 (Qinvalid_function
, fun
);
3014 previous_optional_or_rest
= true;
3021 arg
= Flist (nargs
- i
, &arg_vector
[i
]);
3025 arg
= arg_vector
[i
++];
3027 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3031 /* Bind the argument. */
3032 if (!NILP (lexenv
) && SYMBOLP (next
))
3033 /* Lexically bind NEXT by adding it to the lexenv alist. */
3034 lexenv
= Fcons (Fcons (next
, arg
), lexenv
);
3036 /* Dynamically bind NEXT. */
3037 specbind (next
, arg
);
3038 previous_optional_or_rest
= false;
3042 if (!NILP (syms_left
) || previous_optional_or_rest
)
3043 xsignal1 (Qinvalid_function
, fun
);
3045 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3047 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
3048 /* Instantiate a new lexical environment. */
3049 specbind (Qinternal_interpreter_environment
, lexenv
);
3052 val
= Fprogn (XCDR (XCDR (fun
)));
3055 /* If we have not actually read the bytecode string
3056 and constants vector yet, fetch them from the file. */
3057 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3058 Ffetch_bytecode (fun
);
3059 val
= exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
3060 AREF (fun
, COMPILED_CONSTANTS
),
3061 AREF (fun
, COMPILED_STACK_DEPTH
),
3065 return unbind_to (count
, val
);
3068 DEFUN ("func-arity", Ffunc_arity
, Sfunc_arity
, 1, 1, 0,
3069 doc
: /* Return minimum and maximum number of args allowed for FUNCTION.
3070 FUNCTION must be a function of some kind.
3071 The returned value is a cons cell (MIN . MAX). MIN is the minimum number
3072 of args. MAX is the maximum number, or the symbol `many', for a
3073 function with `&rest' args, or `unevalled' for a special form. */)
3074 (Lisp_Object function
)
3076 Lisp_Object original
;
3080 original
= function
;
3084 /* Optimize for no indirection. */
3085 function
= original
;
3086 if (SYMBOLP (function
) && !NILP (function
))
3088 function
= XSYMBOL (function
)->u
.s
.function
;
3089 if (SYMBOLP (function
))
3090 function
= indirect_function (function
);
3093 if (CONSP (function
) && EQ (XCAR (function
), Qmacro
))
3094 function
= XCDR (function
);
3096 if (SUBRP (function
))
3097 result
= Fsubr_arity (function
);
3098 else if (COMPILEDP (function
))
3099 result
= lambda_arity (function
);
3101 else if (MODULE_FUNCTIONP (function
))
3102 result
= module_function_arity (XMODULE_FUNCTION (function
));
3106 if (NILP (function
))
3107 xsignal1 (Qvoid_function
, original
);
3108 if (!CONSP (function
))
3109 xsignal1 (Qinvalid_function
, original
);
3110 funcar
= XCAR (function
);
3111 if (!SYMBOLP (funcar
))
3112 xsignal1 (Qinvalid_function
, original
);
3113 if (EQ (funcar
, Qlambda
)
3114 || EQ (funcar
, Qclosure
))
3115 result
= lambda_arity (function
);
3116 else if (EQ (funcar
, Qautoload
))
3118 Fautoload_do_load (function
, original
, Qnil
);
3122 xsignal1 (Qinvalid_function
, original
);
3127 /* FUN must be either a lambda-expression or a compiled-code object. */
3129 lambda_arity (Lisp_Object fun
)
3131 Lisp_Object syms_left
;
3135 if (EQ (XCAR (fun
), Qclosure
))
3137 fun
= XCDR (fun
); /* Drop `closure'. */
3140 syms_left
= XCDR (fun
);
3141 if (CONSP (syms_left
))
3142 syms_left
= XCAR (syms_left
);
3144 xsignal1 (Qinvalid_function
, fun
);
3146 else if (COMPILEDP (fun
))
3148 ptrdiff_t size
= PVSIZE (fun
);
3149 if (size
<= COMPILED_STACK_DEPTH
)
3150 xsignal1 (Qinvalid_function
, fun
);
3151 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3152 if (INTEGERP (syms_left
))
3153 return get_byte_code_arity (syms_left
);
3158 EMACS_INT minargs
= 0, maxargs
= 0;
3159 bool optional
= false;
3160 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3162 Lisp_Object next
= XCAR (syms_left
);
3163 if (!SYMBOLP (next
))
3164 xsignal1 (Qinvalid_function
, fun
);
3166 if (EQ (next
, Qand_rest
))
3167 return Fcons (make_number (minargs
), Qmany
);
3168 else if (EQ (next
, Qand_optional
))
3178 if (!NILP (syms_left
))
3179 xsignal1 (Qinvalid_function
, fun
);
3181 return Fcons (make_number (minargs
), make_number (maxargs
));
3184 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3186 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3187 (Lisp_Object object
)
3191 if (COMPILEDP (object
))
3193 ptrdiff_t size
= PVSIZE (object
);
3194 if (size
<= COMPILED_STACK_DEPTH
)
3195 xsignal1 (Qinvalid_function
, object
);
3196 if (CONSP (AREF (object
, COMPILED_BYTECODE
)))
3198 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3201 tem
= AREF (object
, COMPILED_BYTECODE
);
3202 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3203 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3205 error ("Invalid byte code");
3207 ASET (object
, COMPILED_BYTECODE
, XCAR (tem
));
3208 ASET (object
, COMPILED_CONSTANTS
, XCDR (tem
));
3214 /* Return true if SYMBOL currently has a let-binding
3215 which was made in the buffer that is now current. */
3218 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
3220 union specbinding
*p
;
3221 Lisp_Object buf
= Fcurrent_buffer ();
3223 for (p
= specpdl_ptr
; p
> specpdl
; )
3224 if ((--p
)->kind
> SPECPDL_LET
)
3226 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (specpdl_symbol (p
));
3227 eassert (let_bound_symbol
->u
.s
.redirect
!= SYMBOL_VARALIAS
);
3228 if (symbol
== let_bound_symbol
3229 && EQ (specpdl_where (p
), buf
))
3237 do_specbind (struct Lisp_Symbol
*sym
, union specbinding
*bind
,
3238 Lisp_Object value
, enum Set_Internal_Bind bindflag
)
3240 switch (sym
->u
.s
.redirect
)
3242 case SYMBOL_PLAINVAL
:
3243 if (!sym
->u
.s
.trapped_write
)
3244 SET_SYMBOL_VAL (sym
, value
);
3246 set_internal (specpdl_symbol (bind
), value
, Qnil
, bindflag
);
3249 case SYMBOL_FORWARDED
:
3250 if (BUFFER_OBJFWDP (SYMBOL_FWD (sym
))
3251 && specpdl_kind (bind
) == SPECPDL_LET_DEFAULT
)
3253 set_default_internal (specpdl_symbol (bind
), value
, bindflag
);
3257 case SYMBOL_LOCALIZED
:
3258 set_internal (specpdl_symbol (bind
), value
, Qnil
, bindflag
);
3266 /* `specpdl_ptr' describes which variable is
3267 let-bound, so it can be properly undone when we unbind_to.
3268 It can be either a plain SPECPDL_LET or a SPECPDL_LET_LOCAL/DEFAULT.
3269 - SYMBOL is the variable being bound. Note that it should not be
3270 aliased (i.e. when let-binding V1 that's aliased to V2, we want
3272 - WHERE tells us in which buffer the binding took place.
3273 This is used for SPECPDL_LET_LOCAL bindings (i.e. bindings to a
3274 buffer-local variable) as well as for SPECPDL_LET_DEFAULT bindings,
3275 i.e. bindings to the default value of a variable which can be
3279 specbind (Lisp_Object symbol
, Lisp_Object value
)
3281 struct Lisp_Symbol
*sym
;
3283 CHECK_SYMBOL (symbol
);
3284 sym
= XSYMBOL (symbol
);
3287 switch (sym
->u
.s
.redirect
)
3289 case SYMBOL_VARALIAS
:
3290 sym
= indirect_variable (sym
); XSETSYMBOL (symbol
, sym
); goto start
;
3291 case SYMBOL_PLAINVAL
:
3292 /* The most common case is that of a non-constant symbol with a
3293 trivial value. Make that as fast as we can. */
3294 specpdl_ptr
->let
.kind
= SPECPDL_LET
;
3295 specpdl_ptr
->let
.symbol
= symbol
;
3296 specpdl_ptr
->let
.old_value
= SYMBOL_VAL (sym
);
3297 specpdl_ptr
->let
.saved_value
= Qnil
;
3299 do_specbind (sym
, specpdl_ptr
- 1, value
, SET_INTERNAL_BIND
);
3301 case SYMBOL_LOCALIZED
:
3302 case SYMBOL_FORWARDED
:
3304 Lisp_Object ovalue
= find_symbol_value (symbol
);
3305 specpdl_ptr
->let
.kind
= SPECPDL_LET_LOCAL
;
3306 specpdl_ptr
->let
.symbol
= symbol
;
3307 specpdl_ptr
->let
.old_value
= ovalue
;
3308 specpdl_ptr
->let
.where
= Fcurrent_buffer ();
3309 specpdl_ptr
->let
.saved_value
= Qnil
;
3311 eassert (sym
->u
.s
.redirect
!= SYMBOL_LOCALIZED
3312 || (EQ (SYMBOL_BLV (sym
)->where
, Fcurrent_buffer ())));
3314 if (sym
->u
.s
.redirect
== SYMBOL_LOCALIZED
)
3316 if (!blv_found (SYMBOL_BLV (sym
)))
3317 specpdl_ptr
->let
.kind
= SPECPDL_LET_DEFAULT
;
3319 else if (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)))
3321 /* If SYMBOL is a per-buffer variable which doesn't have a
3322 buffer-local value here, make the `let' change the global
3323 value by changing the value of SYMBOL in all buffers not
3324 having their own value. This is consistent with what
3325 happens with other buffer-local variables. */
3326 if (NILP (Flocal_variable_p (symbol
, Qnil
)))
3328 specpdl_ptr
->let
.kind
= SPECPDL_LET_DEFAULT
;
3330 do_specbind (sym
, specpdl_ptr
- 1, value
, SET_INTERNAL_BIND
);
3335 specpdl_ptr
->let
.kind
= SPECPDL_LET
;
3338 do_specbind (sym
, specpdl_ptr
- 1, value
, SET_INTERNAL_BIND
);
3341 default: emacs_abort ();
3345 /* Push unwind-protect entries of various types. */
3348 record_unwind_protect (void (*function
) (Lisp_Object
), Lisp_Object arg
)
3350 specpdl_ptr
->unwind
.kind
= SPECPDL_UNWIND
;
3351 specpdl_ptr
->unwind
.func
= function
;
3352 specpdl_ptr
->unwind
.arg
= arg
;
3357 record_unwind_protect_ptr (void (*function
) (void *), void *arg
)
3359 specpdl_ptr
->unwind_ptr
.kind
= SPECPDL_UNWIND_PTR
;
3360 specpdl_ptr
->unwind_ptr
.func
= function
;
3361 specpdl_ptr
->unwind_ptr
.arg
= arg
;
3366 record_unwind_protect_int (void (*function
) (int), int arg
)
3368 specpdl_ptr
->unwind_int
.kind
= SPECPDL_UNWIND_INT
;
3369 specpdl_ptr
->unwind_int
.func
= function
;
3370 specpdl_ptr
->unwind_int
.arg
= arg
;
3375 record_unwind_protect_void (void (*function
) (void))
3377 specpdl_ptr
->unwind_void
.kind
= SPECPDL_UNWIND_VOID
;
3378 specpdl_ptr
->unwind_void
.func
= function
;
3383 rebind_for_thread_switch (void)
3385 union specbinding
*bind
;
3387 for (bind
= specpdl
; bind
!= specpdl_ptr
; ++bind
)
3389 if (bind
->kind
>= SPECPDL_LET
)
3391 Lisp_Object value
= specpdl_saved_value (bind
);
3392 Lisp_Object sym
= specpdl_symbol (bind
);
3393 bind
->let
.saved_value
= Qnil
;
3394 do_specbind (XSYMBOL (sym
), bind
, value
,
3395 SET_INTERNAL_THREAD_SWITCH
);
3401 do_one_unbind (union specbinding
*this_binding
, bool unwinding
,
3402 enum Set_Internal_Bind bindflag
)
3404 eassert (unwinding
|| this_binding
->kind
>= SPECPDL_LET
);
3405 switch (this_binding
->kind
)
3407 case SPECPDL_UNWIND
:
3408 this_binding
->unwind
.func (this_binding
->unwind
.arg
);
3410 case SPECPDL_UNWIND_PTR
:
3411 this_binding
->unwind_ptr
.func (this_binding
->unwind_ptr
.arg
);
3413 case SPECPDL_UNWIND_INT
:
3414 this_binding
->unwind_int
.func (this_binding
->unwind_int
.arg
);
3416 case SPECPDL_UNWIND_VOID
:
3417 this_binding
->unwind_void
.func ();
3419 case SPECPDL_BACKTRACE
:
3422 { /* If variable has a trivial value (no forwarding), and isn't
3423 trapped, we can just set it. */
3424 Lisp_Object sym
= specpdl_symbol (this_binding
);
3425 if (SYMBOLP (sym
) && XSYMBOL (sym
)->u
.s
.redirect
== SYMBOL_PLAINVAL
)
3427 if (XSYMBOL (sym
)->u
.s
.trapped_write
== SYMBOL_UNTRAPPED_WRITE
)
3428 SET_SYMBOL_VAL (XSYMBOL (sym
), specpdl_old_value (this_binding
));
3430 set_internal (sym
, specpdl_old_value (this_binding
),
3435 /* Come here only if make_local_foo was used for the first time
3436 on this var within this let. */
3438 case SPECPDL_LET_DEFAULT
:
3439 set_default_internal (specpdl_symbol (this_binding
),
3440 specpdl_old_value (this_binding
),
3443 case SPECPDL_LET_LOCAL
:
3445 Lisp_Object symbol
= specpdl_symbol (this_binding
);
3446 Lisp_Object where
= specpdl_where (this_binding
);
3447 Lisp_Object old_value
= specpdl_old_value (this_binding
);
3448 eassert (BUFFERP (where
));
3450 /* If this was a local binding, reset the value in the appropriate
3451 buffer, but only if that buffer's binding still exists. */
3452 if (!NILP (Flocal_variable_p (symbol
, where
)))
3453 set_internal (symbol
, old_value
, where
, bindflag
);
3463 /* Push an unwind-protect entry that does nothing, so that
3464 set_unwind_protect_ptr can overwrite it later. */
3467 record_unwind_protect_nothing (void)
3469 record_unwind_protect_void (do_nothing
);
3472 /* Clear the unwind-protect entry COUNT, so that it does nothing.
3473 It need not be at the top of the stack. */
3476 clear_unwind_protect (ptrdiff_t count
)
3478 union specbinding
*p
= specpdl
+ count
;
3479 p
->unwind_void
.kind
= SPECPDL_UNWIND_VOID
;
3480 p
->unwind_void
.func
= do_nothing
;
3483 /* Set the unwind-protect entry COUNT so that it invokes FUNC (ARG).
3484 It need not be at the top of the stack. Discard the entry's
3485 previous value without invoking it. */
3488 set_unwind_protect (ptrdiff_t count
, void (*func
) (Lisp_Object
),
3491 union specbinding
*p
= specpdl
+ count
;
3492 p
->unwind
.kind
= SPECPDL_UNWIND
;
3493 p
->unwind
.func
= func
;
3494 p
->unwind
.arg
= arg
;
3498 set_unwind_protect_ptr (ptrdiff_t count
, void (*func
) (void *), void *arg
)
3500 union specbinding
*p
= specpdl
+ count
;
3501 p
->unwind_ptr
.kind
= SPECPDL_UNWIND_PTR
;
3502 p
->unwind_ptr
.func
= func
;
3503 p
->unwind_ptr
.arg
= arg
;
3506 /* Pop and execute entries from the unwind-protect stack until the
3507 depth COUNT is reached. Return VALUE. */
3510 unbind_to (ptrdiff_t count
, Lisp_Object value
)
3512 Lisp_Object quitf
= Vquit_flag
;
3516 while (specpdl_ptr
!= specpdl
+ count
)
3518 /* Copy the binding, and decrement specpdl_ptr, before we do
3519 the work to unbind it. We decrement first
3520 so that an error in unbinding won't try to unbind
3521 the same entry again, and we copy the binding first
3522 in case more bindings are made during some of the code we run. */
3524 union specbinding this_binding
;
3525 this_binding
= *--specpdl_ptr
;
3527 do_one_unbind (&this_binding
, true, SET_INTERNAL_UNBIND
);
3530 if (NILP (Vquit_flag
) && !NILP (quitf
))
3537 unbind_for_thread_switch (struct thread_state
*thr
)
3539 union specbinding
*bind
;
3541 for (bind
= thr
->m_specpdl_ptr
; bind
> thr
->m_specpdl
;)
3543 if ((--bind
)->kind
>= SPECPDL_LET
)
3545 Lisp_Object sym
= specpdl_symbol (bind
);
3546 bind
->let
.saved_value
= find_symbol_value (sym
);
3547 do_one_unbind (bind
, false, SET_INTERNAL_THREAD_SWITCH
);
3552 DEFUN ("special-variable-p", Fspecial_variable_p
, Sspecial_variable_p
, 1, 1, 0,
3553 doc
: /* Return non-nil if SYMBOL's global binding has been declared special.
3554 A special variable is one that will be bound dynamically, even in a
3555 context where binding is lexical by default. */)
3556 (Lisp_Object symbol
)
3558 CHECK_SYMBOL (symbol
);
3559 return XSYMBOL (symbol
)->u
.s
.declared_special
? Qt
: Qnil
;
3563 static union specbinding
*
3564 get_backtrace_starting_at (Lisp_Object base
)
3566 union specbinding
*pdl
= backtrace_top ();
3569 { /* Skip up to `base'. */
3570 base
= Findirect_function (base
, Qt
);
3571 while (backtrace_p (pdl
)
3572 && !EQ (base
, Findirect_function (backtrace_function (pdl
), Qt
)))
3573 pdl
= backtrace_next (pdl
);
3579 static union specbinding
*
3580 get_backtrace_frame (Lisp_Object nframes
, Lisp_Object base
)
3582 register EMACS_INT i
;
3584 CHECK_NATNUM (nframes
);
3585 union specbinding
*pdl
= get_backtrace_starting_at (base
);
3587 /* Find the frame requested. */
3588 for (i
= XFASTINT (nframes
); i
> 0 && backtrace_p (pdl
); i
--)
3589 pdl
= backtrace_next (pdl
);
3595 backtrace_frame_apply (Lisp_Object function
, union specbinding
*pdl
)
3597 if (!backtrace_p (pdl
))
3600 Lisp_Object flags
= Qnil
;
3601 if (backtrace_debug_on_exit (pdl
))
3602 flags
= Fcons (QCdebug_on_exit
, Fcons (Qt
, Qnil
));
3604 if (backtrace_nargs (pdl
) == UNEVALLED
)
3605 return call4 (function
, Qnil
, backtrace_function (pdl
), *backtrace_args (pdl
), flags
);
3608 Lisp_Object tem
= Flist (backtrace_nargs (pdl
), backtrace_args (pdl
));
3609 return call4 (function
, Qt
, backtrace_function (pdl
), tem
, flags
);
3613 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3614 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3615 The debugger is entered when that frame exits, if the flag is non-nil. */)
3616 (Lisp_Object level
, Lisp_Object flag
)
3618 CHECK_NUMBER (level
);
3619 union specbinding
*pdl
= get_backtrace_frame(level
, Qnil
);
3621 if (backtrace_p (pdl
))
3622 set_backtrace_debug_on_exit (pdl
, !NILP (flag
));
3627 DEFUN ("mapbacktrace", Fmapbacktrace
, Smapbacktrace
, 1, 2, 0,
3628 doc
: /* Call FUNCTION for each frame in backtrace.
3629 If BASE is non-nil, it should be a function and iteration will start
3630 from its nearest activation frame.
3631 FUNCTION is called with 4 arguments: EVALD, FUNC, ARGS, and FLAGS. If
3632 a frame has not evaluated its arguments yet or is a special form,
3633 EVALD is nil and ARGS is a list of forms. If a frame has evaluated
3634 its arguments and called its function already, EVALD is t and ARGS is
3636 FLAGS is a plist of properties of the current frame: currently, the
3637 only supported property is :debug-on-exit. `mapbacktrace' always
3639 (Lisp_Object function
, Lisp_Object base
)
3641 union specbinding
*pdl
= get_backtrace_starting_at (base
);
3643 while (backtrace_p (pdl
))
3645 ptrdiff_t i
= pdl
- specpdl
;
3646 backtrace_frame_apply (function
, pdl
);
3647 /* Beware! PDL is no longer valid here because FUNCTION might
3648 have caused grow_specpdl to reallocate pdlvec. We must use
3649 the saved index, cf. Bug#27258. */
3650 pdl
= backtrace_next (&specpdl
[i
]);
3656 DEFUN ("backtrace-frame--internal", Fbacktrace_frame_internal
,
3657 Sbacktrace_frame_internal
, 3, 3, NULL
,
3658 doc
: /* Call FUNCTION on stack frame NFRAMES away from BASE.
3659 Return the result of FUNCTION, or nil if no matching frame could be found. */)
3660 (Lisp_Object function
, Lisp_Object nframes
, Lisp_Object base
)
3662 return backtrace_frame_apply (function
, get_backtrace_frame (nframes
, base
));
3665 /* For backtrace-eval, we want to temporarily unwind the last few elements of
3666 the specpdl stack, and then rewind them. We store the pre-unwind values
3667 directly in the pre-existing specpdl elements (i.e. we swap the current
3668 value and the old value stored in the specpdl), kind of like the inplace
3669 pointer-reversal trick. As it turns out, the rewind does the same as the
3670 unwind, except it starts from the other end of the specpdl stack, so we use
3671 the same function for both unwind and rewind. */
3673 backtrace_eval_unrewind (int distance
)
3675 union specbinding
*tmp
= specpdl_ptr
;
3678 { /* It's a rewind rather than unwind. */
3679 tmp
+= distance
- 1;
3681 distance
= -distance
;
3684 for (; distance
> 0; distance
--)
3689 /* FIXME: Ideally we'd like to "temporarily unwind" (some of) those
3690 unwind_protect, but the problem is that we don't know how to
3691 rewind them afterwards. */
3692 case SPECPDL_UNWIND
:
3694 Lisp_Object oldarg
= tmp
->unwind
.arg
;
3695 if (tmp
->unwind
.func
== set_buffer_if_live
)
3696 tmp
->unwind
.arg
= Fcurrent_buffer ();
3697 else if (tmp
->unwind
.func
== save_excursion_restore
)
3698 tmp
->unwind
.arg
= save_excursion_save ();
3701 tmp
->unwind
.func (oldarg
);
3705 case SPECPDL_UNWIND_PTR
:
3706 case SPECPDL_UNWIND_INT
:
3707 case SPECPDL_UNWIND_VOID
:
3708 case SPECPDL_BACKTRACE
:
3711 { /* If variable has a trivial value (no forwarding), we can
3712 just set it. No need to check for constant symbols here,
3713 since that was already done by specbind. */
3714 Lisp_Object sym
= specpdl_symbol (tmp
);
3716 && XSYMBOL (sym
)->u
.s
.redirect
== SYMBOL_PLAINVAL
)
3718 Lisp_Object old_value
= specpdl_old_value (tmp
);
3719 set_specpdl_old_value (tmp
, SYMBOL_VAL (XSYMBOL (sym
)));
3720 SET_SYMBOL_VAL (XSYMBOL (sym
), old_value
);
3724 /* Come here only if make_local_foo was used for the first
3725 time on this var within this let. */
3727 case SPECPDL_LET_DEFAULT
:
3729 Lisp_Object sym
= specpdl_symbol (tmp
);
3730 Lisp_Object old_value
= specpdl_old_value (tmp
);
3731 set_specpdl_old_value (tmp
, Fdefault_value (sym
));
3732 Fset_default (sym
, old_value
);
3735 case SPECPDL_LET_LOCAL
:
3737 Lisp_Object symbol
= specpdl_symbol (tmp
);
3738 Lisp_Object where
= specpdl_where (tmp
);
3739 Lisp_Object old_value
= specpdl_old_value (tmp
);
3740 eassert (BUFFERP (where
));
3742 /* If this was a local binding, reset the value in the appropriate
3743 buffer, but only if that buffer's binding still exists. */
3744 if (!NILP (Flocal_variable_p (symbol
, where
)))
3746 set_specpdl_old_value
3747 (tmp
, Fbuffer_local_value (symbol
, where
));
3748 set_internal (symbol
, old_value
, where
, SET_INTERNAL_UNBIND
);
3756 DEFUN ("backtrace-eval", Fbacktrace_eval
, Sbacktrace_eval
, 2, 3, NULL
,
3757 doc
: /* Evaluate EXP in the context of some activation frame.
3758 NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */)
3759 (Lisp_Object exp
, Lisp_Object nframes
, Lisp_Object base
)
3761 union specbinding
*pdl
= get_backtrace_frame (nframes
, base
);
3762 ptrdiff_t count
= SPECPDL_INDEX ();
3763 ptrdiff_t distance
= specpdl_ptr
- pdl
;
3764 eassert (distance
>= 0);
3766 if (!backtrace_p (pdl
))
3767 error ("Activation frame not found!");
3769 backtrace_eval_unrewind (distance
);
3770 record_unwind_protect_int (backtrace_eval_unrewind
, -distance
);
3772 /* Use eval_sub rather than Feval since the main motivation behind
3773 backtrace-eval is to be able to get/set the value of lexical variables
3774 from the debugger. */
3775 return unbind_to (count
, eval_sub (exp
));
3778 DEFUN ("backtrace--locals", Fbacktrace__locals
, Sbacktrace__locals
, 1, 2, NULL
,
3779 doc
: /* Return names and values of local variables of a stack frame.
3780 NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */)
3781 (Lisp_Object nframes
, Lisp_Object base
)
3783 union specbinding
*frame
= get_backtrace_frame (nframes
, base
);
3784 union specbinding
*prevframe
3785 = get_backtrace_frame (make_number (XFASTINT (nframes
) - 1), base
);
3786 ptrdiff_t distance
= specpdl_ptr
- frame
;
3787 Lisp_Object result
= Qnil
;
3788 eassert (distance
>= 0);
3790 if (!backtrace_p (prevframe
))
3791 error ("Activation frame not found!");
3792 if (!backtrace_p (frame
))
3793 error ("Activation frame not found!");
3795 /* The specpdl entries normally contain the symbol being bound along with its
3796 `old_value', so it can be restored. The new value to which it is bound is
3797 available in one of two places: either in the current value of the
3798 variable (if it hasn't been rebound yet) or in the `old_value' slot of the
3799 next specpdl entry for it.
3800 `backtrace_eval_unrewind' happens to swap the role of `old_value'
3801 and "new value", so we abuse it here, to fetch the new value.
3802 It's ugly (we'd rather not modify global data) and a bit inefficient,
3803 but it does the job for now. */
3804 backtrace_eval_unrewind (distance
);
3808 union specbinding
*tmp
= prevframe
;
3809 for (; tmp
> frame
; tmp
--)
3814 case SPECPDL_LET_DEFAULT
:
3815 case SPECPDL_LET_LOCAL
:
3817 Lisp_Object sym
= specpdl_symbol (tmp
);
3818 Lisp_Object val
= specpdl_old_value (tmp
);
3819 if (EQ (sym
, Qinternal_interpreter_environment
))
3821 Lisp_Object env
= val
;
3822 for (; CONSP (env
); env
= XCDR (env
))
3824 Lisp_Object binding
= XCAR (env
);
3825 if (CONSP (binding
))
3826 result
= Fcons (Fcons (XCAR (binding
),
3832 result
= Fcons (Fcons (sym
, val
), result
);
3836 case SPECPDL_UNWIND
:
3837 case SPECPDL_UNWIND_PTR
:
3838 case SPECPDL_UNWIND_INT
:
3839 case SPECPDL_UNWIND_VOID
:
3840 case SPECPDL_BACKTRACE
:
3849 /* Restore values from specpdl to original place. */
3850 backtrace_eval_unrewind (-distance
);
3857 mark_specpdl (union specbinding
*first
, union specbinding
*ptr
)
3859 union specbinding
*pdl
;
3860 for (pdl
= first
; pdl
!= ptr
; pdl
++)
3864 case SPECPDL_UNWIND
:
3865 mark_object (specpdl_arg (pdl
));
3868 case SPECPDL_BACKTRACE
:
3870 ptrdiff_t nargs
= backtrace_nargs (pdl
);
3871 mark_object (backtrace_function (pdl
));
3872 if (nargs
== UNEVALLED
)
3875 mark_object (backtrace_args (pdl
)[nargs
]);
3879 case SPECPDL_LET_DEFAULT
:
3880 case SPECPDL_LET_LOCAL
:
3881 mark_object (specpdl_where (pdl
));
3884 mark_object (specpdl_symbol (pdl
));
3885 mark_object (specpdl_old_value (pdl
));
3886 mark_object (specpdl_saved_value (pdl
));
3889 case SPECPDL_UNWIND_PTR
:
3890 case SPECPDL_UNWIND_INT
:
3891 case SPECPDL_UNWIND_VOID
:
3901 get_backtrace (Lisp_Object array
)
3903 union specbinding
*pdl
= backtrace_next (backtrace_top ());
3904 ptrdiff_t i
= 0, asize
= ASIZE (array
);
3906 /* Copy the backtrace contents into working memory. */
3907 for (; i
< asize
; i
++)
3909 if (backtrace_p (pdl
))
3911 ASET (array
, i
, backtrace_function (pdl
));
3912 pdl
= backtrace_next (pdl
);
3915 ASET (array
, i
, Qnil
);
3919 Lisp_Object
backtrace_top_function (void)
3921 union specbinding
*pdl
= backtrace_top ();
3922 return (backtrace_p (pdl
) ? backtrace_function (pdl
) : Qnil
);
3928 DEFVAR_INT ("max-specpdl-size", max_specpdl_size
,
3929 doc
: /* Limit on number of Lisp variable bindings and `unwind-protect's.
3930 If Lisp code tries to increase the total number past this amount,
3931 an error is signaled.
3932 You can safely use a value considerably larger than the default value,
3933 if that proves inconveniently small. However, if you increase it too far,
3934 Emacs could run out of memory trying to make the stack bigger.
3935 Note that this limit may be silently increased by the debugger
3936 if `debug-on-error' or `debug-on-quit' is set. */);
3938 DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth
,
3939 doc
: /* Limit on depth in `eval', `apply' and `funcall' before error.
3941 This limit serves to catch infinite recursions for you before they cause
3942 actual stack overflow in C, which would be fatal for Emacs.
3943 You can safely make it considerably larger than its default value,
3944 if that proves inconveniently small. However, if you increase it too far,
3945 Emacs could overflow the real C stack, and crash. */);
3947 DEFVAR_LISP ("quit-flag", Vquit_flag
,
3948 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3949 If the value is t, that means do an ordinary quit.
3950 If the value equals `throw-on-input', that means quit by throwing
3951 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3952 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3953 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3956 DEFVAR_LISP ("inhibit-quit", Vinhibit_quit
,
3957 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3958 Note that `quit-flag' will still be set by typing C-g,
3959 so a quit will be signaled as soon as `inhibit-quit' is nil.
3960 To prevent this happening, set `quit-flag' to nil
3961 before making `inhibit-quit' nil. */);
3962 Vinhibit_quit
= Qnil
;
3964 DEFSYM (Qsetq
, "setq");
3965 DEFSYM (Qinhibit_quit
, "inhibit-quit");
3966 DEFSYM (Qautoload
, "autoload");
3967 DEFSYM (Qinhibit_debugger
, "inhibit-debugger");
3968 DEFSYM (Qmacro
, "macro");
3970 /* Note that the process handling also uses Qexit, but we don't want
3971 to staticpro it twice, so we just do it here. */
3972 DEFSYM (Qexit
, "exit");
3974 DEFSYM (Qinteractive
, "interactive");
3975 DEFSYM (Qcommandp
, "commandp");
3976 DEFSYM (Qand_rest
, "&rest");
3977 DEFSYM (Qand_optional
, "&optional");
3978 DEFSYM (Qclosure
, "closure");
3979 DEFSYM (QCdocumentation
, ":documentation");
3980 DEFSYM (Qdebug
, "debug");
3982 DEFVAR_LISP ("inhibit-debugger", Vinhibit_debugger
,
3983 doc
: /* Non-nil means never enter the debugger.
3984 Normally set while the debugger is already active, to avoid recursive
3986 Vinhibit_debugger
= Qnil
;
3988 DEFVAR_LISP ("debug-on-error", Vdebug_on_error
,
3989 doc
: /* Non-nil means enter debugger if an error is signaled.
3990 Does not apply to errors handled by `condition-case' or those
3991 matched by `debug-ignored-errors'.
3992 If the value is a list, an error only means to enter the debugger
3993 if one of its condition symbols appears in the list.
3994 When you evaluate an expression interactively, this variable
3995 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3996 The command `toggle-debug-on-error' toggles this.
3997 See also the variable `debug-on-quit' and `inhibit-debugger'. */);
3998 Vdebug_on_error
= Qnil
;
4000 DEFVAR_LISP ("debug-ignored-errors", Vdebug_ignored_errors
,
4001 doc
: /* List of errors for which the debugger should not be called.
4002 Each element may be a condition-name or a regexp that matches error messages.
4003 If any element applies to a given error, that error skips the debugger
4004 and just returns to top level.
4005 This overrides the variable `debug-on-error'.
4006 It does not apply to errors handled by `condition-case'. */);
4007 Vdebug_ignored_errors
= Qnil
;
4009 DEFVAR_BOOL ("debug-on-quit", debug_on_quit
,
4010 doc
: /* Non-nil means enter debugger if quit is signaled (C-g, for example).
4011 Does not apply if quit is handled by a `condition-case'. */);
4014 DEFVAR_BOOL ("debug-on-next-call", debug_on_next_call
,
4015 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
4017 DEFVAR_BOOL ("debugger-may-continue", debugger_may_continue
,
4018 doc
: /* Non-nil means debugger may continue execution.
4019 This is nil when the debugger is called under circumstances where it
4020 might not be safe to continue. */);
4021 debugger_may_continue
= 1;
4023 DEFVAR_BOOL ("debugger-stack-frame-as-list", debugger_stack_frame_as_list
,
4024 doc
: /* Non-nil means display call stack frames as lists. */);
4025 debugger_stack_frame_as_list
= 0;
4027 DEFVAR_LISP ("debugger", Vdebugger
,
4028 doc
: /* Function to call to invoke debugger.
4029 If due to frame exit, args are `exit' and the value being returned;
4030 this function's value will be returned instead of that.
4031 If due to error, args are `error' and a list of the args to `signal'.
4032 If due to `apply' or `funcall' entry, one arg, `lambda'.
4033 If due to `eval' entry, one arg, t. */);
4036 DEFVAR_LISP ("signal-hook-function", Vsignal_hook_function
,
4037 doc
: /* If non-nil, this is a function for `signal' to call.
4038 It receives the same arguments that `signal' was given.
4039 The Edebug package uses this to regain control. */);
4040 Vsignal_hook_function
= Qnil
;
4042 DEFVAR_LISP ("debug-on-signal", Vdebug_on_signal
,
4043 doc
: /* Non-nil means call the debugger regardless of condition handlers.
4044 Note that `debug-on-error', `debug-on-quit' and friends
4045 still determine whether to handle the particular condition. */);
4046 Vdebug_on_signal
= Qnil
;
4048 /* When lexical binding is being used,
4049 Vinternal_interpreter_environment is non-nil, and contains an alist
4050 of lexically-bound variable, or (t), indicating an empty
4051 environment. The lisp name of this variable would be
4052 `internal-interpreter-environment' if it weren't hidden.
4053 Every element of this list can be either a cons (VAR . VAL)
4054 specifying a lexical binding, or a single symbol VAR indicating
4055 that this variable should use dynamic scoping. */
4056 DEFSYM (Qinternal_interpreter_environment
,
4057 "internal-interpreter-environment");
4058 DEFVAR_LISP ("internal-interpreter-environment",
4059 Vinternal_interpreter_environment
,
4060 doc
: /* If non-nil, the current lexical environment of the lisp interpreter.
4061 When lexical binding is not being used, this variable is nil.
4062 A value of `(t)' indicates an empty environment, otherwise it is an
4063 alist of active lexical bindings. */);
4064 Vinternal_interpreter_environment
= Qnil
;
4065 /* Don't export this variable to Elisp, so no one can mess with it
4066 (Just imagine if someone makes it buffer-local). */
4067 Funintern (Qinternal_interpreter_environment
, Qnil
);
4069 Vrun_hooks
= intern_c_string ("run-hooks");
4070 staticpro (&Vrun_hooks
);
4072 staticpro (&Vautoload_queue
);
4073 Vautoload_queue
= Qnil
;
4074 staticpro (&Vsignaling_function
);
4075 Vsignaling_function
= Qnil
;
4077 inhibit_lisp_code
= Qnil
;
4088 defsubr (&Sfunction
);
4089 defsubr (&Sdefault_toplevel_value
);
4090 defsubr (&Sset_default_toplevel_value
);
4092 defsubr (&Sdefvaralias
);
4093 DEFSYM (Qdefvaralias
, "defvaralias");
4094 defsubr (&Sdefconst
);
4095 defsubr (&Smake_var_non_special
);
4099 defsubr (&Smacroexpand
);
4102 defsubr (&Sunwind_protect
);
4103 defsubr (&Scondition_case
);
4105 defsubr (&Scommandp
);
4106 defsubr (&Sautoload
);
4107 defsubr (&Sautoload_do_load
);
4110 defsubr (&Sfuncall
);
4111 defsubr (&Sfunc_arity
);
4112 defsubr (&Srun_hooks
);
4113 defsubr (&Srun_hook_with_args
);
4114 defsubr (&Srun_hook_with_args_until_success
);
4115 defsubr (&Srun_hook_with_args_until_failure
);
4116 defsubr (&Srun_hook_wrapped
);
4117 defsubr (&Sfetch_bytecode
);
4118 defsubr (&Sbacktrace_debug
);
4119 DEFSYM (QCdebug_on_exit
, ":debug-on-exit");
4120 defsubr (&Smapbacktrace
);
4121 defsubr (&Sbacktrace_frame_internal
);
4122 defsubr (&Sbacktrace_eval
);
4123 defsubr (&Sbacktrace__locals
);
4124 defsubr (&Sspecial_variable_p
);
4125 defsubr (&Sfunctionp
);