1 /* Evaluator for GNU Emacs Lisp interpreter.
3 Copyright (C) 1985-1987, 1993-1995, 1999-2017 Free Software Foundation,
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or (at
11 your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
27 #include "blockinput.h"
30 #include "dispextern.h"
33 /* CACHEABLE is ordinarily nothing, except it is 'volatile' if
34 necessary to cajole GCC into not warning incorrectly that a
35 variable should be volatile. */
36 #if defined GCC_LINT || defined lint
37 # define CACHEABLE volatile
39 # define CACHEABLE /* empty */
42 /* Chain of condition and catch handlers currently in effect. */
44 /* struct handler *handlerlist; */
46 /* Non-nil means record all fset's and provide's, to be undone
47 if the file being autoloaded is not fully loaded.
48 They are recorded by being consed onto the front of Vautoload_queue:
49 (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide. */
51 Lisp_Object Vautoload_queue
;
53 /* This holds either the symbol `run-hooks' or nil.
54 It is nil at an early stage of startup, and when Emacs
56 Lisp_Object Vrun_hooks
;
58 /* The commented-out variables below are macros defined in thread.h. */
60 /* Current number of specbindings allocated in specpdl, not counting
61 the dummy entry specpdl[-1]. */
63 /* ptrdiff_t specpdl_size; */
65 /* Pointer to beginning of specpdl. A dummy entry specpdl[-1] exists
66 only so that its address can be taken. */
68 /* union specbinding *specpdl; */
70 /* Pointer to first unused element in specpdl. */
72 /* union specbinding *specpdl_ptr; */
74 /* Depth in Lisp evaluations and function calls. */
76 /* static EMACS_INT lisp_eval_depth; */
78 /* The value of num_nonmacro_input_events as of the last time we
79 started to enter the debugger. If we decide to enter the debugger
80 again when this is still equal to num_nonmacro_input_events, then we
81 know that the debugger itself has an error, and we should just
82 signal the error instead of entering an infinite loop of debugger
85 static EMACS_INT when_entered_debugger
;
87 /* The function from which the last `signal' was called. Set in
89 /* FIXME: We should probably get rid of this! */
90 Lisp_Object Vsignaling_function
;
92 /* If non-nil, Lisp code must not be run since some part of Emacs is in
93 an inconsistent state. Currently unused. */
94 Lisp_Object inhibit_lisp_code
;
96 /* These would ordinarily be static, but they need to be visible to GDB. */
97 bool backtrace_p (union specbinding
*) EXTERNALLY_VISIBLE
;
98 Lisp_Object
*backtrace_args (union specbinding
*) EXTERNALLY_VISIBLE
;
99 Lisp_Object
backtrace_function (union specbinding
*) EXTERNALLY_VISIBLE
;
100 union specbinding
*backtrace_next (union specbinding
*) EXTERNALLY_VISIBLE
;
101 union specbinding
*backtrace_top (void) EXTERNALLY_VISIBLE
;
103 static Lisp_Object
funcall_lambda (Lisp_Object
, ptrdiff_t, Lisp_Object
*);
104 static Lisp_Object
apply_lambda (Lisp_Object
, Lisp_Object
, ptrdiff_t);
105 static Lisp_Object
lambda_arity (Lisp_Object
);
108 specpdl_symbol (union specbinding
*pdl
)
110 eassert (pdl
->kind
>= SPECPDL_LET
);
111 return pdl
->let
.symbol
;
114 static enum specbind_tag
115 specpdl_kind (union specbinding
*pdl
)
117 eassert (pdl
->kind
>= SPECPDL_LET
);
118 return pdl
->let
.kind
;
122 specpdl_old_value (union specbinding
*pdl
)
124 eassert (pdl
->kind
>= SPECPDL_LET
);
125 return pdl
->let
.old_value
;
129 set_specpdl_old_value (union specbinding
*pdl
, Lisp_Object val
)
131 eassert (pdl
->kind
>= SPECPDL_LET
);
132 pdl
->let
.old_value
= val
;
136 specpdl_where (union specbinding
*pdl
)
138 eassert (pdl
->kind
> SPECPDL_LET
);
139 return pdl
->let
.where
;
143 specpdl_saved_value (union specbinding
*pdl
)
145 eassert (pdl
->kind
>= SPECPDL_LET
);
146 return pdl
->let
.saved_value
;
150 specpdl_arg (union specbinding
*pdl
)
152 eassert (pdl
->kind
== SPECPDL_UNWIND
);
153 return pdl
->unwind
.arg
;
157 backtrace_function (union specbinding
*pdl
)
159 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
160 return pdl
->bt
.function
;
164 backtrace_nargs (union specbinding
*pdl
)
166 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
167 return pdl
->bt
.nargs
;
171 backtrace_args (union specbinding
*pdl
)
173 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
178 backtrace_debug_on_exit (union specbinding
*pdl
)
180 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
181 return pdl
->bt
.debug_on_exit
;
184 /* Functions to modify slots of backtrace records. */
187 set_backtrace_args (union specbinding
*pdl
, Lisp_Object
*args
, ptrdiff_t nargs
)
189 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
191 pdl
->bt
.nargs
= nargs
;
195 set_backtrace_debug_on_exit (union specbinding
*pdl
, bool doe
)
197 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
198 pdl
->bt
.debug_on_exit
= doe
;
201 /* Helper functions to scan the backtrace. */
204 backtrace_p (union specbinding
*pdl
)
205 { return pdl
>= specpdl
; }
210 union specbinding
*pdl
= specpdl_ptr
- 1;
211 while (backtrace_p (pdl
) && pdl
->kind
!= SPECPDL_BACKTRACE
)
217 backtrace_next (union specbinding
*pdl
)
220 while (backtrace_p (pdl
) && pdl
->kind
!= SPECPDL_BACKTRACE
)
226 init_eval_once (void)
229 union specbinding
*pdlvec
= xmalloc ((size
+ 1) * sizeof *specpdl
);
231 specpdl
= specpdl_ptr
= pdlvec
+ 1;
232 /* Don't forget to update docs (lispref node "Local Variables"). */
233 max_specpdl_size
= 1300; /* 1000 is not enough for CEDET's c-by.el. */
234 max_lisp_eval_depth
= 800;
239 /* static struct handler handlerlist_sentinel; */
244 specpdl_ptr
= specpdl
;
245 { /* Put a dummy catcher at top-level so that handlerlist is never NULL.
246 This is important since handlerlist->nextfree holds the freelist
247 which would otherwise leak every time we unwind back to top-level. */
248 handlerlist_sentinel
= xzalloc (sizeof (struct handler
));
249 handlerlist
= handlerlist_sentinel
->nextfree
= handlerlist_sentinel
;
250 struct handler
*c
= push_handler (Qunbound
, CATCHER
);
251 eassert (c
== handlerlist_sentinel
);
252 handlerlist_sentinel
->nextfree
= NULL
;
253 handlerlist_sentinel
->next
= NULL
;
256 debug_on_next_call
= 0;
258 /* This is less than the initial value of num_nonmacro_input_events. */
259 when_entered_debugger
= -1;
262 /* Unwind-protect function used by call_debugger. */
265 restore_stack_limits (Lisp_Object data
)
267 max_specpdl_size
= XINT (XCAR (data
));
268 max_lisp_eval_depth
= XINT (XCDR (data
));
271 static void grow_specpdl (void);
273 /* Call the Lisp debugger, giving it argument ARG. */
276 call_debugger (Lisp_Object arg
)
278 bool debug_while_redisplaying
;
279 ptrdiff_t count
= SPECPDL_INDEX ();
281 EMACS_INT old_depth
= max_lisp_eval_depth
;
282 /* Do not allow max_specpdl_size less than actual depth (Bug#16603). */
283 EMACS_INT old_max
= max (max_specpdl_size
, count
);
285 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
286 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
288 /* While debugging Bug#16603, previous value of 100 was found
289 too small to avoid specpdl overflow in the debugger itself. */
290 if (max_specpdl_size
- 200 < count
)
291 max_specpdl_size
= count
+ 200;
293 if (old_max
== count
)
295 /* We can enter the debugger due to specpdl overflow (Bug#16603). */
300 /* Restore limits after leaving the debugger. */
301 record_unwind_protect (restore_stack_limits
,
302 Fcons (make_number (old_max
),
303 make_number (old_depth
)));
305 #ifdef HAVE_WINDOW_SYSTEM
306 if (display_hourglass_p
)
310 debug_on_next_call
= 0;
311 when_entered_debugger
= num_nonmacro_input_events
;
313 /* Resetting redisplaying_p to 0 makes sure that debug output is
314 displayed if the debugger is invoked during redisplay. */
315 debug_while_redisplaying
= redisplaying_p
;
317 specbind (intern ("debugger-may-continue"),
318 debug_while_redisplaying
? Qnil
: Qt
);
319 specbind (Qinhibit_redisplay
, Qnil
);
320 specbind (Qinhibit_debugger
, Qt
);
322 /* If we are debugging an error while `inhibit-changing-match-data'
323 is bound to non-nil (e.g., within a call to `string-match-p'),
324 then make sure debugger code can still use match data. */
325 specbind (Qinhibit_changing_match_data
, Qnil
);
327 #if 0 /* Binding this prevents execution of Lisp code during
328 redisplay, which necessarily leads to display problems. */
329 specbind (Qinhibit_eval_during_redisplay
, Qt
);
332 val
= apply1 (Vdebugger
, arg
);
334 /* Interrupting redisplay and resuming it later is not safe under
335 all circumstances. So, when the debugger returns, abort the
336 interrupted redisplay by going back to the top-level. */
337 if (debug_while_redisplaying
)
340 return unbind_to (count
, val
);
344 do_debug_on_call (Lisp_Object code
, ptrdiff_t count
)
346 debug_on_next_call
= 0;
347 set_backtrace_debug_on_exit (specpdl
+ count
, true);
348 call_debugger (list1 (code
));
351 /* NOTE!!! Every function that can call EVAL must protect its args
352 and temporaries from garbage collection while it needs them.
353 The definition of `For' shows what you have to do. */
355 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
356 doc
: /* Eval args until one of them yields non-nil, then return that value.
357 The remaining args are not evalled at all.
358 If all args return nil, return nil.
359 usage: (or CONDITIONS...) */)
362 Lisp_Object val
= Qnil
;
366 Lisp_Object arg
= XCAR (args
);
368 val
= eval_sub (arg
);
376 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
377 doc
: /* Eval args until one of them yields nil, then return nil.
378 The remaining args are not evalled at all.
379 If no arg yields nil, return the last arg's value.
380 usage: (and CONDITIONS...) */)
383 Lisp_Object val
= Qt
;
387 Lisp_Object arg
= XCAR (args
);
389 val
= eval_sub (arg
);
397 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
398 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
399 Returns the value of THEN or the value of the last of the ELSE's.
400 THEN must be one expression, but ELSE... can be zero or more expressions.
401 If COND yields nil, and there are no ELSE's, the value is nil.
402 usage: (if COND THEN ELSE...) */)
407 cond
= eval_sub (XCAR (args
));
410 return eval_sub (Fcar (XCDR (args
)));
411 return Fprogn (Fcdr (XCDR (args
)));
414 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
415 doc
: /* Try each clause until one succeeds.
416 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
417 and, if the value is non-nil, this clause succeeds:
418 then the expressions in BODY are evaluated and the last one's
419 value is the value of the cond-form.
420 If a clause has one element, as in (CONDITION), then the cond-form
421 returns CONDITION's value, if that is non-nil.
422 If no clause succeeds, cond returns nil.
423 usage: (cond CLAUSES...) */)
426 Lisp_Object val
= args
;
430 Lisp_Object clause
= XCAR (args
);
431 val
= eval_sub (Fcar (clause
));
434 if (!NILP (XCDR (clause
)))
435 val
= Fprogn (XCDR (clause
));
444 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
445 doc
: /* Eval BODY forms sequentially and return value of last one.
446 usage: (progn BODY...) */)
449 Lisp_Object val
= Qnil
;
453 Lisp_Object form
= XCAR (body
);
455 val
= eval_sub (form
);
461 /* Evaluate BODY sequentially, discarding its value. */
464 prog_ignore (Lisp_Object body
)
469 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
470 doc
: /* Eval FIRST and BODY sequentially; return value from FIRST.
471 The value of FIRST is saved during the evaluation of the remaining args,
472 whose values are discarded.
473 usage: (prog1 FIRST BODY...) */)
476 Lisp_Object val
= eval_sub (XCAR (args
));
477 prog_ignore (XCDR (args
));
481 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
482 doc
: /* Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
483 The value of FORM2 is saved during the evaluation of the
484 remaining args, whose values are discarded.
485 usage: (prog2 FORM1 FORM2 BODY...) */)
488 eval_sub (XCAR (args
));
489 return Fprog1 (XCDR (args
));
492 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
493 doc
: /* Set each SYM to the value of its VAL.
494 The symbols SYM are variables; they are literal (not evaluated).
495 The values VAL are expressions; they are evaluated.
496 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
497 The second VAL is not computed until after the first SYM is set, and so on;
498 each VAL can use the new value of variables set earlier in the `setq'.
499 The return value of the `setq' form is the value of the last VAL.
500 usage: (setq [SYM VAL]...) */)
503 Lisp_Object val
= args
, tail
= args
;
505 for (EMACS_INT nargs
= 0; CONSP (tail
); nargs
+= 2)
507 Lisp_Object sym
= XCAR (tail
), lex_binding
;
510 xsignal2 (Qwrong_number_of_arguments
, Qsetq
, make_number (nargs
+ 1));
511 Lisp_Object arg
= XCAR (tail
);
513 val
= eval_sub (arg
);
514 /* Like for eval_sub, we do not check declared_special here since
515 it's been done when let-binding. */
516 if (!NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
518 && !NILP (lex_binding
519 = Fassq (sym
, Vinternal_interpreter_environment
)))
520 XSETCDR (lex_binding
, val
); /* SYM is lexically bound. */
522 Fset (sym
, val
); /* SYM is dynamically bound. */
528 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
529 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
530 Warning: `quote' does not construct its return value, but just returns
531 the value that was pre-constructed by the Lisp reader (see info node
532 `(elisp)Printed Representation').
533 This means that \\='(a . b) is not identical to (cons \\='a \\='b): the former
534 does not cons. Quoting should be reserved for constants that will
535 never be modified by side-effects, unless you like self-modifying code.
536 See the common pitfall in info node `(elisp)Rearrangement' for an example
537 of unexpected results when a quoted object is modified.
538 usage: (quote ARG) */)
541 if (!NILP (XCDR (args
)))
542 xsignal2 (Qwrong_number_of_arguments
, Qquote
, Flength (args
));
546 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
547 doc
: /* Like `quote', but preferred for objects which are functions.
548 In byte compilation, `function' causes its argument to be compiled.
549 `quote' cannot do that.
550 usage: (function ARG) */)
553 Lisp_Object quoted
= XCAR (args
);
555 if (!NILP (XCDR (args
)))
556 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
558 if (!NILP (Vinternal_interpreter_environment
)
560 && EQ (XCAR (quoted
), Qlambda
))
561 { /* This is a lambda expression within a lexical environment;
562 return an interpreted closure instead of a simple lambda. */
563 Lisp_Object cdr
= XCDR (quoted
);
564 Lisp_Object tmp
= cdr
;
566 && (tmp
= XCDR (tmp
), CONSP (tmp
))
567 && (tmp
= XCAR (tmp
), CONSP (tmp
))
568 && (EQ (QCdocumentation
, XCAR (tmp
))))
569 { /* Handle the special (:documentation <form>) to build the docstring
571 Lisp_Object docstring
= eval_sub (Fcar (XCDR (tmp
)));
572 CHECK_STRING (docstring
);
573 cdr
= Fcons (XCAR (cdr
), Fcons (docstring
, XCDR (XCDR (cdr
))));
575 return Fcons (Qclosure
, Fcons (Vinternal_interpreter_environment
,
579 /* Simply quote the argument. */
584 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
585 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
586 Aliased variables always have the same value; setting one sets the other.
587 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
588 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
589 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
590 itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
591 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
592 The return value is BASE-VARIABLE. */)
593 (Lisp_Object new_alias
, Lisp_Object base_variable
, Lisp_Object docstring
)
595 struct Lisp_Symbol
*sym
;
597 CHECK_SYMBOL (new_alias
);
598 CHECK_SYMBOL (base_variable
);
600 if (SYMBOL_CONSTANT_P (new_alias
))
601 /* Making it an alias effectively changes its value. */
602 error ("Cannot make a constant an alias");
604 sym
= XSYMBOL (new_alias
);
606 switch (sym
->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 /* http://lists.gnu.org/archive/html/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
->trapped_write
== SYMBOL_TRAPPED_WRITE
)
636 notify_variable_watchers (new_alias
, base_variable
, Qdefvaralias
, Qnil
);
638 sym
->declared_special
= 1;
639 XSYMBOL (base_variable
)->declared_special
= 1;
640 sym
->redirect
= SYMBOL_VARALIAS
;
641 SET_SYMBOL_ALIAS (sym
, XSYMBOL (base_variable
));
642 sym
->trapped_write
= XSYMBOL (base_variable
)->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
)->declared_special
= 1;
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
)->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
)->declared_special
= 1;
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
)->declared_special
= 0;
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
)->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
)->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
)->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 push_handler (Lisp_Object tag_ch_val
, enum handlertype handlertype
)
1422 struct handler
*c
= push_handler_nosignal (tag_ch_val
, handlertype
);
1424 memory_full (sizeof *c
);
1429 push_handler_nosignal (Lisp_Object tag_ch_val
, enum handlertype handlertype
)
1431 struct handler
*CACHEABLE c
= handlerlist
->nextfree
;
1434 c
= malloc (sizeof *c
);
1437 if (profiler_memory_running
)
1438 malloc_probe (sizeof *c
);
1440 handlerlist
->nextfree
= c
;
1442 c
->type
= handlertype
;
1443 c
->tag_or_ch
= tag_ch_val
;
1445 c
->next
= handlerlist
;
1446 c
->f_lisp_eval_depth
= lisp_eval_depth
;
1447 c
->pdlcount
= SPECPDL_INDEX ();
1448 c
->poll_suppress_count
= poll_suppress_count
;
1449 c
->interrupt_input_blocked
= interrupt_input_blocked
;
1455 static Lisp_Object
signal_or_quit (Lisp_Object
, Lisp_Object
, bool);
1456 static Lisp_Object
find_handler_clause (Lisp_Object
, Lisp_Object
);
1457 static bool maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
,
1461 process_quit_flag (void)
1463 Lisp_Object flag
= Vquit_flag
;
1465 if (EQ (flag
, Qkill_emacs
))
1467 if (EQ (Vthrow_on_input
, flag
))
1468 Fthrow (Vthrow_on_input
, Qt
);
1472 /* Check quit-flag and quit if it is non-nil. Typing C-g does not
1473 directly cause a quit; it only sets Vquit_flag. So the program
1474 needs to call maybe_quit at times when it is safe to quit. Every
1475 loop that might run for a long time or might not exit ought to call
1476 maybe_quit at least once, at a safe place. Unless that is
1477 impossible, of course. But it is very desirable to avoid creating
1478 loops where maybe_quit is impossible.
1480 If quit-flag is set to `kill-emacs' the SIGINT handler has received
1481 a request to exit Emacs when it is safe to do.
1483 When not quitting, process any pending signals.
1485 If you change this function, also adapt module_should_quit in
1491 if (!NILP (Vquit_flag
) && NILP (Vinhibit_quit
))
1492 process_quit_flag ();
1493 else if (pending_signals
)
1494 process_pending_signals ();
1497 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1498 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1499 This function does not return.
1501 An error symbol is a symbol with an `error-conditions' property
1502 that is a list of condition names.
1503 A handler for any of those names will get to handle this signal.
1504 The symbol `error' should normally be one of them.
1506 DATA should be a list. Its elements are printed as part of the error message.
1507 See Info anchor `(elisp)Definition of signal' for some details on how this
1508 error message is constructed.
1509 If the signal is handled, DATA is made available to the handler.
1510 See also the function `condition-case'. */
1511 attributes
: noreturn
)
1512 (Lisp_Object error_symbol
, Lisp_Object data
)
1514 signal_or_quit (error_symbol
, data
, false);
1518 /* Quit, in response to a keyboard quit request. */
1522 return signal_or_quit (Qquit
, Qnil
, true);
1525 /* Signal an error, or quit. ERROR_SYMBOL and DATA are as with Fsignal.
1526 If KEYBOARD_QUIT, this is a quit; ERROR_SYMBOL should be
1527 Qquit and DATA should be Qnil, and this function may return.
1528 Otherwise this function is like Fsignal and does not return. */
1531 signal_or_quit (Lisp_Object error_symbol
, Lisp_Object data
, bool keyboard_quit
)
1533 /* When memory is full, ERROR-SYMBOL is nil,
1534 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1535 That is a special case--don't do this in other situations. */
1536 Lisp_Object conditions
;
1538 Lisp_Object real_error_symbol
1539 = (NILP (error_symbol
) ? Fcar (data
) : error_symbol
);
1540 Lisp_Object clause
= Qnil
;
1543 if (gc_in_progress
|| waiting_for_input
)
1546 #if 0 /* rms: I don't know why this was here,
1547 but it is surely wrong for an error that is handled. */
1548 #ifdef HAVE_WINDOW_SYSTEM
1549 if (display_hourglass_p
)
1550 cancel_hourglass ();
1554 /* This hook is used by edebug. */
1555 if (! NILP (Vsignal_hook_function
)
1556 && ! NILP (error_symbol
))
1558 /* Edebug takes care of restoring these variables when it exits. */
1559 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1560 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1562 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1563 max_specpdl_size
= SPECPDL_INDEX () + 40;
1565 call2 (Vsignal_hook_function
, error_symbol
, data
);
1568 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1570 /* Remember from where signal was called. Skip over the frame for
1571 `signal' itself. If a frame for `error' follows, skip that,
1572 too. Don't do this when ERROR_SYMBOL is nil, because that
1573 is a memory-full error. */
1574 Vsignaling_function
= Qnil
;
1575 if (!NILP (error_symbol
))
1577 union specbinding
*pdl
= backtrace_next (backtrace_top ());
1578 if (backtrace_p (pdl
) && EQ (backtrace_function (pdl
), Qerror
))
1579 pdl
= backtrace_next (pdl
);
1580 if (backtrace_p (pdl
))
1581 Vsignaling_function
= backtrace_function (pdl
);
1584 for (h
= handlerlist
; h
; h
= h
->next
)
1586 if (h
->type
!= CONDITION_CASE
)
1588 clause
= find_handler_clause (h
->tag_or_ch
, conditions
);
1593 if (/* Don't run the debugger for a memory-full error.
1594 (There is no room in memory to do that!) */
1595 !NILP (error_symbol
)
1596 && (!NILP (Vdebug_on_signal
)
1597 /* If no handler is present now, try to run the debugger. */
1599 /* A `debug' symbol in the handler list disables the normal
1600 suppression of the debugger. */
1601 || (CONSP (clause
) && !NILP (Fmemq (Qdebug
, clause
)))
1602 /* Special handler that means "print a message and run debugger
1604 || EQ (h
->tag_or_ch
, Qerror
)))
1606 bool debugger_called
1607 = maybe_call_debugger (conditions
, error_symbol
, data
);
1608 /* We can't return values to code which signaled an error, but we
1609 can continue code which has signaled a quit. */
1610 if (keyboard_quit
&& debugger_called
&& EQ (real_error_symbol
, Qquit
))
1616 Lisp_Object unwind_data
1617 = (NILP (error_symbol
) ? data
: Fcons (error_symbol
, data
));
1619 unwind_to_catch (h
, unwind_data
);
1623 if (handlerlist
!= handlerlist_sentinel
)
1624 /* FIXME: This will come right back here if there's no `top-level'
1625 catcher. A better solution would be to abort here, and instead
1626 add a catch-all condition handler so we never come here. */
1627 Fthrow (Qtop_level
, Qt
);
1630 if (! NILP (error_symbol
))
1631 data
= Fcons (error_symbol
, data
);
1633 string
= Ferror_message_string (data
);
1634 fatal ("%s", SDATA (string
));
1637 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1640 xsignal0 (Lisp_Object error_symbol
)
1642 xsignal (error_symbol
, Qnil
);
1646 xsignal1 (Lisp_Object error_symbol
, Lisp_Object arg
)
1648 xsignal (error_symbol
, list1 (arg
));
1652 xsignal2 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
)
1654 xsignal (error_symbol
, list2 (arg1
, arg2
));
1658 xsignal3 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
1660 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1663 /* Signal `error' with message S, and additional arg ARG.
1664 If ARG is not a genuine list, make it a one-element list. */
1667 signal_error (const char *s
, Lisp_Object arg
)
1669 Lisp_Object tortoise
, hare
;
1671 hare
= tortoise
= arg
;
1672 while (CONSP (hare
))
1679 tortoise
= XCDR (tortoise
);
1681 if (EQ (hare
, tortoise
))
1688 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1692 /* Return true if LIST is a non-nil atom or
1693 a list containing one of CONDITIONS. */
1696 wants_debugger (Lisp_Object list
, Lisp_Object conditions
)
1703 while (CONSP (conditions
))
1705 Lisp_Object
this, tail
;
1706 this = XCAR (conditions
);
1707 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1708 if (EQ (XCAR (tail
), this))
1710 conditions
= XCDR (conditions
);
1715 /* Return true if an error with condition-symbols CONDITIONS,
1716 and described by SIGNAL-DATA, should skip the debugger
1717 according to debugger-ignored-errors. */
1720 skip_debugger (Lisp_Object conditions
, Lisp_Object data
)
1723 bool first_string
= 1;
1724 Lisp_Object error_message
;
1726 error_message
= Qnil
;
1727 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1729 if (STRINGP (XCAR (tail
)))
1733 error_message
= Ferror_message_string (data
);
1737 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1742 Lisp_Object contail
;
1744 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1745 if (EQ (XCAR (tail
), XCAR (contail
)))
1753 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1754 SIG and DATA describe the signal. There are two ways to pass them:
1755 = SIG is the error symbol, and DATA is the rest of the data.
1756 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1757 This is for memory-full errors only. */
1759 maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
, Lisp_Object data
)
1761 Lisp_Object combined_data
;
1763 combined_data
= Fcons (sig
, data
);
1766 /* Don't try to run the debugger with interrupts blocked.
1767 The editing loop would return anyway. */
1768 ! input_blocked_p ()
1769 && NILP (Vinhibit_debugger
)
1770 /* Does user want to enter debugger for this kind of error? */
1773 : wants_debugger (Vdebug_on_error
, conditions
))
1774 && ! skip_debugger (conditions
, combined_data
)
1775 /* RMS: What's this for? */
1776 && when_entered_debugger
< num_nonmacro_input_events
)
1778 call_debugger (list2 (Qerror
, combined_data
));
1786 find_handler_clause (Lisp_Object handlers
, Lisp_Object conditions
)
1788 register Lisp_Object h
;
1790 /* t is used by handlers for all conditions, set up by C code. */
1791 if (EQ (handlers
, Qt
))
1794 /* error is used similarly, but means print an error message
1795 and run the debugger if that is enabled. */
1796 if (EQ (handlers
, Qerror
))
1799 for (h
= handlers
; CONSP (h
); h
= XCDR (h
))
1801 Lisp_Object handler
= XCAR (h
);
1802 if (!NILP (Fmemq (handler
, conditions
)))
1810 /* Format and return a string; called like vprintf. */
1812 vformat_string (const char *m
, va_list ap
)
1815 ptrdiff_t size
= sizeof buf
;
1816 ptrdiff_t size_max
= STRING_BYTES_BOUND
+ 1;
1821 used
= evxprintf (&buffer
, &size
, buf
, size_max
, m
, ap
);
1822 string
= make_string (buffer
, used
);
1829 /* Dump an error message; called like vprintf. */
1831 verror (const char *m
, va_list ap
)
1833 xsignal1 (Qerror
, vformat_string (m
, ap
));
1837 /* Dump an error message; called like printf. */
1841 error (const char *m
, ...)
1848 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
1849 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
1850 This means it contains a description for how to read arguments to give it.
1851 The value is nil for an invalid function or a symbol with no function
1854 Interactively callable functions include strings and vectors (treated
1855 as keyboard macros), lambda-expressions that contain a top-level call
1856 to `interactive', autoload definitions made by `autoload' with non-nil
1857 fourth argument, and some of the built-in functions of Lisp.
1859 Also, a symbol satisfies `commandp' if its function definition does so.
1861 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
1862 then strings and vectors are not accepted. */)
1863 (Lisp_Object function
, Lisp_Object for_call_interactively
)
1865 register Lisp_Object fun
;
1866 register Lisp_Object funcar
;
1867 Lisp_Object if_prop
= Qnil
;
1871 fun
= indirect_function (fun
); /* Check cycles. */
1875 /* Check an `interactive-form' property if present, analogous to the
1876 function-documentation property. */
1878 while (SYMBOLP (fun
))
1880 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
1883 fun
= Fsymbol_function (fun
);
1886 /* Emacs primitives are interactive if their DEFUN specifies an
1887 interactive spec. */
1889 return XSUBR (fun
)->intspec
? Qt
: if_prop
;
1891 /* Bytecode objects are interactive if they are long enough to
1892 have an element whose index is COMPILED_INTERACTIVE, which is
1893 where the interactive spec is stored. */
1894 else if (COMPILEDP (fun
))
1895 return (PVSIZE (fun
) > COMPILED_INTERACTIVE
? Qt
: if_prop
);
1897 /* Strings and vectors are keyboard macros. */
1898 if (STRINGP (fun
) || VECTORP (fun
))
1899 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
1901 /* Lists may represent commands. */
1904 funcar
= XCAR (fun
);
1905 if (EQ (funcar
, Qclosure
))
1906 return (!NILP (Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
)))))
1908 else if (EQ (funcar
, Qlambda
))
1909 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
1910 else if (EQ (funcar
, Qautoload
))
1911 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
1916 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1917 doc
: /* Define FUNCTION to autoload from FILE.
1918 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
1919 Third arg DOCSTRING is documentation for the function.
1920 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
1921 Fifth arg TYPE indicates the type of the object:
1922 nil or omitted says FUNCTION is a function,
1923 `keymap' says FUNCTION is really a keymap, and
1924 `macro' or t says FUNCTION is really a macro.
1925 Third through fifth args give info about the real definition.
1926 They default to nil.
1927 If FUNCTION is already defined other than as an autoload,
1928 this does nothing and returns nil. */)
1929 (Lisp_Object function
, Lisp_Object file
, Lisp_Object docstring
, Lisp_Object interactive
, Lisp_Object type
)
1931 CHECK_SYMBOL (function
);
1932 CHECK_STRING (file
);
1934 /* If function is defined and not as an autoload, don't override. */
1935 if (!NILP (XSYMBOL (function
)->function
)
1936 && !AUTOLOADP (XSYMBOL (function
)->function
))
1939 if (!NILP (Vpurify_flag
) && EQ (docstring
, make_number (0)))
1940 /* `read1' in lread.c has found the docstring starting with "\
1941 and assumed the docstring will be provided by Snarf-documentation, so it
1942 passed us 0 instead. But that leads to accidental sharing in purecopy's
1943 hash-consing, so we use a (hopefully) unique integer instead. */
1944 docstring
= make_number (XHASH (function
));
1945 return Fdefalias (function
,
1946 list5 (Qautoload
, file
, docstring
, interactive
, type
),
1951 un_autoload (Lisp_Object oldqueue
)
1953 Lisp_Object queue
, first
, second
;
1955 /* Queue to unwind is current value of Vautoload_queue.
1956 oldqueue is the shadowed value to leave in Vautoload_queue. */
1957 queue
= Vautoload_queue
;
1958 Vautoload_queue
= oldqueue
;
1959 while (CONSP (queue
))
1961 first
= XCAR (queue
);
1962 second
= Fcdr (first
);
1963 first
= Fcar (first
);
1964 if (EQ (first
, make_number (0)))
1967 Ffset (first
, second
);
1968 queue
= XCDR (queue
);
1972 /* Load an autoloaded function.
1973 FUNNAME is the symbol which is the function's name.
1974 FUNDEF is the autoload definition (a list). */
1976 DEFUN ("autoload-do-load", Fautoload_do_load
, Sautoload_do_load
, 1, 3, 0,
1977 doc
: /* Load FUNDEF which should be an autoload.
1978 If non-nil, FUNNAME should be the symbol whose function value is FUNDEF,
1979 in which case the function returns the new autoloaded function value.
1980 If equal to `macro', MACRO-ONLY specifies that FUNDEF should only be loaded if
1981 it defines a macro. */)
1982 (Lisp_Object fundef
, Lisp_Object funname
, Lisp_Object macro_only
)
1984 ptrdiff_t count
= SPECPDL_INDEX ();
1986 if (!CONSP (fundef
) || !EQ (Qautoload
, XCAR (fundef
)))
1989 if (EQ (macro_only
, Qmacro
))
1991 Lisp_Object kind
= Fnth (make_number (4), fundef
);
1992 if (! (EQ (kind
, Qt
) || EQ (kind
, Qmacro
)))
1996 /* This is to make sure that loadup.el gives a clear picture
1997 of what files are preloaded and when. */
1998 if (! NILP (Vpurify_flag
))
1999 error ("Attempt to autoload %s while preparing to dump",
2000 SDATA (SYMBOL_NAME (funname
)));
2002 CHECK_SYMBOL (funname
);
2004 /* Preserve the match data. */
2005 record_unwind_save_match_data ();
2007 /* If autoloading gets an error (which includes the error of failing
2008 to define the function being called), we use Vautoload_queue
2009 to undo function definitions and `provide' calls made by
2010 the function. We do this in the specific case of autoloading
2011 because autoloading is not an explicit request "load this file",
2012 but rather a request to "call this function".
2014 The value saved here is to be restored into Vautoload_queue. */
2015 record_unwind_protect (un_autoload
, Vautoload_queue
);
2016 Vautoload_queue
= Qt
;
2017 /* If `macro_only', assume this autoload to be a "best-effort",
2018 so don't signal an error if autoloading fails. */
2019 Fload (Fcar (Fcdr (fundef
)), macro_only
, Qt
, Qnil
, Qt
);
2021 /* Once loading finishes, don't undo it. */
2022 Vautoload_queue
= Qt
;
2023 unbind_to (count
, Qnil
);
2029 Lisp_Object fun
= Findirect_function (funname
, Qnil
);
2031 if (!NILP (Fequal (fun
, fundef
)))
2032 error ("Autoloading file %s failed to define function %s",
2033 SDATA (Fcar (Fcar (Vload_history
))),
2034 SDATA (SYMBOL_NAME (funname
)));
2041 DEFUN ("eval", Feval
, Seval
, 1, 2, 0,
2042 doc
: /* Evaluate FORM and return its value.
2043 If LEXICAL is t, evaluate using lexical scoping.
2044 LEXICAL can also be an actual lexical environment, in the form of an
2045 alist mapping symbols to their value. */)
2046 (Lisp_Object form
, Lisp_Object lexical
)
2048 ptrdiff_t count
= SPECPDL_INDEX ();
2049 specbind (Qinternal_interpreter_environment
,
2050 CONSP (lexical
) || NILP (lexical
) ? lexical
: list1 (Qt
));
2051 return unbind_to (count
, eval_sub (form
));
2054 /* Grow the specpdl stack by one entry.
2055 The caller should have already initialized the entry.
2056 Signal an error on stack overflow.
2058 Make sure that there is always one unused entry past the top of the
2059 stack, so that the just-initialized entry is safely unwound if
2060 memory exhausted and an error is signaled here. Also, allocate a
2061 never-used entry just before the bottom of the stack; sometimes its
2062 address is taken. */
2069 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2071 ptrdiff_t count
= SPECPDL_INDEX ();
2072 ptrdiff_t max_size
= min (max_specpdl_size
, PTRDIFF_MAX
- 1000);
2073 union specbinding
*pdlvec
= specpdl
- 1;
2074 ptrdiff_t pdlvecsize
= specpdl_size
+ 1;
2075 if (max_size
<= specpdl_size
)
2077 if (max_specpdl_size
< 400)
2078 max_size
= max_specpdl_size
= 400;
2079 if (max_size
<= specpdl_size
)
2080 signal_error ("Variable binding depth exceeds max-specpdl-size",
2083 pdlvec
= xpalloc (pdlvec
, &pdlvecsize
, 1, max_size
+ 1, sizeof *specpdl
);
2084 specpdl
= pdlvec
+ 1;
2085 specpdl_size
= pdlvecsize
- 1;
2086 specpdl_ptr
= specpdl
+ count
;
2091 record_in_backtrace (Lisp_Object function
, Lisp_Object
*args
, ptrdiff_t nargs
)
2093 ptrdiff_t count
= SPECPDL_INDEX ();
2095 eassert (nargs
>= UNEVALLED
);
2096 specpdl_ptr
->bt
.kind
= SPECPDL_BACKTRACE
;
2097 specpdl_ptr
->bt
.debug_on_exit
= false;
2098 specpdl_ptr
->bt
.function
= function
;
2099 current_thread
->stack_top
= specpdl_ptr
->bt
.args
= args
;
2100 specpdl_ptr
->bt
.nargs
= nargs
;
2106 /* Eval a sub-expression of the current expression (i.e. in the same
2109 eval_sub (Lisp_Object form
)
2111 Lisp_Object fun
, val
, original_fun
, original_args
;
2115 /* Declare here, as this array may be accessed by call_debugger near
2116 the end of this function. See Bug#21245. */
2117 Lisp_Object argvals
[8];
2121 /* Look up its binding in the lexical environment.
2122 We do not pay attention to the declared_special flag here, since we
2123 already did that when let-binding the variable. */
2124 Lisp_Object lex_binding
2125 = !NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
2126 ? Fassq (form
, Vinternal_interpreter_environment
)
2128 if (CONSP (lex_binding
))
2129 return XCDR (lex_binding
);
2131 return Fsymbol_value (form
);
2141 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2143 if (max_lisp_eval_depth
< 100)
2144 max_lisp_eval_depth
= 100;
2145 if (lisp_eval_depth
> max_lisp_eval_depth
)
2146 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2149 original_fun
= XCAR (form
);
2150 original_args
= XCDR (form
);
2151 CHECK_LIST (original_args
);
2153 /* This also protects them from gc. */
2154 count
= record_in_backtrace (original_fun
, &original_args
, UNEVALLED
);
2156 if (debug_on_next_call
)
2157 do_debug_on_call (Qt
, count
);
2159 /* At this point, only original_fun and original_args
2160 have values that will be used below. */
2163 /* Optimize for no indirection. */
2166 fun
= Ffunction (Fcons (fun
, Qnil
));
2167 else if (!NILP (fun
) && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2168 fun
= indirect_function (fun
);
2172 Lisp_Object args_left
= original_args
;
2173 Lisp_Object numargs
= Flength (args_left
);
2177 if (XINT (numargs
) < XSUBR (fun
)->min_args
2178 || (XSUBR (fun
)->max_args
>= 0
2179 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2180 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2182 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2183 val
= (XSUBR (fun
)->function
.aUNEVALLED
) (args_left
);
2184 else if (XSUBR (fun
)->max_args
== MANY
)
2186 /* Pass a vector of evaluated arguments. */
2188 ptrdiff_t argnum
= 0;
2191 SAFE_ALLOCA_LISP (vals
, XINT (numargs
));
2193 while (CONSP (args_left
) && argnum
< XINT (numargs
))
2195 Lisp_Object arg
= XCAR (args_left
);
2196 args_left
= XCDR (args_left
);
2197 vals
[argnum
++] = eval_sub (arg
);
2200 set_backtrace_args (specpdl
+ count
, vals
, argnum
);
2202 val
= XSUBR (fun
)->function
.aMANY (argnum
, vals
);
2206 /* Do the debug-on-exit now, while VALS still exists. */
2207 if (backtrace_debug_on_exit (specpdl
+ count
))
2208 val
= call_debugger (list2 (Qexit
, val
));
2215 int i
, maxargs
= XSUBR (fun
)->max_args
;
2217 for (i
= 0; i
< maxargs
; i
++)
2219 argvals
[i
] = eval_sub (Fcar (args_left
));
2220 args_left
= Fcdr (args_left
);
2223 set_backtrace_args (specpdl
+ count
, argvals
, XINT (numargs
));
2228 val
= (XSUBR (fun
)->function
.a0 ());
2231 val
= (XSUBR (fun
)->function
.a1 (argvals
[0]));
2234 val
= (XSUBR (fun
)->function
.a2 (argvals
[0], argvals
[1]));
2237 val
= (XSUBR (fun
)->function
.a3
2238 (argvals
[0], argvals
[1], argvals
[2]));
2241 val
= (XSUBR (fun
)->function
.a4
2242 (argvals
[0], argvals
[1], argvals
[2], argvals
[3]));
2245 val
= (XSUBR (fun
)->function
.a5
2246 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2250 val
= (XSUBR (fun
)->function
.a6
2251 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2252 argvals
[4], argvals
[5]));
2255 val
= (XSUBR (fun
)->function
.a7
2256 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2257 argvals
[4], argvals
[5], argvals
[6]));
2261 val
= (XSUBR (fun
)->function
.a8
2262 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2263 argvals
[4], argvals
[5], argvals
[6], argvals
[7]));
2267 /* Someone has created a subr that takes more arguments than
2268 is supported by this code. We need to either rewrite the
2269 subr to use a different argument protocol, or add more
2270 cases to this switch. */
2275 else if (COMPILEDP (fun
) || MODULE_FUNCTIONP (fun
))
2276 return apply_lambda (fun
, original_args
, count
);
2280 xsignal1 (Qvoid_function
, original_fun
);
2282 xsignal1 (Qinvalid_function
, original_fun
);
2283 funcar
= XCAR (fun
);
2284 if (!SYMBOLP (funcar
))
2285 xsignal1 (Qinvalid_function
, original_fun
);
2286 if (EQ (funcar
, Qautoload
))
2288 Fautoload_do_load (fun
, original_fun
, Qnil
);
2291 if (EQ (funcar
, Qmacro
))
2293 ptrdiff_t count1
= SPECPDL_INDEX ();
2295 /* Bind lexical-binding during expansion of the macro, so the
2296 macro can know reliably if the code it outputs will be
2297 interpreted using lexical-binding or not. */
2298 specbind (Qlexical_binding
,
2299 NILP (Vinternal_interpreter_environment
) ? Qnil
: Qt
);
2300 exp
= apply1 (Fcdr (fun
), original_args
);
2301 unbind_to (count1
, Qnil
);
2302 val
= eval_sub (exp
);
2304 else if (EQ (funcar
, Qlambda
)
2305 || EQ (funcar
, Qclosure
))
2306 return apply_lambda (fun
, original_args
, count
);
2308 xsignal1 (Qinvalid_function
, original_fun
);
2313 if (backtrace_debug_on_exit (specpdl
+ count
))
2314 val
= call_debugger (list2 (Qexit
, val
));
2320 DEFUN ("apply", Fapply
, Sapply
, 1, MANY
, 0,
2321 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2322 Then return the value FUNCTION returns.
2323 Thus, (apply \\='+ 1 2 \\='(3 4)) returns 10.
2324 usage: (apply FUNCTION &rest ARGUMENTS) */)
2325 (ptrdiff_t nargs
, Lisp_Object
*args
)
2327 ptrdiff_t i
, numargs
, funcall_nargs
;
2328 register Lisp_Object
*funcall_args
= NULL
;
2329 register Lisp_Object spread_arg
= args
[nargs
- 1];
2330 Lisp_Object fun
= args
[0];
2334 CHECK_LIST (spread_arg
);
2336 numargs
= XINT (Flength (spread_arg
));
2339 return Ffuncall (nargs
- 1, args
);
2340 else if (numargs
== 1)
2342 args
[nargs
- 1] = XCAR (spread_arg
);
2343 return Ffuncall (nargs
, args
);
2346 numargs
+= nargs
- 2;
2348 /* Optimize for no indirection. */
2349 if (SYMBOLP (fun
) && !NILP (fun
)
2350 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2352 fun
= indirect_function (fun
);
2354 /* Let funcall get the error. */
2358 if (SUBRP (fun
) && XSUBR (fun
)->max_args
> numargs
2359 /* Don't hide an error by adding missing arguments. */
2360 && numargs
>= XSUBR (fun
)->min_args
)
2362 /* Avoid making funcall cons up a yet another new vector of arguments
2363 by explicitly supplying nil's for optional values. */
2364 SAFE_ALLOCA_LISP (funcall_args
, 1 + XSUBR (fun
)->max_args
);
2365 memclear (funcall_args
+ numargs
+ 1,
2366 (XSUBR (fun
)->max_args
- numargs
) * word_size
);
2367 funcall_nargs
= 1 + XSUBR (fun
)->max_args
;
2370 { /* We add 1 to numargs because funcall_args includes the
2371 function itself as well as its arguments. */
2372 SAFE_ALLOCA_LISP (funcall_args
, 1 + numargs
);
2373 funcall_nargs
= 1 + numargs
;
2376 memcpy (funcall_args
, args
, nargs
* word_size
);
2377 /* Spread the last arg we got. Its first element goes in
2378 the slot that it used to occupy, hence this value of I. */
2380 while (!NILP (spread_arg
))
2382 funcall_args
[i
++] = XCAR (spread_arg
);
2383 spread_arg
= XCDR (spread_arg
);
2386 retval
= Ffuncall (funcall_nargs
, funcall_args
);
2392 /* Run hook variables in various ways. */
2395 funcall_nil (ptrdiff_t nargs
, Lisp_Object
*args
)
2397 Ffuncall (nargs
, args
);
2401 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2402 doc
: /* Run each hook in HOOKS.
2403 Each argument should be a symbol, a hook variable.
2404 These symbols are processed in the order specified.
2405 If a hook symbol has a non-nil value, that value may be a function
2406 or a list of functions to be called to run the hook.
2407 If the value is a function, it is called with no arguments.
2408 If it is a list, the elements are called, in order, with no arguments.
2410 Major modes should not use this function directly to run their mode
2411 hook; they should use `run-mode-hooks' instead.
2413 Do not use `make-local-variable' to make a hook variable buffer-local.
2414 Instead, use `add-hook' and specify t for the LOCAL argument.
2415 usage: (run-hooks &rest HOOKS) */)
2416 (ptrdiff_t nargs
, Lisp_Object
*args
)
2420 for (i
= 0; i
< nargs
; i
++)
2426 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2427 Srun_hook_with_args
, 1, MANY
, 0,
2428 doc
: /* Run HOOK with the specified arguments ARGS.
2429 HOOK should be a symbol, a hook variable. The value of HOOK
2430 may be nil, a function, or a list of functions. Call each
2431 function in order with arguments ARGS. The final return value
2434 Do not use `make-local-variable' to make a hook variable buffer-local.
2435 Instead, use `add-hook' and specify t for the LOCAL argument.
2436 usage: (run-hook-with-args HOOK &rest ARGS) */)
2437 (ptrdiff_t nargs
, Lisp_Object
*args
)
2439 return run_hook_with_args (nargs
, args
, funcall_nil
);
2442 /* NB this one still documents a specific non-nil return value.
2443 (As did run-hook-with-args and run-hook-with-args-until-failure
2444 until they were changed in 24.1.) */
2445 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2446 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2447 doc
: /* Run HOOK with the specified arguments ARGS.
2448 HOOK should be a symbol, a hook variable. The value of HOOK
2449 may be nil, a function, or a list of functions. Call each
2450 function in order with arguments ARGS, stopping at the first
2451 one that returns non-nil, and return that value. Otherwise (if
2452 all functions return nil, or if there are no functions to call),
2455 Do not use `make-local-variable' to make a hook variable buffer-local.
2456 Instead, use `add-hook' and specify t for the LOCAL argument.
2457 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2458 (ptrdiff_t nargs
, Lisp_Object
*args
)
2460 return run_hook_with_args (nargs
, args
, Ffuncall
);
2464 funcall_not (ptrdiff_t nargs
, Lisp_Object
*args
)
2466 return NILP (Ffuncall (nargs
, args
)) ? Qt
: Qnil
;
2469 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2470 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2471 doc
: /* Run HOOK with the specified arguments ARGS.
2472 HOOK should be a symbol, a hook variable. The value of HOOK
2473 may be nil, a function, or a list of functions. Call each
2474 function in order with arguments ARGS, stopping at the first
2475 one that returns nil, and return nil. Otherwise (if all functions
2476 return non-nil, or if there are no functions to call), return non-nil
2477 \(do not rely on the precise return value in this case).
2479 Do not use `make-local-variable' to make a hook variable buffer-local.
2480 Instead, use `add-hook' and specify t for the LOCAL argument.
2481 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2482 (ptrdiff_t nargs
, Lisp_Object
*args
)
2484 return NILP (run_hook_with_args (nargs
, args
, funcall_not
)) ? Qt
: Qnil
;
2488 run_hook_wrapped_funcall (ptrdiff_t nargs
, Lisp_Object
*args
)
2490 Lisp_Object tmp
= args
[0], ret
;
2493 ret
= Ffuncall (nargs
, args
);
2499 DEFUN ("run-hook-wrapped", Frun_hook_wrapped
, Srun_hook_wrapped
, 2, MANY
, 0,
2500 doc
: /* Run HOOK, passing each function through WRAP-FUNCTION.
2501 I.e. instead of calling each function FUN directly with arguments ARGS,
2502 it calls WRAP-FUNCTION with arguments FUN and ARGS.
2503 As soon as a call to WRAP-FUNCTION returns non-nil, `run-hook-wrapped'
2504 aborts and returns that value.
2505 usage: (run-hook-wrapped HOOK WRAP-FUNCTION &rest ARGS) */)
2506 (ptrdiff_t nargs
, Lisp_Object
*args
)
2508 return run_hook_with_args (nargs
, args
, run_hook_wrapped_funcall
);
2511 /* ARGS[0] should be a hook symbol.
2512 Call each of the functions in the hook value, passing each of them
2513 as arguments all the rest of ARGS (all NARGS - 1 elements).
2514 FUNCALL specifies how to call each function on the hook. */
2517 run_hook_with_args (ptrdiff_t nargs
, Lisp_Object
*args
,
2518 Lisp_Object (*funcall
) (ptrdiff_t nargs
, Lisp_Object
*args
))
2520 Lisp_Object sym
, val
, ret
= Qnil
;
2522 /* If we are dying or still initializing,
2523 don't do anything--it would probably crash if we tried. */
2524 if (NILP (Vrun_hooks
))
2528 val
= find_symbol_value (sym
);
2530 if (EQ (val
, Qunbound
) || NILP (val
))
2532 else if (!CONSP (val
) || FUNCTIONP (val
))
2535 return funcall (nargs
, args
);
2539 Lisp_Object global_vals
= Qnil
;
2542 CONSP (val
) && NILP (ret
);
2545 if (EQ (XCAR (val
), Qt
))
2547 /* t indicates this hook has a local binding;
2548 it means to run the global binding too. */
2549 global_vals
= Fdefault_value (sym
);
2550 if (NILP (global_vals
)) continue;
2552 if (!CONSP (global_vals
) || EQ (XCAR (global_vals
), Qlambda
))
2554 args
[0] = global_vals
;
2555 ret
= funcall (nargs
, args
);
2560 CONSP (global_vals
) && NILP (ret
);
2561 global_vals
= XCDR (global_vals
))
2563 args
[0] = XCAR (global_vals
);
2564 /* In a global value, t should not occur. If it does, we
2565 must ignore it to avoid an endless loop. */
2566 if (!EQ (args
[0], Qt
))
2567 ret
= funcall (nargs
, args
);
2573 args
[0] = XCAR (val
);
2574 ret
= funcall (nargs
, args
);
2582 /* Run the hook HOOK, giving each function no args. */
2585 run_hook (Lisp_Object hook
)
2587 Frun_hook_with_args (1, &hook
);
2590 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2593 run_hook_with_args_2 (Lisp_Object hook
, Lisp_Object arg1
, Lisp_Object arg2
)
2595 CALLN (Frun_hook_with_args
, hook
, arg1
, arg2
);
2598 /* Apply fn to arg. */
2600 apply1 (Lisp_Object fn
, Lisp_Object arg
)
2602 return NILP (arg
) ? Ffuncall (1, &fn
) : CALLN (Fapply
, fn
, arg
);
2605 /* Call function fn on no arguments. */
2607 call0 (Lisp_Object fn
)
2609 return Ffuncall (1, &fn
);
2612 /* Call function fn with 1 argument arg1. */
2615 call1 (Lisp_Object fn
, Lisp_Object arg1
)
2617 return CALLN (Ffuncall
, fn
, arg1
);
2620 /* Call function fn with 2 arguments arg1, arg2. */
2623 call2 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
)
2625 return CALLN (Ffuncall
, fn
, arg1
, arg2
);
2628 /* Call function fn with 3 arguments arg1, arg2, arg3. */
2631 call3 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2633 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
);
2636 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
2639 call4 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2642 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
);
2645 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
2648 call5 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2649 Lisp_Object arg4
, Lisp_Object arg5
)
2651 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
);
2654 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
2657 call6 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2658 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
)
2660 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
);
2663 /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
2666 call7 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2667 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
)
2669 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
);
2672 /* Call function fn with 8 arguments arg1, arg2, arg3, arg4, arg5,
2673 arg6, arg7, arg8. */
2676 call8 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2677 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
,
2680 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
, arg8
);
2683 DEFUN ("functionp", Ffunctionp
, Sfunctionp
, 1, 1, 0,
2684 doc
: /* Non-nil if OBJECT is a function. */)
2685 (Lisp_Object object
)
2687 if (FUNCTIONP (object
))
2693 FUNCTIONP (Lisp_Object object
)
2695 if (SYMBOLP (object
) && !NILP (Ffboundp (object
)))
2697 object
= Findirect_function (object
, Qt
);
2699 if (CONSP (object
) && EQ (XCAR (object
), Qautoload
))
2701 /* Autoloaded symbols are functions, except if they load
2702 macros or keymaps. */
2703 for (int i
= 0; i
< 4 && CONSP (object
); i
++)
2704 object
= XCDR (object
);
2706 return ! (CONSP (object
) && !NILP (XCAR (object
)));
2711 return XSUBR (object
)->max_args
!= UNEVALLED
;
2712 else if (COMPILEDP (object
) || MODULE_FUNCTIONP (object
))
2714 else if (CONSP (object
))
2716 Lisp_Object car
= XCAR (object
);
2717 return EQ (car
, Qlambda
) || EQ (car
, Qclosure
);
2723 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2724 doc
: /* Call first argument as a function, passing remaining arguments to it.
2725 Return the value that function returns.
2726 Thus, (funcall \\='cons \\='x \\='y) returns (x . y).
2727 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2728 (ptrdiff_t nargs
, Lisp_Object
*args
)
2730 Lisp_Object fun
, original_fun
;
2732 ptrdiff_t numargs
= nargs
- 1;
2738 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2740 if (max_lisp_eval_depth
< 100)
2741 max_lisp_eval_depth
= 100;
2742 if (lisp_eval_depth
> max_lisp_eval_depth
)
2743 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2746 count
= record_in_backtrace (args
[0], &args
[1], nargs
- 1);
2750 if (debug_on_next_call
)
2751 do_debug_on_call (Qlambda
, count
);
2755 original_fun
= args
[0];
2759 /* Optimize for no indirection. */
2761 if (SYMBOLP (fun
) && !NILP (fun
)
2762 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2763 fun
= indirect_function (fun
);
2766 val
= funcall_subr (XSUBR (fun
), numargs
, args
+ 1);
2767 else if (COMPILEDP (fun
) || MODULE_FUNCTIONP (fun
))
2768 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2772 xsignal1 (Qvoid_function
, original_fun
);
2774 xsignal1 (Qinvalid_function
, original_fun
);
2775 funcar
= XCAR (fun
);
2776 if (!SYMBOLP (funcar
))
2777 xsignal1 (Qinvalid_function
, original_fun
);
2778 if (EQ (funcar
, Qlambda
)
2779 || EQ (funcar
, Qclosure
))
2780 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2781 else if (EQ (funcar
, Qautoload
))
2783 Fautoload_do_load (fun
, original_fun
, Qnil
);
2788 xsignal1 (Qinvalid_function
, original_fun
);
2792 if (backtrace_debug_on_exit (specpdl
+ count
))
2793 val
= call_debugger (list2 (Qexit
, val
));
2799 /* Apply a C subroutine SUBR to the NUMARGS evaluated arguments in ARG_VECTOR
2800 and return the result of evaluation. */
2803 funcall_subr (struct Lisp_Subr
*subr
, ptrdiff_t numargs
, Lisp_Object
*args
)
2805 if (numargs
< subr
->min_args
2806 || (subr
->max_args
>= 0 && subr
->max_args
< numargs
))
2809 XSETSUBR (fun
, subr
);
2810 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (numargs
));
2813 else if (subr
->max_args
== UNEVALLED
)
2816 XSETSUBR (fun
, subr
);
2817 xsignal1 (Qinvalid_function
, fun
);
2820 else if (subr
->max_args
== MANY
)
2821 return (subr
->function
.aMANY
) (numargs
, args
);
2824 Lisp_Object internal_argbuf
[8];
2825 Lisp_Object
*internal_args
;
2826 if (subr
->max_args
> numargs
)
2828 eassert (subr
->max_args
<= ARRAYELTS (internal_argbuf
));
2829 internal_args
= internal_argbuf
;
2830 memcpy (internal_args
, args
, numargs
* word_size
);
2831 memclear (internal_args
+ numargs
,
2832 (subr
->max_args
- numargs
) * word_size
);
2835 internal_args
= args
;
2836 switch (subr
->max_args
)
2839 return (subr
->function
.a0 ());
2841 return (subr
->function
.a1 (internal_args
[0]));
2843 return (subr
->function
.a2
2844 (internal_args
[0], internal_args
[1]));
2846 return (subr
->function
.a3
2847 (internal_args
[0], internal_args
[1], internal_args
[2]));
2849 return (subr
->function
.a4
2850 (internal_args
[0], internal_args
[1], internal_args
[2],
2853 return (subr
->function
.a5
2854 (internal_args
[0], internal_args
[1], internal_args
[2],
2855 internal_args
[3], internal_args
[4]));
2857 return (subr
->function
.a6
2858 (internal_args
[0], internal_args
[1], internal_args
[2],
2859 internal_args
[3], internal_args
[4], internal_args
[5]));
2861 return (subr
->function
.a7
2862 (internal_args
[0], internal_args
[1], internal_args
[2],
2863 internal_args
[3], internal_args
[4], internal_args
[5],
2866 return (subr
->function
.a8
2867 (internal_args
[0], internal_args
[1], internal_args
[2],
2868 internal_args
[3], internal_args
[4], internal_args
[5],
2869 internal_args
[6], internal_args
[7]));
2873 /* If a subr takes more than 8 arguments without using MANY
2874 or UNEVALLED, we need to extend this function to support it.
2875 Until this is done, there is no way to call the function. */
2882 apply_lambda (Lisp_Object fun
, Lisp_Object args
, ptrdiff_t count
)
2884 Lisp_Object args_left
;
2887 Lisp_Object
*arg_vector
;
2891 numargs
= XFASTINT (Flength (args
));
2892 SAFE_ALLOCA_LISP (arg_vector
, numargs
);
2895 for (i
= 0; i
< numargs
; )
2897 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2898 tem
= eval_sub (tem
);
2899 arg_vector
[i
++] = tem
;
2902 set_backtrace_args (specpdl
+ count
, arg_vector
, i
);
2903 tem
= funcall_lambda (fun
, numargs
, arg_vector
);
2907 /* Do the debug-on-exit now, while arg_vector still exists. */
2908 if (backtrace_debug_on_exit (specpdl
+ count
))
2909 tem
= call_debugger (list2 (Qexit
, tem
));
2915 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2916 and return the result of evaluation.
2917 FUN must be either a lambda-expression, a compiled-code object,
2918 or a module function. */
2921 funcall_lambda (Lisp_Object fun
, ptrdiff_t nargs
,
2922 register Lisp_Object
*arg_vector
)
2924 Lisp_Object val
, syms_left
, next
, lexenv
;
2925 ptrdiff_t count
= SPECPDL_INDEX ();
2927 bool optional
, rest
;
2931 if (EQ (XCAR (fun
), Qclosure
))
2933 Lisp_Object cdr
= XCDR (fun
); /* Drop `closure'. */
2935 xsignal1 (Qinvalid_function
, fun
);
2937 lexenv
= XCAR (fun
);
2941 syms_left
= XCDR (fun
);
2942 if (CONSP (syms_left
))
2943 syms_left
= XCAR (syms_left
);
2945 xsignal1 (Qinvalid_function
, fun
);
2947 else if (COMPILEDP (fun
))
2949 ptrdiff_t size
= PVSIZE (fun
);
2950 if (size
<= COMPILED_STACK_DEPTH
)
2951 xsignal1 (Qinvalid_function
, fun
);
2952 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
2953 if (INTEGERP (syms_left
))
2954 /* A byte-code object with an integer args template means we
2955 shouldn't bind any arguments, instead just call the byte-code
2956 interpreter directly; it will push arguments as necessary.
2958 Byte-code objects with a nil args template (the default)
2959 have dynamically-bound arguments, and use the
2960 argument-binding code below instead (as do all interpreted
2961 functions, even lexically bound ones). */
2963 /* If we have not actually read the bytecode string
2964 and constants vector yet, fetch them from the file. */
2965 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
2966 Ffetch_bytecode (fun
);
2967 return exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
2968 AREF (fun
, COMPILED_CONSTANTS
),
2969 AREF (fun
, COMPILED_STACK_DEPTH
),
2976 else if (MODULE_FUNCTIONP (fun
))
2977 return funcall_module (fun
, nargs
, arg_vector
);
2982 i
= optional
= rest
= 0;
2983 bool previous_optional_or_rest
= false;
2984 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
2988 next
= XCAR (syms_left
);
2989 if (!SYMBOLP (next
))
2990 xsignal1 (Qinvalid_function
, fun
);
2992 if (EQ (next
, Qand_rest
))
2994 if (rest
|| previous_optional_or_rest
)
2995 xsignal1 (Qinvalid_function
, fun
);
2997 previous_optional_or_rest
= true;
2999 else if (EQ (next
, Qand_optional
))
3001 if (optional
|| rest
|| previous_optional_or_rest
)
3002 xsignal1 (Qinvalid_function
, fun
);
3004 previous_optional_or_rest
= true;
3011 arg
= Flist (nargs
- i
, &arg_vector
[i
]);
3015 arg
= arg_vector
[i
++];
3017 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3021 /* Bind the argument. */
3022 if (!NILP (lexenv
) && SYMBOLP (next
))
3023 /* Lexically bind NEXT by adding it to the lexenv alist. */
3024 lexenv
= Fcons (Fcons (next
, arg
), lexenv
);
3026 /* Dynamically bind NEXT. */
3027 specbind (next
, arg
);
3028 previous_optional_or_rest
= false;
3032 if (!NILP (syms_left
) || previous_optional_or_rest
)
3033 xsignal1 (Qinvalid_function
, fun
);
3035 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3037 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
3038 /* Instantiate a new lexical environment. */
3039 specbind (Qinternal_interpreter_environment
, lexenv
);
3042 val
= Fprogn (XCDR (XCDR (fun
)));
3045 /* If we have not actually read the bytecode string
3046 and constants vector yet, fetch them from the file. */
3047 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3048 Ffetch_bytecode (fun
);
3049 val
= exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
3050 AREF (fun
, COMPILED_CONSTANTS
),
3051 AREF (fun
, COMPILED_STACK_DEPTH
),
3055 return unbind_to (count
, val
);
3058 DEFUN ("func-arity", Ffunc_arity
, Sfunc_arity
, 1, 1, 0,
3059 doc
: /* Return minimum and maximum number of args allowed for FUNCTION.
3060 FUNCTION must be a function of some kind.
3061 The returned value is a cons cell (MIN . MAX). MIN is the minimum number
3062 of args. MAX is the maximum number, or the symbol `many', for a
3063 function with `&rest' args, or `unevalled' for a special form. */)
3064 (Lisp_Object function
)
3066 Lisp_Object original
;
3070 original
= function
;
3074 /* Optimize for no indirection. */
3075 function
= original
;
3076 if (SYMBOLP (function
) && !NILP (function
))
3078 function
= XSYMBOL (function
)->function
;
3079 if (SYMBOLP (function
))
3080 function
= indirect_function (function
);
3083 if (CONSP (function
) && EQ (XCAR (function
), Qmacro
))
3084 function
= XCDR (function
);
3086 if (SUBRP (function
))
3087 result
= Fsubr_arity (function
);
3088 else if (COMPILEDP (function
))
3089 result
= lambda_arity (function
);
3091 else if (MODULE_FUNCTIONP (function
))
3092 result
= module_function_arity (XMODULE_FUNCTION (function
));
3096 if (NILP (function
))
3097 xsignal1 (Qvoid_function
, original
);
3098 if (!CONSP (function
))
3099 xsignal1 (Qinvalid_function
, original
);
3100 funcar
= XCAR (function
);
3101 if (!SYMBOLP (funcar
))
3102 xsignal1 (Qinvalid_function
, original
);
3103 if (EQ (funcar
, Qlambda
)
3104 || EQ (funcar
, Qclosure
))
3105 result
= lambda_arity (function
);
3106 else if (EQ (funcar
, Qautoload
))
3108 Fautoload_do_load (function
, original
, Qnil
);
3112 xsignal1 (Qinvalid_function
, original
);
3117 /* FUN must be either a lambda-expression or a compiled-code object. */
3119 lambda_arity (Lisp_Object fun
)
3121 Lisp_Object syms_left
;
3125 if (EQ (XCAR (fun
), Qclosure
))
3127 fun
= XCDR (fun
); /* Drop `closure'. */
3130 syms_left
= XCDR (fun
);
3131 if (CONSP (syms_left
))
3132 syms_left
= XCAR (syms_left
);
3134 xsignal1 (Qinvalid_function
, fun
);
3136 else if (COMPILEDP (fun
))
3138 ptrdiff_t size
= PVSIZE (fun
);
3139 if (size
<= COMPILED_STACK_DEPTH
)
3140 xsignal1 (Qinvalid_function
, fun
);
3141 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3142 if (INTEGERP (syms_left
))
3143 return get_byte_code_arity (syms_left
);
3148 EMACS_INT minargs
= 0, maxargs
= 0;
3149 bool optional
= false;
3150 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3152 Lisp_Object next
= XCAR (syms_left
);
3153 if (!SYMBOLP (next
))
3154 xsignal1 (Qinvalid_function
, fun
);
3156 if (EQ (next
, Qand_rest
))
3157 return Fcons (make_number (minargs
), Qmany
);
3158 else if (EQ (next
, Qand_optional
))
3168 if (!NILP (syms_left
))
3169 xsignal1 (Qinvalid_function
, fun
);
3171 return Fcons (make_number (minargs
), make_number (maxargs
));
3174 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3176 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3177 (Lisp_Object object
)
3181 if (COMPILEDP (object
))
3183 ptrdiff_t size
= PVSIZE (object
);
3184 if (size
<= COMPILED_STACK_DEPTH
)
3185 xsignal1 (Qinvalid_function
, object
);
3186 if (CONSP (AREF (object
, COMPILED_BYTECODE
)))
3188 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3191 tem
= AREF (object
, COMPILED_BYTECODE
);
3192 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3193 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3195 error ("Invalid byte code");
3197 ASET (object
, COMPILED_BYTECODE
, XCAR (tem
));
3198 ASET (object
, COMPILED_CONSTANTS
, XCDR (tem
));
3204 /* Return true if SYMBOL currently has a let-binding
3205 which was made in the buffer that is now current. */
3208 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
3210 union specbinding
*p
;
3211 Lisp_Object buf
= Fcurrent_buffer ();
3213 for (p
= specpdl_ptr
; p
> specpdl
; )
3214 if ((--p
)->kind
> SPECPDL_LET
)
3216 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (specpdl_symbol (p
));
3217 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
3218 if (symbol
== let_bound_symbol
3219 && EQ (specpdl_where (p
), buf
))
3227 do_specbind (struct Lisp_Symbol
*sym
, union specbinding
*bind
,
3228 Lisp_Object value
, enum Set_Internal_Bind bindflag
)
3230 switch (sym
->redirect
)
3232 case SYMBOL_PLAINVAL
:
3233 if (!sym
->trapped_write
)
3234 SET_SYMBOL_VAL (sym
, value
);
3236 set_internal (specpdl_symbol (bind
), value
, Qnil
, bindflag
);
3239 case SYMBOL_FORWARDED
:
3240 if (BUFFER_OBJFWDP (SYMBOL_FWD (sym
))
3241 && specpdl_kind (bind
) == SPECPDL_LET_DEFAULT
)
3243 set_default_internal (specpdl_symbol (bind
), value
, bindflag
);
3247 case SYMBOL_LOCALIZED
:
3248 set_internal (specpdl_symbol (bind
), value
, Qnil
, bindflag
);
3256 /* `specpdl_ptr' describes which variable is
3257 let-bound, so it can be properly undone when we unbind_to.
3258 It can be either a plain SPECPDL_LET or a SPECPDL_LET_LOCAL/DEFAULT.
3259 - SYMBOL is the variable being bound. Note that it should not be
3260 aliased (i.e. when let-binding V1 that's aliased to V2, we want
3262 - WHERE tells us in which buffer the binding took place.
3263 This is used for SPECPDL_LET_LOCAL bindings (i.e. bindings to a
3264 buffer-local variable) as well as for SPECPDL_LET_DEFAULT bindings,
3265 i.e. bindings to the default value of a variable which can be
3269 specbind (Lisp_Object symbol
, Lisp_Object value
)
3271 struct Lisp_Symbol
*sym
;
3273 CHECK_SYMBOL (symbol
);
3274 sym
= XSYMBOL (symbol
);
3277 switch (sym
->redirect
)
3279 case SYMBOL_VARALIAS
:
3280 sym
= indirect_variable (sym
); XSETSYMBOL (symbol
, sym
); goto start
;
3281 case SYMBOL_PLAINVAL
:
3282 /* The most common case is that of a non-constant symbol with a
3283 trivial value. Make that as fast as we can. */
3284 specpdl_ptr
->let
.kind
= SPECPDL_LET
;
3285 specpdl_ptr
->let
.symbol
= symbol
;
3286 specpdl_ptr
->let
.old_value
= SYMBOL_VAL (sym
);
3287 specpdl_ptr
->let
.saved_value
= Qnil
;
3289 do_specbind (sym
, specpdl_ptr
- 1, value
, SET_INTERNAL_BIND
);
3291 case SYMBOL_LOCALIZED
:
3292 case SYMBOL_FORWARDED
:
3294 Lisp_Object ovalue
= find_symbol_value (symbol
);
3295 specpdl_ptr
->let
.kind
= SPECPDL_LET_LOCAL
;
3296 specpdl_ptr
->let
.symbol
= symbol
;
3297 specpdl_ptr
->let
.old_value
= ovalue
;
3298 specpdl_ptr
->let
.where
= Fcurrent_buffer ();
3299 specpdl_ptr
->let
.saved_value
= Qnil
;
3301 eassert (sym
->redirect
!= SYMBOL_LOCALIZED
3302 || (EQ (SYMBOL_BLV (sym
)->where
, Fcurrent_buffer ())));
3304 if (sym
->redirect
== SYMBOL_LOCALIZED
)
3306 if (!blv_found (SYMBOL_BLV (sym
)))
3307 specpdl_ptr
->let
.kind
= SPECPDL_LET_DEFAULT
;
3309 else if (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)))
3311 /* If SYMBOL is a per-buffer variable which doesn't have a
3312 buffer-local value here, make the `let' change the global
3313 value by changing the value of SYMBOL in all buffers not
3314 having their own value. This is consistent with what
3315 happens with other buffer-local variables. */
3316 if (NILP (Flocal_variable_p (symbol
, Qnil
)))
3318 specpdl_ptr
->let
.kind
= SPECPDL_LET_DEFAULT
;
3320 do_specbind (sym
, specpdl_ptr
- 1, value
, SET_INTERNAL_BIND
);
3325 specpdl_ptr
->let
.kind
= SPECPDL_LET
;
3328 do_specbind (sym
, specpdl_ptr
- 1, value
, SET_INTERNAL_BIND
);
3331 default: emacs_abort ();
3335 /* Push unwind-protect entries of various types. */
3338 record_unwind_protect (void (*function
) (Lisp_Object
), Lisp_Object arg
)
3340 specpdl_ptr
->unwind
.kind
= SPECPDL_UNWIND
;
3341 specpdl_ptr
->unwind
.func
= function
;
3342 specpdl_ptr
->unwind
.arg
= arg
;
3347 record_unwind_protect_ptr (void (*function
) (void *), void *arg
)
3349 specpdl_ptr
->unwind_ptr
.kind
= SPECPDL_UNWIND_PTR
;
3350 specpdl_ptr
->unwind_ptr
.func
= function
;
3351 specpdl_ptr
->unwind_ptr
.arg
= arg
;
3356 record_unwind_protect_int (void (*function
) (int), int arg
)
3358 specpdl_ptr
->unwind_int
.kind
= SPECPDL_UNWIND_INT
;
3359 specpdl_ptr
->unwind_int
.func
= function
;
3360 specpdl_ptr
->unwind_int
.arg
= arg
;
3365 record_unwind_protect_void (void (*function
) (void))
3367 specpdl_ptr
->unwind_void
.kind
= SPECPDL_UNWIND_VOID
;
3368 specpdl_ptr
->unwind_void
.func
= function
;
3373 rebind_for_thread_switch (void)
3375 union specbinding
*bind
;
3377 for (bind
= specpdl
; bind
!= specpdl_ptr
; ++bind
)
3379 if (bind
->kind
>= SPECPDL_LET
)
3381 Lisp_Object value
= specpdl_saved_value (bind
);
3382 Lisp_Object sym
= specpdl_symbol (bind
);
3383 bind
->let
.saved_value
= Qnil
;
3384 do_specbind (XSYMBOL (sym
), bind
, value
,
3385 SET_INTERNAL_THREAD_SWITCH
);
3391 do_one_unbind (union specbinding
*this_binding
, bool unwinding
,
3392 enum Set_Internal_Bind bindflag
)
3394 eassert (unwinding
|| this_binding
->kind
>= SPECPDL_LET
);
3395 switch (this_binding
->kind
)
3397 case SPECPDL_UNWIND
:
3398 this_binding
->unwind
.func (this_binding
->unwind
.arg
);
3400 case SPECPDL_UNWIND_PTR
:
3401 this_binding
->unwind_ptr
.func (this_binding
->unwind_ptr
.arg
);
3403 case SPECPDL_UNWIND_INT
:
3404 this_binding
->unwind_int
.func (this_binding
->unwind_int
.arg
);
3406 case SPECPDL_UNWIND_VOID
:
3407 this_binding
->unwind_void
.func ();
3409 case SPECPDL_BACKTRACE
:
3412 { /* If variable has a trivial value (no forwarding), and isn't
3413 trapped, we can just set it. */
3414 Lisp_Object sym
= specpdl_symbol (this_binding
);
3415 if (SYMBOLP (sym
) && XSYMBOL (sym
)->redirect
== SYMBOL_PLAINVAL
)
3417 if (XSYMBOL (sym
)->trapped_write
== SYMBOL_UNTRAPPED_WRITE
)
3418 SET_SYMBOL_VAL (XSYMBOL (sym
), specpdl_old_value (this_binding
));
3420 set_internal (sym
, specpdl_old_value (this_binding
),
3425 /* Come here only if make_local_foo was used for the first time
3426 on this var within this let. */
3428 case SPECPDL_LET_DEFAULT
:
3429 set_default_internal (specpdl_symbol (this_binding
),
3430 specpdl_old_value (this_binding
),
3433 case SPECPDL_LET_LOCAL
:
3435 Lisp_Object symbol
= specpdl_symbol (this_binding
);
3436 Lisp_Object where
= specpdl_where (this_binding
);
3437 Lisp_Object old_value
= specpdl_old_value (this_binding
);
3438 eassert (BUFFERP (where
));
3440 /* If this was a local binding, reset the value in the appropriate
3441 buffer, but only if that buffer's binding still exists. */
3442 if (!NILP (Flocal_variable_p (symbol
, where
)))
3443 set_internal (symbol
, old_value
, where
, bindflag
);
3453 /* Push an unwind-protect entry that does nothing, so that
3454 set_unwind_protect_ptr can overwrite it later. */
3457 record_unwind_protect_nothing (void)
3459 record_unwind_protect_void (do_nothing
);
3462 /* Clear the unwind-protect entry COUNT, so that it does nothing.
3463 It need not be at the top of the stack. */
3466 clear_unwind_protect (ptrdiff_t count
)
3468 union specbinding
*p
= specpdl
+ count
;
3469 p
->unwind_void
.kind
= SPECPDL_UNWIND_VOID
;
3470 p
->unwind_void
.func
= do_nothing
;
3473 /* Set the unwind-protect entry COUNT so that it invokes FUNC (ARG).
3474 It need not be at the top of the stack. Discard the entry's
3475 previous value without invoking it. */
3478 set_unwind_protect (ptrdiff_t count
, void (*func
) (Lisp_Object
),
3481 union specbinding
*p
= specpdl
+ count
;
3482 p
->unwind
.kind
= SPECPDL_UNWIND
;
3483 p
->unwind
.func
= func
;
3484 p
->unwind
.arg
= arg
;
3488 set_unwind_protect_ptr (ptrdiff_t count
, void (*func
) (void *), void *arg
)
3490 union specbinding
*p
= specpdl
+ count
;
3491 p
->unwind_ptr
.kind
= SPECPDL_UNWIND_PTR
;
3492 p
->unwind_ptr
.func
= func
;
3493 p
->unwind_ptr
.arg
= arg
;
3496 /* Pop and execute entries from the unwind-protect stack until the
3497 depth COUNT is reached. Return VALUE. */
3500 unbind_to (ptrdiff_t count
, Lisp_Object value
)
3502 Lisp_Object quitf
= Vquit_flag
;
3506 while (specpdl_ptr
!= specpdl
+ count
)
3508 /* Copy the binding, and decrement specpdl_ptr, before we do
3509 the work to unbind it. We decrement first
3510 so that an error in unbinding won't try to unbind
3511 the same entry again, and we copy the binding first
3512 in case more bindings are made during some of the code we run. */
3514 union specbinding this_binding
;
3515 this_binding
= *--specpdl_ptr
;
3517 do_one_unbind (&this_binding
, true, SET_INTERNAL_UNBIND
);
3520 if (NILP (Vquit_flag
) && !NILP (quitf
))
3527 unbind_for_thread_switch (struct thread_state
*thr
)
3529 union specbinding
*bind
;
3531 for (bind
= thr
->m_specpdl_ptr
; bind
> thr
->m_specpdl
;)
3533 if ((--bind
)->kind
>= SPECPDL_LET
)
3535 Lisp_Object sym
= specpdl_symbol (bind
);
3536 bind
->let
.saved_value
= find_symbol_value (sym
);
3537 do_one_unbind (bind
, false, SET_INTERNAL_THREAD_SWITCH
);
3542 DEFUN ("special-variable-p", Fspecial_variable_p
, Sspecial_variable_p
, 1, 1, 0,
3543 doc
: /* Return non-nil if SYMBOL's global binding has been declared special.
3544 A special variable is one that will be bound dynamically, even in a
3545 context where binding is lexical by default. */)
3546 (Lisp_Object symbol
)
3548 CHECK_SYMBOL (symbol
);
3549 return XSYMBOL (symbol
)->declared_special
? Qt
: Qnil
;
3553 static union specbinding
*
3554 get_backtrace_starting_at (Lisp_Object base
)
3556 union specbinding
*pdl
= backtrace_top ();
3559 { /* Skip up to `base'. */
3560 base
= Findirect_function (base
, Qt
);
3561 while (backtrace_p (pdl
)
3562 && !EQ (base
, Findirect_function (backtrace_function (pdl
), Qt
)))
3563 pdl
= backtrace_next (pdl
);
3569 static union specbinding
*
3570 get_backtrace_frame (Lisp_Object nframes
, Lisp_Object base
)
3572 register EMACS_INT i
;
3574 CHECK_NATNUM (nframes
);
3575 union specbinding
*pdl
= get_backtrace_starting_at (base
);
3577 /* Find the frame requested. */
3578 for (i
= XFASTINT (nframes
); i
> 0 && backtrace_p (pdl
); i
--)
3579 pdl
= backtrace_next (pdl
);
3585 backtrace_frame_apply (Lisp_Object function
, union specbinding
*pdl
)
3587 if (!backtrace_p (pdl
))
3590 Lisp_Object flags
= Qnil
;
3591 if (backtrace_debug_on_exit (pdl
))
3592 flags
= Fcons (QCdebug_on_exit
, Fcons (Qt
, Qnil
));
3594 if (backtrace_nargs (pdl
) == UNEVALLED
)
3595 return call4 (function
, Qnil
, backtrace_function (pdl
), *backtrace_args (pdl
), flags
);
3598 Lisp_Object tem
= Flist (backtrace_nargs (pdl
), backtrace_args (pdl
));
3599 return call4 (function
, Qt
, backtrace_function (pdl
), tem
, flags
);
3603 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3604 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3605 The debugger is entered when that frame exits, if the flag is non-nil. */)
3606 (Lisp_Object level
, Lisp_Object flag
)
3608 CHECK_NUMBER (level
);
3609 union specbinding
*pdl
= get_backtrace_frame(level
, Qnil
);
3611 if (backtrace_p (pdl
))
3612 set_backtrace_debug_on_exit (pdl
, !NILP (flag
));
3617 DEFUN ("mapbacktrace", Fmapbacktrace
, Smapbacktrace
, 1, 2, 0,
3618 doc
: /* Call FUNCTION for each frame in backtrace.
3619 If BASE is non-nil, it should be a function and iteration will start
3620 from its nearest activation frame.
3621 FUNCTION is called with 4 arguments: EVALD, FUNC, ARGS, and FLAGS. If
3622 a frame has not evaluated its arguments yet or is a special form,
3623 EVALD is nil and ARGS is a list of forms. If a frame has evaluated
3624 its arguments and called its function already, EVALD is t and ARGS is
3626 FLAGS is a plist of properties of the current frame: currently, the
3627 only supported property is :debug-on-exit. `mapbacktrace' always
3629 (Lisp_Object function
, Lisp_Object base
)
3631 union specbinding
*pdl
= get_backtrace_starting_at (base
);
3633 while (backtrace_p (pdl
))
3635 ptrdiff_t i
= pdl
- specpdl
;
3636 backtrace_frame_apply (function
, pdl
);
3637 /* Beware! PDL is no longer valid here because FUNCTION might
3638 have caused grow_specpdl to reallocate pdlvec. We must use
3639 the saved index, cf. Bug#27258. */
3640 pdl
= backtrace_next (&specpdl
[i
]);
3646 DEFUN ("backtrace-frame--internal", Fbacktrace_frame_internal
,
3647 Sbacktrace_frame_internal
, 3, 3, NULL
,
3648 doc
: /* Call FUNCTION on stack frame NFRAMES away from BASE.
3649 Return the result of FUNCTION, or nil if no matching frame could be found. */)
3650 (Lisp_Object function
, Lisp_Object nframes
, Lisp_Object base
)
3652 return backtrace_frame_apply (function
, get_backtrace_frame (nframes
, base
));
3655 /* For backtrace-eval, we want to temporarily unwind the last few elements of
3656 the specpdl stack, and then rewind them. We store the pre-unwind values
3657 directly in the pre-existing specpdl elements (i.e. we swap the current
3658 value and the old value stored in the specpdl), kind of like the inplace
3659 pointer-reversal trick. As it turns out, the rewind does the same as the
3660 unwind, except it starts from the other end of the specpdl stack, so we use
3661 the same function for both unwind and rewind. */
3663 backtrace_eval_unrewind (int distance
)
3665 union specbinding
*tmp
= specpdl_ptr
;
3668 { /* It's a rewind rather than unwind. */
3669 tmp
+= distance
- 1;
3671 distance
= -distance
;
3674 for (; distance
> 0; distance
--)
3679 /* FIXME: Ideally we'd like to "temporarily unwind" (some of) those
3680 unwind_protect, but the problem is that we don't know how to
3681 rewind them afterwards. */
3682 case SPECPDL_UNWIND
:
3684 Lisp_Object oldarg
= tmp
->unwind
.arg
;
3685 if (tmp
->unwind
.func
== set_buffer_if_live
)
3686 tmp
->unwind
.arg
= Fcurrent_buffer ();
3687 else if (tmp
->unwind
.func
== save_excursion_restore
)
3688 tmp
->unwind
.arg
= save_excursion_save ();
3691 tmp
->unwind
.func (oldarg
);
3695 case SPECPDL_UNWIND_PTR
:
3696 case SPECPDL_UNWIND_INT
:
3697 case SPECPDL_UNWIND_VOID
:
3698 case SPECPDL_BACKTRACE
:
3701 { /* If variable has a trivial value (no forwarding), we can
3702 just set it. No need to check for constant symbols here,
3703 since that was already done by specbind. */
3704 Lisp_Object sym
= specpdl_symbol (tmp
);
3705 if (SYMBOLP (sym
) && XSYMBOL (sym
)->redirect
== SYMBOL_PLAINVAL
)
3707 Lisp_Object old_value
= specpdl_old_value (tmp
);
3708 set_specpdl_old_value (tmp
, SYMBOL_VAL (XSYMBOL (sym
)));
3709 SET_SYMBOL_VAL (XSYMBOL (sym
), old_value
);
3713 /* Come here only if make_local_foo was used for the first
3714 time on this var within this let. */
3716 case SPECPDL_LET_DEFAULT
:
3718 Lisp_Object sym
= specpdl_symbol (tmp
);
3719 Lisp_Object old_value
= specpdl_old_value (tmp
);
3720 set_specpdl_old_value (tmp
, Fdefault_value (sym
));
3721 Fset_default (sym
, old_value
);
3724 case SPECPDL_LET_LOCAL
:
3726 Lisp_Object symbol
= specpdl_symbol (tmp
);
3727 Lisp_Object where
= specpdl_where (tmp
);
3728 Lisp_Object old_value
= specpdl_old_value (tmp
);
3729 eassert (BUFFERP (where
));
3731 /* If this was a local binding, reset the value in the appropriate
3732 buffer, but only if that buffer's binding still exists. */
3733 if (!NILP (Flocal_variable_p (symbol
, where
)))
3735 set_specpdl_old_value
3736 (tmp
, Fbuffer_local_value (symbol
, where
));
3737 set_internal (symbol
, old_value
, where
, SET_INTERNAL_UNBIND
);
3745 DEFUN ("backtrace-eval", Fbacktrace_eval
, Sbacktrace_eval
, 2, 3, NULL
,
3746 doc
: /* Evaluate EXP in the context of some activation frame.
3747 NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */)
3748 (Lisp_Object exp
, Lisp_Object nframes
, Lisp_Object base
)
3750 union specbinding
*pdl
= get_backtrace_frame (nframes
, base
);
3751 ptrdiff_t count
= SPECPDL_INDEX ();
3752 ptrdiff_t distance
= specpdl_ptr
- pdl
;
3753 eassert (distance
>= 0);
3755 if (!backtrace_p (pdl
))
3756 error ("Activation frame not found!");
3758 backtrace_eval_unrewind (distance
);
3759 record_unwind_protect_int (backtrace_eval_unrewind
, -distance
);
3761 /* Use eval_sub rather than Feval since the main motivation behind
3762 backtrace-eval is to be able to get/set the value of lexical variables
3763 from the debugger. */
3764 return unbind_to (count
, eval_sub (exp
));
3767 DEFUN ("backtrace--locals", Fbacktrace__locals
, Sbacktrace__locals
, 1, 2, NULL
,
3768 doc
: /* Return names and values of local variables of a stack frame.
3769 NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */)
3770 (Lisp_Object nframes
, Lisp_Object base
)
3772 union specbinding
*frame
= get_backtrace_frame (nframes
, base
);
3773 union specbinding
*prevframe
3774 = get_backtrace_frame (make_number (XFASTINT (nframes
) - 1), base
);
3775 ptrdiff_t distance
= specpdl_ptr
- frame
;
3776 Lisp_Object result
= Qnil
;
3777 eassert (distance
>= 0);
3779 if (!backtrace_p (prevframe
))
3780 error ("Activation frame not found!");
3781 if (!backtrace_p (frame
))
3782 error ("Activation frame not found!");
3784 /* The specpdl entries normally contain the symbol being bound along with its
3785 `old_value', so it can be restored. The new value to which it is bound is
3786 available in one of two places: either in the current value of the
3787 variable (if it hasn't been rebound yet) or in the `old_value' slot of the
3788 next specpdl entry for it.
3789 `backtrace_eval_unrewind' happens to swap the role of `old_value'
3790 and "new value", so we abuse it here, to fetch the new value.
3791 It's ugly (we'd rather not modify global data) and a bit inefficient,
3792 but it does the job for now. */
3793 backtrace_eval_unrewind (distance
);
3797 union specbinding
*tmp
= prevframe
;
3798 for (; tmp
> frame
; tmp
--)
3803 case SPECPDL_LET_DEFAULT
:
3804 case SPECPDL_LET_LOCAL
:
3806 Lisp_Object sym
= specpdl_symbol (tmp
);
3807 Lisp_Object val
= specpdl_old_value (tmp
);
3808 if (EQ (sym
, Qinternal_interpreter_environment
))
3810 Lisp_Object env
= val
;
3811 for (; CONSP (env
); env
= XCDR (env
))
3813 Lisp_Object binding
= XCAR (env
);
3814 if (CONSP (binding
))
3815 result
= Fcons (Fcons (XCAR (binding
),
3821 result
= Fcons (Fcons (sym
, val
), result
);
3825 case SPECPDL_UNWIND
:
3826 case SPECPDL_UNWIND_PTR
:
3827 case SPECPDL_UNWIND_INT
:
3828 case SPECPDL_UNWIND_VOID
:
3829 case SPECPDL_BACKTRACE
:
3838 /* Restore values from specpdl to original place. */
3839 backtrace_eval_unrewind (-distance
);
3846 mark_specpdl (union specbinding
*first
, union specbinding
*ptr
)
3848 union specbinding
*pdl
;
3849 for (pdl
= first
; pdl
!= ptr
; pdl
++)
3853 case SPECPDL_UNWIND
:
3854 mark_object (specpdl_arg (pdl
));
3857 case SPECPDL_BACKTRACE
:
3859 ptrdiff_t nargs
= backtrace_nargs (pdl
);
3860 mark_object (backtrace_function (pdl
));
3861 if (nargs
== UNEVALLED
)
3864 mark_object (backtrace_args (pdl
)[nargs
]);
3868 case SPECPDL_LET_DEFAULT
:
3869 case SPECPDL_LET_LOCAL
:
3870 mark_object (specpdl_where (pdl
));
3873 mark_object (specpdl_symbol (pdl
));
3874 mark_object (specpdl_old_value (pdl
));
3875 mark_object (specpdl_saved_value (pdl
));
3878 case SPECPDL_UNWIND_PTR
:
3879 case SPECPDL_UNWIND_INT
:
3880 case SPECPDL_UNWIND_VOID
:
3890 get_backtrace (Lisp_Object array
)
3892 union specbinding
*pdl
= backtrace_next (backtrace_top ());
3893 ptrdiff_t i
= 0, asize
= ASIZE (array
);
3895 /* Copy the backtrace contents into working memory. */
3896 for (; i
< asize
; i
++)
3898 if (backtrace_p (pdl
))
3900 ASET (array
, i
, backtrace_function (pdl
));
3901 pdl
= backtrace_next (pdl
);
3904 ASET (array
, i
, Qnil
);
3908 Lisp_Object
backtrace_top_function (void)
3910 union specbinding
*pdl
= backtrace_top ();
3911 return (backtrace_p (pdl
) ? backtrace_function (pdl
) : Qnil
);
3917 DEFVAR_INT ("max-specpdl-size", max_specpdl_size
,
3918 doc
: /* Limit on number of Lisp variable bindings and `unwind-protect's.
3919 If Lisp code tries to increase the total number past this amount,
3920 an error is signaled.
3921 You can safely use a value considerably larger than the default value,
3922 if that proves inconveniently small. However, if you increase it too far,
3923 Emacs could run out of memory trying to make the stack bigger.
3924 Note that this limit may be silently increased by the debugger
3925 if `debug-on-error' or `debug-on-quit' is set. */);
3927 DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth
,
3928 doc
: /* Limit on depth in `eval', `apply' and `funcall' before error.
3930 This limit serves to catch infinite recursions for you before they cause
3931 actual stack overflow in C, which would be fatal for Emacs.
3932 You can safely make it considerably larger than its default value,
3933 if that proves inconveniently small. However, if you increase it too far,
3934 Emacs could overflow the real C stack, and crash. */);
3936 DEFVAR_LISP ("quit-flag", Vquit_flag
,
3937 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3938 If the value is t, that means do an ordinary quit.
3939 If the value equals `throw-on-input', that means quit by throwing
3940 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3941 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3942 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3945 DEFVAR_LISP ("inhibit-quit", Vinhibit_quit
,
3946 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3947 Note that `quit-flag' will still be set by typing C-g,
3948 so a quit will be signaled as soon as `inhibit-quit' is nil.
3949 To prevent this happening, set `quit-flag' to nil
3950 before making `inhibit-quit' nil. */);
3951 Vinhibit_quit
= Qnil
;
3953 DEFSYM (Qsetq
, "setq");
3954 DEFSYM (Qinhibit_quit
, "inhibit-quit");
3955 DEFSYM (Qautoload
, "autoload");
3956 DEFSYM (Qinhibit_debugger
, "inhibit-debugger");
3957 DEFSYM (Qmacro
, "macro");
3959 /* Note that the process handling also uses Qexit, but we don't want
3960 to staticpro it twice, so we just do it here. */
3961 DEFSYM (Qexit
, "exit");
3963 DEFSYM (Qinteractive
, "interactive");
3964 DEFSYM (Qcommandp
, "commandp");
3965 DEFSYM (Qand_rest
, "&rest");
3966 DEFSYM (Qand_optional
, "&optional");
3967 DEFSYM (Qclosure
, "closure");
3968 DEFSYM (QCdocumentation
, ":documentation");
3969 DEFSYM (Qdebug
, "debug");
3971 DEFVAR_LISP ("inhibit-debugger", Vinhibit_debugger
,
3972 doc
: /* Non-nil means never enter the debugger.
3973 Normally set while the debugger is already active, to avoid recursive
3975 Vinhibit_debugger
= Qnil
;
3977 DEFVAR_LISP ("debug-on-error", Vdebug_on_error
,
3978 doc
: /* Non-nil means enter debugger if an error is signaled.
3979 Does not apply to errors handled by `condition-case' or those
3980 matched by `debug-ignored-errors'.
3981 If the value is a list, an error only means to enter the debugger
3982 if one of its condition symbols appears in the list.
3983 When you evaluate an expression interactively, this variable
3984 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3985 The command `toggle-debug-on-error' toggles this.
3986 See also the variable `debug-on-quit' and `inhibit-debugger'. */);
3987 Vdebug_on_error
= Qnil
;
3989 DEFVAR_LISP ("debug-ignored-errors", Vdebug_ignored_errors
,
3990 doc
: /* List of errors for which the debugger should not be called.
3991 Each element may be a condition-name or a regexp that matches error messages.
3992 If any element applies to a given error, that error skips the debugger
3993 and just returns to top level.
3994 This overrides the variable `debug-on-error'.
3995 It does not apply to errors handled by `condition-case'. */);
3996 Vdebug_ignored_errors
= Qnil
;
3998 DEFVAR_BOOL ("debug-on-quit", debug_on_quit
,
3999 doc
: /* Non-nil means enter debugger if quit is signaled (C-g, for example).
4000 Does not apply if quit is handled by a `condition-case'. */);
4003 DEFVAR_BOOL ("debug-on-next-call", debug_on_next_call
,
4004 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
4006 DEFVAR_BOOL ("debugger-may-continue", debugger_may_continue
,
4007 doc
: /* Non-nil means debugger may continue execution.
4008 This is nil when the debugger is called under circumstances where it
4009 might not be safe to continue. */);
4010 debugger_may_continue
= 1;
4012 DEFVAR_BOOL ("debugger-stack-frame-as-list", debugger_stack_frame_as_list
,
4013 doc
: /* Non-nil means display call stack frames as lists. */);
4014 debugger_stack_frame_as_list
= 0;
4016 DEFVAR_LISP ("debugger", Vdebugger
,
4017 doc
: /* Function to call to invoke debugger.
4018 If due to frame exit, args are `exit' and the value being returned;
4019 this function's value will be returned instead of that.
4020 If due to error, args are `error' and a list of the args to `signal'.
4021 If due to `apply' or `funcall' entry, one arg, `lambda'.
4022 If due to `eval' entry, one arg, t. */);
4025 DEFVAR_LISP ("signal-hook-function", Vsignal_hook_function
,
4026 doc
: /* If non-nil, this is a function for `signal' to call.
4027 It receives the same arguments that `signal' was given.
4028 The Edebug package uses this to regain control. */);
4029 Vsignal_hook_function
= Qnil
;
4031 DEFVAR_LISP ("debug-on-signal", Vdebug_on_signal
,
4032 doc
: /* Non-nil means call the debugger regardless of condition handlers.
4033 Note that `debug-on-error', `debug-on-quit' and friends
4034 still determine whether to handle the particular condition. */);
4035 Vdebug_on_signal
= Qnil
;
4037 /* When lexical binding is being used,
4038 Vinternal_interpreter_environment is non-nil, and contains an alist
4039 of lexically-bound variable, or (t), indicating an empty
4040 environment. The lisp name of this variable would be
4041 `internal-interpreter-environment' if it weren't hidden.
4042 Every element of this list can be either a cons (VAR . VAL)
4043 specifying a lexical binding, or a single symbol VAR indicating
4044 that this variable should use dynamic scoping. */
4045 DEFSYM (Qinternal_interpreter_environment
,
4046 "internal-interpreter-environment");
4047 DEFVAR_LISP ("internal-interpreter-environment",
4048 Vinternal_interpreter_environment
,
4049 doc
: /* If non-nil, the current lexical environment of the lisp interpreter.
4050 When lexical binding is not being used, this variable is nil.
4051 A value of `(t)' indicates an empty environment, otherwise it is an
4052 alist of active lexical bindings. */);
4053 Vinternal_interpreter_environment
= Qnil
;
4054 /* Don't export this variable to Elisp, so no one can mess with it
4055 (Just imagine if someone makes it buffer-local). */
4056 Funintern (Qinternal_interpreter_environment
, Qnil
);
4058 Vrun_hooks
= intern_c_string ("run-hooks");
4059 staticpro (&Vrun_hooks
);
4061 staticpro (&Vautoload_queue
);
4062 Vautoload_queue
= Qnil
;
4063 staticpro (&Vsignaling_function
);
4064 Vsignaling_function
= Qnil
;
4066 inhibit_lisp_code
= Qnil
;
4077 defsubr (&Sfunction
);
4078 defsubr (&Sdefault_toplevel_value
);
4079 defsubr (&Sset_default_toplevel_value
);
4081 defsubr (&Sdefvaralias
);
4082 DEFSYM (Qdefvaralias
, "defvaralias");
4083 defsubr (&Sdefconst
);
4084 defsubr (&Smake_var_non_special
);
4088 defsubr (&Smacroexpand
);
4091 defsubr (&Sunwind_protect
);
4092 defsubr (&Scondition_case
);
4094 defsubr (&Scommandp
);
4095 defsubr (&Sautoload
);
4096 defsubr (&Sautoload_do_load
);
4099 defsubr (&Sfuncall
);
4100 defsubr (&Sfunc_arity
);
4101 defsubr (&Srun_hooks
);
4102 defsubr (&Srun_hook_with_args
);
4103 defsubr (&Srun_hook_with_args_until_success
);
4104 defsubr (&Srun_hook_with_args_until_failure
);
4105 defsubr (&Srun_hook_wrapped
);
4106 defsubr (&Sfetch_bytecode
);
4107 defsubr (&Sbacktrace_debug
);
4108 DEFSYM (QCdebug_on_exit
, ":debug-on-exit");
4109 defsubr (&Smapbacktrace
);
4110 defsubr (&Sbacktrace_frame_internal
);
4111 defsubr (&Sbacktrace_eval
);
4112 defsubr (&Sbacktrace__locals
);
4113 defsubr (&Sspecial_variable_p
);
4114 defsubr (&Sfunctionp
);