1 /* Evaluator for GNU Emacs Lisp interpreter.
3 Copyright (C) 1985-1987, 1993-1995, 1999-2018 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
)
1608 /* Don't try to call a lisp function if we've already overflowed
1609 the specpdl stack. */
1610 && specpdl_ptr
< specpdl
+ specpdl_size
)
1612 /* Edebug takes care of restoring these variables when it exits. */
1613 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1614 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1616 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1617 max_specpdl_size
= SPECPDL_INDEX () + 40;
1619 call2 (Vsignal_hook_function
, error_symbol
, data
);
1622 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1624 /* Remember from where signal was called. Skip over the frame for
1625 `signal' itself. If a frame for `error' follows, skip that,
1626 too. Don't do this when ERROR_SYMBOL is nil, because that
1627 is a memory-full error. */
1628 Vsignaling_function
= Qnil
;
1629 if (!NILP (error_symbol
))
1631 union specbinding
*pdl
= backtrace_next (backtrace_top ());
1632 if (backtrace_p (pdl
) && EQ (backtrace_function (pdl
), Qerror
))
1633 pdl
= backtrace_next (pdl
);
1634 if (backtrace_p (pdl
))
1635 Vsignaling_function
= backtrace_function (pdl
);
1638 for (h
= handlerlist
; h
; h
= h
->next
)
1640 if (h
->type
!= CONDITION_CASE
)
1642 clause
= find_handler_clause (h
->tag_or_ch
, conditions
);
1647 if (/* Don't run the debugger for a memory-full error.
1648 (There is no room in memory to do that!) */
1649 !NILP (error_symbol
)
1650 && (!NILP (Vdebug_on_signal
)
1651 /* If no handler is present now, try to run the debugger. */
1653 /* A `debug' symbol in the handler list disables the normal
1654 suppression of the debugger. */
1655 || (CONSP (clause
) && !NILP (Fmemq (Qdebug
, clause
)))
1656 /* Special handler that means "print a message and run debugger
1658 || EQ (h
->tag_or_ch
, Qerror
)))
1660 bool debugger_called
1661 = maybe_call_debugger (conditions
, error_symbol
, data
);
1662 /* We can't return values to code which signaled an error, but we
1663 can continue code which has signaled a quit. */
1664 if (keyboard_quit
&& debugger_called
&& EQ (real_error_symbol
, Qquit
))
1670 Lisp_Object unwind_data
1671 = (NILP (error_symbol
) ? data
: Fcons (error_symbol
, data
));
1673 unwind_to_catch (h
, unwind_data
);
1677 if (handlerlist
!= handlerlist_sentinel
)
1678 /* FIXME: This will come right back here if there's no `top-level'
1679 catcher. A better solution would be to abort here, and instead
1680 add a catch-all condition handler so we never come here. */
1681 Fthrow (Qtop_level
, Qt
);
1684 if (! NILP (error_symbol
))
1685 data
= Fcons (error_symbol
, data
);
1687 string
= Ferror_message_string (data
);
1688 fatal ("%s", SDATA (string
));
1691 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1694 xsignal0 (Lisp_Object error_symbol
)
1696 xsignal (error_symbol
, Qnil
);
1700 xsignal1 (Lisp_Object error_symbol
, Lisp_Object arg
)
1702 xsignal (error_symbol
, list1 (arg
));
1706 xsignal2 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
)
1708 xsignal (error_symbol
, list2 (arg1
, arg2
));
1712 xsignal3 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
1714 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1717 /* Signal `error' with message S, and additional arg ARG.
1718 If ARG is not a genuine list, make it a one-element list. */
1721 signal_error (const char *s
, Lisp_Object arg
)
1723 Lisp_Object tortoise
, hare
;
1725 hare
= tortoise
= arg
;
1726 while (CONSP (hare
))
1733 tortoise
= XCDR (tortoise
);
1735 if (EQ (hare
, tortoise
))
1742 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1746 /* Return true if LIST is a non-nil atom or
1747 a list containing one of CONDITIONS. */
1750 wants_debugger (Lisp_Object list
, Lisp_Object conditions
)
1757 while (CONSP (conditions
))
1759 Lisp_Object
this, tail
;
1760 this = XCAR (conditions
);
1761 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1762 if (EQ (XCAR (tail
), this))
1764 conditions
= XCDR (conditions
);
1769 /* Return true if an error with condition-symbols CONDITIONS,
1770 and described by SIGNAL-DATA, should skip the debugger
1771 according to debugger-ignored-errors. */
1774 skip_debugger (Lisp_Object conditions
, Lisp_Object data
)
1777 bool first_string
= 1;
1778 Lisp_Object error_message
;
1780 error_message
= Qnil
;
1781 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1783 if (STRINGP (XCAR (tail
)))
1787 error_message
= Ferror_message_string (data
);
1791 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1796 Lisp_Object contail
;
1798 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1799 if (EQ (XCAR (tail
), XCAR (contail
)))
1807 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1808 SIG and DATA describe the signal. There are two ways to pass them:
1809 = SIG is the error symbol, and DATA is the rest of the data.
1810 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1811 This is for memory-full errors only. */
1813 maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
, Lisp_Object data
)
1815 Lisp_Object combined_data
;
1817 combined_data
= Fcons (sig
, data
);
1820 /* Don't try to run the debugger with interrupts blocked.
1821 The editing loop would return anyway. */
1822 ! input_blocked_p ()
1823 && NILP (Vinhibit_debugger
)
1824 /* Does user want to enter debugger for this kind of error? */
1827 : wants_debugger (Vdebug_on_error
, conditions
))
1828 && ! skip_debugger (conditions
, combined_data
)
1829 /* RMS: What's this for? */
1830 && when_entered_debugger
< num_nonmacro_input_events
)
1832 call_debugger (list2 (Qerror
, combined_data
));
1840 find_handler_clause (Lisp_Object handlers
, Lisp_Object conditions
)
1842 register Lisp_Object h
;
1844 /* t is used by handlers for all conditions, set up by C code. */
1845 if (EQ (handlers
, Qt
))
1848 /* error is used similarly, but means print an error message
1849 and run the debugger if that is enabled. */
1850 if (EQ (handlers
, Qerror
))
1853 for (h
= handlers
; CONSP (h
); h
= XCDR (h
))
1855 Lisp_Object handler
= XCAR (h
);
1856 if (!NILP (Fmemq (handler
, conditions
)))
1864 /* Format and return a string; called like vprintf. */
1866 vformat_string (const char *m
, va_list ap
)
1869 ptrdiff_t size
= sizeof buf
;
1870 ptrdiff_t size_max
= STRING_BYTES_BOUND
+ 1;
1875 used
= evxprintf (&buffer
, &size
, buf
, size_max
, m
, ap
);
1876 string
= make_string (buffer
, used
);
1883 /* Dump an error message; called like vprintf. */
1885 verror (const char *m
, va_list ap
)
1887 xsignal1 (Qerror
, vformat_string (m
, ap
));
1891 /* Dump an error message; called like printf. */
1895 error (const char *m
, ...)
1902 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
1903 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
1904 This means it contains a description for how to read arguments to give it.
1905 The value is nil for an invalid function or a symbol with no function
1908 Interactively callable functions include strings and vectors (treated
1909 as keyboard macros), lambda-expressions that contain a top-level call
1910 to `interactive', autoload definitions made by `autoload' with non-nil
1911 fourth argument, and some of the built-in functions of Lisp.
1913 Also, a symbol satisfies `commandp' if its function definition does so.
1915 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
1916 then strings and vectors are not accepted. */)
1917 (Lisp_Object function
, Lisp_Object for_call_interactively
)
1919 register Lisp_Object fun
;
1920 register Lisp_Object funcar
;
1921 Lisp_Object if_prop
= Qnil
;
1925 fun
= indirect_function (fun
); /* Check cycles. */
1929 /* Check an `interactive-form' property if present, analogous to the
1930 function-documentation property. */
1932 while (SYMBOLP (fun
))
1934 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
1937 fun
= Fsymbol_function (fun
);
1940 /* Emacs primitives are interactive if their DEFUN specifies an
1941 interactive spec. */
1943 return XSUBR (fun
)->intspec
? Qt
: if_prop
;
1945 /* Bytecode objects are interactive if they are long enough to
1946 have an element whose index is COMPILED_INTERACTIVE, which is
1947 where the interactive spec is stored. */
1948 else if (COMPILEDP (fun
))
1949 return (PVSIZE (fun
) > COMPILED_INTERACTIVE
? Qt
: if_prop
);
1951 /* Strings and vectors are keyboard macros. */
1952 if (STRINGP (fun
) || VECTORP (fun
))
1953 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
1955 /* Lists may represent commands. */
1958 funcar
= XCAR (fun
);
1959 if (EQ (funcar
, Qclosure
))
1960 return (!NILP (Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
)))))
1962 else if (EQ (funcar
, Qlambda
))
1963 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
1964 else if (EQ (funcar
, Qautoload
))
1965 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
1970 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1971 doc
: /* Define FUNCTION to autoload from FILE.
1972 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
1973 Third arg DOCSTRING is documentation for the function.
1974 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
1975 Fifth arg TYPE indicates the type of the object:
1976 nil or omitted says FUNCTION is a function,
1977 `keymap' says FUNCTION is really a keymap, and
1978 `macro' or t says FUNCTION is really a macro.
1979 Third through fifth args give info about the real definition.
1980 They default to nil.
1981 If FUNCTION is already defined other than as an autoload,
1982 this does nothing and returns nil. */)
1983 (Lisp_Object function
, Lisp_Object file
, Lisp_Object docstring
, Lisp_Object interactive
, Lisp_Object type
)
1985 CHECK_SYMBOL (function
);
1986 CHECK_STRING (file
);
1988 /* If function is defined and not as an autoload, don't override. */
1989 if (!NILP (XSYMBOL (function
)->u
.s
.function
)
1990 && !AUTOLOADP (XSYMBOL (function
)->u
.s
.function
))
1993 if (!NILP (Vpurify_flag
) && EQ (docstring
, make_number (0)))
1994 /* `read1' in lread.c has found the docstring starting with "\
1995 and assumed the docstring will be provided by Snarf-documentation, so it
1996 passed us 0 instead. But that leads to accidental sharing in purecopy's
1997 hash-consing, so we use a (hopefully) unique integer instead. */
1998 docstring
= make_number (XHASH (function
));
1999 return Fdefalias (function
,
2000 list5 (Qautoload
, file
, docstring
, interactive
, type
),
2005 un_autoload (Lisp_Object oldqueue
)
2007 Lisp_Object queue
, first
, second
;
2009 /* Queue to unwind is current value of Vautoload_queue.
2010 oldqueue is the shadowed value to leave in Vautoload_queue. */
2011 queue
= Vautoload_queue
;
2012 Vautoload_queue
= oldqueue
;
2013 while (CONSP (queue
))
2015 first
= XCAR (queue
);
2016 second
= Fcdr (first
);
2017 first
= Fcar (first
);
2018 if (EQ (first
, make_number (0)))
2021 Ffset (first
, second
);
2022 queue
= XCDR (queue
);
2026 /* Load an autoloaded function.
2027 FUNNAME is the symbol which is the function's name.
2028 FUNDEF is the autoload definition (a list). */
2030 DEFUN ("autoload-do-load", Fautoload_do_load
, Sautoload_do_load
, 1, 3, 0,
2031 doc
: /* Load FUNDEF which should be an autoload.
2032 If non-nil, FUNNAME should be the symbol whose function value is FUNDEF,
2033 in which case the function returns the new autoloaded function value.
2034 If equal to `macro', MACRO-ONLY specifies that FUNDEF should only be loaded if
2035 it defines a macro. */)
2036 (Lisp_Object fundef
, Lisp_Object funname
, Lisp_Object macro_only
)
2038 ptrdiff_t count
= SPECPDL_INDEX ();
2040 if (!CONSP (fundef
) || !EQ (Qautoload
, XCAR (fundef
)))
2043 Lisp_Object kind
= Fnth (make_number (4), fundef
);
2044 if (EQ (macro_only
, Qmacro
)
2045 && !(EQ (kind
, Qt
) || EQ (kind
, Qmacro
)))
2048 /* This is to make sure that loadup.el gives a clear picture
2049 of what files are preloaded and when. */
2050 if (! NILP (Vpurify_flag
))
2051 error ("Attempt to autoload %s while preparing to dump",
2052 SDATA (SYMBOL_NAME (funname
)));
2054 CHECK_SYMBOL (funname
);
2056 /* Preserve the match data. */
2057 record_unwind_save_match_data ();
2059 /* If autoloading gets an error (which includes the error of failing
2060 to define the function being called), we use Vautoload_queue
2061 to undo function definitions and `provide' calls made by
2062 the function. We do this in the specific case of autoloading
2063 because autoloading is not an explicit request "load this file",
2064 but rather a request to "call this function".
2066 The value saved here is to be restored into Vautoload_queue. */
2067 record_unwind_protect (un_autoload
, Vautoload_queue
);
2068 Vautoload_queue
= Qt
;
2069 /* If `macro_only' is set and fundef isn't a macro, assume this autoload to
2070 be a "best-effort" (e.g. to try and find a compiler macro),
2071 so don't signal an error if autoloading fails. */
2072 Lisp_Object ignore_errors
2073 = (EQ (kind
, Qt
) || EQ (kind
, Qmacro
)) ? Qnil
: macro_only
;
2074 Fload (Fcar (Fcdr (fundef
)), ignore_errors
, Qt
, Qnil
, Qt
);
2076 /* Once loading finishes, don't undo it. */
2077 Vautoload_queue
= Qt
;
2078 unbind_to (count
, Qnil
);
2080 if (NILP (funname
) || !NILP (ignore_errors
))
2084 Lisp_Object fun
= Findirect_function (funname
, Qnil
);
2086 if (!NILP (Fequal (fun
, fundef
)))
2087 error ("Autoloading file %s failed to define function %s",
2088 SDATA (Fcar (Fcar (Vload_history
))),
2089 SDATA (SYMBOL_NAME (funname
)));
2096 DEFUN ("eval", Feval
, Seval
, 1, 2, 0,
2097 doc
: /* Evaluate FORM and return its value.
2098 If LEXICAL is t, evaluate using lexical scoping.
2099 LEXICAL can also be an actual lexical environment, in the form of an
2100 alist mapping symbols to their value. */)
2101 (Lisp_Object form
, Lisp_Object lexical
)
2103 ptrdiff_t count
= SPECPDL_INDEX ();
2104 specbind (Qinternal_interpreter_environment
,
2105 CONSP (lexical
) || NILP (lexical
) ? lexical
: list1 (Qt
));
2106 return unbind_to (count
, eval_sub (form
));
2109 /* Grow the specpdl stack by one entry.
2110 The caller should have already initialized the entry.
2111 Signal an error on stack overflow.
2113 Make sure that there is always one unused entry past the top of the
2114 stack, so that the just-initialized entry is safely unwound if
2115 memory exhausted and an error is signaled here. Also, allocate a
2116 never-used entry just before the bottom of the stack; sometimes its
2117 address is taken. */
2124 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2126 ptrdiff_t count
= SPECPDL_INDEX ();
2127 ptrdiff_t max_size
= min (max_specpdl_size
, PTRDIFF_MAX
- 1000);
2128 union specbinding
*pdlvec
= specpdl
- 1;
2129 ptrdiff_t pdlvecsize
= specpdl_size
+ 1;
2130 if (max_size
<= specpdl_size
)
2132 if (max_specpdl_size
< 400)
2133 max_size
= max_specpdl_size
= 400;
2134 if (max_size
<= specpdl_size
)
2135 signal_error ("Variable binding depth exceeds max-specpdl-size",
2138 pdlvec
= xpalloc (pdlvec
, &pdlvecsize
, 1, max_size
+ 1, sizeof *specpdl
);
2139 specpdl
= pdlvec
+ 1;
2140 specpdl_size
= pdlvecsize
- 1;
2141 specpdl_ptr
= specpdl
+ count
;
2146 record_in_backtrace (Lisp_Object function
, Lisp_Object
*args
, ptrdiff_t nargs
)
2148 ptrdiff_t count
= SPECPDL_INDEX ();
2150 eassert (nargs
>= UNEVALLED
);
2151 specpdl_ptr
->bt
.kind
= SPECPDL_BACKTRACE
;
2152 specpdl_ptr
->bt
.debug_on_exit
= false;
2153 specpdl_ptr
->bt
.function
= function
;
2154 current_thread
->stack_top
= specpdl_ptr
->bt
.args
= args
;
2155 specpdl_ptr
->bt
.nargs
= nargs
;
2161 /* Eval a sub-expression of the current expression (i.e. in the same
2164 eval_sub (Lisp_Object form
)
2166 Lisp_Object fun
, val
, original_fun
, original_args
;
2170 /* Declare here, as this array may be accessed by call_debugger near
2171 the end of this function. See Bug#21245. */
2172 Lisp_Object argvals
[8];
2176 /* Look up its binding in the lexical environment.
2177 We do not pay attention to the declared_special flag here, since we
2178 already did that when let-binding the variable. */
2179 Lisp_Object lex_binding
2180 = !NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
2181 ? Fassq (form
, Vinternal_interpreter_environment
)
2183 if (CONSP (lex_binding
))
2184 return XCDR (lex_binding
);
2186 return Fsymbol_value (form
);
2196 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2198 if (max_lisp_eval_depth
< 100)
2199 max_lisp_eval_depth
= 100;
2200 if (lisp_eval_depth
> max_lisp_eval_depth
)
2201 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2204 original_fun
= XCAR (form
);
2205 original_args
= XCDR (form
);
2206 CHECK_LIST (original_args
);
2208 /* This also protects them from gc. */
2209 count
= record_in_backtrace (original_fun
, &original_args
, UNEVALLED
);
2211 if (debug_on_next_call
)
2212 do_debug_on_call (Qt
, count
);
2214 /* At this point, only original_fun and original_args
2215 have values that will be used below. */
2218 /* Optimize for no indirection. */
2221 fun
= Ffunction (Fcons (fun
, Qnil
));
2222 else if (!NILP (fun
) && (fun
= XSYMBOL (fun
)->u
.s
.function
, SYMBOLP (fun
)))
2223 fun
= indirect_function (fun
);
2227 Lisp_Object args_left
= original_args
;
2228 Lisp_Object numargs
= Flength (args_left
);
2232 if (XINT (numargs
) < XSUBR (fun
)->min_args
2233 || (XSUBR (fun
)->max_args
>= 0
2234 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2235 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2237 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2238 val
= (XSUBR (fun
)->function
.aUNEVALLED
) (args_left
);
2239 else if (XSUBR (fun
)->max_args
== MANY
)
2241 /* Pass a vector of evaluated arguments. */
2243 ptrdiff_t argnum
= 0;
2246 SAFE_ALLOCA_LISP (vals
, XINT (numargs
));
2248 while (CONSP (args_left
) && argnum
< XINT (numargs
))
2250 Lisp_Object arg
= XCAR (args_left
);
2251 args_left
= XCDR (args_left
);
2252 vals
[argnum
++] = eval_sub (arg
);
2255 set_backtrace_args (specpdl
+ count
, vals
, argnum
);
2257 val
= XSUBR (fun
)->function
.aMANY (argnum
, vals
);
2261 /* Do the debug-on-exit now, while VALS still exists. */
2262 if (backtrace_debug_on_exit (specpdl
+ count
))
2263 val
= call_debugger (list2 (Qexit
, val
));
2270 int i
, maxargs
= XSUBR (fun
)->max_args
;
2272 for (i
= 0; i
< maxargs
; i
++)
2274 argvals
[i
] = eval_sub (Fcar (args_left
));
2275 args_left
= Fcdr (args_left
);
2278 set_backtrace_args (specpdl
+ count
, argvals
, XINT (numargs
));
2283 val
= (XSUBR (fun
)->function
.a0 ());
2286 val
= (XSUBR (fun
)->function
.a1 (argvals
[0]));
2289 val
= (XSUBR (fun
)->function
.a2 (argvals
[0], argvals
[1]));
2292 val
= (XSUBR (fun
)->function
.a3
2293 (argvals
[0], argvals
[1], argvals
[2]));
2296 val
= (XSUBR (fun
)->function
.a4
2297 (argvals
[0], argvals
[1], argvals
[2], argvals
[3]));
2300 val
= (XSUBR (fun
)->function
.a5
2301 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2305 val
= (XSUBR (fun
)->function
.a6
2306 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2307 argvals
[4], argvals
[5]));
2310 val
= (XSUBR (fun
)->function
.a7
2311 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2312 argvals
[4], argvals
[5], argvals
[6]));
2316 val
= (XSUBR (fun
)->function
.a8
2317 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2318 argvals
[4], argvals
[5], argvals
[6], argvals
[7]));
2322 /* Someone has created a subr that takes more arguments than
2323 is supported by this code. We need to either rewrite the
2324 subr to use a different argument protocol, or add more
2325 cases to this switch. */
2330 else if (COMPILEDP (fun
) || MODULE_FUNCTIONP (fun
))
2331 return apply_lambda (fun
, original_args
, count
);
2335 xsignal1 (Qvoid_function
, original_fun
);
2337 xsignal1 (Qinvalid_function
, original_fun
);
2338 funcar
= XCAR (fun
);
2339 if (!SYMBOLP (funcar
))
2340 xsignal1 (Qinvalid_function
, original_fun
);
2341 if (EQ (funcar
, Qautoload
))
2343 Fautoload_do_load (fun
, original_fun
, Qnil
);
2346 if (EQ (funcar
, Qmacro
))
2348 ptrdiff_t count1
= SPECPDL_INDEX ();
2350 /* Bind lexical-binding during expansion of the macro, so the
2351 macro can know reliably if the code it outputs will be
2352 interpreted using lexical-binding or not. */
2353 specbind (Qlexical_binding
,
2354 NILP (Vinternal_interpreter_environment
) ? Qnil
: Qt
);
2355 exp
= apply1 (Fcdr (fun
), original_args
);
2356 unbind_to (count1
, Qnil
);
2357 val
= eval_sub (exp
);
2359 else if (EQ (funcar
, Qlambda
)
2360 || EQ (funcar
, Qclosure
))
2361 return apply_lambda (fun
, original_args
, count
);
2363 xsignal1 (Qinvalid_function
, original_fun
);
2368 if (backtrace_debug_on_exit (specpdl
+ count
))
2369 val
= call_debugger (list2 (Qexit
, val
));
2375 DEFUN ("apply", Fapply
, Sapply
, 1, MANY
, 0,
2376 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2377 Then return the value FUNCTION returns.
2378 Thus, (apply \\='+ 1 2 \\='(3 4)) returns 10.
2379 usage: (apply FUNCTION &rest ARGUMENTS) */)
2380 (ptrdiff_t nargs
, Lisp_Object
*args
)
2382 ptrdiff_t i
, numargs
, funcall_nargs
;
2383 register Lisp_Object
*funcall_args
= NULL
;
2384 register Lisp_Object spread_arg
= args
[nargs
- 1];
2385 Lisp_Object fun
= args
[0];
2389 CHECK_LIST (spread_arg
);
2391 numargs
= XINT (Flength (spread_arg
));
2394 return Ffuncall (nargs
- 1, args
);
2395 else if (numargs
== 1)
2397 args
[nargs
- 1] = XCAR (spread_arg
);
2398 return Ffuncall (nargs
, args
);
2401 numargs
+= nargs
- 2;
2403 /* Optimize for no indirection. */
2404 if (SYMBOLP (fun
) && !NILP (fun
)
2405 && (fun
= XSYMBOL (fun
)->u
.s
.function
, SYMBOLP (fun
)))
2407 fun
= indirect_function (fun
);
2409 /* Let funcall get the error. */
2413 if (SUBRP (fun
) && XSUBR (fun
)->max_args
> numargs
2414 /* Don't hide an error by adding missing arguments. */
2415 && numargs
>= XSUBR (fun
)->min_args
)
2417 /* Avoid making funcall cons up a yet another new vector of arguments
2418 by explicitly supplying nil's for optional values. */
2419 SAFE_ALLOCA_LISP (funcall_args
, 1 + XSUBR (fun
)->max_args
);
2420 memclear (funcall_args
+ numargs
+ 1,
2421 (XSUBR (fun
)->max_args
- numargs
) * word_size
);
2422 funcall_nargs
= 1 + XSUBR (fun
)->max_args
;
2425 { /* We add 1 to numargs because funcall_args includes the
2426 function itself as well as its arguments. */
2427 SAFE_ALLOCA_LISP (funcall_args
, 1 + numargs
);
2428 funcall_nargs
= 1 + numargs
;
2431 memcpy (funcall_args
, args
, nargs
* word_size
);
2432 /* Spread the last arg we got. Its first element goes in
2433 the slot that it used to occupy, hence this value of I. */
2435 while (!NILP (spread_arg
))
2437 funcall_args
[i
++] = XCAR (spread_arg
);
2438 spread_arg
= XCDR (spread_arg
);
2441 retval
= Ffuncall (funcall_nargs
, funcall_args
);
2447 /* Run hook variables in various ways. */
2450 funcall_nil (ptrdiff_t nargs
, Lisp_Object
*args
)
2452 Ffuncall (nargs
, args
);
2456 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2457 doc
: /* Run each hook in HOOKS.
2458 Each argument should be a symbol, a hook variable.
2459 These symbols are processed in the order specified.
2460 If a hook symbol has a non-nil value, that value may be a function
2461 or a list of functions to be called to run the hook.
2462 If the value is a function, it is called with no arguments.
2463 If it is a list, the elements are called, in order, with no arguments.
2465 Major modes should not use this function directly to run their mode
2466 hook; they should use `run-mode-hooks' instead.
2468 Do not use `make-local-variable' to make a hook variable buffer-local.
2469 Instead, use `add-hook' and specify t for the LOCAL argument.
2470 usage: (run-hooks &rest HOOKS) */)
2471 (ptrdiff_t nargs
, Lisp_Object
*args
)
2475 for (i
= 0; i
< nargs
; i
++)
2481 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2482 Srun_hook_with_args
, 1, MANY
, 0,
2483 doc
: /* Run HOOK with the specified arguments ARGS.
2484 HOOK should be a symbol, a hook variable. The value of HOOK
2485 may be nil, a function, or a list of functions. Call each
2486 function in order with arguments ARGS. The final return value
2489 Do not use `make-local-variable' to make a hook variable buffer-local.
2490 Instead, use `add-hook' and specify t for the LOCAL argument.
2491 usage: (run-hook-with-args HOOK &rest ARGS) */)
2492 (ptrdiff_t nargs
, Lisp_Object
*args
)
2494 return run_hook_with_args (nargs
, args
, funcall_nil
);
2497 /* NB this one still documents a specific non-nil return value.
2498 (As did run-hook-with-args and run-hook-with-args-until-failure
2499 until they were changed in 24.1.) */
2500 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2501 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2502 doc
: /* Run HOOK with the specified arguments ARGS.
2503 HOOK should be a symbol, a hook variable. The value of HOOK
2504 may be nil, a function, or a list of functions. Call each
2505 function in order with arguments ARGS, stopping at the first
2506 one that returns non-nil, and return that value. Otherwise (if
2507 all functions return nil, or if there are no functions to call),
2510 Do not use `make-local-variable' to make a hook variable buffer-local.
2511 Instead, use `add-hook' and specify t for the LOCAL argument.
2512 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2513 (ptrdiff_t nargs
, Lisp_Object
*args
)
2515 return run_hook_with_args (nargs
, args
, Ffuncall
);
2519 funcall_not (ptrdiff_t nargs
, Lisp_Object
*args
)
2521 return NILP (Ffuncall (nargs
, args
)) ? Qt
: Qnil
;
2524 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2525 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2526 doc
: /* Run HOOK with the specified arguments ARGS.
2527 HOOK should be a symbol, a hook variable. The value of HOOK
2528 may be nil, a function, or a list of functions. Call each
2529 function in order with arguments ARGS, stopping at the first
2530 one that returns nil, and return nil. Otherwise (if all functions
2531 return non-nil, or if there are no functions to call), return non-nil
2532 \(do not rely on the precise return value in this case).
2534 Do not use `make-local-variable' to make a hook variable buffer-local.
2535 Instead, use `add-hook' and specify t for the LOCAL argument.
2536 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2537 (ptrdiff_t nargs
, Lisp_Object
*args
)
2539 return NILP (run_hook_with_args (nargs
, args
, funcall_not
)) ? Qt
: Qnil
;
2543 run_hook_wrapped_funcall (ptrdiff_t nargs
, Lisp_Object
*args
)
2545 Lisp_Object tmp
= args
[0], ret
;
2548 ret
= Ffuncall (nargs
, args
);
2554 DEFUN ("run-hook-wrapped", Frun_hook_wrapped
, Srun_hook_wrapped
, 2, MANY
, 0,
2555 doc
: /* Run HOOK, passing each function through WRAP-FUNCTION.
2556 I.e. instead of calling each function FUN directly with arguments ARGS,
2557 it calls WRAP-FUNCTION with arguments FUN and ARGS.
2558 As soon as a call to WRAP-FUNCTION returns non-nil, `run-hook-wrapped'
2559 aborts and returns that value.
2560 usage: (run-hook-wrapped HOOK WRAP-FUNCTION &rest ARGS) */)
2561 (ptrdiff_t nargs
, Lisp_Object
*args
)
2563 return run_hook_with_args (nargs
, args
, run_hook_wrapped_funcall
);
2566 /* ARGS[0] should be a hook symbol.
2567 Call each of the functions in the hook value, passing each of them
2568 as arguments all the rest of ARGS (all NARGS - 1 elements).
2569 FUNCALL specifies how to call each function on the hook. */
2572 run_hook_with_args (ptrdiff_t nargs
, Lisp_Object
*args
,
2573 Lisp_Object (*funcall
) (ptrdiff_t nargs
, Lisp_Object
*args
))
2575 Lisp_Object sym
, val
, ret
= Qnil
;
2577 /* If we are dying or still initializing,
2578 don't do anything--it would probably crash if we tried. */
2579 if (NILP (Vrun_hooks
))
2583 val
= find_symbol_value (sym
);
2585 if (EQ (val
, Qunbound
) || NILP (val
))
2587 else if (!CONSP (val
) || FUNCTIONP (val
))
2590 return funcall (nargs
, args
);
2594 Lisp_Object global_vals
= Qnil
;
2597 CONSP (val
) && NILP (ret
);
2600 if (EQ (XCAR (val
), Qt
))
2602 /* t indicates this hook has a local binding;
2603 it means to run the global binding too. */
2604 global_vals
= Fdefault_value (sym
);
2605 if (NILP (global_vals
)) continue;
2607 if (!CONSP (global_vals
) || EQ (XCAR (global_vals
), Qlambda
))
2609 args
[0] = global_vals
;
2610 ret
= funcall (nargs
, args
);
2615 CONSP (global_vals
) && NILP (ret
);
2616 global_vals
= XCDR (global_vals
))
2618 args
[0] = XCAR (global_vals
);
2619 /* In a global value, t should not occur. If it does, we
2620 must ignore it to avoid an endless loop. */
2621 if (!EQ (args
[0], Qt
))
2622 ret
= funcall (nargs
, args
);
2628 args
[0] = XCAR (val
);
2629 ret
= funcall (nargs
, args
);
2637 /* Run the hook HOOK, giving each function no args. */
2640 run_hook (Lisp_Object hook
)
2642 Frun_hook_with_args (1, &hook
);
2645 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2648 run_hook_with_args_2 (Lisp_Object hook
, Lisp_Object arg1
, Lisp_Object arg2
)
2650 CALLN (Frun_hook_with_args
, hook
, arg1
, arg2
);
2653 /* Apply fn to arg. */
2655 apply1 (Lisp_Object fn
, Lisp_Object arg
)
2657 return NILP (arg
) ? Ffuncall (1, &fn
) : CALLN (Fapply
, fn
, arg
);
2660 /* Call function fn on no arguments. */
2662 call0 (Lisp_Object fn
)
2664 return Ffuncall (1, &fn
);
2667 /* Call function fn with 1 argument arg1. */
2670 call1 (Lisp_Object fn
, Lisp_Object arg1
)
2672 return CALLN (Ffuncall
, fn
, arg1
);
2675 /* Call function fn with 2 arguments arg1, arg2. */
2678 call2 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
)
2680 return CALLN (Ffuncall
, fn
, arg1
, arg2
);
2683 /* Call function fn with 3 arguments arg1, arg2, arg3. */
2686 call3 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2688 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
);
2691 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
2694 call4 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2697 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
);
2700 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
2703 call5 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2704 Lisp_Object arg4
, Lisp_Object arg5
)
2706 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
);
2709 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
2712 call6 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2713 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
)
2715 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
);
2718 /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
2721 call7 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2722 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
)
2724 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
);
2727 /* Call function fn with 8 arguments arg1, arg2, arg3, arg4, arg5,
2728 arg6, arg7, arg8. */
2731 call8 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2732 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
,
2735 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
, arg8
);
2738 DEFUN ("functionp", Ffunctionp
, Sfunctionp
, 1, 1, 0,
2739 doc
: /* Return t if OBJECT is a function. */)
2740 (Lisp_Object object
)
2742 if (FUNCTIONP (object
))
2748 FUNCTIONP (Lisp_Object object
)
2750 if (SYMBOLP (object
) && !NILP (Ffboundp (object
)))
2752 object
= Findirect_function (object
, Qt
);
2754 if (CONSP (object
) && EQ (XCAR (object
), Qautoload
))
2756 /* Autoloaded symbols are functions, except if they load
2757 macros or keymaps. */
2758 for (int i
= 0; i
< 4 && CONSP (object
); i
++)
2759 object
= XCDR (object
);
2761 return ! (CONSP (object
) && !NILP (XCAR (object
)));
2766 return XSUBR (object
)->max_args
!= UNEVALLED
;
2767 else if (COMPILEDP (object
) || MODULE_FUNCTIONP (object
))
2769 else if (CONSP (object
))
2771 Lisp_Object car
= XCAR (object
);
2772 return EQ (car
, Qlambda
) || EQ (car
, Qclosure
);
2778 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2779 doc
: /* Call first argument as a function, passing remaining arguments to it.
2780 Return the value that function returns.
2781 Thus, (funcall \\='cons \\='x \\='y) returns (x . y).
2782 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2783 (ptrdiff_t nargs
, Lisp_Object
*args
)
2785 Lisp_Object fun
, original_fun
;
2787 ptrdiff_t numargs
= nargs
- 1;
2793 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2795 if (max_lisp_eval_depth
< 100)
2796 max_lisp_eval_depth
= 100;
2797 if (lisp_eval_depth
> max_lisp_eval_depth
)
2798 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2801 count
= record_in_backtrace (args
[0], &args
[1], nargs
- 1);
2805 if (debug_on_next_call
)
2806 do_debug_on_call (Qlambda
, count
);
2810 original_fun
= args
[0];
2814 /* Optimize for no indirection. */
2816 if (SYMBOLP (fun
) && !NILP (fun
)
2817 && (fun
= XSYMBOL (fun
)->u
.s
.function
, SYMBOLP (fun
)))
2818 fun
= indirect_function (fun
);
2821 val
= funcall_subr (XSUBR (fun
), numargs
, args
+ 1);
2822 else if (COMPILEDP (fun
) || MODULE_FUNCTIONP (fun
))
2823 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2827 xsignal1 (Qvoid_function
, original_fun
);
2829 xsignal1 (Qinvalid_function
, original_fun
);
2830 funcar
= XCAR (fun
);
2831 if (!SYMBOLP (funcar
))
2832 xsignal1 (Qinvalid_function
, original_fun
);
2833 if (EQ (funcar
, Qlambda
)
2834 || EQ (funcar
, Qclosure
))
2835 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2836 else if (EQ (funcar
, Qautoload
))
2838 Fautoload_do_load (fun
, original_fun
, Qnil
);
2843 xsignal1 (Qinvalid_function
, original_fun
);
2847 if (backtrace_debug_on_exit (specpdl
+ count
))
2848 val
= call_debugger (list2 (Qexit
, val
));
2854 /* Apply a C subroutine SUBR to the NUMARGS evaluated arguments in ARG_VECTOR
2855 and return the result of evaluation. */
2858 funcall_subr (struct Lisp_Subr
*subr
, ptrdiff_t numargs
, Lisp_Object
*args
)
2860 if (numargs
< subr
->min_args
2861 || (subr
->max_args
>= 0 && subr
->max_args
< numargs
))
2864 XSETSUBR (fun
, subr
);
2865 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (numargs
));
2868 else if (subr
->max_args
== UNEVALLED
)
2871 XSETSUBR (fun
, subr
);
2872 xsignal1 (Qinvalid_function
, fun
);
2875 else if (subr
->max_args
== MANY
)
2876 return (subr
->function
.aMANY
) (numargs
, args
);
2879 Lisp_Object internal_argbuf
[8];
2880 Lisp_Object
*internal_args
;
2881 if (subr
->max_args
> numargs
)
2883 eassert (subr
->max_args
<= ARRAYELTS (internal_argbuf
));
2884 internal_args
= internal_argbuf
;
2885 memcpy (internal_args
, args
, numargs
* word_size
);
2886 memclear (internal_args
+ numargs
,
2887 (subr
->max_args
- numargs
) * word_size
);
2890 internal_args
= args
;
2891 switch (subr
->max_args
)
2894 return (subr
->function
.a0 ());
2896 return (subr
->function
.a1 (internal_args
[0]));
2898 return (subr
->function
.a2
2899 (internal_args
[0], internal_args
[1]));
2901 return (subr
->function
.a3
2902 (internal_args
[0], internal_args
[1], internal_args
[2]));
2904 return (subr
->function
.a4
2905 (internal_args
[0], internal_args
[1], internal_args
[2],
2908 return (subr
->function
.a5
2909 (internal_args
[0], internal_args
[1], internal_args
[2],
2910 internal_args
[3], internal_args
[4]));
2912 return (subr
->function
.a6
2913 (internal_args
[0], internal_args
[1], internal_args
[2],
2914 internal_args
[3], internal_args
[4], internal_args
[5]));
2916 return (subr
->function
.a7
2917 (internal_args
[0], internal_args
[1], internal_args
[2],
2918 internal_args
[3], internal_args
[4], internal_args
[5],
2921 return (subr
->function
.a8
2922 (internal_args
[0], internal_args
[1], internal_args
[2],
2923 internal_args
[3], internal_args
[4], internal_args
[5],
2924 internal_args
[6], internal_args
[7]));
2928 /* If a subr takes more than 8 arguments without using MANY
2929 or UNEVALLED, we need to extend this function to support it.
2930 Until this is done, there is no way to call the function. */
2937 apply_lambda (Lisp_Object fun
, Lisp_Object args
, ptrdiff_t count
)
2939 Lisp_Object args_left
;
2942 Lisp_Object
*arg_vector
;
2946 numargs
= XFASTINT (Flength (args
));
2947 SAFE_ALLOCA_LISP (arg_vector
, numargs
);
2950 for (i
= 0; i
< numargs
; )
2952 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2953 tem
= eval_sub (tem
);
2954 arg_vector
[i
++] = tem
;
2957 set_backtrace_args (specpdl
+ count
, arg_vector
, i
);
2958 tem
= funcall_lambda (fun
, numargs
, arg_vector
);
2962 /* Do the debug-on-exit now, while arg_vector still exists. */
2963 if (backtrace_debug_on_exit (specpdl
+ count
))
2964 tem
= call_debugger (list2 (Qexit
, tem
));
2970 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2971 and return the result of evaluation.
2972 FUN must be either a lambda-expression, a compiled-code object,
2973 or a module function. */
2976 funcall_lambda (Lisp_Object fun
, ptrdiff_t nargs
,
2977 register Lisp_Object
*arg_vector
)
2979 Lisp_Object val
, syms_left
, next
, lexenv
;
2980 ptrdiff_t count
= SPECPDL_INDEX ();
2982 bool optional
, rest
;
2986 if (EQ (XCAR (fun
), Qclosure
))
2988 Lisp_Object cdr
= XCDR (fun
); /* Drop `closure'. */
2990 xsignal1 (Qinvalid_function
, fun
);
2992 lexenv
= XCAR (fun
);
2996 syms_left
= XCDR (fun
);
2997 if (CONSP (syms_left
))
2998 syms_left
= XCAR (syms_left
);
3000 xsignal1 (Qinvalid_function
, fun
);
3002 else if (COMPILEDP (fun
))
3004 ptrdiff_t size
= PVSIZE (fun
);
3005 if (size
<= COMPILED_STACK_DEPTH
)
3006 xsignal1 (Qinvalid_function
, fun
);
3007 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3008 if (INTEGERP (syms_left
))
3009 /* A byte-code object with an integer args template means we
3010 shouldn't bind any arguments, instead just call the byte-code
3011 interpreter directly; it will push arguments as necessary.
3013 Byte-code objects with a nil args template (the default)
3014 have dynamically-bound arguments, and use the
3015 argument-binding code below instead (as do all interpreted
3016 functions, even lexically bound ones). */
3018 /* If we have not actually read the bytecode string
3019 and constants vector yet, fetch them from the file. */
3020 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3021 Ffetch_bytecode (fun
);
3022 return exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
3023 AREF (fun
, COMPILED_CONSTANTS
),
3024 AREF (fun
, COMPILED_STACK_DEPTH
),
3031 else if (MODULE_FUNCTIONP (fun
))
3032 return funcall_module (fun
, nargs
, arg_vector
);
3037 i
= optional
= rest
= 0;
3038 bool previous_optional_or_rest
= false;
3039 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3043 next
= XCAR (syms_left
);
3044 if (!SYMBOLP (next
))
3045 xsignal1 (Qinvalid_function
, fun
);
3047 if (EQ (next
, Qand_rest
))
3049 if (rest
|| previous_optional_or_rest
)
3050 xsignal1 (Qinvalid_function
, fun
);
3052 previous_optional_or_rest
= true;
3054 else if (EQ (next
, Qand_optional
))
3056 if (optional
|| rest
|| previous_optional_or_rest
)
3057 xsignal1 (Qinvalid_function
, fun
);
3059 previous_optional_or_rest
= true;
3066 arg
= Flist (nargs
- i
, &arg_vector
[i
]);
3070 arg
= arg_vector
[i
++];
3072 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3076 /* Bind the argument. */
3077 if (!NILP (lexenv
) && SYMBOLP (next
))
3078 /* Lexically bind NEXT by adding it to the lexenv alist. */
3079 lexenv
= Fcons (Fcons (next
, arg
), lexenv
);
3081 /* Dynamically bind NEXT. */
3082 specbind (next
, arg
);
3083 previous_optional_or_rest
= false;
3087 if (!NILP (syms_left
) || previous_optional_or_rest
)
3088 xsignal1 (Qinvalid_function
, fun
);
3090 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3092 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
3093 /* Instantiate a new lexical environment. */
3094 specbind (Qinternal_interpreter_environment
, lexenv
);
3097 val
= Fprogn (XCDR (XCDR (fun
)));
3100 /* If we have not actually read the bytecode string
3101 and constants vector yet, fetch them from the file. */
3102 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3103 Ffetch_bytecode (fun
);
3104 val
= exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
3105 AREF (fun
, COMPILED_CONSTANTS
),
3106 AREF (fun
, COMPILED_STACK_DEPTH
),
3110 return unbind_to (count
, val
);
3113 DEFUN ("func-arity", Ffunc_arity
, Sfunc_arity
, 1, 1, 0,
3114 doc
: /* Return minimum and maximum number of args allowed for FUNCTION.
3115 FUNCTION must be a function of some kind.
3116 The returned value is a cons cell (MIN . MAX). MIN is the minimum number
3117 of args. MAX is the maximum number, or the symbol `many', for a
3118 function with `&rest' args, or `unevalled' for a special form. */)
3119 (Lisp_Object function
)
3121 Lisp_Object original
;
3125 original
= function
;
3129 /* Optimize for no indirection. */
3130 function
= original
;
3131 if (SYMBOLP (function
) && !NILP (function
))
3133 function
= XSYMBOL (function
)->u
.s
.function
;
3134 if (SYMBOLP (function
))
3135 function
= indirect_function (function
);
3138 if (CONSP (function
) && EQ (XCAR (function
), Qmacro
))
3139 function
= XCDR (function
);
3141 if (SUBRP (function
))
3142 result
= Fsubr_arity (function
);
3143 else if (COMPILEDP (function
))
3144 result
= lambda_arity (function
);
3146 else if (MODULE_FUNCTIONP (function
))
3147 result
= module_function_arity (XMODULE_FUNCTION (function
));
3151 if (NILP (function
))
3152 xsignal1 (Qvoid_function
, original
);
3153 if (!CONSP (function
))
3154 xsignal1 (Qinvalid_function
, original
);
3155 funcar
= XCAR (function
);
3156 if (!SYMBOLP (funcar
))
3157 xsignal1 (Qinvalid_function
, original
);
3158 if (EQ (funcar
, Qlambda
)
3159 || EQ (funcar
, Qclosure
))
3160 result
= lambda_arity (function
);
3161 else if (EQ (funcar
, Qautoload
))
3163 Fautoload_do_load (function
, original
, Qnil
);
3167 xsignal1 (Qinvalid_function
, original
);
3172 /* FUN must be either a lambda-expression or a compiled-code object. */
3174 lambda_arity (Lisp_Object fun
)
3176 Lisp_Object syms_left
;
3180 if (EQ (XCAR (fun
), Qclosure
))
3182 fun
= XCDR (fun
); /* Drop `closure'. */
3185 syms_left
= XCDR (fun
);
3186 if (CONSP (syms_left
))
3187 syms_left
= XCAR (syms_left
);
3189 xsignal1 (Qinvalid_function
, fun
);
3191 else if (COMPILEDP (fun
))
3193 ptrdiff_t size
= PVSIZE (fun
);
3194 if (size
<= COMPILED_STACK_DEPTH
)
3195 xsignal1 (Qinvalid_function
, fun
);
3196 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3197 if (INTEGERP (syms_left
))
3198 return get_byte_code_arity (syms_left
);
3203 EMACS_INT minargs
= 0, maxargs
= 0;
3204 bool optional
= false;
3205 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3207 Lisp_Object next
= XCAR (syms_left
);
3208 if (!SYMBOLP (next
))
3209 xsignal1 (Qinvalid_function
, fun
);
3211 if (EQ (next
, Qand_rest
))
3212 return Fcons (make_number (minargs
), Qmany
);
3213 else if (EQ (next
, Qand_optional
))
3223 if (!NILP (syms_left
))
3224 xsignal1 (Qinvalid_function
, fun
);
3226 return Fcons (make_number (minargs
), make_number (maxargs
));
3229 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3231 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3232 (Lisp_Object object
)
3236 if (COMPILEDP (object
))
3238 ptrdiff_t size
= PVSIZE (object
);
3239 if (size
<= COMPILED_STACK_DEPTH
)
3240 xsignal1 (Qinvalid_function
, object
);
3241 if (CONSP (AREF (object
, COMPILED_BYTECODE
)))
3243 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3246 tem
= AREF (object
, COMPILED_BYTECODE
);
3247 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3248 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3250 error ("Invalid byte code");
3252 ASET (object
, COMPILED_BYTECODE
, XCAR (tem
));
3253 ASET (object
, COMPILED_CONSTANTS
, XCDR (tem
));
3259 /* Return true if SYMBOL currently has a let-binding
3260 which was made in the buffer that is now current. */
3263 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
3265 union specbinding
*p
;
3266 Lisp_Object buf
= Fcurrent_buffer ();
3268 for (p
= specpdl_ptr
; p
> specpdl
; )
3269 if ((--p
)->kind
> SPECPDL_LET
)
3271 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (specpdl_symbol (p
));
3272 eassert (let_bound_symbol
->u
.s
.redirect
!= SYMBOL_VARALIAS
);
3273 if (symbol
== let_bound_symbol
3274 && EQ (specpdl_where (p
), buf
))
3282 do_specbind (struct Lisp_Symbol
*sym
, union specbinding
*bind
,
3283 Lisp_Object value
, enum Set_Internal_Bind bindflag
)
3285 switch (sym
->u
.s
.redirect
)
3287 case SYMBOL_PLAINVAL
:
3288 if (!sym
->u
.s
.trapped_write
)
3289 SET_SYMBOL_VAL (sym
, value
);
3291 set_internal (specpdl_symbol (bind
), value
, Qnil
, bindflag
);
3294 case SYMBOL_FORWARDED
:
3295 if (BUFFER_OBJFWDP (SYMBOL_FWD (sym
))
3296 && specpdl_kind (bind
) == SPECPDL_LET_DEFAULT
)
3298 set_default_internal (specpdl_symbol (bind
), value
, bindflag
);
3302 case SYMBOL_LOCALIZED
:
3303 set_internal (specpdl_symbol (bind
), value
, Qnil
, bindflag
);
3311 /* `specpdl_ptr' describes which variable is
3312 let-bound, so it can be properly undone when we unbind_to.
3313 It can be either a plain SPECPDL_LET or a SPECPDL_LET_LOCAL/DEFAULT.
3314 - SYMBOL is the variable being bound. Note that it should not be
3315 aliased (i.e. when let-binding V1 that's aliased to V2, we want
3317 - WHERE tells us in which buffer the binding took place.
3318 This is used for SPECPDL_LET_LOCAL bindings (i.e. bindings to a
3319 buffer-local variable) as well as for SPECPDL_LET_DEFAULT bindings,
3320 i.e. bindings to the default value of a variable which can be
3324 specbind (Lisp_Object symbol
, Lisp_Object value
)
3326 struct Lisp_Symbol
*sym
;
3328 CHECK_SYMBOL (symbol
);
3329 sym
= XSYMBOL (symbol
);
3332 switch (sym
->u
.s
.redirect
)
3334 case SYMBOL_VARALIAS
:
3335 sym
= indirect_variable (sym
); XSETSYMBOL (symbol
, sym
); goto start
;
3336 case SYMBOL_PLAINVAL
:
3337 /* The most common case is that of a non-constant symbol with a
3338 trivial value. Make that as fast as we can. */
3339 specpdl_ptr
->let
.kind
= SPECPDL_LET
;
3340 specpdl_ptr
->let
.symbol
= symbol
;
3341 specpdl_ptr
->let
.old_value
= SYMBOL_VAL (sym
);
3342 specpdl_ptr
->let
.saved_value
= Qnil
;
3344 do_specbind (sym
, specpdl_ptr
- 1, value
, SET_INTERNAL_BIND
);
3346 case SYMBOL_LOCALIZED
:
3347 case SYMBOL_FORWARDED
:
3349 Lisp_Object ovalue
= find_symbol_value (symbol
);
3350 specpdl_ptr
->let
.kind
= SPECPDL_LET_LOCAL
;
3351 specpdl_ptr
->let
.symbol
= symbol
;
3352 specpdl_ptr
->let
.old_value
= ovalue
;
3353 specpdl_ptr
->let
.where
= Fcurrent_buffer ();
3354 specpdl_ptr
->let
.saved_value
= Qnil
;
3356 eassert (sym
->u
.s
.redirect
!= SYMBOL_LOCALIZED
3357 || (EQ (SYMBOL_BLV (sym
)->where
, Fcurrent_buffer ())));
3359 if (sym
->u
.s
.redirect
== SYMBOL_LOCALIZED
)
3361 if (!blv_found (SYMBOL_BLV (sym
)))
3362 specpdl_ptr
->let
.kind
= SPECPDL_LET_DEFAULT
;
3364 else if (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)))
3366 /* If SYMBOL is a per-buffer variable which doesn't have a
3367 buffer-local value here, make the `let' change the global
3368 value by changing the value of SYMBOL in all buffers not
3369 having their own value. This is consistent with what
3370 happens with other buffer-local variables. */
3371 if (NILP (Flocal_variable_p (symbol
, Qnil
)))
3373 specpdl_ptr
->let
.kind
= SPECPDL_LET_DEFAULT
;
3375 do_specbind (sym
, specpdl_ptr
- 1, value
, SET_INTERNAL_BIND
);
3380 specpdl_ptr
->let
.kind
= SPECPDL_LET
;
3383 do_specbind (sym
, specpdl_ptr
- 1, value
, SET_INTERNAL_BIND
);
3386 default: emacs_abort ();
3390 /* Push unwind-protect entries of various types. */
3393 record_unwind_protect (void (*function
) (Lisp_Object
), Lisp_Object arg
)
3395 specpdl_ptr
->unwind
.kind
= SPECPDL_UNWIND
;
3396 specpdl_ptr
->unwind
.func
= function
;
3397 specpdl_ptr
->unwind
.arg
= arg
;
3402 record_unwind_protect_ptr (void (*function
) (void *), void *arg
)
3404 specpdl_ptr
->unwind_ptr
.kind
= SPECPDL_UNWIND_PTR
;
3405 specpdl_ptr
->unwind_ptr
.func
= function
;
3406 specpdl_ptr
->unwind_ptr
.arg
= arg
;
3411 record_unwind_protect_int (void (*function
) (int), int arg
)
3413 specpdl_ptr
->unwind_int
.kind
= SPECPDL_UNWIND_INT
;
3414 specpdl_ptr
->unwind_int
.func
= function
;
3415 specpdl_ptr
->unwind_int
.arg
= arg
;
3420 record_unwind_protect_void (void (*function
) (void))
3422 specpdl_ptr
->unwind_void
.kind
= SPECPDL_UNWIND_VOID
;
3423 specpdl_ptr
->unwind_void
.func
= function
;
3428 rebind_for_thread_switch (void)
3430 union specbinding
*bind
;
3432 for (bind
= specpdl
; bind
!= specpdl_ptr
; ++bind
)
3434 if (bind
->kind
>= SPECPDL_LET
)
3436 Lisp_Object value
= specpdl_saved_value (bind
);
3437 Lisp_Object sym
= specpdl_symbol (bind
);
3438 bind
->let
.saved_value
= Qnil
;
3439 do_specbind (XSYMBOL (sym
), bind
, value
,
3440 SET_INTERNAL_THREAD_SWITCH
);
3446 do_one_unbind (union specbinding
*this_binding
, bool unwinding
,
3447 enum Set_Internal_Bind bindflag
)
3449 eassert (unwinding
|| this_binding
->kind
>= SPECPDL_LET
);
3450 switch (this_binding
->kind
)
3452 case SPECPDL_UNWIND
:
3453 this_binding
->unwind
.func (this_binding
->unwind
.arg
);
3455 case SPECPDL_UNWIND_PTR
:
3456 this_binding
->unwind_ptr
.func (this_binding
->unwind_ptr
.arg
);
3458 case SPECPDL_UNWIND_INT
:
3459 this_binding
->unwind_int
.func (this_binding
->unwind_int
.arg
);
3461 case SPECPDL_UNWIND_VOID
:
3462 this_binding
->unwind_void
.func ();
3464 case SPECPDL_BACKTRACE
:
3467 { /* If variable has a trivial value (no forwarding), and isn't
3468 trapped, we can just set it. */
3469 Lisp_Object sym
= specpdl_symbol (this_binding
);
3470 if (SYMBOLP (sym
) && XSYMBOL (sym
)->u
.s
.redirect
== SYMBOL_PLAINVAL
)
3472 if (XSYMBOL (sym
)->u
.s
.trapped_write
== SYMBOL_UNTRAPPED_WRITE
)
3473 SET_SYMBOL_VAL (XSYMBOL (sym
), specpdl_old_value (this_binding
));
3475 set_internal (sym
, specpdl_old_value (this_binding
),
3480 /* Come here only if make_local_foo was used for the first time
3481 on this var within this let. */
3483 case SPECPDL_LET_DEFAULT
:
3484 set_default_internal (specpdl_symbol (this_binding
),
3485 specpdl_old_value (this_binding
),
3488 case SPECPDL_LET_LOCAL
:
3490 Lisp_Object symbol
= specpdl_symbol (this_binding
);
3491 Lisp_Object where
= specpdl_where (this_binding
);
3492 Lisp_Object old_value
= specpdl_old_value (this_binding
);
3493 eassert (BUFFERP (where
));
3495 /* If this was a local binding, reset the value in the appropriate
3496 buffer, but only if that buffer's binding still exists. */
3497 if (!NILP (Flocal_variable_p (symbol
, where
)))
3498 set_internal (symbol
, old_value
, where
, bindflag
);
3508 /* Push an unwind-protect entry that does nothing, so that
3509 set_unwind_protect_ptr can overwrite it later. */
3512 record_unwind_protect_nothing (void)
3514 record_unwind_protect_void (do_nothing
);
3517 /* Clear the unwind-protect entry COUNT, so that it does nothing.
3518 It need not be at the top of the stack. */
3521 clear_unwind_protect (ptrdiff_t count
)
3523 union specbinding
*p
= specpdl
+ count
;
3524 p
->unwind_void
.kind
= SPECPDL_UNWIND_VOID
;
3525 p
->unwind_void
.func
= do_nothing
;
3528 /* Set the unwind-protect entry COUNT so that it invokes FUNC (ARG).
3529 It need not be at the top of the stack. Discard the entry's
3530 previous value without invoking it. */
3533 set_unwind_protect (ptrdiff_t count
, void (*func
) (Lisp_Object
),
3536 union specbinding
*p
= specpdl
+ count
;
3537 p
->unwind
.kind
= SPECPDL_UNWIND
;
3538 p
->unwind
.func
= func
;
3539 p
->unwind
.arg
= arg
;
3543 set_unwind_protect_ptr (ptrdiff_t count
, void (*func
) (void *), void *arg
)
3545 union specbinding
*p
= specpdl
+ count
;
3546 p
->unwind_ptr
.kind
= SPECPDL_UNWIND_PTR
;
3547 p
->unwind_ptr
.func
= func
;
3548 p
->unwind_ptr
.arg
= arg
;
3551 /* Pop and execute entries from the unwind-protect stack until the
3552 depth COUNT is reached. Return VALUE. */
3555 unbind_to (ptrdiff_t count
, Lisp_Object value
)
3557 Lisp_Object quitf
= Vquit_flag
;
3561 while (specpdl_ptr
!= specpdl
+ count
)
3563 /* Copy the binding, and decrement specpdl_ptr, before we do
3564 the work to unbind it. We decrement first
3565 so that an error in unbinding won't try to unbind
3566 the same entry again, and we copy the binding first
3567 in case more bindings are made during some of the code we run. */
3569 union specbinding this_binding
;
3570 this_binding
= *--specpdl_ptr
;
3572 do_one_unbind (&this_binding
, true, SET_INTERNAL_UNBIND
);
3575 if (NILP (Vquit_flag
) && !NILP (quitf
))
3582 unbind_for_thread_switch (struct thread_state
*thr
)
3584 union specbinding
*bind
;
3586 for (bind
= thr
->m_specpdl_ptr
; bind
> thr
->m_specpdl
;)
3588 if ((--bind
)->kind
>= SPECPDL_LET
)
3590 Lisp_Object sym
= specpdl_symbol (bind
);
3591 bind
->let
.saved_value
= find_symbol_value (sym
);
3592 do_one_unbind (bind
, false, SET_INTERNAL_THREAD_SWITCH
);
3597 DEFUN ("special-variable-p", Fspecial_variable_p
, Sspecial_variable_p
, 1, 1, 0,
3598 doc
: /* Return non-nil if SYMBOL's global binding has been declared special.
3599 A special variable is one that will be bound dynamically, even in a
3600 context where binding is lexical by default. */)
3601 (Lisp_Object symbol
)
3603 CHECK_SYMBOL (symbol
);
3604 return XSYMBOL (symbol
)->u
.s
.declared_special
? Qt
: Qnil
;
3608 static union specbinding
*
3609 get_backtrace_starting_at (Lisp_Object base
)
3611 union specbinding
*pdl
= backtrace_top ();
3614 { /* Skip up to `base'. */
3615 base
= Findirect_function (base
, Qt
);
3616 while (backtrace_p (pdl
)
3617 && !EQ (base
, Findirect_function (backtrace_function (pdl
), Qt
)))
3618 pdl
= backtrace_next (pdl
);
3624 static union specbinding
*
3625 get_backtrace_frame (Lisp_Object nframes
, Lisp_Object base
)
3627 register EMACS_INT i
;
3629 CHECK_NATNUM (nframes
);
3630 union specbinding
*pdl
= get_backtrace_starting_at (base
);
3632 /* Find the frame requested. */
3633 for (i
= XFASTINT (nframes
); i
> 0 && backtrace_p (pdl
); i
--)
3634 pdl
= backtrace_next (pdl
);
3640 backtrace_frame_apply (Lisp_Object function
, union specbinding
*pdl
)
3642 if (!backtrace_p (pdl
))
3645 Lisp_Object flags
= Qnil
;
3646 if (backtrace_debug_on_exit (pdl
))
3647 flags
= Fcons (QCdebug_on_exit
, Fcons (Qt
, Qnil
));
3649 if (backtrace_nargs (pdl
) == UNEVALLED
)
3650 return call4 (function
, Qnil
, backtrace_function (pdl
), *backtrace_args (pdl
), flags
);
3653 Lisp_Object tem
= Flist (backtrace_nargs (pdl
), backtrace_args (pdl
));
3654 return call4 (function
, Qt
, backtrace_function (pdl
), tem
, flags
);
3658 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3659 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3660 The debugger is entered when that frame exits, if the flag is non-nil. */)
3661 (Lisp_Object level
, Lisp_Object flag
)
3663 CHECK_NUMBER (level
);
3664 union specbinding
*pdl
= get_backtrace_frame(level
, Qnil
);
3666 if (backtrace_p (pdl
))
3667 set_backtrace_debug_on_exit (pdl
, !NILP (flag
));
3672 DEFUN ("mapbacktrace", Fmapbacktrace
, Smapbacktrace
, 1, 2, 0,
3673 doc
: /* Call FUNCTION for each frame in backtrace.
3674 If BASE is non-nil, it should be a function and iteration will start
3675 from its nearest activation frame.
3676 FUNCTION is called with 4 arguments: EVALD, FUNC, ARGS, and FLAGS. If
3677 a frame has not evaluated its arguments yet or is a special form,
3678 EVALD is nil and ARGS is a list of forms. If a frame has evaluated
3679 its arguments and called its function already, EVALD is t and ARGS is
3681 FLAGS is a plist of properties of the current frame: currently, the
3682 only supported property is :debug-on-exit. `mapbacktrace' always
3684 (Lisp_Object function
, Lisp_Object base
)
3686 union specbinding
*pdl
= get_backtrace_starting_at (base
);
3688 while (backtrace_p (pdl
))
3690 ptrdiff_t i
= pdl
- specpdl
;
3691 backtrace_frame_apply (function
, pdl
);
3692 /* Beware! PDL is no longer valid here because FUNCTION might
3693 have caused grow_specpdl to reallocate pdlvec. We must use
3694 the saved index, cf. Bug#27258. */
3695 pdl
= backtrace_next (&specpdl
[i
]);
3701 DEFUN ("backtrace-frame--internal", Fbacktrace_frame_internal
,
3702 Sbacktrace_frame_internal
, 3, 3, NULL
,
3703 doc
: /* Call FUNCTION on stack frame NFRAMES away from BASE.
3704 Return the result of FUNCTION, or nil if no matching frame could be found. */)
3705 (Lisp_Object function
, Lisp_Object nframes
, Lisp_Object base
)
3707 return backtrace_frame_apply (function
, get_backtrace_frame (nframes
, base
));
3710 /* For backtrace-eval, we want to temporarily unwind the last few elements of
3711 the specpdl stack, and then rewind them. We store the pre-unwind values
3712 directly in the pre-existing specpdl elements (i.e. we swap the current
3713 value and the old value stored in the specpdl), kind of like the inplace
3714 pointer-reversal trick. As it turns out, the rewind does the same as the
3715 unwind, except it starts from the other end of the specpdl stack, so we use
3716 the same function for both unwind and rewind. */
3718 backtrace_eval_unrewind (int distance
)
3720 union specbinding
*tmp
= specpdl_ptr
;
3723 { /* It's a rewind rather than unwind. */
3724 tmp
+= distance
- 1;
3726 distance
= -distance
;
3729 for (; distance
> 0; distance
--)
3734 /* FIXME: Ideally we'd like to "temporarily unwind" (some of) those
3735 unwind_protect, but the problem is that we don't know how to
3736 rewind them afterwards. */
3737 case SPECPDL_UNWIND
:
3739 Lisp_Object oldarg
= tmp
->unwind
.arg
;
3740 if (tmp
->unwind
.func
== set_buffer_if_live
)
3741 tmp
->unwind
.arg
= Fcurrent_buffer ();
3742 else if (tmp
->unwind
.func
== save_excursion_restore
)
3743 tmp
->unwind
.arg
= save_excursion_save ();
3746 tmp
->unwind
.func (oldarg
);
3750 case SPECPDL_UNWIND_PTR
:
3751 case SPECPDL_UNWIND_INT
:
3752 case SPECPDL_UNWIND_VOID
:
3753 case SPECPDL_BACKTRACE
:
3756 { /* If variable has a trivial value (no forwarding), we can
3757 just set it. No need to check for constant symbols here,
3758 since that was already done by specbind. */
3759 Lisp_Object sym
= specpdl_symbol (tmp
);
3761 && XSYMBOL (sym
)->u
.s
.redirect
== SYMBOL_PLAINVAL
)
3763 Lisp_Object old_value
= specpdl_old_value (tmp
);
3764 set_specpdl_old_value (tmp
, SYMBOL_VAL (XSYMBOL (sym
)));
3765 SET_SYMBOL_VAL (XSYMBOL (sym
), old_value
);
3769 /* Come here only if make_local_foo was used for the first
3770 time on this var within this let. */
3772 case SPECPDL_LET_DEFAULT
:
3774 Lisp_Object sym
= specpdl_symbol (tmp
);
3775 Lisp_Object old_value
= specpdl_old_value (tmp
);
3776 set_specpdl_old_value (tmp
, Fdefault_value (sym
));
3777 Fset_default (sym
, old_value
);
3780 case SPECPDL_LET_LOCAL
:
3782 Lisp_Object symbol
= specpdl_symbol (tmp
);
3783 Lisp_Object where
= specpdl_where (tmp
);
3784 Lisp_Object old_value
= specpdl_old_value (tmp
);
3785 eassert (BUFFERP (where
));
3787 /* If this was a local binding, reset the value in the appropriate
3788 buffer, but only if that buffer's binding still exists. */
3789 if (!NILP (Flocal_variable_p (symbol
, where
)))
3791 set_specpdl_old_value
3792 (tmp
, Fbuffer_local_value (symbol
, where
));
3793 set_internal (symbol
, old_value
, where
, SET_INTERNAL_UNBIND
);
3801 DEFUN ("backtrace-eval", Fbacktrace_eval
, Sbacktrace_eval
, 2, 3, NULL
,
3802 doc
: /* Evaluate EXP in the context of some activation frame.
3803 NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */)
3804 (Lisp_Object exp
, Lisp_Object nframes
, Lisp_Object base
)
3806 union specbinding
*pdl
= get_backtrace_frame (nframes
, base
);
3807 ptrdiff_t count
= SPECPDL_INDEX ();
3808 ptrdiff_t distance
= specpdl_ptr
- pdl
;
3809 eassert (distance
>= 0);
3811 if (!backtrace_p (pdl
))
3812 error ("Activation frame not found!");
3814 backtrace_eval_unrewind (distance
);
3815 record_unwind_protect_int (backtrace_eval_unrewind
, -distance
);
3817 /* Use eval_sub rather than Feval since the main motivation behind
3818 backtrace-eval is to be able to get/set the value of lexical variables
3819 from the debugger. */
3820 return unbind_to (count
, eval_sub (exp
));
3823 DEFUN ("backtrace--locals", Fbacktrace__locals
, Sbacktrace__locals
, 1, 2, NULL
,
3824 doc
: /* Return names and values of local variables of a stack frame.
3825 NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */)
3826 (Lisp_Object nframes
, Lisp_Object base
)
3828 union specbinding
*frame
= get_backtrace_frame (nframes
, base
);
3829 union specbinding
*prevframe
3830 = get_backtrace_frame (make_number (XFASTINT (nframes
) - 1), base
);
3831 ptrdiff_t distance
= specpdl_ptr
- frame
;
3832 Lisp_Object result
= Qnil
;
3833 eassert (distance
>= 0);
3835 if (!backtrace_p (prevframe
))
3836 error ("Activation frame not found!");
3837 if (!backtrace_p (frame
))
3838 error ("Activation frame not found!");
3840 /* The specpdl entries normally contain the symbol being bound along with its
3841 `old_value', so it can be restored. The new value to which it is bound is
3842 available in one of two places: either in the current value of the
3843 variable (if it hasn't been rebound yet) or in the `old_value' slot of the
3844 next specpdl entry for it.
3845 `backtrace_eval_unrewind' happens to swap the role of `old_value'
3846 and "new value", so we abuse it here, to fetch the new value.
3847 It's ugly (we'd rather not modify global data) and a bit inefficient,
3848 but it does the job for now. */
3849 backtrace_eval_unrewind (distance
);
3853 union specbinding
*tmp
= prevframe
;
3854 for (; tmp
> frame
; tmp
--)
3859 case SPECPDL_LET_DEFAULT
:
3860 case SPECPDL_LET_LOCAL
:
3862 Lisp_Object sym
= specpdl_symbol (tmp
);
3863 Lisp_Object val
= specpdl_old_value (tmp
);
3864 if (EQ (sym
, Qinternal_interpreter_environment
))
3866 Lisp_Object env
= val
;
3867 for (; CONSP (env
); env
= XCDR (env
))
3869 Lisp_Object binding
= XCAR (env
);
3870 if (CONSP (binding
))
3871 result
= Fcons (Fcons (XCAR (binding
),
3877 result
= Fcons (Fcons (sym
, val
), result
);
3881 case SPECPDL_UNWIND
:
3882 case SPECPDL_UNWIND_PTR
:
3883 case SPECPDL_UNWIND_INT
:
3884 case SPECPDL_UNWIND_VOID
:
3885 case SPECPDL_BACKTRACE
:
3894 /* Restore values from specpdl to original place. */
3895 backtrace_eval_unrewind (-distance
);
3902 mark_specpdl (union specbinding
*first
, union specbinding
*ptr
)
3904 union specbinding
*pdl
;
3905 for (pdl
= first
; pdl
!= ptr
; pdl
++)
3909 case SPECPDL_UNWIND
:
3910 mark_object (specpdl_arg (pdl
));
3913 case SPECPDL_BACKTRACE
:
3915 ptrdiff_t nargs
= backtrace_nargs (pdl
);
3916 mark_object (backtrace_function (pdl
));
3917 if (nargs
== UNEVALLED
)
3920 mark_object (backtrace_args (pdl
)[nargs
]);
3924 case SPECPDL_LET_DEFAULT
:
3925 case SPECPDL_LET_LOCAL
:
3926 mark_object (specpdl_where (pdl
));
3929 mark_object (specpdl_symbol (pdl
));
3930 mark_object (specpdl_old_value (pdl
));
3931 mark_object (specpdl_saved_value (pdl
));
3934 case SPECPDL_UNWIND_PTR
:
3935 case SPECPDL_UNWIND_INT
:
3936 case SPECPDL_UNWIND_VOID
:
3946 get_backtrace (Lisp_Object array
)
3948 union specbinding
*pdl
= backtrace_next (backtrace_top ());
3949 ptrdiff_t i
= 0, asize
= ASIZE (array
);
3951 /* Copy the backtrace contents into working memory. */
3952 for (; i
< asize
; i
++)
3954 if (backtrace_p (pdl
))
3956 ASET (array
, i
, backtrace_function (pdl
));
3957 pdl
= backtrace_next (pdl
);
3960 ASET (array
, i
, Qnil
);
3964 Lisp_Object
backtrace_top_function (void)
3966 union specbinding
*pdl
= backtrace_top ();
3967 return (backtrace_p (pdl
) ? backtrace_function (pdl
) : Qnil
);
3973 DEFVAR_INT ("max-specpdl-size", max_specpdl_size
,
3974 doc
: /* Limit on number of Lisp variable bindings and `unwind-protect's.
3975 If Lisp code tries to increase the total number past this amount,
3976 an error is signaled.
3977 You can safely use a value considerably larger than the default value,
3978 if that proves inconveniently small. However, if you increase it too far,
3979 Emacs could run out of memory trying to make the stack bigger.
3980 Note that this limit may be silently increased by the debugger
3981 if `debug-on-error' or `debug-on-quit' is set. */);
3983 DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth
,
3984 doc
: /* Limit on depth in `eval', `apply' and `funcall' before error.
3986 This limit serves to catch infinite recursions for you before they cause
3987 actual stack overflow in C, which would be fatal for Emacs.
3988 You can safely make it considerably larger than its default value,
3989 if that proves inconveniently small. However, if you increase it too far,
3990 Emacs could overflow the real C stack, and crash. */);
3992 DEFVAR_LISP ("quit-flag", Vquit_flag
,
3993 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3994 If the value is t, that means do an ordinary quit.
3995 If the value equals `throw-on-input', that means quit by throwing
3996 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3997 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3998 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
4001 DEFVAR_LISP ("inhibit-quit", Vinhibit_quit
,
4002 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
4003 Note that `quit-flag' will still be set by typing C-g,
4004 so a quit will be signaled as soon as `inhibit-quit' is nil.
4005 To prevent this happening, set `quit-flag' to nil
4006 before making `inhibit-quit' nil. */);
4007 Vinhibit_quit
= Qnil
;
4009 DEFSYM (Qsetq
, "setq");
4010 DEFSYM (Qinhibit_quit
, "inhibit-quit");
4011 DEFSYM (Qautoload
, "autoload");
4012 DEFSYM (Qinhibit_debugger
, "inhibit-debugger");
4013 DEFSYM (Qmacro
, "macro");
4015 /* Note that the process handling also uses Qexit, but we don't want
4016 to staticpro it twice, so we just do it here. */
4017 DEFSYM (Qexit
, "exit");
4019 DEFSYM (Qinteractive
, "interactive");
4020 DEFSYM (Qcommandp
, "commandp");
4021 DEFSYM (Qand_rest
, "&rest");
4022 DEFSYM (Qand_optional
, "&optional");
4023 DEFSYM (Qclosure
, "closure");
4024 DEFSYM (QCdocumentation
, ":documentation");
4025 DEFSYM (Qdebug
, "debug");
4027 DEFVAR_LISP ("inhibit-debugger", Vinhibit_debugger
,
4028 doc
: /* Non-nil means never enter the debugger.
4029 Normally set while the debugger is already active, to avoid recursive
4031 Vinhibit_debugger
= Qnil
;
4033 DEFVAR_LISP ("debug-on-error", Vdebug_on_error
,
4034 doc
: /* Non-nil means enter debugger if an error is signaled.
4035 Does not apply to errors handled by `condition-case' or those
4036 matched by `debug-ignored-errors'.
4037 If the value is a list, an error only means to enter the debugger
4038 if one of its condition symbols appears in the list.
4039 When you evaluate an expression interactively, this variable
4040 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
4041 The command `toggle-debug-on-error' toggles this.
4042 See also the variable `debug-on-quit' and `inhibit-debugger'. */);
4043 Vdebug_on_error
= Qnil
;
4045 DEFVAR_LISP ("debug-ignored-errors", Vdebug_ignored_errors
,
4046 doc
: /* List of errors for which the debugger should not be called.
4047 Each element may be a condition-name or a regexp that matches error messages.
4048 If any element applies to a given error, that error skips the debugger
4049 and just returns to top level.
4050 This overrides the variable `debug-on-error'.
4051 It does not apply to errors handled by `condition-case'. */);
4052 Vdebug_ignored_errors
= Qnil
;
4054 DEFVAR_BOOL ("debug-on-quit", debug_on_quit
,
4055 doc
: /* Non-nil means enter debugger if quit is signaled (C-g, for example).
4056 Does not apply if quit is handled by a `condition-case'. */);
4059 DEFVAR_BOOL ("debug-on-next-call", debug_on_next_call
,
4060 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
4062 DEFVAR_BOOL ("debugger-may-continue", debugger_may_continue
,
4063 doc
: /* Non-nil means debugger may continue execution.
4064 This is nil when the debugger is called under circumstances where it
4065 might not be safe to continue. */);
4066 debugger_may_continue
= 1;
4068 DEFVAR_BOOL ("debugger-stack-frame-as-list", debugger_stack_frame_as_list
,
4069 doc
: /* Non-nil means display call stack frames as lists. */);
4070 debugger_stack_frame_as_list
= 0;
4072 DEFVAR_LISP ("debugger", Vdebugger
,
4073 doc
: /* Function to call to invoke debugger.
4074 If due to frame exit, args are `exit' and the value being returned;
4075 this function's value will be returned instead of that.
4076 If due to error, args are `error' and a list of the args to `signal'.
4077 If due to `apply' or `funcall' entry, one arg, `lambda'.
4078 If due to `eval' entry, one arg, t. */);
4081 DEFVAR_LISP ("signal-hook-function", Vsignal_hook_function
,
4082 doc
: /* If non-nil, this is a function for `signal' to call.
4083 It receives the same arguments that `signal' was given.
4084 The Edebug package uses this to regain control. */);
4085 Vsignal_hook_function
= Qnil
;
4087 DEFVAR_LISP ("debug-on-signal", Vdebug_on_signal
,
4088 doc
: /* Non-nil means call the debugger regardless of condition handlers.
4089 Note that `debug-on-error', `debug-on-quit' and friends
4090 still determine whether to handle the particular condition. */);
4091 Vdebug_on_signal
= Qnil
;
4093 /* When lexical binding is being used,
4094 Vinternal_interpreter_environment is non-nil, and contains an alist
4095 of lexically-bound variable, or (t), indicating an empty
4096 environment. The lisp name of this variable would be
4097 `internal-interpreter-environment' if it weren't hidden.
4098 Every element of this list can be either a cons (VAR . VAL)
4099 specifying a lexical binding, or a single symbol VAR indicating
4100 that this variable should use dynamic scoping. */
4101 DEFSYM (Qinternal_interpreter_environment
,
4102 "internal-interpreter-environment");
4103 DEFVAR_LISP ("internal-interpreter-environment",
4104 Vinternal_interpreter_environment
,
4105 doc
: /* If non-nil, the current lexical environment of the lisp interpreter.
4106 When lexical binding is not being used, this variable is nil.
4107 A value of `(t)' indicates an empty environment, otherwise it is an
4108 alist of active lexical bindings. */);
4109 Vinternal_interpreter_environment
= Qnil
;
4110 /* Don't export this variable to Elisp, so no one can mess with it
4111 (Just imagine if someone makes it buffer-local). */
4112 Funintern (Qinternal_interpreter_environment
, Qnil
);
4114 Vrun_hooks
= intern_c_string ("run-hooks");
4115 staticpro (&Vrun_hooks
);
4117 staticpro (&Vautoload_queue
);
4118 Vautoload_queue
= Qnil
;
4119 staticpro (&Vsignaling_function
);
4120 Vsignaling_function
= Qnil
;
4122 inhibit_lisp_code
= Qnil
;
4124 DEFSYM (Qcatch_all_memory_full
, "catch-all-memory-full");
4125 Funintern (Qcatch_all_memory_full
, Qnil
);
4136 defsubr (&Sfunction
);
4137 defsubr (&Sdefault_toplevel_value
);
4138 defsubr (&Sset_default_toplevel_value
);
4140 defsubr (&Sdefvaralias
);
4141 DEFSYM (Qdefvaralias
, "defvaralias");
4142 defsubr (&Sdefconst
);
4143 defsubr (&Smake_var_non_special
);
4147 defsubr (&Smacroexpand
);
4150 defsubr (&Sunwind_protect
);
4151 defsubr (&Scondition_case
);
4153 defsubr (&Scommandp
);
4154 defsubr (&Sautoload
);
4155 defsubr (&Sautoload_do_load
);
4158 defsubr (&Sfuncall
);
4159 defsubr (&Sfunc_arity
);
4160 defsubr (&Srun_hooks
);
4161 defsubr (&Srun_hook_with_args
);
4162 defsubr (&Srun_hook_with_args_until_success
);
4163 defsubr (&Srun_hook_with_args_until_failure
);
4164 defsubr (&Srun_hook_wrapped
);
4165 defsubr (&Sfetch_bytecode
);
4166 defsubr (&Sbacktrace_debug
);
4167 DEFSYM (QCdebug_on_exit
, ":debug-on-exit");
4168 defsubr (&Smapbacktrace
);
4169 defsubr (&Sbacktrace_frame_internal
);
4170 defsubr (&Sbacktrace_eval
);
4171 defsubr (&Sbacktrace__locals
);
4172 defsubr (&Sspecial_variable_p
);
4173 defsubr (&Sfunctionp
);