1 /* Evaluator for GNU Emacs Lisp interpreter.
3 Copyright (C) 1985-1987, 1993-1995, 1999-2017 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 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
286 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
288 /* While debugging Bug#16603, previous value of 100 was found
289 too small to avoid specpdl overflow in the debugger itself. */
290 if (max_specpdl_size
- 200 < count
)
291 max_specpdl_size
= count
+ 200;
293 if (old_max
== count
)
295 /* We can enter the debugger due to specpdl overflow (Bug#16603). */
300 /* Restore limits after leaving the debugger. */
301 record_unwind_protect (restore_stack_limits
,
302 Fcons (make_number (old_max
),
303 make_number (old_depth
)));
305 #ifdef HAVE_WINDOW_SYSTEM
306 if (display_hourglass_p
)
310 debug_on_next_call
= 0;
311 when_entered_debugger
= num_nonmacro_input_events
;
313 /* Resetting redisplaying_p to 0 makes sure that debug output is
314 displayed if the debugger is invoked during redisplay. */
315 debug_while_redisplaying
= redisplaying_p
;
317 specbind (intern ("debugger-may-continue"),
318 debug_while_redisplaying
? Qnil
: Qt
);
319 specbind (Qinhibit_redisplay
, Qnil
);
320 specbind (Qinhibit_debugger
, Qt
);
322 /* If we are debugging an error while `inhibit-changing-match-data'
323 is bound to non-nil (e.g., within a call to `string-match-p'),
324 then make sure debugger code can still use match data. */
325 specbind (Qinhibit_changing_match_data
, Qnil
);
327 #if 0 /* Binding this prevents execution of Lisp code during
328 redisplay, which necessarily leads to display problems. */
329 specbind (Qinhibit_eval_during_redisplay
, Qt
);
332 val
= apply1 (Vdebugger
, arg
);
334 /* Interrupting redisplay and resuming it later is not safe under
335 all circumstances. So, when the debugger returns, abort the
336 interrupted redisplay by going back to the top-level. */
337 if (debug_while_redisplaying
)
340 return unbind_to (count
, val
);
344 do_debug_on_call (Lisp_Object code
, ptrdiff_t count
)
346 debug_on_next_call
= 0;
347 set_backtrace_debug_on_exit (specpdl
+ count
, true);
348 call_debugger (list1 (code
));
351 /* NOTE!!! Every function that can call EVAL must protect its args
352 and temporaries from garbage collection while it needs them.
353 The definition of `For' shows what you have to do. */
355 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
356 doc
: /* Eval args until one of them yields non-nil, then return that value.
357 The remaining args are not evalled at all.
358 If all args return nil, return nil.
359 usage: (or CONDITIONS...) */)
362 Lisp_Object val
= Qnil
;
366 Lisp_Object arg
= XCAR (args
);
368 val
= eval_sub (arg
);
376 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
377 doc
: /* Eval args until one of them yields nil, then return nil.
378 The remaining args are not evalled at all.
379 If no arg yields nil, return the last arg's value.
380 usage: (and CONDITIONS...) */)
383 Lisp_Object val
= Qt
;
387 Lisp_Object arg
= XCAR (args
);
389 val
= eval_sub (arg
);
397 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
398 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
399 Returns the value of THEN or the value of the last of the ELSE's.
400 THEN must be one expression, but ELSE... can be zero or more expressions.
401 If COND yields nil, and there are no ELSE's, the value is nil.
402 usage: (if COND THEN ELSE...) */)
407 cond
= eval_sub (XCAR (args
));
410 return eval_sub (Fcar (XCDR (args
)));
411 return Fprogn (Fcdr (XCDR (args
)));
414 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
415 doc
: /* Try each clause until one succeeds.
416 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
417 and, if the value is non-nil, this clause succeeds:
418 then the expressions in BODY are evaluated and the last one's
419 value is the value of the cond-form.
420 If a clause has one element, as in (CONDITION), then the cond-form
421 returns CONDITION's value, if that is non-nil.
422 If no clause succeeds, cond returns nil.
423 usage: (cond CLAUSES...) */)
426 Lisp_Object val
= args
;
430 Lisp_Object clause
= XCAR (args
);
431 val
= eval_sub (Fcar (clause
));
434 if (!NILP (XCDR (clause
)))
435 val
= Fprogn (XCDR (clause
));
444 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
445 doc
: /* Eval BODY forms sequentially and return value of last one.
446 usage: (progn BODY...) */)
449 Lisp_Object val
= Qnil
;
453 Lisp_Object form
= XCAR (body
);
455 val
= eval_sub (form
);
461 /* Evaluate BODY sequentially, discarding its value. */
464 prog_ignore (Lisp_Object body
)
469 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
470 doc
: /* Eval FIRST and BODY sequentially; return value from FIRST.
471 The value of FIRST is saved during the evaluation of the remaining args,
472 whose values are discarded.
473 usage: (prog1 FIRST BODY...) */)
476 Lisp_Object val
= eval_sub (XCAR (args
));
477 prog_ignore (XCDR (args
));
481 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
482 doc
: /* Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
483 The value of FORM2 is saved during the evaluation of the
484 remaining args, whose values are discarded.
485 usage: (prog2 FORM1 FORM2 BODY...) */)
488 eval_sub (XCAR (args
));
489 return Fprog1 (XCDR (args
));
492 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
493 doc
: /* Set each SYM to the value of its VAL.
494 The symbols SYM are variables; they are literal (not evaluated).
495 The values VAL are expressions; they are evaluated.
496 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
497 The second VAL is not computed until after the first SYM is set, and so on;
498 each VAL can use the new value of variables set earlier in the `setq'.
499 The return value of the `setq' form is the value of the last VAL.
500 usage: (setq [SYM VAL]...) */)
503 Lisp_Object val
= args
, tail
= args
;
505 for (EMACS_INT nargs
= 0; CONSP (tail
); nargs
+= 2)
507 Lisp_Object sym
= XCAR (tail
), lex_binding
;
510 xsignal2 (Qwrong_number_of_arguments
, Qsetq
, make_number (nargs
+ 1));
511 Lisp_Object arg
= XCAR (tail
);
513 val
= eval_sub (arg
);
514 /* Like for eval_sub, we do not check declared_special here since
515 it's been done when let-binding. */
516 if (!NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
518 && !NILP (lex_binding
519 = Fassq (sym
, Vinternal_interpreter_environment
)))
520 XSETCDR (lex_binding
, val
); /* SYM is lexically bound. */
522 Fset (sym
, val
); /* SYM is dynamically bound. */
528 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
529 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
530 Warning: `quote' does not construct its return value, but just returns
531 the value that was pre-constructed by the Lisp reader (see info node
532 `(elisp)Printed Representation').
533 This means that \\='(a . b) is not identical to (cons \\='a \\='b): the former
534 does not cons. Quoting should be reserved for constants that will
535 never be modified by side-effects, unless you like self-modifying code.
536 See the common pitfall in info node `(elisp)Rearrangement' for an example
537 of unexpected results when a quoted object is modified.
538 usage: (quote ARG) */)
541 if (!NILP (XCDR (args
)))
542 xsignal2 (Qwrong_number_of_arguments
, Qquote
, Flength (args
));
546 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
547 doc
: /* Like `quote', but preferred for objects which are functions.
548 In byte compilation, `function' causes its argument to be compiled.
549 `quote' cannot do that.
550 usage: (function ARG) */)
553 Lisp_Object quoted
= XCAR (args
);
555 if (!NILP (XCDR (args
)))
556 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
558 if (!NILP (Vinternal_interpreter_environment
)
560 && EQ (XCAR (quoted
), Qlambda
))
561 { /* This is a lambda expression within a lexical environment;
562 return an interpreted closure instead of a simple lambda. */
563 Lisp_Object cdr
= XCDR (quoted
);
564 Lisp_Object tmp
= cdr
;
566 && (tmp
= XCDR (tmp
), CONSP (tmp
))
567 && (tmp
= XCAR (tmp
), CONSP (tmp
))
568 && (EQ (QCdocumentation
, XCAR (tmp
))))
569 { /* Handle the special (:documentation <form>) to build the docstring
571 Lisp_Object docstring
= eval_sub (Fcar (XCDR (tmp
)));
572 CHECK_STRING (docstring
);
573 cdr
= Fcons (XCAR (cdr
), Fcons (docstring
, XCDR (XCDR (cdr
))));
575 return Fcons (Qclosure
, Fcons (Vinternal_interpreter_environment
,
579 /* Simply quote the argument. */
584 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
585 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
586 Aliased variables always have the same value; setting one sets the other.
587 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
588 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
589 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
590 itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
591 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
592 The return value is BASE-VARIABLE. */)
593 (Lisp_Object new_alias
, Lisp_Object base_variable
, Lisp_Object docstring
)
595 struct Lisp_Symbol
*sym
;
597 CHECK_SYMBOL (new_alias
);
598 CHECK_SYMBOL (base_variable
);
600 if (SYMBOL_CONSTANT_P (new_alias
))
601 /* Making it an alias effectively changes its value. */
602 error ("Cannot make a constant an alias");
604 sym
= XSYMBOL (new_alias
);
606 switch (sym
->u
.s
.redirect
)
608 case SYMBOL_FORWARDED
:
609 error ("Cannot make an internal variable an alias");
610 case SYMBOL_LOCALIZED
:
611 error ("Don't know how to make a localized variable an alias");
612 case SYMBOL_PLAINVAL
:
613 case SYMBOL_VARALIAS
:
619 /* https://lists.gnu.org/r/emacs-devel/2008-04/msg00834.html
620 If n_a is bound, but b_v is not, set the value of b_v to n_a,
621 so that old-code that affects n_a before the aliasing is setup
623 if (NILP (Fboundp (base_variable
)))
624 set_internal (base_variable
, find_symbol_value (new_alias
),
625 Qnil
, SET_INTERNAL_BIND
);
627 union specbinding
*p
;
629 for (p
= specpdl_ptr
; p
> specpdl
; )
630 if ((--p
)->kind
>= SPECPDL_LET
631 && (EQ (new_alias
, specpdl_symbol (p
))))
632 error ("Don't know how to make a let-bound variable an alias");
635 if (sym
->u
.s
.trapped_write
== SYMBOL_TRAPPED_WRITE
)
636 notify_variable_watchers (new_alias
, base_variable
, Qdefvaralias
, Qnil
);
638 sym
->u
.s
.declared_special
= true;
639 XSYMBOL (base_variable
)->u
.s
.declared_special
= true;
640 sym
->u
.s
.redirect
= SYMBOL_VARALIAS
;
641 SET_SYMBOL_ALIAS (sym
, XSYMBOL (base_variable
));
642 sym
->u
.s
.trapped_write
= XSYMBOL (base_variable
)->u
.s
.trapped_write
;
643 LOADHIST_ATTACH (new_alias
);
644 /* Even if docstring is nil: remove old docstring. */
645 Fput (new_alias
, Qvariable_documentation
, docstring
);
647 return base_variable
;
650 static union specbinding
*
651 default_toplevel_binding (Lisp_Object symbol
)
653 union specbinding
*binding
= NULL
;
654 union specbinding
*pdl
= specpdl_ptr
;
655 while (pdl
> specpdl
)
657 switch ((--pdl
)->kind
)
659 case SPECPDL_LET_DEFAULT
:
661 if (EQ (specpdl_symbol (pdl
), symbol
))
666 case SPECPDL_UNWIND_PTR
:
667 case SPECPDL_UNWIND_INT
:
668 case SPECPDL_UNWIND_VOID
:
669 case SPECPDL_BACKTRACE
:
670 case SPECPDL_LET_LOCAL
:
680 DEFUN ("default-toplevel-value", Fdefault_toplevel_value
, Sdefault_toplevel_value
, 1, 1, 0,
681 doc
: /* Return SYMBOL's toplevel default value.
682 "Toplevel" means outside of any let binding. */)
685 union specbinding
*binding
= default_toplevel_binding (symbol
);
687 = binding
? specpdl_old_value (binding
) : Fdefault_value (symbol
);
688 if (!EQ (value
, Qunbound
))
690 xsignal1 (Qvoid_variable
, symbol
);
693 DEFUN ("set-default-toplevel-value", Fset_default_toplevel_value
,
694 Sset_default_toplevel_value
, 2, 2, 0,
695 doc
: /* Set SYMBOL's toplevel default value to VALUE.
696 "Toplevel" means outside of any let binding. */)
697 (Lisp_Object symbol
, Lisp_Object value
)
699 union specbinding
*binding
= default_toplevel_binding (symbol
);
701 set_specpdl_old_value (binding
, value
);
703 Fset_default (symbol
, value
);
707 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
708 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
709 You are not required to define a variable in order to use it, but
710 defining it lets you supply an initial value and documentation, which
711 can be referred to by the Emacs help facilities and other programming
712 tools. The `defvar' form also declares the variable as \"special\",
713 so that it is always dynamically bound even if `lexical-binding' is t.
715 If SYMBOL's value is void and the optional argument INITVALUE is
716 provided, INITVALUE is evaluated and the result used to set SYMBOL's
717 value. If SYMBOL is buffer-local, its default value is what is set;
718 buffer-local values are not affected. If INITVALUE is missing,
719 SYMBOL's value is not set.
721 If SYMBOL has a local binding, then this form affects the local
722 binding. This is usually not what you want. Thus, if you need to
723 load a file defining variables, with this form or with `defconst' or
724 `defcustom', you should always load that file _outside_ any bindings
725 for these variables. (`defconst' and `defcustom' behave similarly in
728 The optional argument DOCSTRING is a documentation string for the
731 To define a user option, use `defcustom' instead of `defvar'.
732 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
735 Lisp_Object sym
, tem
, tail
;
742 if (!NILP (XCDR (tail
)) && !NILP (XCDR (XCDR (tail
))))
743 error ("Too many arguments");
745 tem
= Fdefault_boundp (sym
);
747 /* Do it before evaluating the initial value, for self-references. */
748 XSYMBOL (sym
)->u
.s
.declared_special
= true;
751 Fset_default (sym
, eval_sub (XCAR (tail
)));
753 { /* Check if there is really a global binding rather than just a let
754 binding that shadows the global unboundness of the var. */
755 union specbinding
*binding
= default_toplevel_binding (sym
);
756 if (binding
&& EQ (specpdl_old_value (binding
), Qunbound
))
758 set_specpdl_old_value (binding
, eval_sub (XCAR (tail
)));
765 if (!NILP (Vpurify_flag
))
766 tem
= Fpurecopy (tem
);
767 Fput (sym
, Qvariable_documentation
, tem
);
769 LOADHIST_ATTACH (sym
);
771 else if (!NILP (Vinternal_interpreter_environment
)
772 && !XSYMBOL (sym
)->u
.s
.declared_special
)
773 /* A simple (defvar foo) with lexical scoping does "nothing" except
774 declare that var to be dynamically scoped *locally* (i.e. within
775 the current file or let-block). */
776 Vinternal_interpreter_environment
777 = Fcons (sym
, Vinternal_interpreter_environment
);
780 /* Simple (defvar <var>) should not count as a definition at all.
781 It could get in the way of other definitions, and unloading this
782 package could try to make the variable unbound. */
788 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
789 doc
: /* Define SYMBOL as a constant variable.
790 This declares that neither programs nor users should ever change the
791 value. This constancy is not actually enforced by Emacs Lisp, but
792 SYMBOL is marked as a special variable so that it is never lexically
795 The `defconst' form always sets the value of SYMBOL to the result of
796 evalling INITVALUE. If SYMBOL is buffer-local, its default value is
797 what is set; buffer-local values are not affected. If SYMBOL has a
798 local binding, then this form sets the local binding's value.
799 However, you should normally not make local bindings for variables
800 defined with this form.
802 The optional DOCSTRING specifies the variable's documentation string.
803 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
806 Lisp_Object sym
, tem
;
809 Lisp_Object docstring
= Qnil
;
810 if (!NILP (XCDR (XCDR (args
))))
812 if (!NILP (XCDR (XCDR (XCDR (args
)))))
813 error ("Too many arguments");
814 docstring
= XCAR (XCDR (XCDR (args
)));
817 tem
= eval_sub (XCAR (XCDR (args
)));
818 if (!NILP (Vpurify_flag
))
819 tem
= Fpurecopy (tem
);
820 Fset_default (sym
, tem
);
821 XSYMBOL (sym
)->u
.s
.declared_special
= true;
822 if (!NILP (docstring
))
824 if (!NILP (Vpurify_flag
))
825 docstring
= Fpurecopy (docstring
);
826 Fput (sym
, Qvariable_documentation
, docstring
);
828 Fput (sym
, Qrisky_local_variable
, Qt
);
829 LOADHIST_ATTACH (sym
);
833 /* Make SYMBOL lexically scoped. */
834 DEFUN ("internal-make-var-non-special", Fmake_var_non_special
,
835 Smake_var_non_special
, 1, 1, 0,
836 doc
: /* Internal function. */)
839 CHECK_SYMBOL (symbol
);
840 XSYMBOL (symbol
)->u
.s
.declared_special
= false;
845 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
846 doc
: /* Bind variables according to VARLIST then eval BODY.
847 The value of the last form in BODY is returned.
848 Each element of VARLIST is a symbol (which is bound to nil)
849 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
850 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
851 usage: (let* VARLIST BODY...) */)
854 Lisp_Object var
, val
, elt
, lexenv
;
855 ptrdiff_t count
= SPECPDL_INDEX ();
857 lexenv
= Vinternal_interpreter_environment
;
859 Lisp_Object varlist
= XCAR (args
);
860 while (CONSP (varlist
))
864 elt
= XCAR (varlist
);
865 varlist
= XCDR (varlist
);
874 if (! NILP (Fcdr (XCDR (elt
))))
875 signal_error ("`let' bindings can have only one value-form", elt
);
876 val
= eval_sub (Fcar (XCDR (elt
)));
879 if (!NILP (lexenv
) && SYMBOLP (var
)
880 && !XSYMBOL (var
)->u
.s
.declared_special
881 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
882 /* Lexically bind VAR by adding it to the interpreter's binding
886 = Fcons (Fcons (var
, val
), Vinternal_interpreter_environment
);
887 if (EQ (Vinternal_interpreter_environment
, lexenv
))
888 /* Save the old lexical environment on the specpdl stack,
889 but only for the first lexical binding, since we'll never
890 need to revert to one of the intermediate ones. */
891 specbind (Qinternal_interpreter_environment
, newenv
);
893 Vinternal_interpreter_environment
= newenv
;
898 CHECK_LIST_END (varlist
, XCAR (args
));
900 val
= Fprogn (XCDR (args
));
901 return unbind_to (count
, val
);
904 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
905 doc
: /* Bind variables according to VARLIST then eval BODY.
906 The value of the last form in BODY is returned.
907 Each element of VARLIST is a symbol (which is bound to nil)
908 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
909 All the VALUEFORMs are evalled before any symbols are bound.
910 usage: (let VARLIST BODY...) */)
913 Lisp_Object
*temps
, tem
, lexenv
;
914 Lisp_Object elt
, varlist
;
915 ptrdiff_t count
= SPECPDL_INDEX ();
919 varlist
= XCAR (args
);
920 CHECK_LIST (varlist
);
922 /* Make space to hold the values to give the bound variables. */
923 EMACS_INT varlist_len
= XFASTINT (Flength (varlist
));
924 SAFE_ALLOCA_LISP (temps
, varlist_len
);
925 ptrdiff_t nvars
= varlist_len
;
927 /* Compute the values and store them in `temps'. */
929 for (argnum
= 0; argnum
< nvars
&& CONSP (varlist
); argnum
++)
932 elt
= XCAR (varlist
);
933 varlist
= XCDR (varlist
);
935 temps
[argnum
] = Qnil
;
936 else if (! NILP (Fcdr (Fcdr (elt
))))
937 signal_error ("`let' bindings can have only one value-form", elt
);
939 temps
[argnum
] = eval_sub (Fcar (Fcdr (elt
)));
943 lexenv
= Vinternal_interpreter_environment
;
945 varlist
= XCAR (args
);
946 for (argnum
= 0; argnum
< nvars
&& CONSP (varlist
); argnum
++)
950 elt
= XCAR (varlist
);
951 varlist
= XCDR (varlist
);
952 var
= SYMBOLP (elt
) ? elt
: Fcar (elt
);
955 if (!NILP (lexenv
) && SYMBOLP (var
)
956 && !XSYMBOL (var
)->u
.s
.declared_special
957 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
958 /* Lexically bind VAR by adding it to the lexenv alist. */
959 lexenv
= Fcons (Fcons (var
, tem
), lexenv
);
961 /* Dynamically bind VAR. */
965 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
966 /* Instantiate a new lexical environment. */
967 specbind (Qinternal_interpreter_environment
, lexenv
);
969 elt
= Fprogn (XCDR (args
));
971 return unbind_to (count
, elt
);
974 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
975 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
976 The order of execution is thus TEST, BODY, TEST, BODY and so on
977 until TEST returns nil.
978 usage: (while TEST BODY...) */)
981 Lisp_Object test
, body
;
985 while (!NILP (eval_sub (test
)))
994 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
995 doc
: /* Return result of expanding macros at top level of FORM.
996 If FORM is not a macro call, it is returned unchanged.
997 Otherwise, the macro is expanded and the expansion is considered
998 in place of FORM. When a non-macro-call results, it is returned.
1000 The second optional arg ENVIRONMENT specifies an environment of macro
1001 definitions to shadow the loaded ones for use in file byte-compilation. */)
1002 (Lisp_Object form
, Lisp_Object environment
)
1004 /* With cleanups from Hallvard Furuseth. */
1005 register Lisp_Object expander
, sym
, def
, tem
;
1009 /* Come back here each time we expand a macro call,
1010 in case it expands into another macro call. */
1013 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1014 def
= sym
= XCAR (form
);
1016 /* Trace symbols aliases to other symbols
1017 until we get a symbol that is not an alias. */
1018 while (SYMBOLP (def
))
1022 tem
= Fassq (sym
, environment
);
1025 def
= XSYMBOL (sym
)->u
.s
.function
;
1031 /* Right now TEM is the result from SYM in ENVIRONMENT,
1032 and if TEM is nil then DEF is SYM's function definition. */
1035 /* SYM is not mentioned in ENVIRONMENT.
1036 Look at its function definition. */
1037 def
= Fautoload_do_load (def
, sym
, Qmacro
);
1039 /* Not defined or definition not suitable. */
1041 if (!EQ (XCAR (def
), Qmacro
))
1043 else expander
= XCDR (def
);
1047 expander
= XCDR (tem
);
1048 if (NILP (expander
))
1052 Lisp_Object newform
= apply1 (expander
, XCDR (form
));
1053 if (EQ (form
, newform
))
1062 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1063 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1064 TAG is evalled to get the tag to use; it must not be nil.
1066 Then the BODY is executed.
1067 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
1068 If no throw happens, `catch' returns the value of the last BODY form.
1069 If a throw happens, it specifies the value to return from `catch'.
1070 usage: (catch TAG BODY...) */)
1073 Lisp_Object tag
= eval_sub (XCAR (args
));
1074 return internal_catch (tag
, Fprogn
, XCDR (args
));
1077 /* Assert that E is true, but do not evaluate E. Use this instead of
1078 eassert (E) when E contains variables that might be clobbered by a
1081 #define clobbered_eassert(E) verify (sizeof (E) != 0)
1083 /* Set up a catch, then call C function FUNC on argument ARG.
1084 FUNC should return a Lisp_Object.
1085 This is how catches are done from within C code. */
1088 internal_catch (Lisp_Object tag
,
1089 Lisp_Object (*func
) (Lisp_Object
), Lisp_Object arg
)
1091 /* This structure is made part of the chain `catchlist'. */
1092 struct handler
*c
= push_handler (tag
, CATCHER
);
1095 if (! sys_setjmp (c
->jmp
))
1097 Lisp_Object val
= func (arg
);
1098 eassert (handlerlist
== c
);
1099 handlerlist
= c
->next
;
1103 { /* Throw works by a longjmp that comes right here. */
1104 Lisp_Object val
= handlerlist
->val
;
1105 clobbered_eassert (handlerlist
== c
);
1106 handlerlist
= handlerlist
->next
;
1111 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1112 jump to that CATCH, returning VALUE as the value of that catch.
1114 This is the guts of Fthrow and Fsignal; they differ only in the way
1115 they choose the catch tag to throw to. A catch tag for a
1116 condition-case form has a TAG of Qnil.
1118 Before each catch is discarded, unbind all special bindings and
1119 execute all unwind-protect clauses made above that catch. Unwind
1120 the handler stack as we go, so that the proper handlers are in
1121 effect for each unwind-protect clause we run. At the end, restore
1122 some static info saved in CATCH, and longjmp to the location
1125 This is used for correct unwinding in Fthrow and Fsignal. */
1127 static _Noreturn
void
1128 unwind_to_catch (struct handler
*catch, Lisp_Object value
)
1132 eassert (catch->next
);
1134 /* Save the value in the tag. */
1137 /* Restore certain special C variables. */
1138 set_poll_suppress_count (catch->poll_suppress_count
);
1139 unblock_input_to (catch->interrupt_input_blocked
);
1143 /* Unwind the specpdl stack, and then restore the proper set of
1145 unbind_to (handlerlist
->pdlcount
, Qnil
);
1146 last_time
= handlerlist
== catch;
1148 handlerlist
= handlerlist
->next
;
1150 while (! last_time
);
1152 eassert (handlerlist
== catch);
1154 lisp_eval_depth
= catch->f_lisp_eval_depth
;
1156 sys_longjmp (catch->jmp
, 1);
1159 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1160 doc
: /* Throw to the catch for TAG and return VALUE from it.
1161 Both TAG and VALUE are evalled. */
1162 attributes
: noreturn
)
1163 (register Lisp_Object tag
, Lisp_Object value
)
1168 for (c
= handlerlist
; c
; c
= c
->next
)
1170 if (c
->type
== CATCHER_ALL
)
1171 unwind_to_catch (c
, Fcons (tag
, value
));
1172 if (c
->type
== CATCHER
&& EQ (c
->tag_or_ch
, tag
))
1173 unwind_to_catch (c
, value
);
1175 xsignal2 (Qno_catch
, tag
, value
);
1179 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1180 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1181 If BODYFORM completes normally, its value is returned
1182 after executing the UNWINDFORMS.
1183 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1184 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1188 ptrdiff_t count
= SPECPDL_INDEX ();
1190 record_unwind_protect (prog_ignore
, XCDR (args
));
1191 val
= eval_sub (XCAR (args
));
1192 return unbind_to (count
, val
);
1195 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1196 doc
: /* Regain control when an error is signaled.
1197 Executes BODYFORM and returns its value if no error happens.
1198 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1199 where the BODY is made of Lisp expressions.
1201 A handler is applicable to an error
1202 if CONDITION-NAME is one of the error's condition names.
1203 If an error happens, the first applicable handler is run.
1205 The car of a handler may be a list of condition names instead of a
1206 single condition name; then it handles all of them. If the special
1207 condition name `debug' is present in this list, it allows another
1208 condition in the list to run the debugger if `debug-on-error' and the
1209 other usual mechanisms says it should (otherwise, `condition-case'
1210 suppresses the debugger).
1212 When a handler handles an error, control returns to the `condition-case'
1213 and it executes the handler's BODY...
1214 with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
1215 \(If VAR is nil, the handler can't access that information.)
1216 Then the value of the last BODY form is returned from the `condition-case'
1219 See also the function `signal' for more info.
1220 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1223 Lisp_Object var
= XCAR (args
);
1224 Lisp_Object bodyform
= XCAR (XCDR (args
));
1225 Lisp_Object handlers
= XCDR (XCDR (args
));
1227 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1230 /* Like Fcondition_case, but the args are separate
1231 rather than passed in a list. Used by Fbyte_code. */
1234 internal_lisp_condition_case (Lisp_Object var
, Lisp_Object bodyform
,
1235 Lisp_Object handlers
)
1237 struct handler
*oldhandlerlist
= handlerlist
;
1238 ptrdiff_t CACHEABLE clausenb
= 0;
1242 for (Lisp_Object tail
= handlers
; CONSP (tail
); tail
= XCDR (tail
))
1244 Lisp_Object tem
= XCAR (tail
);
1248 && (SYMBOLP (XCAR (tem
))
1249 || CONSP (XCAR (tem
))))))
1250 error ("Invalid condition handler: %s",
1251 SDATA (Fprin1_to_string (tem
, Qt
)));
1254 /* The first clause is the one that should be checked first, so it
1255 should be added to handlerlist last. So build in CLAUSES a table
1256 that contains HANDLERS but in reverse order. CLAUSES is pointer
1257 to volatile to avoid issues with setjmp and local storage.
1258 SAFE_ALLOCA won't work here due to the setjmp, so impose a
1259 MAX_ALLOCA limit. */
1260 if (MAX_ALLOCA
/ word_size
< clausenb
)
1261 memory_full (SIZE_MAX
);
1262 Lisp_Object
volatile *clauses
= alloca (clausenb
* sizeof *clauses
);
1263 clauses
+= clausenb
;
1264 for (Lisp_Object tail
= handlers
; CONSP (tail
); tail
= XCDR (tail
))
1265 *--clauses
= XCAR (tail
);
1266 for (ptrdiff_t i
= 0; i
< clausenb
; i
++)
1268 Lisp_Object clause
= clauses
[i
];
1269 Lisp_Object condition
= CONSP (clause
) ? XCAR (clause
) : Qnil
;
1270 if (!CONSP (condition
))
1271 condition
= list1 (condition
);
1272 struct handler
*c
= push_handler (condition
, CONDITION_CASE
);
1273 if (sys_setjmp (c
->jmp
))
1275 Lisp_Object val
= handlerlist
->val
;
1276 Lisp_Object
volatile *chosen_clause
= clauses
;
1277 for (struct handler
*h
= handlerlist
->next
; h
!= oldhandlerlist
;
1280 Lisp_Object handler_body
= XCDR (*chosen_clause
);
1281 handlerlist
= oldhandlerlist
;
1284 return Fprogn (handler_body
);
1286 Lisp_Object handler_var
= var
;
1287 if (!NILP (Vinternal_interpreter_environment
))
1289 val
= Fcons (Fcons (var
, val
),
1290 Vinternal_interpreter_environment
);
1291 handler_var
= Qinternal_interpreter_environment
;
1294 /* Bind HANDLER_VAR to VAL while evaluating HANDLER_BODY.
1295 The unbind_to undoes just this binding; whoever longjumped
1296 to us unwound the stack to C->pdlcount before throwing. */
1297 ptrdiff_t count
= SPECPDL_INDEX ();
1298 specbind (handler_var
, val
);
1299 return unbind_to (count
, Fprogn (handler_body
));
1303 Lisp_Object result
= eval_sub (bodyform
);
1304 handlerlist
= oldhandlerlist
;
1308 /* Call the function BFUN with no arguments, catching errors within it
1309 according to HANDLERS. If there is an error, call HFUN with
1310 one argument which is the data that describes the error:
1313 HANDLERS can be a list of conditions to catch.
1314 If HANDLERS is Qt, catch all errors.
1315 If HANDLERS is Qerror, catch all errors
1316 but allow the debugger to run if that is enabled. */
1319 internal_condition_case (Lisp_Object (*bfun
) (void), Lisp_Object handlers
,
1320 Lisp_Object (*hfun
) (Lisp_Object
))
1322 struct handler
*c
= push_handler (handlers
, CONDITION_CASE
);
1323 if (sys_setjmp (c
->jmp
))
1325 Lisp_Object val
= handlerlist
->val
;
1326 clobbered_eassert (handlerlist
== c
);
1327 handlerlist
= handlerlist
->next
;
1332 Lisp_Object val
= bfun ();
1333 eassert (handlerlist
== c
);
1334 handlerlist
= c
->next
;
1339 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1342 internal_condition_case_1 (Lisp_Object (*bfun
) (Lisp_Object
), Lisp_Object arg
,
1343 Lisp_Object handlers
,
1344 Lisp_Object (*hfun
) (Lisp_Object
))
1346 struct handler
*c
= push_handler (handlers
, CONDITION_CASE
);
1347 if (sys_setjmp (c
->jmp
))
1349 Lisp_Object val
= handlerlist
->val
;
1350 clobbered_eassert (handlerlist
== c
);
1351 handlerlist
= handlerlist
->next
;
1356 Lisp_Object val
= bfun (arg
);
1357 eassert (handlerlist
== c
);
1358 handlerlist
= c
->next
;
1363 /* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as
1367 internal_condition_case_2 (Lisp_Object (*bfun
) (Lisp_Object
, Lisp_Object
),
1370 Lisp_Object handlers
,
1371 Lisp_Object (*hfun
) (Lisp_Object
))
1373 struct handler
*c
= push_handler (handlers
, CONDITION_CASE
);
1374 if (sys_setjmp (c
->jmp
))
1376 Lisp_Object val
= handlerlist
->val
;
1377 clobbered_eassert (handlerlist
== c
);
1378 handlerlist
= handlerlist
->next
;
1383 Lisp_Object val
= bfun (arg1
, arg2
);
1384 eassert (handlerlist
== c
);
1385 handlerlist
= c
->next
;
1390 /* Like internal_condition_case but call BFUN with NARGS as first,
1391 and ARGS as second argument. */
1394 internal_condition_case_n (Lisp_Object (*bfun
) (ptrdiff_t, Lisp_Object
*),
1397 Lisp_Object handlers
,
1398 Lisp_Object (*hfun
) (Lisp_Object err
,
1402 struct handler
*c
= push_handler (handlers
, CONDITION_CASE
);
1403 if (sys_setjmp (c
->jmp
))
1405 Lisp_Object val
= handlerlist
->val
;
1406 clobbered_eassert (handlerlist
== c
);
1407 handlerlist
= handlerlist
->next
;
1408 return hfun (val
, nargs
, args
);
1412 Lisp_Object val
= bfun (nargs
, args
);
1413 eassert (handlerlist
== c
);
1414 handlerlist
= c
->next
;
1420 internal_catch_all_1 (Lisp_Object (*function
) (void *), void *argument
)
1422 struct handler
*c
= push_handler_nosignal (Qt
, CATCHER_ALL
);
1424 return Qcatch_all_memory_full
;
1426 if (sys_setjmp (c
->jmp
) == 0)
1428 Lisp_Object val
= function (argument
);
1429 eassert (handlerlist
== c
);
1430 handlerlist
= c
->next
;
1435 eassert (handlerlist
== c
);
1436 Lisp_Object val
= c
->val
;
1437 handlerlist
= c
->next
;
1438 Fsignal (Qno_catch
, val
);
1442 /* Like a combination of internal_condition_case_1 and internal_catch.
1443 Catches all signals and throws. Never exits nonlocally; returns
1444 Qcatch_all_memory_full if no handler could be allocated. */
1447 internal_catch_all (Lisp_Object (*function
) (void *), void *argument
,
1448 Lisp_Object (*handler
) (Lisp_Object
))
1450 struct handler
*c
= push_handler_nosignal (Qt
, CONDITION_CASE
);
1452 return Qcatch_all_memory_full
;
1454 if (sys_setjmp (c
->jmp
) == 0)
1456 Lisp_Object val
= internal_catch_all_1 (function
, argument
);
1457 eassert (handlerlist
== c
);
1458 handlerlist
= c
->next
;
1463 eassert (handlerlist
== c
);
1464 Lisp_Object val
= c
->val
;
1465 handlerlist
= c
->next
;
1466 return handler (val
);
1471 push_handler (Lisp_Object tag_ch_val
, enum handlertype handlertype
)
1473 struct handler
*c
= push_handler_nosignal (tag_ch_val
, handlertype
);
1475 memory_full (sizeof *c
);
1480 push_handler_nosignal (Lisp_Object tag_ch_val
, enum handlertype handlertype
)
1482 struct handler
*CACHEABLE c
= handlerlist
->nextfree
;
1485 c
= malloc (sizeof *c
);
1488 if (profiler_memory_running
)
1489 malloc_probe (sizeof *c
);
1491 handlerlist
->nextfree
= c
;
1493 c
->type
= handlertype
;
1494 c
->tag_or_ch
= tag_ch_val
;
1496 c
->next
= handlerlist
;
1497 c
->f_lisp_eval_depth
= lisp_eval_depth
;
1498 c
->pdlcount
= SPECPDL_INDEX ();
1499 c
->poll_suppress_count
= poll_suppress_count
;
1500 c
->interrupt_input_blocked
= interrupt_input_blocked
;
1506 static Lisp_Object
signal_or_quit (Lisp_Object
, Lisp_Object
, bool);
1507 static Lisp_Object
find_handler_clause (Lisp_Object
, Lisp_Object
);
1508 static bool maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
,
1512 process_quit_flag (void)
1514 Lisp_Object flag
= Vquit_flag
;
1516 if (EQ (flag
, Qkill_emacs
))
1518 if (EQ (Vthrow_on_input
, flag
))
1519 Fthrow (Vthrow_on_input
, Qt
);
1523 /* Check quit-flag and quit if it is non-nil. Typing C-g does not
1524 directly cause a quit; it only sets Vquit_flag. So the program
1525 needs to call maybe_quit at times when it is safe to quit. Every
1526 loop that might run for a long time or might not exit ought to call
1527 maybe_quit at least once, at a safe place. Unless that is
1528 impossible, of course. But it is very desirable to avoid creating
1529 loops where maybe_quit is impossible.
1531 If quit-flag is set to `kill-emacs' the SIGINT handler has received
1532 a request to exit Emacs when it is safe to do.
1534 When not quitting, process any pending signals.
1536 If you change this function, also adapt module_should_quit in
1542 if (!NILP (Vquit_flag
) && NILP (Vinhibit_quit
))
1543 process_quit_flag ();
1544 else if (pending_signals
)
1545 process_pending_signals ();
1548 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1549 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1550 This function does not return.
1552 An error symbol is a symbol with an `error-conditions' property
1553 that is a list of condition names.
1554 A handler for any of those names will get to handle this signal.
1555 The symbol `error' should normally be one of them.
1557 DATA should be a list. Its elements are printed as part of the error message.
1558 See Info anchor `(elisp)Definition of signal' for some details on how this
1559 error message is constructed.
1560 If the signal is handled, DATA is made available to the handler.
1561 See also the function `condition-case'. */
1562 attributes
: noreturn
)
1563 (Lisp_Object error_symbol
, Lisp_Object data
)
1565 signal_or_quit (error_symbol
, data
, false);
1569 /* Quit, in response to a keyboard quit request. */
1573 return signal_or_quit (Qquit
, Qnil
, true);
1576 /* Signal an error, or quit. ERROR_SYMBOL and DATA are as with Fsignal.
1577 If KEYBOARD_QUIT, this is a quit; ERROR_SYMBOL should be
1578 Qquit and DATA should be Qnil, and this function may return.
1579 Otherwise this function is like Fsignal and does not return. */
1582 signal_or_quit (Lisp_Object error_symbol
, Lisp_Object data
, bool keyboard_quit
)
1584 /* When memory is full, ERROR-SYMBOL is nil,
1585 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1586 That is a special case--don't do this in other situations. */
1587 Lisp_Object conditions
;
1589 Lisp_Object real_error_symbol
1590 = (NILP (error_symbol
) ? Fcar (data
) : error_symbol
);
1591 Lisp_Object clause
= Qnil
;
1594 if (gc_in_progress
|| waiting_for_input
)
1597 #if 0 /* rms: I don't know why this was here,
1598 but it is surely wrong for an error that is handled. */
1599 #ifdef HAVE_WINDOW_SYSTEM
1600 if (display_hourglass_p
)
1601 cancel_hourglass ();
1605 /* This hook is used by edebug. */
1606 if (! NILP (Vsignal_hook_function
)
1607 && ! NILP (error_symbol
))
1609 /* Edebug takes care of restoring these variables when it exits. */
1610 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1611 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1613 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1614 max_specpdl_size
= SPECPDL_INDEX () + 40;
1616 call2 (Vsignal_hook_function
, error_symbol
, data
);
1619 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1621 /* Remember from where signal was called. Skip over the frame for
1622 `signal' itself. If a frame for `error' follows, skip that,
1623 too. Don't do this when ERROR_SYMBOL is nil, because that
1624 is a memory-full error. */
1625 Vsignaling_function
= Qnil
;
1626 if (!NILP (error_symbol
))
1628 union specbinding
*pdl
= backtrace_next (backtrace_top ());
1629 if (backtrace_p (pdl
) && EQ (backtrace_function (pdl
), Qerror
))
1630 pdl
= backtrace_next (pdl
);
1631 if (backtrace_p (pdl
))
1632 Vsignaling_function
= backtrace_function (pdl
);
1635 for (h
= handlerlist
; h
; h
= h
->next
)
1637 if (h
->type
!= CONDITION_CASE
)
1639 clause
= find_handler_clause (h
->tag_or_ch
, conditions
);
1644 if (/* Don't run the debugger for a memory-full error.
1645 (There is no room in memory to do that!) */
1646 !NILP (error_symbol
)
1647 && (!NILP (Vdebug_on_signal
)
1648 /* If no handler is present now, try to run the debugger. */
1650 /* A `debug' symbol in the handler list disables the normal
1651 suppression of the debugger. */
1652 || (CONSP (clause
) && !NILP (Fmemq (Qdebug
, clause
)))
1653 /* Special handler that means "print a message and run debugger
1655 || EQ (h
->tag_or_ch
, Qerror
)))
1657 bool debugger_called
1658 = maybe_call_debugger (conditions
, error_symbol
, data
);
1659 /* We can't return values to code which signaled an error, but we
1660 can continue code which has signaled a quit. */
1661 if (keyboard_quit
&& debugger_called
&& EQ (real_error_symbol
, Qquit
))
1667 Lisp_Object unwind_data
1668 = (NILP (error_symbol
) ? data
: Fcons (error_symbol
, data
));
1670 unwind_to_catch (h
, unwind_data
);
1674 if (handlerlist
!= handlerlist_sentinel
)
1675 /* FIXME: This will come right back here if there's no `top-level'
1676 catcher. A better solution would be to abort here, and instead
1677 add a catch-all condition handler so we never come here. */
1678 Fthrow (Qtop_level
, Qt
);
1681 if (! NILP (error_symbol
))
1682 data
= Fcons (error_symbol
, data
);
1684 string
= Ferror_message_string (data
);
1685 fatal ("%s", SDATA (string
));
1688 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1691 xsignal0 (Lisp_Object error_symbol
)
1693 xsignal (error_symbol
, Qnil
);
1697 xsignal1 (Lisp_Object error_symbol
, Lisp_Object arg
)
1699 xsignal (error_symbol
, list1 (arg
));
1703 xsignal2 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
)
1705 xsignal (error_symbol
, list2 (arg1
, arg2
));
1709 xsignal3 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
1711 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1714 /* Signal `error' with message S, and additional arg ARG.
1715 If ARG is not a genuine list, make it a one-element list. */
1718 signal_error (const char *s
, Lisp_Object arg
)
1720 Lisp_Object tortoise
, hare
;
1722 hare
= tortoise
= arg
;
1723 while (CONSP (hare
))
1730 tortoise
= XCDR (tortoise
);
1732 if (EQ (hare
, tortoise
))
1739 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1743 /* Return true if LIST is a non-nil atom or
1744 a list containing one of CONDITIONS. */
1747 wants_debugger (Lisp_Object list
, Lisp_Object conditions
)
1754 while (CONSP (conditions
))
1756 Lisp_Object
this, tail
;
1757 this = XCAR (conditions
);
1758 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1759 if (EQ (XCAR (tail
), this))
1761 conditions
= XCDR (conditions
);
1766 /* Return true if an error with condition-symbols CONDITIONS,
1767 and described by SIGNAL-DATA, should skip the debugger
1768 according to debugger-ignored-errors. */
1771 skip_debugger (Lisp_Object conditions
, Lisp_Object data
)
1774 bool first_string
= 1;
1775 Lisp_Object error_message
;
1777 error_message
= Qnil
;
1778 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1780 if (STRINGP (XCAR (tail
)))
1784 error_message
= Ferror_message_string (data
);
1788 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1793 Lisp_Object contail
;
1795 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1796 if (EQ (XCAR (tail
), XCAR (contail
)))
1804 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1805 SIG and DATA describe the signal. There are two ways to pass them:
1806 = SIG is the error symbol, and DATA is the rest of the data.
1807 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1808 This is for memory-full errors only. */
1810 maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
, Lisp_Object data
)
1812 Lisp_Object combined_data
;
1814 combined_data
= Fcons (sig
, data
);
1817 /* Don't try to run the debugger with interrupts blocked.
1818 The editing loop would return anyway. */
1819 ! input_blocked_p ()
1820 && NILP (Vinhibit_debugger
)
1821 /* Does user want to enter debugger for this kind of error? */
1824 : wants_debugger (Vdebug_on_error
, conditions
))
1825 && ! skip_debugger (conditions
, combined_data
)
1826 /* RMS: What's this for? */
1827 && when_entered_debugger
< num_nonmacro_input_events
)
1829 call_debugger (list2 (Qerror
, combined_data
));
1837 find_handler_clause (Lisp_Object handlers
, Lisp_Object conditions
)
1839 register Lisp_Object h
;
1841 /* t is used by handlers for all conditions, set up by C code. */
1842 if (EQ (handlers
, Qt
))
1845 /* error is used similarly, but means print an error message
1846 and run the debugger if that is enabled. */
1847 if (EQ (handlers
, Qerror
))
1850 for (h
= handlers
; CONSP (h
); h
= XCDR (h
))
1852 Lisp_Object handler
= XCAR (h
);
1853 if (!NILP (Fmemq (handler
, conditions
)))
1861 /* Format and return a string; called like vprintf. */
1863 vformat_string (const char *m
, va_list ap
)
1866 ptrdiff_t size
= sizeof buf
;
1867 ptrdiff_t size_max
= STRING_BYTES_BOUND
+ 1;
1872 used
= evxprintf (&buffer
, &size
, buf
, size_max
, m
, ap
);
1873 string
= make_string (buffer
, used
);
1880 /* Dump an error message; called like vprintf. */
1882 verror (const char *m
, va_list ap
)
1884 xsignal1 (Qerror
, vformat_string (m
, ap
));
1888 /* Dump an error message; called like printf. */
1892 error (const char *m
, ...)
1899 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
1900 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
1901 This means it contains a description for how to read arguments to give it.
1902 The value is nil for an invalid function or a symbol with no function
1905 Interactively callable functions include strings and vectors (treated
1906 as keyboard macros), lambda-expressions that contain a top-level call
1907 to `interactive', autoload definitions made by `autoload' with non-nil
1908 fourth argument, and some of the built-in functions of Lisp.
1910 Also, a symbol satisfies `commandp' if its function definition does so.
1912 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
1913 then strings and vectors are not accepted. */)
1914 (Lisp_Object function
, Lisp_Object for_call_interactively
)
1916 register Lisp_Object fun
;
1917 register Lisp_Object funcar
;
1918 Lisp_Object if_prop
= Qnil
;
1922 fun
= indirect_function (fun
); /* Check cycles. */
1926 /* Check an `interactive-form' property if present, analogous to the
1927 function-documentation property. */
1929 while (SYMBOLP (fun
))
1931 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
1934 fun
= Fsymbol_function (fun
);
1937 /* Emacs primitives are interactive if their DEFUN specifies an
1938 interactive spec. */
1940 return XSUBR (fun
)->intspec
? Qt
: if_prop
;
1942 /* Bytecode objects are interactive if they are long enough to
1943 have an element whose index is COMPILED_INTERACTIVE, which is
1944 where the interactive spec is stored. */
1945 else if (COMPILEDP (fun
))
1946 return (PVSIZE (fun
) > COMPILED_INTERACTIVE
? Qt
: if_prop
);
1948 /* Strings and vectors are keyboard macros. */
1949 if (STRINGP (fun
) || VECTORP (fun
))
1950 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
1952 /* Lists may represent commands. */
1955 funcar
= XCAR (fun
);
1956 if (EQ (funcar
, Qclosure
))
1957 return (!NILP (Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
)))))
1959 else if (EQ (funcar
, Qlambda
))
1960 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
1961 else if (EQ (funcar
, Qautoload
))
1962 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
1967 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1968 doc
: /* Define FUNCTION to autoload from FILE.
1969 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
1970 Third arg DOCSTRING is documentation for the function.
1971 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
1972 Fifth arg TYPE indicates the type of the object:
1973 nil or omitted says FUNCTION is a function,
1974 `keymap' says FUNCTION is really a keymap, and
1975 `macro' or t says FUNCTION is really a macro.
1976 Third through fifth args give info about the real definition.
1977 They default to nil.
1978 If FUNCTION is already defined other than as an autoload,
1979 this does nothing and returns nil. */)
1980 (Lisp_Object function
, Lisp_Object file
, Lisp_Object docstring
, Lisp_Object interactive
, Lisp_Object type
)
1982 CHECK_SYMBOL (function
);
1983 CHECK_STRING (file
);
1985 /* If function is defined and not as an autoload, don't override. */
1986 if (!NILP (XSYMBOL (function
)->u
.s
.function
)
1987 && !AUTOLOADP (XSYMBOL (function
)->u
.s
.function
))
1990 if (!NILP (Vpurify_flag
) && EQ (docstring
, make_number (0)))
1991 /* `read1' in lread.c has found the docstring starting with "\
1992 and assumed the docstring will be provided by Snarf-documentation, so it
1993 passed us 0 instead. But that leads to accidental sharing in purecopy's
1994 hash-consing, so we use a (hopefully) unique integer instead. */
1995 docstring
= make_number (XHASH (function
));
1996 return Fdefalias (function
,
1997 list5 (Qautoload
, file
, docstring
, interactive
, type
),
2002 un_autoload (Lisp_Object oldqueue
)
2004 Lisp_Object queue
, first
, second
;
2006 /* Queue to unwind is current value of Vautoload_queue.
2007 oldqueue is the shadowed value to leave in Vautoload_queue. */
2008 queue
= Vautoload_queue
;
2009 Vautoload_queue
= oldqueue
;
2010 while (CONSP (queue
))
2012 first
= XCAR (queue
);
2013 second
= Fcdr (first
);
2014 first
= Fcar (first
);
2015 if (EQ (first
, make_number (0)))
2018 Ffset (first
, second
);
2019 queue
= XCDR (queue
);
2023 /* Load an autoloaded function.
2024 FUNNAME is the symbol which is the function's name.
2025 FUNDEF is the autoload definition (a list). */
2027 DEFUN ("autoload-do-load", Fautoload_do_load
, Sautoload_do_load
, 1, 3, 0,
2028 doc
: /* Load FUNDEF which should be an autoload.
2029 If non-nil, FUNNAME should be the symbol whose function value is FUNDEF,
2030 in which case the function returns the new autoloaded function value.
2031 If equal to `macro', MACRO-ONLY specifies that FUNDEF should only be loaded if
2032 it defines a macro. */)
2033 (Lisp_Object fundef
, Lisp_Object funname
, Lisp_Object macro_only
)
2035 ptrdiff_t count
= SPECPDL_INDEX ();
2037 if (!CONSP (fundef
) || !EQ (Qautoload
, XCAR (fundef
)))
2040 Lisp_Object kind
= Fnth (make_number (4), fundef
);
2041 if (EQ (macro_only
, Qmacro
)
2042 && !(EQ (kind
, Qt
) || EQ (kind
, Qmacro
)))
2045 /* This is to make sure that loadup.el gives a clear picture
2046 of what files are preloaded and when. */
2047 if (! NILP (Vpurify_flag
))
2048 error ("Attempt to autoload %s while preparing to dump",
2049 SDATA (SYMBOL_NAME (funname
)));
2051 CHECK_SYMBOL (funname
);
2053 /* Preserve the match data. */
2054 record_unwind_save_match_data ();
2056 /* If autoloading gets an error (which includes the error of failing
2057 to define the function being called), we use Vautoload_queue
2058 to undo function definitions and `provide' calls made by
2059 the function. We do this in the specific case of autoloading
2060 because autoloading is not an explicit request "load this file",
2061 but rather a request to "call this function".
2063 The value saved here is to be restored into Vautoload_queue. */
2064 record_unwind_protect (un_autoload
, Vautoload_queue
);
2065 Vautoload_queue
= Qt
;
2066 /* If `macro_only' is set and fundef isn't a macro, assume this autoload to
2067 be a "best-effort" (e.g. to try and find a compiler macro),
2068 so don't signal an error if autoloading fails. */
2069 Lisp_Object ignore_errors
2070 = (EQ (kind
, Qt
) || EQ (kind
, Qmacro
)) ? Qnil
: macro_only
;
2071 Fload (Fcar (Fcdr (fundef
)), ignore_errors
, Qt
, Qnil
, Qt
);
2073 /* Once loading finishes, don't undo it. */
2074 Vautoload_queue
= Qt
;
2075 unbind_to (count
, Qnil
);
2077 if (NILP (funname
) || !NILP (ignore_errors
))
2081 Lisp_Object fun
= Findirect_function (funname
, Qnil
);
2083 if (!NILP (Fequal (fun
, fundef
)))
2084 error ("Autoloading file %s failed to define function %s",
2085 SDATA (Fcar (Fcar (Vload_history
))),
2086 SDATA (SYMBOL_NAME (funname
)));
2093 DEFUN ("eval", Feval
, Seval
, 1, 2, 0,
2094 doc
: /* Evaluate FORM and return its value.
2095 If LEXICAL is t, evaluate using lexical scoping.
2096 LEXICAL can also be an actual lexical environment, in the form of an
2097 alist mapping symbols to their value. */)
2098 (Lisp_Object form
, Lisp_Object lexical
)
2100 ptrdiff_t count
= SPECPDL_INDEX ();
2101 specbind (Qinternal_interpreter_environment
,
2102 CONSP (lexical
) || NILP (lexical
) ? lexical
: list1 (Qt
));
2103 return unbind_to (count
, eval_sub (form
));
2106 /* Grow the specpdl stack by one entry.
2107 The caller should have already initialized the entry.
2108 Signal an error on stack overflow.
2110 Make sure that there is always one unused entry past the top of the
2111 stack, so that the just-initialized entry is safely unwound if
2112 memory exhausted and an error is signaled here. Also, allocate a
2113 never-used entry just before the bottom of the stack; sometimes its
2114 address is taken. */
2121 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2123 ptrdiff_t count
= SPECPDL_INDEX ();
2124 ptrdiff_t max_size
= min (max_specpdl_size
, PTRDIFF_MAX
- 1000);
2125 union specbinding
*pdlvec
= specpdl
- 1;
2126 ptrdiff_t pdlvecsize
= specpdl_size
+ 1;
2127 if (max_size
<= specpdl_size
)
2129 if (max_specpdl_size
< 400)
2130 max_size
= max_specpdl_size
= 400;
2131 if (max_size
<= specpdl_size
)
2132 signal_error ("Variable binding depth exceeds max-specpdl-size",
2135 pdlvec
= xpalloc (pdlvec
, &pdlvecsize
, 1, max_size
+ 1, sizeof *specpdl
);
2136 specpdl
= pdlvec
+ 1;
2137 specpdl_size
= pdlvecsize
- 1;
2138 specpdl_ptr
= specpdl
+ count
;
2143 record_in_backtrace (Lisp_Object function
, Lisp_Object
*args
, ptrdiff_t nargs
)
2145 ptrdiff_t count
= SPECPDL_INDEX ();
2147 eassert (nargs
>= UNEVALLED
);
2148 specpdl_ptr
->bt
.kind
= SPECPDL_BACKTRACE
;
2149 specpdl_ptr
->bt
.debug_on_exit
= false;
2150 specpdl_ptr
->bt
.function
= function
;
2151 current_thread
->stack_top
= specpdl_ptr
->bt
.args
= args
;
2152 specpdl_ptr
->bt
.nargs
= nargs
;
2158 /* Eval a sub-expression of the current expression (i.e. in the same
2161 eval_sub (Lisp_Object form
)
2163 Lisp_Object fun
, val
, original_fun
, original_args
;
2167 /* Declare here, as this array may be accessed by call_debugger near
2168 the end of this function. See Bug#21245. */
2169 Lisp_Object argvals
[8];
2173 /* Look up its binding in the lexical environment.
2174 We do not pay attention to the declared_special flag here, since we
2175 already did that when let-binding the variable. */
2176 Lisp_Object lex_binding
2177 = !NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
2178 ? Fassq (form
, Vinternal_interpreter_environment
)
2180 if (CONSP (lex_binding
))
2181 return XCDR (lex_binding
);
2183 return Fsymbol_value (form
);
2193 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2195 if (max_lisp_eval_depth
< 100)
2196 max_lisp_eval_depth
= 100;
2197 if (lisp_eval_depth
> max_lisp_eval_depth
)
2198 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2201 original_fun
= XCAR (form
);
2202 original_args
= XCDR (form
);
2203 CHECK_LIST (original_args
);
2205 /* This also protects them from gc. */
2206 count
= record_in_backtrace (original_fun
, &original_args
, UNEVALLED
);
2208 if (debug_on_next_call
)
2209 do_debug_on_call (Qt
, count
);
2211 /* At this point, only original_fun and original_args
2212 have values that will be used below. */
2215 /* Optimize for no indirection. */
2218 fun
= Ffunction (Fcons (fun
, Qnil
));
2219 else if (!NILP (fun
) && (fun
= XSYMBOL (fun
)->u
.s
.function
, SYMBOLP (fun
)))
2220 fun
= indirect_function (fun
);
2224 Lisp_Object args_left
= original_args
;
2225 Lisp_Object numargs
= Flength (args_left
);
2229 if (XINT (numargs
) < XSUBR (fun
)->min_args
2230 || (XSUBR (fun
)->max_args
>= 0
2231 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2232 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2234 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2235 val
= (XSUBR (fun
)->function
.aUNEVALLED
) (args_left
);
2236 else if (XSUBR (fun
)->max_args
== MANY
)
2238 /* Pass a vector of evaluated arguments. */
2240 ptrdiff_t argnum
= 0;
2243 SAFE_ALLOCA_LISP (vals
, XINT (numargs
));
2245 while (CONSP (args_left
) && argnum
< XINT (numargs
))
2247 Lisp_Object arg
= XCAR (args_left
);
2248 args_left
= XCDR (args_left
);
2249 vals
[argnum
++] = eval_sub (arg
);
2252 set_backtrace_args (specpdl
+ count
, vals
, argnum
);
2254 val
= XSUBR (fun
)->function
.aMANY (argnum
, vals
);
2258 /* Do the debug-on-exit now, while VALS still exists. */
2259 if (backtrace_debug_on_exit (specpdl
+ count
))
2260 val
= call_debugger (list2 (Qexit
, val
));
2267 int i
, maxargs
= XSUBR (fun
)->max_args
;
2269 for (i
= 0; i
< maxargs
; i
++)
2271 argvals
[i
] = eval_sub (Fcar (args_left
));
2272 args_left
= Fcdr (args_left
);
2275 set_backtrace_args (specpdl
+ count
, argvals
, XINT (numargs
));
2280 val
= (XSUBR (fun
)->function
.a0 ());
2283 val
= (XSUBR (fun
)->function
.a1 (argvals
[0]));
2286 val
= (XSUBR (fun
)->function
.a2 (argvals
[0], argvals
[1]));
2289 val
= (XSUBR (fun
)->function
.a3
2290 (argvals
[0], argvals
[1], argvals
[2]));
2293 val
= (XSUBR (fun
)->function
.a4
2294 (argvals
[0], argvals
[1], argvals
[2], argvals
[3]));
2297 val
= (XSUBR (fun
)->function
.a5
2298 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2302 val
= (XSUBR (fun
)->function
.a6
2303 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2304 argvals
[4], argvals
[5]));
2307 val
= (XSUBR (fun
)->function
.a7
2308 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2309 argvals
[4], argvals
[5], argvals
[6]));
2313 val
= (XSUBR (fun
)->function
.a8
2314 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2315 argvals
[4], argvals
[5], argvals
[6], argvals
[7]));
2319 /* Someone has created a subr that takes more arguments than
2320 is supported by this code. We need to either rewrite the
2321 subr to use a different argument protocol, or add more
2322 cases to this switch. */
2327 else if (COMPILEDP (fun
) || MODULE_FUNCTIONP (fun
))
2328 return apply_lambda (fun
, original_args
, count
);
2332 xsignal1 (Qvoid_function
, original_fun
);
2334 xsignal1 (Qinvalid_function
, original_fun
);
2335 funcar
= XCAR (fun
);
2336 if (!SYMBOLP (funcar
))
2337 xsignal1 (Qinvalid_function
, original_fun
);
2338 if (EQ (funcar
, Qautoload
))
2340 Fautoload_do_load (fun
, original_fun
, Qnil
);
2343 if (EQ (funcar
, Qmacro
))
2345 ptrdiff_t count1
= SPECPDL_INDEX ();
2347 /* Bind lexical-binding during expansion of the macro, so the
2348 macro can know reliably if the code it outputs will be
2349 interpreted using lexical-binding or not. */
2350 specbind (Qlexical_binding
,
2351 NILP (Vinternal_interpreter_environment
) ? Qnil
: Qt
);
2352 exp
= apply1 (Fcdr (fun
), original_args
);
2353 unbind_to (count1
, Qnil
);
2354 val
= eval_sub (exp
);
2356 else if (EQ (funcar
, Qlambda
)
2357 || EQ (funcar
, Qclosure
))
2358 return apply_lambda (fun
, original_args
, count
);
2360 xsignal1 (Qinvalid_function
, original_fun
);
2365 if (backtrace_debug_on_exit (specpdl
+ count
))
2366 val
= call_debugger (list2 (Qexit
, val
));
2372 DEFUN ("apply", Fapply
, Sapply
, 1, MANY
, 0,
2373 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2374 Then return the value FUNCTION returns.
2375 Thus, (apply \\='+ 1 2 \\='(3 4)) returns 10.
2376 usage: (apply FUNCTION &rest ARGUMENTS) */)
2377 (ptrdiff_t nargs
, Lisp_Object
*args
)
2379 ptrdiff_t i
, numargs
, funcall_nargs
;
2380 register Lisp_Object
*funcall_args
= NULL
;
2381 register Lisp_Object spread_arg
= args
[nargs
- 1];
2382 Lisp_Object fun
= args
[0];
2386 CHECK_LIST (spread_arg
);
2388 numargs
= XINT (Flength (spread_arg
));
2391 return Ffuncall (nargs
- 1, args
);
2392 else if (numargs
== 1)
2394 args
[nargs
- 1] = XCAR (spread_arg
);
2395 return Ffuncall (nargs
, args
);
2398 numargs
+= nargs
- 2;
2400 /* Optimize for no indirection. */
2401 if (SYMBOLP (fun
) && !NILP (fun
)
2402 && (fun
= XSYMBOL (fun
)->u
.s
.function
, SYMBOLP (fun
)))
2404 fun
= indirect_function (fun
);
2406 /* Let funcall get the error. */
2410 if (SUBRP (fun
) && XSUBR (fun
)->max_args
> numargs
2411 /* Don't hide an error by adding missing arguments. */
2412 && numargs
>= XSUBR (fun
)->min_args
)
2414 /* Avoid making funcall cons up a yet another new vector of arguments
2415 by explicitly supplying nil's for optional values. */
2416 SAFE_ALLOCA_LISP (funcall_args
, 1 + XSUBR (fun
)->max_args
);
2417 memclear (funcall_args
+ numargs
+ 1,
2418 (XSUBR (fun
)->max_args
- numargs
) * word_size
);
2419 funcall_nargs
= 1 + XSUBR (fun
)->max_args
;
2422 { /* We add 1 to numargs because funcall_args includes the
2423 function itself as well as its arguments. */
2424 SAFE_ALLOCA_LISP (funcall_args
, 1 + numargs
);
2425 funcall_nargs
= 1 + numargs
;
2428 memcpy (funcall_args
, args
, nargs
* word_size
);
2429 /* Spread the last arg we got. Its first element goes in
2430 the slot that it used to occupy, hence this value of I. */
2432 while (!NILP (spread_arg
))
2434 funcall_args
[i
++] = XCAR (spread_arg
);
2435 spread_arg
= XCDR (spread_arg
);
2438 retval
= Ffuncall (funcall_nargs
, funcall_args
);
2444 /* Run hook variables in various ways. */
2447 funcall_nil (ptrdiff_t nargs
, Lisp_Object
*args
)
2449 Ffuncall (nargs
, args
);
2453 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2454 doc
: /* Run each hook in HOOKS.
2455 Each argument should be a symbol, a hook variable.
2456 These symbols are processed in the order specified.
2457 If a hook symbol has a non-nil value, that value may be a function
2458 or a list of functions to be called to run the hook.
2459 If the value is a function, it is called with no arguments.
2460 If it is a list, the elements are called, in order, with no arguments.
2462 Major modes should not use this function directly to run their mode
2463 hook; they should use `run-mode-hooks' instead.
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-hooks &rest HOOKS) */)
2468 (ptrdiff_t nargs
, Lisp_Object
*args
)
2472 for (i
= 0; i
< nargs
; i
++)
2478 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2479 Srun_hook_with_args
, 1, MANY
, 0,
2480 doc
: /* Run HOOK with the specified arguments ARGS.
2481 HOOK should be a symbol, a hook variable. The value of HOOK
2482 may be nil, a function, or a list of functions. Call each
2483 function in order with arguments ARGS. The final return value
2486 Do not use `make-local-variable' to make a hook variable buffer-local.
2487 Instead, use `add-hook' and specify t for the LOCAL argument.
2488 usage: (run-hook-with-args HOOK &rest ARGS) */)
2489 (ptrdiff_t nargs
, Lisp_Object
*args
)
2491 return run_hook_with_args (nargs
, args
, funcall_nil
);
2494 /* NB this one still documents a specific non-nil return value.
2495 (As did run-hook-with-args and run-hook-with-args-until-failure
2496 until they were changed in 24.1.) */
2497 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2498 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2499 doc
: /* Run HOOK with the specified arguments ARGS.
2500 HOOK should be a symbol, a hook variable. The value of HOOK
2501 may be nil, a function, or a list of functions. Call each
2502 function in order with arguments ARGS, stopping at the first
2503 one that returns non-nil, and return that value. Otherwise (if
2504 all functions return nil, or if there are no functions to call),
2507 Do not use `make-local-variable' to make a hook variable buffer-local.
2508 Instead, use `add-hook' and specify t for the LOCAL argument.
2509 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2510 (ptrdiff_t nargs
, Lisp_Object
*args
)
2512 return run_hook_with_args (nargs
, args
, Ffuncall
);
2516 funcall_not (ptrdiff_t nargs
, Lisp_Object
*args
)
2518 return NILP (Ffuncall (nargs
, args
)) ? Qt
: Qnil
;
2521 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2522 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2523 doc
: /* Run HOOK with the specified arguments ARGS.
2524 HOOK should be a symbol, a hook variable. The value of HOOK
2525 may be nil, a function, or a list of functions. Call each
2526 function in order with arguments ARGS, stopping at the first
2527 one that returns nil, and return nil. Otherwise (if all functions
2528 return non-nil, or if there are no functions to call), return non-nil
2529 \(do not rely on the precise return value in this case).
2531 Do not use `make-local-variable' to make a hook variable buffer-local.
2532 Instead, use `add-hook' and specify t for the LOCAL argument.
2533 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2534 (ptrdiff_t nargs
, Lisp_Object
*args
)
2536 return NILP (run_hook_with_args (nargs
, args
, funcall_not
)) ? Qt
: Qnil
;
2540 run_hook_wrapped_funcall (ptrdiff_t nargs
, Lisp_Object
*args
)
2542 Lisp_Object tmp
= args
[0], ret
;
2545 ret
= Ffuncall (nargs
, args
);
2551 DEFUN ("run-hook-wrapped", Frun_hook_wrapped
, Srun_hook_wrapped
, 2, MANY
, 0,
2552 doc
: /* Run HOOK, passing each function through WRAP-FUNCTION.
2553 I.e. instead of calling each function FUN directly with arguments ARGS,
2554 it calls WRAP-FUNCTION with arguments FUN and ARGS.
2555 As soon as a call to WRAP-FUNCTION returns non-nil, `run-hook-wrapped'
2556 aborts and returns that value.
2557 usage: (run-hook-wrapped HOOK WRAP-FUNCTION &rest ARGS) */)
2558 (ptrdiff_t nargs
, Lisp_Object
*args
)
2560 return run_hook_with_args (nargs
, args
, run_hook_wrapped_funcall
);
2563 /* ARGS[0] should be a hook symbol.
2564 Call each of the functions in the hook value, passing each of them
2565 as arguments all the rest of ARGS (all NARGS - 1 elements).
2566 FUNCALL specifies how to call each function on the hook. */
2569 run_hook_with_args (ptrdiff_t nargs
, Lisp_Object
*args
,
2570 Lisp_Object (*funcall
) (ptrdiff_t nargs
, Lisp_Object
*args
))
2572 Lisp_Object sym
, val
, ret
= Qnil
;
2574 /* If we are dying or still initializing,
2575 don't do anything--it would probably crash if we tried. */
2576 if (NILP (Vrun_hooks
))
2580 val
= find_symbol_value (sym
);
2582 if (EQ (val
, Qunbound
) || NILP (val
))
2584 else if (!CONSP (val
) || FUNCTIONP (val
))
2587 return funcall (nargs
, args
);
2591 Lisp_Object global_vals
= Qnil
;
2594 CONSP (val
) && NILP (ret
);
2597 if (EQ (XCAR (val
), Qt
))
2599 /* t indicates this hook has a local binding;
2600 it means to run the global binding too. */
2601 global_vals
= Fdefault_value (sym
);
2602 if (NILP (global_vals
)) continue;
2604 if (!CONSP (global_vals
) || EQ (XCAR (global_vals
), Qlambda
))
2606 args
[0] = global_vals
;
2607 ret
= funcall (nargs
, args
);
2612 CONSP (global_vals
) && NILP (ret
);
2613 global_vals
= XCDR (global_vals
))
2615 args
[0] = XCAR (global_vals
);
2616 /* In a global value, t should not occur. If it does, we
2617 must ignore it to avoid an endless loop. */
2618 if (!EQ (args
[0], Qt
))
2619 ret
= funcall (nargs
, args
);
2625 args
[0] = XCAR (val
);
2626 ret
= funcall (nargs
, args
);
2634 /* Run the hook HOOK, giving each function no args. */
2637 run_hook (Lisp_Object hook
)
2639 Frun_hook_with_args (1, &hook
);
2642 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2645 run_hook_with_args_2 (Lisp_Object hook
, Lisp_Object arg1
, Lisp_Object arg2
)
2647 CALLN (Frun_hook_with_args
, hook
, arg1
, arg2
);
2650 /* Apply fn to arg. */
2652 apply1 (Lisp_Object fn
, Lisp_Object arg
)
2654 return NILP (arg
) ? Ffuncall (1, &fn
) : CALLN (Fapply
, fn
, arg
);
2657 /* Call function fn on no arguments. */
2659 call0 (Lisp_Object fn
)
2661 return Ffuncall (1, &fn
);
2664 /* Call function fn with 1 argument arg1. */
2667 call1 (Lisp_Object fn
, Lisp_Object arg1
)
2669 return CALLN (Ffuncall
, fn
, arg1
);
2672 /* Call function fn with 2 arguments arg1, arg2. */
2675 call2 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
)
2677 return CALLN (Ffuncall
, fn
, arg1
, arg2
);
2680 /* Call function fn with 3 arguments arg1, arg2, arg3. */
2683 call3 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2685 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
);
2688 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
2691 call4 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2694 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
);
2697 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
2700 call5 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2701 Lisp_Object arg4
, Lisp_Object arg5
)
2703 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
);
2706 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
2709 call6 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2710 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
)
2712 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
);
2715 /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
2718 call7 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2719 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
)
2721 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
);
2724 /* Call function fn with 8 arguments arg1, arg2, arg3, arg4, arg5,
2725 arg6, arg7, arg8. */
2728 call8 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2729 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
,
2732 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
, arg8
);
2735 DEFUN ("functionp", Ffunctionp
, Sfunctionp
, 1, 1, 0,
2736 doc
: /* Return t if OBJECT is a function. */)
2737 (Lisp_Object object
)
2739 if (FUNCTIONP (object
))
2745 FUNCTIONP (Lisp_Object object
)
2747 if (SYMBOLP (object
) && !NILP (Ffboundp (object
)))
2749 object
= Findirect_function (object
, Qt
);
2751 if (CONSP (object
) && EQ (XCAR (object
), Qautoload
))
2753 /* Autoloaded symbols are functions, except if they load
2754 macros or keymaps. */
2755 for (int i
= 0; i
< 4 && CONSP (object
); i
++)
2756 object
= XCDR (object
);
2758 return ! (CONSP (object
) && !NILP (XCAR (object
)));
2763 return XSUBR (object
)->max_args
!= UNEVALLED
;
2764 else if (COMPILEDP (object
) || MODULE_FUNCTIONP (object
))
2766 else if (CONSP (object
))
2768 Lisp_Object car
= XCAR (object
);
2769 return EQ (car
, Qlambda
) || EQ (car
, Qclosure
);
2775 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2776 doc
: /* Call first argument as a function, passing remaining arguments to it.
2777 Return the value that function returns.
2778 Thus, (funcall \\='cons \\='x \\='y) returns (x . y).
2779 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2780 (ptrdiff_t nargs
, Lisp_Object
*args
)
2782 Lisp_Object fun
, original_fun
;
2784 ptrdiff_t numargs
= nargs
- 1;
2790 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2792 if (max_lisp_eval_depth
< 100)
2793 max_lisp_eval_depth
= 100;
2794 if (lisp_eval_depth
> max_lisp_eval_depth
)
2795 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2798 count
= record_in_backtrace (args
[0], &args
[1], nargs
- 1);
2802 if (debug_on_next_call
)
2803 do_debug_on_call (Qlambda
, count
);
2807 original_fun
= args
[0];
2811 /* Optimize for no indirection. */
2813 if (SYMBOLP (fun
) && !NILP (fun
)
2814 && (fun
= XSYMBOL (fun
)->u
.s
.function
, SYMBOLP (fun
)))
2815 fun
= indirect_function (fun
);
2818 val
= funcall_subr (XSUBR (fun
), numargs
, args
+ 1);
2819 else if (COMPILEDP (fun
) || MODULE_FUNCTIONP (fun
))
2820 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2824 xsignal1 (Qvoid_function
, original_fun
);
2826 xsignal1 (Qinvalid_function
, original_fun
);
2827 funcar
= XCAR (fun
);
2828 if (!SYMBOLP (funcar
))
2829 xsignal1 (Qinvalid_function
, original_fun
);
2830 if (EQ (funcar
, Qlambda
)
2831 || EQ (funcar
, Qclosure
))
2832 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2833 else if (EQ (funcar
, Qautoload
))
2835 Fautoload_do_load (fun
, original_fun
, Qnil
);
2840 xsignal1 (Qinvalid_function
, original_fun
);
2844 if (backtrace_debug_on_exit (specpdl
+ count
))
2845 val
= call_debugger (list2 (Qexit
, val
));
2851 /* Apply a C subroutine SUBR to the NUMARGS evaluated arguments in ARG_VECTOR
2852 and return the result of evaluation. */
2855 funcall_subr (struct Lisp_Subr
*subr
, ptrdiff_t numargs
, Lisp_Object
*args
)
2857 if (numargs
< subr
->min_args
2858 || (subr
->max_args
>= 0 && subr
->max_args
< numargs
))
2861 XSETSUBR (fun
, subr
);
2862 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (numargs
));
2865 else if (subr
->max_args
== UNEVALLED
)
2868 XSETSUBR (fun
, subr
);
2869 xsignal1 (Qinvalid_function
, fun
);
2872 else if (subr
->max_args
== MANY
)
2873 return (subr
->function
.aMANY
) (numargs
, args
);
2876 Lisp_Object internal_argbuf
[8];
2877 Lisp_Object
*internal_args
;
2878 if (subr
->max_args
> numargs
)
2880 eassert (subr
->max_args
<= ARRAYELTS (internal_argbuf
));
2881 internal_args
= internal_argbuf
;
2882 memcpy (internal_args
, args
, numargs
* word_size
);
2883 memclear (internal_args
+ numargs
,
2884 (subr
->max_args
- numargs
) * word_size
);
2887 internal_args
= args
;
2888 switch (subr
->max_args
)
2891 return (subr
->function
.a0 ());
2893 return (subr
->function
.a1 (internal_args
[0]));
2895 return (subr
->function
.a2
2896 (internal_args
[0], internal_args
[1]));
2898 return (subr
->function
.a3
2899 (internal_args
[0], internal_args
[1], internal_args
[2]));
2901 return (subr
->function
.a4
2902 (internal_args
[0], internal_args
[1], internal_args
[2],
2905 return (subr
->function
.a5
2906 (internal_args
[0], internal_args
[1], internal_args
[2],
2907 internal_args
[3], internal_args
[4]));
2909 return (subr
->function
.a6
2910 (internal_args
[0], internal_args
[1], internal_args
[2],
2911 internal_args
[3], internal_args
[4], internal_args
[5]));
2913 return (subr
->function
.a7
2914 (internal_args
[0], internal_args
[1], internal_args
[2],
2915 internal_args
[3], internal_args
[4], internal_args
[5],
2918 return (subr
->function
.a8
2919 (internal_args
[0], internal_args
[1], internal_args
[2],
2920 internal_args
[3], internal_args
[4], internal_args
[5],
2921 internal_args
[6], internal_args
[7]));
2925 /* If a subr takes more than 8 arguments without using MANY
2926 or UNEVALLED, we need to extend this function to support it.
2927 Until this is done, there is no way to call the function. */
2934 apply_lambda (Lisp_Object fun
, Lisp_Object args
, ptrdiff_t count
)
2936 Lisp_Object args_left
;
2939 Lisp_Object
*arg_vector
;
2943 numargs
= XFASTINT (Flength (args
));
2944 SAFE_ALLOCA_LISP (arg_vector
, numargs
);
2947 for (i
= 0; i
< numargs
; )
2949 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2950 tem
= eval_sub (tem
);
2951 arg_vector
[i
++] = tem
;
2954 set_backtrace_args (specpdl
+ count
, arg_vector
, i
);
2955 tem
= funcall_lambda (fun
, numargs
, arg_vector
);
2959 /* Do the debug-on-exit now, while arg_vector still exists. */
2960 if (backtrace_debug_on_exit (specpdl
+ count
))
2961 tem
= call_debugger (list2 (Qexit
, tem
));
2967 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2968 and return the result of evaluation.
2969 FUN must be either a lambda-expression, a compiled-code object,
2970 or a module function. */
2973 funcall_lambda (Lisp_Object fun
, ptrdiff_t nargs
,
2974 register Lisp_Object
*arg_vector
)
2976 Lisp_Object val
, syms_left
, next
, lexenv
;
2977 ptrdiff_t count
= SPECPDL_INDEX ();
2979 bool optional
, rest
;
2983 if (EQ (XCAR (fun
), Qclosure
))
2985 Lisp_Object cdr
= XCDR (fun
); /* Drop `closure'. */
2987 xsignal1 (Qinvalid_function
, fun
);
2989 lexenv
= XCAR (fun
);
2993 syms_left
= XCDR (fun
);
2994 if (CONSP (syms_left
))
2995 syms_left
= XCAR (syms_left
);
2997 xsignal1 (Qinvalid_function
, fun
);
2999 else if (COMPILEDP (fun
))
3001 ptrdiff_t size
= PVSIZE (fun
);
3002 if (size
<= COMPILED_STACK_DEPTH
)
3003 xsignal1 (Qinvalid_function
, fun
);
3004 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3005 if (INTEGERP (syms_left
))
3006 /* A byte-code object with an integer args template means we
3007 shouldn't bind any arguments, instead just call the byte-code
3008 interpreter directly; it will push arguments as necessary.
3010 Byte-code objects with a nil args template (the default)
3011 have dynamically-bound arguments, and use the
3012 argument-binding code below instead (as do all interpreted
3013 functions, even lexically bound ones). */
3015 /* If we have not actually read the bytecode string
3016 and constants vector yet, fetch them from the file. */
3017 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3018 Ffetch_bytecode (fun
);
3019 return exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
3020 AREF (fun
, COMPILED_CONSTANTS
),
3021 AREF (fun
, COMPILED_STACK_DEPTH
),
3028 else if (MODULE_FUNCTIONP (fun
))
3029 return funcall_module (fun
, nargs
, arg_vector
);
3034 i
= optional
= rest
= 0;
3035 bool previous_optional_or_rest
= false;
3036 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3040 next
= XCAR (syms_left
);
3041 if (!SYMBOLP (next
))
3042 xsignal1 (Qinvalid_function
, fun
);
3044 if (EQ (next
, Qand_rest
))
3046 if (rest
|| previous_optional_or_rest
)
3047 xsignal1 (Qinvalid_function
, fun
);
3049 previous_optional_or_rest
= true;
3051 else if (EQ (next
, Qand_optional
))
3053 if (optional
|| rest
|| previous_optional_or_rest
)
3054 xsignal1 (Qinvalid_function
, fun
);
3056 previous_optional_or_rest
= true;
3063 arg
= Flist (nargs
- i
, &arg_vector
[i
]);
3067 arg
= arg_vector
[i
++];
3069 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3073 /* Bind the argument. */
3074 if (!NILP (lexenv
) && SYMBOLP (next
))
3075 /* Lexically bind NEXT by adding it to the lexenv alist. */
3076 lexenv
= Fcons (Fcons (next
, arg
), lexenv
);
3078 /* Dynamically bind NEXT. */
3079 specbind (next
, arg
);
3080 previous_optional_or_rest
= false;
3084 if (!NILP (syms_left
) || previous_optional_or_rest
)
3085 xsignal1 (Qinvalid_function
, fun
);
3087 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3089 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
3090 /* Instantiate a new lexical environment. */
3091 specbind (Qinternal_interpreter_environment
, lexenv
);
3094 val
= Fprogn (XCDR (XCDR (fun
)));
3097 /* If we have not actually read the bytecode string
3098 and constants vector yet, fetch them from the file. */
3099 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3100 Ffetch_bytecode (fun
);
3101 val
= exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
3102 AREF (fun
, COMPILED_CONSTANTS
),
3103 AREF (fun
, COMPILED_STACK_DEPTH
),
3107 return unbind_to (count
, val
);
3110 DEFUN ("func-arity", Ffunc_arity
, Sfunc_arity
, 1, 1, 0,
3111 doc
: /* Return minimum and maximum number of args allowed for FUNCTION.
3112 FUNCTION must be a function of some kind.
3113 The returned value is a cons cell (MIN . MAX). MIN is the minimum number
3114 of args. MAX is the maximum number, or the symbol `many', for a
3115 function with `&rest' args, or `unevalled' for a special form. */)
3116 (Lisp_Object function
)
3118 Lisp_Object original
;
3122 original
= function
;
3126 /* Optimize for no indirection. */
3127 function
= original
;
3128 if (SYMBOLP (function
) && !NILP (function
))
3130 function
= XSYMBOL (function
)->u
.s
.function
;
3131 if (SYMBOLP (function
))
3132 function
= indirect_function (function
);
3135 if (CONSP (function
) && EQ (XCAR (function
), Qmacro
))
3136 function
= XCDR (function
);
3138 if (SUBRP (function
))
3139 result
= Fsubr_arity (function
);
3140 else if (COMPILEDP (function
))
3141 result
= lambda_arity (function
);
3143 else if (MODULE_FUNCTIONP (function
))
3144 result
= module_function_arity (XMODULE_FUNCTION (function
));
3148 if (NILP (function
))
3149 xsignal1 (Qvoid_function
, original
);
3150 if (!CONSP (function
))
3151 xsignal1 (Qinvalid_function
, original
);
3152 funcar
= XCAR (function
);
3153 if (!SYMBOLP (funcar
))
3154 xsignal1 (Qinvalid_function
, original
);
3155 if (EQ (funcar
, Qlambda
)
3156 || EQ (funcar
, Qclosure
))
3157 result
= lambda_arity (function
);
3158 else if (EQ (funcar
, Qautoload
))
3160 Fautoload_do_load (function
, original
, Qnil
);
3164 xsignal1 (Qinvalid_function
, original
);
3169 /* FUN must be either a lambda-expression or a compiled-code object. */
3171 lambda_arity (Lisp_Object fun
)
3173 Lisp_Object syms_left
;
3177 if (EQ (XCAR (fun
), Qclosure
))
3179 fun
= XCDR (fun
); /* Drop `closure'. */
3182 syms_left
= XCDR (fun
);
3183 if (CONSP (syms_left
))
3184 syms_left
= XCAR (syms_left
);
3186 xsignal1 (Qinvalid_function
, fun
);
3188 else if (COMPILEDP (fun
))
3190 ptrdiff_t size
= PVSIZE (fun
);
3191 if (size
<= COMPILED_STACK_DEPTH
)
3192 xsignal1 (Qinvalid_function
, fun
);
3193 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3194 if (INTEGERP (syms_left
))
3195 return get_byte_code_arity (syms_left
);
3200 EMACS_INT minargs
= 0, maxargs
= 0;
3201 bool optional
= false;
3202 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3204 Lisp_Object next
= XCAR (syms_left
);
3205 if (!SYMBOLP (next
))
3206 xsignal1 (Qinvalid_function
, fun
);
3208 if (EQ (next
, Qand_rest
))
3209 return Fcons (make_number (minargs
), Qmany
);
3210 else if (EQ (next
, Qand_optional
))
3220 if (!NILP (syms_left
))
3221 xsignal1 (Qinvalid_function
, fun
);
3223 return Fcons (make_number (minargs
), make_number (maxargs
));
3226 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3228 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3229 (Lisp_Object object
)
3233 if (COMPILEDP (object
))
3235 ptrdiff_t size
= PVSIZE (object
);
3236 if (size
<= COMPILED_STACK_DEPTH
)
3237 xsignal1 (Qinvalid_function
, object
);
3238 if (CONSP (AREF (object
, COMPILED_BYTECODE
)))
3240 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3243 tem
= AREF (object
, COMPILED_BYTECODE
);
3244 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3245 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3247 error ("Invalid byte code");
3249 ASET (object
, COMPILED_BYTECODE
, XCAR (tem
));
3250 ASET (object
, COMPILED_CONSTANTS
, XCDR (tem
));
3256 /* Return true if SYMBOL currently has a let-binding
3257 which was made in the buffer that is now current. */
3260 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
3262 union specbinding
*p
;
3263 Lisp_Object buf
= Fcurrent_buffer ();
3265 for (p
= specpdl_ptr
; p
> specpdl
; )
3266 if ((--p
)->kind
> SPECPDL_LET
)
3268 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (specpdl_symbol (p
));
3269 eassert (let_bound_symbol
->u
.s
.redirect
!= SYMBOL_VARALIAS
);
3270 if (symbol
== let_bound_symbol
3271 && EQ (specpdl_where (p
), buf
))
3279 do_specbind (struct Lisp_Symbol
*sym
, union specbinding
*bind
,
3280 Lisp_Object value
, enum Set_Internal_Bind bindflag
)
3282 switch (sym
->u
.s
.redirect
)
3284 case SYMBOL_PLAINVAL
:
3285 if (!sym
->u
.s
.trapped_write
)
3286 SET_SYMBOL_VAL (sym
, value
);
3288 set_internal (specpdl_symbol (bind
), value
, Qnil
, bindflag
);
3291 case SYMBOL_FORWARDED
:
3292 if (BUFFER_OBJFWDP (SYMBOL_FWD (sym
))
3293 && specpdl_kind (bind
) == SPECPDL_LET_DEFAULT
)
3295 set_default_internal (specpdl_symbol (bind
), value
, bindflag
);
3299 case SYMBOL_LOCALIZED
:
3300 set_internal (specpdl_symbol (bind
), value
, Qnil
, bindflag
);
3308 /* `specpdl_ptr' describes which variable is
3309 let-bound, so it can be properly undone when we unbind_to.
3310 It can be either a plain SPECPDL_LET or a SPECPDL_LET_LOCAL/DEFAULT.
3311 - SYMBOL is the variable being bound. Note that it should not be
3312 aliased (i.e. when let-binding V1 that's aliased to V2, we want
3314 - WHERE tells us in which buffer the binding took place.
3315 This is used for SPECPDL_LET_LOCAL bindings (i.e. bindings to a
3316 buffer-local variable) as well as for SPECPDL_LET_DEFAULT bindings,
3317 i.e. bindings to the default value of a variable which can be
3321 specbind (Lisp_Object symbol
, Lisp_Object value
)
3323 struct Lisp_Symbol
*sym
;
3325 CHECK_SYMBOL (symbol
);
3326 sym
= XSYMBOL (symbol
);
3329 switch (sym
->u
.s
.redirect
)
3331 case SYMBOL_VARALIAS
:
3332 sym
= indirect_variable (sym
); XSETSYMBOL (symbol
, sym
); goto start
;
3333 case SYMBOL_PLAINVAL
:
3334 /* The most common case is that of a non-constant symbol with a
3335 trivial value. Make that as fast as we can. */
3336 specpdl_ptr
->let
.kind
= SPECPDL_LET
;
3337 specpdl_ptr
->let
.symbol
= symbol
;
3338 specpdl_ptr
->let
.old_value
= SYMBOL_VAL (sym
);
3339 specpdl_ptr
->let
.saved_value
= Qnil
;
3341 do_specbind (sym
, specpdl_ptr
- 1, value
, SET_INTERNAL_BIND
);
3343 case SYMBOL_LOCALIZED
:
3344 case SYMBOL_FORWARDED
:
3346 Lisp_Object ovalue
= find_symbol_value (symbol
);
3347 specpdl_ptr
->let
.kind
= SPECPDL_LET_LOCAL
;
3348 specpdl_ptr
->let
.symbol
= symbol
;
3349 specpdl_ptr
->let
.old_value
= ovalue
;
3350 specpdl_ptr
->let
.where
= Fcurrent_buffer ();
3351 specpdl_ptr
->let
.saved_value
= Qnil
;
3353 eassert (sym
->u
.s
.redirect
!= SYMBOL_LOCALIZED
3354 || (EQ (SYMBOL_BLV (sym
)->where
, Fcurrent_buffer ())));
3356 if (sym
->u
.s
.redirect
== SYMBOL_LOCALIZED
)
3358 if (!blv_found (SYMBOL_BLV (sym
)))
3359 specpdl_ptr
->let
.kind
= SPECPDL_LET_DEFAULT
;
3361 else if (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)))
3363 /* If SYMBOL is a per-buffer variable which doesn't have a
3364 buffer-local value here, make the `let' change the global
3365 value by changing the value of SYMBOL in all buffers not
3366 having their own value. This is consistent with what
3367 happens with other buffer-local variables. */
3368 if (NILP (Flocal_variable_p (symbol
, Qnil
)))
3370 specpdl_ptr
->let
.kind
= SPECPDL_LET_DEFAULT
;
3372 do_specbind (sym
, specpdl_ptr
- 1, value
, SET_INTERNAL_BIND
);
3377 specpdl_ptr
->let
.kind
= SPECPDL_LET
;
3380 do_specbind (sym
, specpdl_ptr
- 1, value
, SET_INTERNAL_BIND
);
3383 default: emacs_abort ();
3387 /* Push unwind-protect entries of various types. */
3390 record_unwind_protect (void (*function
) (Lisp_Object
), Lisp_Object arg
)
3392 specpdl_ptr
->unwind
.kind
= SPECPDL_UNWIND
;
3393 specpdl_ptr
->unwind
.func
= function
;
3394 specpdl_ptr
->unwind
.arg
= arg
;
3399 record_unwind_protect_ptr (void (*function
) (void *), void *arg
)
3401 specpdl_ptr
->unwind_ptr
.kind
= SPECPDL_UNWIND_PTR
;
3402 specpdl_ptr
->unwind_ptr
.func
= function
;
3403 specpdl_ptr
->unwind_ptr
.arg
= arg
;
3408 record_unwind_protect_int (void (*function
) (int), int arg
)
3410 specpdl_ptr
->unwind_int
.kind
= SPECPDL_UNWIND_INT
;
3411 specpdl_ptr
->unwind_int
.func
= function
;
3412 specpdl_ptr
->unwind_int
.arg
= arg
;
3417 record_unwind_protect_void (void (*function
) (void))
3419 specpdl_ptr
->unwind_void
.kind
= SPECPDL_UNWIND_VOID
;
3420 specpdl_ptr
->unwind_void
.func
= function
;
3425 rebind_for_thread_switch (void)
3427 union specbinding
*bind
;
3429 for (bind
= specpdl
; bind
!= specpdl_ptr
; ++bind
)
3431 if (bind
->kind
>= SPECPDL_LET
)
3433 Lisp_Object value
= specpdl_saved_value (bind
);
3434 Lisp_Object sym
= specpdl_symbol (bind
);
3435 bind
->let
.saved_value
= Qnil
;
3436 do_specbind (XSYMBOL (sym
), bind
, value
,
3437 SET_INTERNAL_THREAD_SWITCH
);
3443 do_one_unbind (union specbinding
*this_binding
, bool unwinding
,
3444 enum Set_Internal_Bind bindflag
)
3446 eassert (unwinding
|| this_binding
->kind
>= SPECPDL_LET
);
3447 switch (this_binding
->kind
)
3449 case SPECPDL_UNWIND
:
3450 this_binding
->unwind
.func (this_binding
->unwind
.arg
);
3452 case SPECPDL_UNWIND_PTR
:
3453 this_binding
->unwind_ptr
.func (this_binding
->unwind_ptr
.arg
);
3455 case SPECPDL_UNWIND_INT
:
3456 this_binding
->unwind_int
.func (this_binding
->unwind_int
.arg
);
3458 case SPECPDL_UNWIND_VOID
:
3459 this_binding
->unwind_void
.func ();
3461 case SPECPDL_BACKTRACE
:
3464 { /* If variable has a trivial value (no forwarding), and isn't
3465 trapped, we can just set it. */
3466 Lisp_Object sym
= specpdl_symbol (this_binding
);
3467 if (SYMBOLP (sym
) && XSYMBOL (sym
)->u
.s
.redirect
== SYMBOL_PLAINVAL
)
3469 if (XSYMBOL (sym
)->u
.s
.trapped_write
== SYMBOL_UNTRAPPED_WRITE
)
3470 SET_SYMBOL_VAL (XSYMBOL (sym
), specpdl_old_value (this_binding
));
3472 set_internal (sym
, specpdl_old_value (this_binding
),
3477 /* Come here only if make_local_foo was used for the first time
3478 on this var within this let. */
3480 case SPECPDL_LET_DEFAULT
:
3481 set_default_internal (specpdl_symbol (this_binding
),
3482 specpdl_old_value (this_binding
),
3485 case SPECPDL_LET_LOCAL
:
3487 Lisp_Object symbol
= specpdl_symbol (this_binding
);
3488 Lisp_Object where
= specpdl_where (this_binding
);
3489 Lisp_Object old_value
= specpdl_old_value (this_binding
);
3490 eassert (BUFFERP (where
));
3492 /* If this was a local binding, reset the value in the appropriate
3493 buffer, but only if that buffer's binding still exists. */
3494 if (!NILP (Flocal_variable_p (symbol
, where
)))
3495 set_internal (symbol
, old_value
, where
, bindflag
);
3505 /* Push an unwind-protect entry that does nothing, so that
3506 set_unwind_protect_ptr can overwrite it later. */
3509 record_unwind_protect_nothing (void)
3511 record_unwind_protect_void (do_nothing
);
3514 /* Clear the unwind-protect entry COUNT, so that it does nothing.
3515 It need not be at the top of the stack. */
3518 clear_unwind_protect (ptrdiff_t count
)
3520 union specbinding
*p
= specpdl
+ count
;
3521 p
->unwind_void
.kind
= SPECPDL_UNWIND_VOID
;
3522 p
->unwind_void
.func
= do_nothing
;
3525 /* Set the unwind-protect entry COUNT so that it invokes FUNC (ARG).
3526 It need not be at the top of the stack. Discard the entry's
3527 previous value without invoking it. */
3530 set_unwind_protect (ptrdiff_t count
, void (*func
) (Lisp_Object
),
3533 union specbinding
*p
= specpdl
+ count
;
3534 p
->unwind
.kind
= SPECPDL_UNWIND
;
3535 p
->unwind
.func
= func
;
3536 p
->unwind
.arg
= arg
;
3540 set_unwind_protect_ptr (ptrdiff_t count
, void (*func
) (void *), void *arg
)
3542 union specbinding
*p
= specpdl
+ count
;
3543 p
->unwind_ptr
.kind
= SPECPDL_UNWIND_PTR
;
3544 p
->unwind_ptr
.func
= func
;
3545 p
->unwind_ptr
.arg
= arg
;
3548 /* Pop and execute entries from the unwind-protect stack until the
3549 depth COUNT is reached. Return VALUE. */
3552 unbind_to (ptrdiff_t count
, Lisp_Object value
)
3554 Lisp_Object quitf
= Vquit_flag
;
3558 while (specpdl_ptr
!= specpdl
+ count
)
3560 /* Copy the binding, and decrement specpdl_ptr, before we do
3561 the work to unbind it. We decrement first
3562 so that an error in unbinding won't try to unbind
3563 the same entry again, and we copy the binding first
3564 in case more bindings are made during some of the code we run. */
3566 union specbinding this_binding
;
3567 this_binding
= *--specpdl_ptr
;
3569 do_one_unbind (&this_binding
, true, SET_INTERNAL_UNBIND
);
3572 if (NILP (Vquit_flag
) && !NILP (quitf
))
3579 unbind_for_thread_switch (struct thread_state
*thr
)
3581 union specbinding
*bind
;
3583 for (bind
= thr
->m_specpdl_ptr
; bind
> thr
->m_specpdl
;)
3585 if ((--bind
)->kind
>= SPECPDL_LET
)
3587 Lisp_Object sym
= specpdl_symbol (bind
);
3588 bind
->let
.saved_value
= find_symbol_value (sym
);
3589 do_one_unbind (bind
, false, SET_INTERNAL_THREAD_SWITCH
);
3594 DEFUN ("special-variable-p", Fspecial_variable_p
, Sspecial_variable_p
, 1, 1, 0,
3595 doc
: /* Return non-nil if SYMBOL's global binding has been declared special.
3596 A special variable is one that will be bound dynamically, even in a
3597 context where binding is lexical by default. */)
3598 (Lisp_Object symbol
)
3600 CHECK_SYMBOL (symbol
);
3601 return XSYMBOL (symbol
)->u
.s
.declared_special
? Qt
: Qnil
;
3605 static union specbinding
*
3606 get_backtrace_starting_at (Lisp_Object base
)
3608 union specbinding
*pdl
= backtrace_top ();
3611 { /* Skip up to `base'. */
3612 base
= Findirect_function (base
, Qt
);
3613 while (backtrace_p (pdl
)
3614 && !EQ (base
, Findirect_function (backtrace_function (pdl
), Qt
)))
3615 pdl
= backtrace_next (pdl
);
3621 static union specbinding
*
3622 get_backtrace_frame (Lisp_Object nframes
, Lisp_Object base
)
3624 register EMACS_INT i
;
3626 CHECK_NATNUM (nframes
);
3627 union specbinding
*pdl
= get_backtrace_starting_at (base
);
3629 /* Find the frame requested. */
3630 for (i
= XFASTINT (nframes
); i
> 0 && backtrace_p (pdl
); i
--)
3631 pdl
= backtrace_next (pdl
);
3637 backtrace_frame_apply (Lisp_Object function
, union specbinding
*pdl
)
3639 if (!backtrace_p (pdl
))
3642 Lisp_Object flags
= Qnil
;
3643 if (backtrace_debug_on_exit (pdl
))
3644 flags
= Fcons (QCdebug_on_exit
, Fcons (Qt
, Qnil
));
3646 if (backtrace_nargs (pdl
) == UNEVALLED
)
3647 return call4 (function
, Qnil
, backtrace_function (pdl
), *backtrace_args (pdl
), flags
);
3650 Lisp_Object tem
= Flist (backtrace_nargs (pdl
), backtrace_args (pdl
));
3651 return call4 (function
, Qt
, backtrace_function (pdl
), tem
, flags
);
3655 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3656 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3657 The debugger is entered when that frame exits, if the flag is non-nil. */)
3658 (Lisp_Object level
, Lisp_Object flag
)
3660 CHECK_NUMBER (level
);
3661 union specbinding
*pdl
= get_backtrace_frame(level
, Qnil
);
3663 if (backtrace_p (pdl
))
3664 set_backtrace_debug_on_exit (pdl
, !NILP (flag
));
3669 DEFUN ("mapbacktrace", Fmapbacktrace
, Smapbacktrace
, 1, 2, 0,
3670 doc
: /* Call FUNCTION for each frame in backtrace.
3671 If BASE is non-nil, it should be a function and iteration will start
3672 from its nearest activation frame.
3673 FUNCTION is called with 4 arguments: EVALD, FUNC, ARGS, and FLAGS. If
3674 a frame has not evaluated its arguments yet or is a special form,
3675 EVALD is nil and ARGS is a list of forms. If a frame has evaluated
3676 its arguments and called its function already, EVALD is t and ARGS is
3678 FLAGS is a plist of properties of the current frame: currently, the
3679 only supported property is :debug-on-exit. `mapbacktrace' always
3681 (Lisp_Object function
, Lisp_Object base
)
3683 union specbinding
*pdl
= get_backtrace_starting_at (base
);
3685 while (backtrace_p (pdl
))
3687 ptrdiff_t i
= pdl
- specpdl
;
3688 backtrace_frame_apply (function
, pdl
);
3689 /* Beware! PDL is no longer valid here because FUNCTION might
3690 have caused grow_specpdl to reallocate pdlvec. We must use
3691 the saved index, cf. Bug#27258. */
3692 pdl
= backtrace_next (&specpdl
[i
]);
3698 DEFUN ("backtrace-frame--internal", Fbacktrace_frame_internal
,
3699 Sbacktrace_frame_internal
, 3, 3, NULL
,
3700 doc
: /* Call FUNCTION on stack frame NFRAMES away from BASE.
3701 Return the result of FUNCTION, or nil if no matching frame could be found. */)
3702 (Lisp_Object function
, Lisp_Object nframes
, Lisp_Object base
)
3704 return backtrace_frame_apply (function
, get_backtrace_frame (nframes
, base
));
3707 /* For backtrace-eval, we want to temporarily unwind the last few elements of
3708 the specpdl stack, and then rewind them. We store the pre-unwind values
3709 directly in the pre-existing specpdl elements (i.e. we swap the current
3710 value and the old value stored in the specpdl), kind of like the inplace
3711 pointer-reversal trick. As it turns out, the rewind does the same as the
3712 unwind, except it starts from the other end of the specpdl stack, so we use
3713 the same function for both unwind and rewind. */
3715 backtrace_eval_unrewind (int distance
)
3717 union specbinding
*tmp
= specpdl_ptr
;
3720 { /* It's a rewind rather than unwind. */
3721 tmp
+= distance
- 1;
3723 distance
= -distance
;
3726 for (; distance
> 0; distance
--)
3731 /* FIXME: Ideally we'd like to "temporarily unwind" (some of) those
3732 unwind_protect, but the problem is that we don't know how to
3733 rewind them afterwards. */
3734 case SPECPDL_UNWIND
:
3736 Lisp_Object oldarg
= tmp
->unwind
.arg
;
3737 if (tmp
->unwind
.func
== set_buffer_if_live
)
3738 tmp
->unwind
.arg
= Fcurrent_buffer ();
3739 else if (tmp
->unwind
.func
== save_excursion_restore
)
3740 tmp
->unwind
.arg
= save_excursion_save ();
3743 tmp
->unwind
.func (oldarg
);
3747 case SPECPDL_UNWIND_PTR
:
3748 case SPECPDL_UNWIND_INT
:
3749 case SPECPDL_UNWIND_VOID
:
3750 case SPECPDL_BACKTRACE
:
3753 { /* If variable has a trivial value (no forwarding), we can
3754 just set it. No need to check for constant symbols here,
3755 since that was already done by specbind. */
3756 Lisp_Object sym
= specpdl_symbol (tmp
);
3758 && XSYMBOL (sym
)->u
.s
.redirect
== SYMBOL_PLAINVAL
)
3760 Lisp_Object old_value
= specpdl_old_value (tmp
);
3761 set_specpdl_old_value (tmp
, SYMBOL_VAL (XSYMBOL (sym
)));
3762 SET_SYMBOL_VAL (XSYMBOL (sym
), old_value
);
3766 /* Come here only if make_local_foo was used for the first
3767 time on this var within this let. */
3769 case SPECPDL_LET_DEFAULT
:
3771 Lisp_Object sym
= specpdl_symbol (tmp
);
3772 Lisp_Object old_value
= specpdl_old_value (tmp
);
3773 set_specpdl_old_value (tmp
, Fdefault_value (sym
));
3774 Fset_default (sym
, old_value
);
3777 case SPECPDL_LET_LOCAL
:
3779 Lisp_Object symbol
= specpdl_symbol (tmp
);
3780 Lisp_Object where
= specpdl_where (tmp
);
3781 Lisp_Object old_value
= specpdl_old_value (tmp
);
3782 eassert (BUFFERP (where
));
3784 /* If this was a local binding, reset the value in the appropriate
3785 buffer, but only if that buffer's binding still exists. */
3786 if (!NILP (Flocal_variable_p (symbol
, where
)))
3788 set_specpdl_old_value
3789 (tmp
, Fbuffer_local_value (symbol
, where
));
3790 set_internal (symbol
, old_value
, where
, SET_INTERNAL_UNBIND
);
3798 DEFUN ("backtrace-eval", Fbacktrace_eval
, Sbacktrace_eval
, 2, 3, NULL
,
3799 doc
: /* Evaluate EXP in the context of some activation frame.
3800 NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */)
3801 (Lisp_Object exp
, Lisp_Object nframes
, Lisp_Object base
)
3803 union specbinding
*pdl
= get_backtrace_frame (nframes
, base
);
3804 ptrdiff_t count
= SPECPDL_INDEX ();
3805 ptrdiff_t distance
= specpdl_ptr
- pdl
;
3806 eassert (distance
>= 0);
3808 if (!backtrace_p (pdl
))
3809 error ("Activation frame not found!");
3811 backtrace_eval_unrewind (distance
);
3812 record_unwind_protect_int (backtrace_eval_unrewind
, -distance
);
3814 /* Use eval_sub rather than Feval since the main motivation behind
3815 backtrace-eval is to be able to get/set the value of lexical variables
3816 from the debugger. */
3817 return unbind_to (count
, eval_sub (exp
));
3820 DEFUN ("backtrace--locals", Fbacktrace__locals
, Sbacktrace__locals
, 1, 2, NULL
,
3821 doc
: /* Return names and values of local variables of a stack frame.
3822 NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */)
3823 (Lisp_Object nframes
, Lisp_Object base
)
3825 union specbinding
*frame
= get_backtrace_frame (nframes
, base
);
3826 union specbinding
*prevframe
3827 = get_backtrace_frame (make_number (XFASTINT (nframes
) - 1), base
);
3828 ptrdiff_t distance
= specpdl_ptr
- frame
;
3829 Lisp_Object result
= Qnil
;
3830 eassert (distance
>= 0);
3832 if (!backtrace_p (prevframe
))
3833 error ("Activation frame not found!");
3834 if (!backtrace_p (frame
))
3835 error ("Activation frame not found!");
3837 /* The specpdl entries normally contain the symbol being bound along with its
3838 `old_value', so it can be restored. The new value to which it is bound is
3839 available in one of two places: either in the current value of the
3840 variable (if it hasn't been rebound yet) or in the `old_value' slot of the
3841 next specpdl entry for it.
3842 `backtrace_eval_unrewind' happens to swap the role of `old_value'
3843 and "new value", so we abuse it here, to fetch the new value.
3844 It's ugly (we'd rather not modify global data) and a bit inefficient,
3845 but it does the job for now. */
3846 backtrace_eval_unrewind (distance
);
3850 union specbinding
*tmp
= prevframe
;
3851 for (; tmp
> frame
; tmp
--)
3856 case SPECPDL_LET_DEFAULT
:
3857 case SPECPDL_LET_LOCAL
:
3859 Lisp_Object sym
= specpdl_symbol (tmp
);
3860 Lisp_Object val
= specpdl_old_value (tmp
);
3861 if (EQ (sym
, Qinternal_interpreter_environment
))
3863 Lisp_Object env
= val
;
3864 for (; CONSP (env
); env
= XCDR (env
))
3866 Lisp_Object binding
= XCAR (env
);
3867 if (CONSP (binding
))
3868 result
= Fcons (Fcons (XCAR (binding
),
3874 result
= Fcons (Fcons (sym
, val
), result
);
3878 case SPECPDL_UNWIND
:
3879 case SPECPDL_UNWIND_PTR
:
3880 case SPECPDL_UNWIND_INT
:
3881 case SPECPDL_UNWIND_VOID
:
3882 case SPECPDL_BACKTRACE
:
3891 /* Restore values from specpdl to original place. */
3892 backtrace_eval_unrewind (-distance
);
3899 mark_specpdl (union specbinding
*first
, union specbinding
*ptr
)
3901 union specbinding
*pdl
;
3902 for (pdl
= first
; pdl
!= ptr
; pdl
++)
3906 case SPECPDL_UNWIND
:
3907 mark_object (specpdl_arg (pdl
));
3910 case SPECPDL_BACKTRACE
:
3912 ptrdiff_t nargs
= backtrace_nargs (pdl
);
3913 mark_object (backtrace_function (pdl
));
3914 if (nargs
== UNEVALLED
)
3917 mark_object (backtrace_args (pdl
)[nargs
]);
3921 case SPECPDL_LET_DEFAULT
:
3922 case SPECPDL_LET_LOCAL
:
3923 mark_object (specpdl_where (pdl
));
3926 mark_object (specpdl_symbol (pdl
));
3927 mark_object (specpdl_old_value (pdl
));
3928 mark_object (specpdl_saved_value (pdl
));
3931 case SPECPDL_UNWIND_PTR
:
3932 case SPECPDL_UNWIND_INT
:
3933 case SPECPDL_UNWIND_VOID
:
3943 get_backtrace (Lisp_Object array
)
3945 union specbinding
*pdl
= backtrace_next (backtrace_top ());
3946 ptrdiff_t i
= 0, asize
= ASIZE (array
);
3948 /* Copy the backtrace contents into working memory. */
3949 for (; i
< asize
; i
++)
3951 if (backtrace_p (pdl
))
3953 ASET (array
, i
, backtrace_function (pdl
));
3954 pdl
= backtrace_next (pdl
);
3957 ASET (array
, i
, Qnil
);
3961 Lisp_Object
backtrace_top_function (void)
3963 union specbinding
*pdl
= backtrace_top ();
3964 return (backtrace_p (pdl
) ? backtrace_function (pdl
) : Qnil
);
3970 DEFVAR_INT ("max-specpdl-size", max_specpdl_size
,
3971 doc
: /* Limit on number of Lisp variable bindings and `unwind-protect's.
3972 If Lisp code tries to increase the total number past this amount,
3973 an error is signaled.
3974 You can safely use a value considerably larger than the default value,
3975 if that proves inconveniently small. However, if you increase it too far,
3976 Emacs could run out of memory trying to make the stack bigger.
3977 Note that this limit may be silently increased by the debugger
3978 if `debug-on-error' or `debug-on-quit' is set. */);
3980 DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth
,
3981 doc
: /* Limit on depth in `eval', `apply' and `funcall' before error.
3983 This limit serves to catch infinite recursions for you before they cause
3984 actual stack overflow in C, which would be fatal for Emacs.
3985 You can safely make it considerably larger than its default value,
3986 if that proves inconveniently small. However, if you increase it too far,
3987 Emacs could overflow the real C stack, and crash. */);
3989 DEFVAR_LISP ("quit-flag", Vquit_flag
,
3990 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3991 If the value is t, that means do an ordinary quit.
3992 If the value equals `throw-on-input', that means quit by throwing
3993 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3994 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3995 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3998 DEFVAR_LISP ("inhibit-quit", Vinhibit_quit
,
3999 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
4000 Note that `quit-flag' will still be set by typing C-g,
4001 so a quit will be signaled as soon as `inhibit-quit' is nil.
4002 To prevent this happening, set `quit-flag' to nil
4003 before making `inhibit-quit' nil. */);
4004 Vinhibit_quit
= Qnil
;
4006 DEFSYM (Qsetq
, "setq");
4007 DEFSYM (Qinhibit_quit
, "inhibit-quit");
4008 DEFSYM (Qautoload
, "autoload");
4009 DEFSYM (Qinhibit_debugger
, "inhibit-debugger");
4010 DEFSYM (Qmacro
, "macro");
4012 /* Note that the process handling also uses Qexit, but we don't want
4013 to staticpro it twice, so we just do it here. */
4014 DEFSYM (Qexit
, "exit");
4016 DEFSYM (Qinteractive
, "interactive");
4017 DEFSYM (Qcommandp
, "commandp");
4018 DEFSYM (Qand_rest
, "&rest");
4019 DEFSYM (Qand_optional
, "&optional");
4020 DEFSYM (Qclosure
, "closure");
4021 DEFSYM (QCdocumentation
, ":documentation");
4022 DEFSYM (Qdebug
, "debug");
4024 DEFVAR_LISP ("inhibit-debugger", Vinhibit_debugger
,
4025 doc
: /* Non-nil means never enter the debugger.
4026 Normally set while the debugger is already active, to avoid recursive
4028 Vinhibit_debugger
= Qnil
;
4030 DEFVAR_LISP ("debug-on-error", Vdebug_on_error
,
4031 doc
: /* Non-nil means enter debugger if an error is signaled.
4032 Does not apply to errors handled by `condition-case' or those
4033 matched by `debug-ignored-errors'.
4034 If the value is a list, an error only means to enter the debugger
4035 if one of its condition symbols appears in the list.
4036 When you evaluate an expression interactively, this variable
4037 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
4038 The command `toggle-debug-on-error' toggles this.
4039 See also the variable `debug-on-quit' and `inhibit-debugger'. */);
4040 Vdebug_on_error
= Qnil
;
4042 DEFVAR_LISP ("debug-ignored-errors", Vdebug_ignored_errors
,
4043 doc
: /* List of errors for which the debugger should not be called.
4044 Each element may be a condition-name or a regexp that matches error messages.
4045 If any element applies to a given error, that error skips the debugger
4046 and just returns to top level.
4047 This overrides the variable `debug-on-error'.
4048 It does not apply to errors handled by `condition-case'. */);
4049 Vdebug_ignored_errors
= Qnil
;
4051 DEFVAR_BOOL ("debug-on-quit", debug_on_quit
,
4052 doc
: /* Non-nil means enter debugger if quit is signaled (C-g, for example).
4053 Does not apply if quit is handled by a `condition-case'. */);
4056 DEFVAR_BOOL ("debug-on-next-call", debug_on_next_call
,
4057 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
4059 DEFVAR_BOOL ("debugger-may-continue", debugger_may_continue
,
4060 doc
: /* Non-nil means debugger may continue execution.
4061 This is nil when the debugger is called under circumstances where it
4062 might not be safe to continue. */);
4063 debugger_may_continue
= 1;
4065 DEFVAR_BOOL ("debugger-stack-frame-as-list", debugger_stack_frame_as_list
,
4066 doc
: /* Non-nil means display call stack frames as lists. */);
4067 debugger_stack_frame_as_list
= 0;
4069 DEFVAR_LISP ("debugger", Vdebugger
,
4070 doc
: /* Function to call to invoke debugger.
4071 If due to frame exit, args are `exit' and the value being returned;
4072 this function's value will be returned instead of that.
4073 If due to error, args are `error' and a list of the args to `signal'.
4074 If due to `apply' or `funcall' entry, one arg, `lambda'.
4075 If due to `eval' entry, one arg, t. */);
4078 DEFVAR_LISP ("signal-hook-function", Vsignal_hook_function
,
4079 doc
: /* If non-nil, this is a function for `signal' to call.
4080 It receives the same arguments that `signal' was given.
4081 The Edebug package uses this to regain control. */);
4082 Vsignal_hook_function
= Qnil
;
4084 DEFVAR_LISP ("debug-on-signal", Vdebug_on_signal
,
4085 doc
: /* Non-nil means call the debugger regardless of condition handlers.
4086 Note that `debug-on-error', `debug-on-quit' and friends
4087 still determine whether to handle the particular condition. */);
4088 Vdebug_on_signal
= Qnil
;
4090 /* When lexical binding is being used,
4091 Vinternal_interpreter_environment is non-nil, and contains an alist
4092 of lexically-bound variable, or (t), indicating an empty
4093 environment. The lisp name of this variable would be
4094 `internal-interpreter-environment' if it weren't hidden.
4095 Every element of this list can be either a cons (VAR . VAL)
4096 specifying a lexical binding, or a single symbol VAR indicating
4097 that this variable should use dynamic scoping. */
4098 DEFSYM (Qinternal_interpreter_environment
,
4099 "internal-interpreter-environment");
4100 DEFVAR_LISP ("internal-interpreter-environment",
4101 Vinternal_interpreter_environment
,
4102 doc
: /* If non-nil, the current lexical environment of the lisp interpreter.
4103 When lexical binding is not being used, this variable is nil.
4104 A value of `(t)' indicates an empty environment, otherwise it is an
4105 alist of active lexical bindings. */);
4106 Vinternal_interpreter_environment
= Qnil
;
4107 /* Don't export this variable to Elisp, so no one can mess with it
4108 (Just imagine if someone makes it buffer-local). */
4109 Funintern (Qinternal_interpreter_environment
, Qnil
);
4111 Vrun_hooks
= intern_c_string ("run-hooks");
4112 staticpro (&Vrun_hooks
);
4114 staticpro (&Vautoload_queue
);
4115 Vautoload_queue
= Qnil
;
4116 staticpro (&Vsignaling_function
);
4117 Vsignaling_function
= Qnil
;
4119 inhibit_lisp_code
= Qnil
;
4121 DEFSYM (Qcatch_all_memory_full
, "catch-all-memory-full");
4122 Funintern (Qcatch_all_memory_full
, Qnil
);
4133 defsubr (&Sfunction
);
4134 defsubr (&Sdefault_toplevel_value
);
4135 defsubr (&Sset_default_toplevel_value
);
4137 defsubr (&Sdefvaralias
);
4138 DEFSYM (Qdefvaralias
, "defvaralias");
4139 defsubr (&Sdefconst
);
4140 defsubr (&Smake_var_non_special
);
4144 defsubr (&Smacroexpand
);
4147 defsubr (&Sunwind_protect
);
4148 defsubr (&Scondition_case
);
4150 defsubr (&Scommandp
);
4151 defsubr (&Sautoload
);
4152 defsubr (&Sautoload_do_load
);
4155 defsubr (&Sfuncall
);
4156 defsubr (&Sfunc_arity
);
4157 defsubr (&Srun_hooks
);
4158 defsubr (&Srun_hook_with_args
);
4159 defsubr (&Srun_hook_with_args_until_success
);
4160 defsubr (&Srun_hook_with_args_until_failure
);
4161 defsubr (&Srun_hook_wrapped
);
4162 defsubr (&Sfetch_bytecode
);
4163 defsubr (&Sbacktrace_debug
);
4164 DEFSYM (QCdebug_on_exit
, ":debug-on-exit");
4165 defsubr (&Smapbacktrace
);
4166 defsubr (&Sbacktrace_frame_internal
);
4167 defsubr (&Sbacktrace_eval
);
4168 defsubr (&Sbacktrace__locals
);
4169 defsubr (&Sspecial_variable_p
);
4170 defsubr (&Sfunctionp
);