1 /* Evaluator for GNU Emacs Lisp interpreter.
3 Copyright (C) 1985-1987, 1993-1995, 1999-2018 Free Software Foundation,
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or (at
11 your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
27 #include "blockinput.h"
30 #include "dispextern.h"
33 /* CACHEABLE is ordinarily nothing, except it is 'volatile' if
34 necessary to cajole GCC into not warning incorrectly that a
35 variable should be volatile. */
36 #if defined GCC_LINT || defined lint
37 # define CACHEABLE volatile
39 # define CACHEABLE /* empty */
42 /* Chain of condition and catch handlers currently in effect. */
44 /* struct handler *handlerlist; */
46 /* Non-nil means record all fset's and provide's, to be undone
47 if the file being autoloaded is not fully loaded.
48 They are recorded by being consed onto the front of Vautoload_queue:
49 (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide. */
51 Lisp_Object Vautoload_queue
;
53 /* This holds either the symbol `run-hooks' or nil.
54 It is nil at an early stage of startup, and when Emacs
56 Lisp_Object Vrun_hooks
;
58 /* The commented-out variables below are macros defined in thread.h. */
60 /* Current number of specbindings allocated in specpdl, not counting
61 the dummy entry specpdl[-1]. */
63 /* ptrdiff_t specpdl_size; */
65 /* Pointer to beginning of specpdl. A dummy entry specpdl[-1] exists
66 only so that its address can be taken. */
68 /* union specbinding *specpdl; */
70 /* Pointer to first unused element in specpdl. */
72 /* union specbinding *specpdl_ptr; */
74 /* Depth in Lisp evaluations and function calls. */
76 /* static EMACS_INT lisp_eval_depth; */
78 /* The value of num_nonmacro_input_events as of the last time we
79 started to enter the debugger. If we decide to enter the debugger
80 again when this is still equal to num_nonmacro_input_events, then we
81 know that the debugger itself has an error, and we should just
82 signal the error instead of entering an infinite loop of debugger
85 static EMACS_INT when_entered_debugger
;
87 /* The function from which the last `signal' was called. Set in
89 /* FIXME: We should probably get rid of this! */
90 Lisp_Object Vsignaling_function
;
92 /* If non-nil, Lisp code must not be run since some part of Emacs is in
93 an inconsistent state. Currently unused. */
94 Lisp_Object inhibit_lisp_code
;
96 /* These would ordinarily be static, but they need to be visible to GDB. */
97 bool backtrace_p (union specbinding
*) EXTERNALLY_VISIBLE
;
98 Lisp_Object
*backtrace_args (union specbinding
*) EXTERNALLY_VISIBLE
;
99 Lisp_Object
backtrace_function (union specbinding
*) EXTERNALLY_VISIBLE
;
100 union specbinding
*backtrace_next (union specbinding
*) EXTERNALLY_VISIBLE
;
101 union specbinding
*backtrace_top (void) EXTERNALLY_VISIBLE
;
103 static Lisp_Object
funcall_lambda (Lisp_Object
, ptrdiff_t, Lisp_Object
*);
104 static Lisp_Object
apply_lambda (Lisp_Object
, Lisp_Object
, ptrdiff_t);
105 static Lisp_Object
lambda_arity (Lisp_Object
);
108 specpdl_symbol (union specbinding
*pdl
)
110 eassert (pdl
->kind
>= SPECPDL_LET
);
111 return pdl
->let
.symbol
;
114 static enum specbind_tag
115 specpdl_kind (union specbinding
*pdl
)
117 eassert (pdl
->kind
>= SPECPDL_LET
);
118 return pdl
->let
.kind
;
122 specpdl_old_value (union specbinding
*pdl
)
124 eassert (pdl
->kind
>= SPECPDL_LET
);
125 return pdl
->let
.old_value
;
129 set_specpdl_old_value (union specbinding
*pdl
, Lisp_Object val
)
131 eassert (pdl
->kind
>= SPECPDL_LET
);
132 pdl
->let
.old_value
= val
;
136 specpdl_where (union specbinding
*pdl
)
138 eassert (pdl
->kind
> SPECPDL_LET
);
139 return pdl
->let
.where
;
143 specpdl_saved_value (union specbinding
*pdl
)
145 eassert (pdl
->kind
>= SPECPDL_LET
);
146 return pdl
->let
.saved_value
;
150 specpdl_arg (union specbinding
*pdl
)
152 eassert (pdl
->kind
== SPECPDL_UNWIND
);
153 return pdl
->unwind
.arg
;
157 backtrace_function (union specbinding
*pdl
)
159 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
160 return pdl
->bt
.function
;
164 backtrace_nargs (union specbinding
*pdl
)
166 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
167 return pdl
->bt
.nargs
;
171 backtrace_args (union specbinding
*pdl
)
173 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
178 backtrace_debug_on_exit (union specbinding
*pdl
)
180 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
181 return pdl
->bt
.debug_on_exit
;
184 /* Functions to modify slots of backtrace records. */
187 set_backtrace_args (union specbinding
*pdl
, Lisp_Object
*args
, ptrdiff_t nargs
)
189 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
191 pdl
->bt
.nargs
= nargs
;
195 set_backtrace_debug_on_exit (union specbinding
*pdl
, bool doe
)
197 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
198 pdl
->bt
.debug_on_exit
= doe
;
201 /* Helper functions to scan the backtrace. */
204 backtrace_p (union specbinding
*pdl
)
205 { return pdl
>= specpdl
; }
210 union specbinding
*pdl
= specpdl_ptr
- 1;
211 while (backtrace_p (pdl
) && pdl
->kind
!= SPECPDL_BACKTRACE
)
217 backtrace_next (union specbinding
*pdl
)
220 while (backtrace_p (pdl
) && pdl
->kind
!= SPECPDL_BACKTRACE
)
226 init_eval_once (void)
229 union specbinding
*pdlvec
= xmalloc ((size
+ 1) * sizeof *specpdl
);
231 specpdl
= specpdl_ptr
= pdlvec
+ 1;
232 /* Don't forget to update docs (lispref node "Local Variables"). */
233 max_specpdl_size
= 1300; /* 1000 is not enough for CEDET's c-by.el. */
234 max_lisp_eval_depth
= 800;
239 /* static struct handler handlerlist_sentinel; */
244 specpdl_ptr
= specpdl
;
245 { /* Put a dummy catcher at top-level so that handlerlist is never NULL.
246 This is important since handlerlist->nextfree holds the freelist
247 which would otherwise leak every time we unwind back to top-level. */
248 handlerlist_sentinel
= xzalloc (sizeof (struct handler
));
249 handlerlist
= handlerlist_sentinel
->nextfree
= handlerlist_sentinel
;
250 struct handler
*c
= push_handler (Qunbound
, CATCHER
);
251 eassert (c
== handlerlist_sentinel
);
252 handlerlist_sentinel
->nextfree
= NULL
;
253 handlerlist_sentinel
->next
= NULL
;
256 debug_on_next_call
= 0;
258 /* This is less than the initial value of num_nonmacro_input_events. */
259 when_entered_debugger
= -1;
262 /* Unwind-protect function used by call_debugger. */
265 restore_stack_limits (Lisp_Object data
)
267 max_specpdl_size
= XINT (XCAR (data
));
268 max_lisp_eval_depth
= XINT (XCDR (data
));
271 static void grow_specpdl (void);
273 /* Call the Lisp debugger, giving it argument ARG. */
276 call_debugger (Lisp_Object arg
)
278 bool debug_while_redisplaying
;
279 ptrdiff_t count
= SPECPDL_INDEX ();
281 EMACS_INT old_depth
= max_lisp_eval_depth
;
282 /* Do not allow max_specpdl_size less than actual depth (Bug#16603). */
283 EMACS_INT old_max
= max (max_specpdl_size
, count
);
285 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
286 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
288 /* While debugging Bug#16603, previous value of 100 was found
289 too small to avoid specpdl overflow in the debugger itself. */
290 if (max_specpdl_size
- 200 < count
)
291 max_specpdl_size
= count
+ 200;
293 if (old_max
== count
)
295 /* We can enter the debugger due to specpdl overflow (Bug#16603). */
300 /* Restore limits after leaving the debugger. */
301 record_unwind_protect (restore_stack_limits
,
302 Fcons (make_number (old_max
),
303 make_number (old_depth
)));
305 #ifdef HAVE_WINDOW_SYSTEM
306 if (display_hourglass_p
)
310 debug_on_next_call
= 0;
311 when_entered_debugger
= num_nonmacro_input_events
;
313 /* Resetting redisplaying_p to 0 makes sure that debug output is
314 displayed if the debugger is invoked during redisplay. */
315 debug_while_redisplaying
= redisplaying_p
;
317 specbind (intern ("debugger-may-continue"),
318 debug_while_redisplaying
? Qnil
: Qt
);
319 specbind (Qinhibit_redisplay
, Qnil
);
320 specbind (Qinhibit_debugger
, Qt
);
322 /* If we are debugging an error while `inhibit-changing-match-data'
323 is bound to non-nil (e.g., within a call to `string-match-p'),
324 then make sure debugger code can still use match data. */
325 specbind (Qinhibit_changing_match_data
, Qnil
);
327 #if 0 /* Binding this prevents execution of Lisp code during
328 redisplay, which necessarily leads to display problems. */
329 specbind (Qinhibit_eval_during_redisplay
, Qt
);
332 val
= apply1 (Vdebugger
, arg
);
334 /* Interrupting redisplay and resuming it later is not safe under
335 all circumstances. So, when the debugger returns, abort the
336 interrupted redisplay by going back to the top-level. */
337 if (debug_while_redisplaying
)
340 return unbind_to (count
, val
);
344 do_debug_on_call (Lisp_Object code
, ptrdiff_t count
)
346 debug_on_next_call
= 0;
347 set_backtrace_debug_on_exit (specpdl
+ count
, true);
348 call_debugger (list1 (code
));
351 /* NOTE!!! Every function that can call EVAL must protect its args
352 and temporaries from garbage collection while it needs them.
353 The definition of `For' shows what you have to do. */
355 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
356 doc
: /* Eval args until one of them yields non-nil, then return that value.
357 The remaining args are not evalled at all.
358 If all args return nil, return nil.
359 usage: (or CONDITIONS...) */)
362 Lisp_Object val
= Qnil
;
366 Lisp_Object arg
= XCAR (args
);
368 val
= eval_sub (arg
);
376 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
377 doc
: /* Eval args until one of them yields nil, then return nil.
378 The remaining args are not evalled at all.
379 If no arg yields nil, return the last arg's value.
380 usage: (and CONDITIONS...) */)
383 Lisp_Object val
= Qt
;
387 Lisp_Object arg
= XCAR (args
);
389 val
= eval_sub (arg
);
397 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
398 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
399 Returns the value of THEN or the value of the last of the ELSE's.
400 THEN must be one expression, but ELSE... can be zero or more expressions.
401 If COND yields nil, and there are no ELSE's, the value is nil.
402 usage: (if COND THEN ELSE...) */)
407 cond
= eval_sub (XCAR (args
));
410 return eval_sub (Fcar (XCDR (args
)));
411 return Fprogn (Fcdr (XCDR (args
)));
414 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
415 doc
: /* Try each clause until one succeeds.
416 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
417 and, if the value is non-nil, this clause succeeds:
418 then the expressions in BODY are evaluated and the last one's
419 value is the value of the cond-form.
420 If a clause has one element, as in (CONDITION), then the cond-form
421 returns CONDITION's value, if that is non-nil.
422 If no clause succeeds, cond returns nil.
423 usage: (cond CLAUSES...) */)
426 Lisp_Object val
= args
;
430 Lisp_Object clause
= XCAR (args
);
431 val
= eval_sub (Fcar (clause
));
434 if (!NILP (XCDR (clause
)))
435 val
= Fprogn (XCDR (clause
));
444 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
445 doc
: /* Eval BODY forms sequentially and return value of last one.
446 usage: (progn BODY...) */)
449 Lisp_Object val
= Qnil
;
453 Lisp_Object form
= XCAR (body
);
455 val
= eval_sub (form
);
461 /* Evaluate BODY sequentially, discarding its value. */
464 prog_ignore (Lisp_Object body
)
469 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
470 doc
: /* Eval FIRST and BODY sequentially; return value from FIRST.
471 The value of FIRST is saved during the evaluation of the remaining args,
472 whose values are discarded.
473 usage: (prog1 FIRST BODY...) */)
476 Lisp_Object val
= eval_sub (XCAR (args
));
477 prog_ignore (XCDR (args
));
481 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
482 doc
: /* Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
483 The value of FORM2 is saved during the evaluation of the
484 remaining args, whose values are discarded.
485 usage: (prog2 FORM1 FORM2 BODY...) */)
488 eval_sub (XCAR (args
));
489 return Fprog1 (XCDR (args
));
492 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
493 doc
: /* Set each SYM to the value of its VAL.
494 The symbols SYM are variables; they are literal (not evaluated).
495 The values VAL are expressions; they are evaluated.
496 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
497 The second VAL is not computed until after the first SYM is set, and so on;
498 each VAL can use the new value of variables set earlier in the `setq'.
499 The return value of the `setq' form is the value of the last VAL.
500 usage: (setq [SYM VAL]...) */)
503 Lisp_Object val
= args
, tail
= args
;
505 for (EMACS_INT nargs
= 0; CONSP (tail
); nargs
+= 2)
507 Lisp_Object sym
= XCAR (tail
), lex_binding
;
510 xsignal2 (Qwrong_number_of_arguments
, Qsetq
, make_number (nargs
+ 1));
511 Lisp_Object arg
= XCAR (tail
);
513 val
= eval_sub (arg
);
514 /* Like for eval_sub, we do not check declared_special here since
515 it's been done when let-binding. */
516 if (!NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
518 && !NILP (lex_binding
519 = Fassq (sym
, Vinternal_interpreter_environment
)))
520 XSETCDR (lex_binding
, val
); /* SYM is lexically bound. */
522 Fset (sym
, val
); /* SYM is dynamically bound. */
528 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
529 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
530 Warning: `quote' does not construct its return value, but just returns
531 the value that was pre-constructed by the Lisp reader (see info node
532 `(elisp)Printed Representation').
533 This means that \\='(a . b) is not identical to (cons \\='a \\='b): the former
534 does not cons. Quoting should be reserved for constants that will
535 never be modified by side-effects, unless you like self-modifying code.
536 See the common pitfall in info node `(elisp)Rearrangement' for an example
537 of unexpected results when a quoted object is modified.
538 usage: (quote ARG) */)
541 if (!NILP (XCDR (args
)))
542 xsignal2 (Qwrong_number_of_arguments
, Qquote
, Flength (args
));
546 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
547 doc
: /* Like `quote', but preferred for objects which are functions.
548 In byte compilation, `function' causes its argument to be compiled.
549 `quote' cannot do that.
550 usage: (function ARG) */)
553 Lisp_Object quoted
= XCAR (args
);
555 if (!NILP (XCDR (args
)))
556 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
558 if (!NILP (Vinternal_interpreter_environment
)
560 && EQ (XCAR (quoted
), Qlambda
))
561 { /* This is a lambda expression within a lexical environment;
562 return an interpreted closure instead of a simple lambda. */
563 Lisp_Object cdr
= XCDR (quoted
);
564 Lisp_Object tmp
= cdr
;
566 && (tmp
= XCDR (tmp
), CONSP (tmp
))
567 && (tmp
= XCAR (tmp
), CONSP (tmp
))
568 && (EQ (QCdocumentation
, XCAR (tmp
))))
569 { /* Handle the special (:documentation <form>) to build the docstring
571 Lisp_Object docstring
= eval_sub (Fcar (XCDR (tmp
)));
572 CHECK_STRING (docstring
);
573 cdr
= Fcons (XCAR (cdr
), Fcons (docstring
, XCDR (XCDR (cdr
))));
575 return Fcons (Qclosure
, Fcons (Vinternal_interpreter_environment
,
579 /* Simply quote the argument. */
584 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
585 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
586 Aliased variables always have the same value; setting one sets the other.
587 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
588 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
589 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
590 itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
591 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
592 The return value is BASE-VARIABLE. */)
593 (Lisp_Object new_alias
, Lisp_Object base_variable
, Lisp_Object docstring
)
595 struct Lisp_Symbol
*sym
;
597 CHECK_SYMBOL (new_alias
);
598 CHECK_SYMBOL (base_variable
);
600 if (SYMBOL_CONSTANT_P (new_alias
))
601 /* Making it an alias effectively changes its value. */
602 error ("Cannot make a constant an alias");
604 sym
= XSYMBOL (new_alias
);
606 switch (sym
->u
.s
.redirect
)
608 case SYMBOL_FORWARDED
:
609 error ("Cannot make an internal variable an alias");
610 case SYMBOL_LOCALIZED
:
611 error ("Don't know how to make a localized variable an alias");
612 case SYMBOL_PLAINVAL
:
613 case SYMBOL_VARALIAS
:
619 /* https://lists.gnu.org/r/emacs-devel/2008-04/msg00834.html
620 If n_a is bound, but b_v is not, set the value of b_v to n_a,
621 so that old-code that affects n_a before the aliasing is setup
623 if (NILP (Fboundp (base_variable
)))
624 set_internal (base_variable
, find_symbol_value (new_alias
),
625 Qnil
, SET_INTERNAL_BIND
);
626 else if (!NILP (Fboundp (new_alias
))
627 && !EQ (find_symbol_value (new_alias
),
628 find_symbol_value (base_variable
)))
629 call2 (intern ("display-warning"),
630 list3 (intern ("defvaralias"), intern ("losing-value"), new_alias
),
631 CALLN (Fformat_message
,
633 ("Overwriting value of `%s' by aliasing to `%s'"),
634 new_alias
, base_variable
));
637 union specbinding
*p
;
639 for (p
= specpdl_ptr
; p
> specpdl
; )
640 if ((--p
)->kind
>= SPECPDL_LET
641 && (EQ (new_alias
, specpdl_symbol (p
))))
642 error ("Don't know how to make a let-bound variable an alias");
645 if (sym
->u
.s
.trapped_write
== SYMBOL_TRAPPED_WRITE
)
646 notify_variable_watchers (new_alias
, base_variable
, Qdefvaralias
, Qnil
);
648 sym
->u
.s
.declared_special
= true;
649 XSYMBOL (base_variable
)->u
.s
.declared_special
= true;
650 sym
->u
.s
.redirect
= SYMBOL_VARALIAS
;
651 SET_SYMBOL_ALIAS (sym
, XSYMBOL (base_variable
));
652 sym
->u
.s
.trapped_write
= XSYMBOL (base_variable
)->u
.s
.trapped_write
;
653 LOADHIST_ATTACH (new_alias
);
654 /* Even if docstring is nil: remove old docstring. */
655 Fput (new_alias
, Qvariable_documentation
, docstring
);
657 return base_variable
;
660 static union specbinding
*
661 default_toplevel_binding (Lisp_Object symbol
)
663 union specbinding
*binding
= NULL
;
664 union specbinding
*pdl
= specpdl_ptr
;
665 while (pdl
> specpdl
)
667 switch ((--pdl
)->kind
)
669 case SPECPDL_LET_DEFAULT
:
671 if (EQ (specpdl_symbol (pdl
), symbol
))
676 case SPECPDL_UNWIND_ARRAY
:
677 case SPECPDL_UNWIND_PTR
:
678 case SPECPDL_UNWIND_INT
:
679 case SPECPDL_UNWIND_EXCURSION
:
680 case SPECPDL_UNWIND_VOID
:
681 case SPECPDL_BACKTRACE
:
682 case SPECPDL_LET_LOCAL
:
692 DEFUN ("default-toplevel-value", Fdefault_toplevel_value
, Sdefault_toplevel_value
, 1, 1, 0,
693 doc
: /* Return SYMBOL's toplevel default value.
694 "Toplevel" means outside of any let binding. */)
697 union specbinding
*binding
= default_toplevel_binding (symbol
);
699 = binding
? specpdl_old_value (binding
) : Fdefault_value (symbol
);
700 if (!EQ (value
, Qunbound
))
702 xsignal1 (Qvoid_variable
, symbol
);
705 DEFUN ("set-default-toplevel-value", Fset_default_toplevel_value
,
706 Sset_default_toplevel_value
, 2, 2, 0,
707 doc
: /* Set SYMBOL's toplevel default value to VALUE.
708 "Toplevel" means outside of any let binding. */)
709 (Lisp_Object symbol
, Lisp_Object value
)
711 union specbinding
*binding
= default_toplevel_binding (symbol
);
713 set_specpdl_old_value (binding
, value
);
715 Fset_default (symbol
, value
);
719 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
720 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
721 You are not required to define a variable in order to use it, but
722 defining it lets you supply an initial value and documentation, which
723 can be referred to by the Emacs help facilities and other programming
724 tools. The `defvar' form also declares the variable as \"special\",
725 so that it is always dynamically bound even if `lexical-binding' is t.
727 If SYMBOL's value is void and the optional argument INITVALUE is
728 provided, INITVALUE is evaluated and the result used to set SYMBOL's
729 value. If SYMBOL is buffer-local, its default value is what is set;
730 buffer-local values are not affected. If INITVALUE is missing,
731 SYMBOL's value is not set.
733 If SYMBOL has a local binding, then this form affects the local
734 binding. This is usually not what you want. Thus, if you need to
735 load a file defining variables, with this form or with `defconst' or
736 `defcustom', you should always load that file _outside_ any bindings
737 for these variables. (`defconst' and `defcustom' behave similarly in
740 The optional argument DOCSTRING is a documentation string for the
743 To define a user option, use `defcustom' instead of `defvar'.
744 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
747 Lisp_Object sym
, tem
, tail
;
756 if (!NILP (XCDR (tail
)) && !NILP (XCDR (XCDR (tail
))))
757 error ("Too many arguments");
759 tem
= Fdefault_boundp (sym
);
761 /* Do it before evaluating the initial value, for self-references. */
762 XSYMBOL (sym
)->u
.s
.declared_special
= true;
765 Fset_default (sym
, eval_sub (XCAR (tail
)));
767 { /* Check if there is really a global binding rather than just a let
768 binding that shadows the global unboundness of the var. */
769 union specbinding
*binding
= default_toplevel_binding (sym
);
770 if (binding
&& EQ (specpdl_old_value (binding
), Qunbound
))
772 set_specpdl_old_value (binding
, eval_sub (XCAR (tail
)));
779 if (!NILP (Vpurify_flag
))
780 tem
= Fpurecopy (tem
);
781 Fput (sym
, Qvariable_documentation
, tem
);
783 LOADHIST_ATTACH (sym
);
785 else if (!NILP (Vinternal_interpreter_environment
)
786 && !XSYMBOL (sym
)->u
.s
.declared_special
)
787 /* A simple (defvar foo) with lexical scoping does "nothing" except
788 declare that var to be dynamically scoped *locally* (i.e. within
789 the current file or let-block). */
790 Vinternal_interpreter_environment
791 = Fcons (sym
, Vinternal_interpreter_environment
);
794 /* Simple (defvar <var>) should not count as a definition at all.
795 It could get in the way of other definitions, and unloading this
796 package could try to make the variable unbound. */
802 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
803 doc
: /* Define SYMBOL as a constant variable.
804 This declares that neither programs nor users should ever change the
805 value. This constancy is not actually enforced by Emacs Lisp, but
806 SYMBOL is marked as a special variable so that it is never lexically
809 The `defconst' form always sets the value of SYMBOL to the result of
810 evalling INITVALUE. If SYMBOL is buffer-local, its default value is
811 what is set; buffer-local values are not affected. If SYMBOL has a
812 local binding, then this form sets the local binding's value.
813 However, you should normally not make local bindings for variables
814 defined with this form.
816 The optional DOCSTRING specifies the variable's documentation string.
817 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
820 Lisp_Object sym
, tem
;
823 Lisp_Object docstring
= Qnil
;
824 if (!NILP (XCDR (XCDR (args
))))
826 if (!NILP (XCDR (XCDR (XCDR (args
)))))
827 error ("Too many arguments");
828 docstring
= XCAR (XCDR (XCDR (args
)));
831 tem
= eval_sub (XCAR (XCDR (args
)));
832 if (!NILP (Vpurify_flag
))
833 tem
= Fpurecopy (tem
);
834 Fset_default (sym
, tem
);
835 XSYMBOL (sym
)->u
.s
.declared_special
= true;
836 if (!NILP (docstring
))
838 if (!NILP (Vpurify_flag
))
839 docstring
= Fpurecopy (docstring
);
840 Fput (sym
, Qvariable_documentation
, docstring
);
842 Fput (sym
, Qrisky_local_variable
, Qt
);
843 LOADHIST_ATTACH (sym
);
847 /* Make SYMBOL lexically scoped. */
848 DEFUN ("internal-make-var-non-special", Fmake_var_non_special
,
849 Smake_var_non_special
, 1, 1, 0,
850 doc
: /* Internal function. */)
853 CHECK_SYMBOL (symbol
);
854 XSYMBOL (symbol
)->u
.s
.declared_special
= false;
859 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
860 doc
: /* Bind variables according to VARLIST then eval BODY.
861 The value of the last form in BODY is returned.
862 Each element of VARLIST is a symbol (which is bound to nil)
863 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
864 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
865 usage: (let* VARLIST BODY...) */)
868 Lisp_Object var
, val
, elt
, lexenv
;
869 ptrdiff_t count
= SPECPDL_INDEX ();
871 lexenv
= Vinternal_interpreter_environment
;
873 Lisp_Object varlist
= XCAR (args
);
874 while (CONSP (varlist
))
878 elt
= XCAR (varlist
);
879 varlist
= XCDR (varlist
);
888 if (! NILP (Fcdr (XCDR (elt
))))
889 signal_error ("`let' bindings can have only one value-form", elt
);
890 val
= eval_sub (Fcar (XCDR (elt
)));
893 if (!NILP (lexenv
) && SYMBOLP (var
)
894 && !XSYMBOL (var
)->u
.s
.declared_special
895 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
896 /* Lexically bind VAR by adding it to the interpreter's binding
900 = Fcons (Fcons (var
, val
), Vinternal_interpreter_environment
);
901 if (EQ (Vinternal_interpreter_environment
, lexenv
))
902 /* Save the old lexical environment on the specpdl stack,
903 but only for the first lexical binding, since we'll never
904 need to revert to one of the intermediate ones. */
905 specbind (Qinternal_interpreter_environment
, newenv
);
907 Vinternal_interpreter_environment
= newenv
;
912 CHECK_LIST_END (varlist
, XCAR (args
));
914 val
= Fprogn (XCDR (args
));
915 return unbind_to (count
, val
);
918 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
919 doc
: /* Bind variables according to VARLIST then eval BODY.
920 The value of the last form in BODY is returned.
921 Each element of VARLIST is a symbol (which is bound to nil)
922 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
923 All the VALUEFORMs are evalled before any symbols are bound.
924 usage: (let VARLIST BODY...) */)
927 Lisp_Object
*temps
, tem
, lexenv
;
928 Lisp_Object elt
, varlist
;
929 ptrdiff_t count
= SPECPDL_INDEX ();
933 varlist
= XCAR (args
);
934 CHECK_LIST (varlist
);
936 /* Make space to hold the values to give the bound variables. */
937 EMACS_INT varlist_len
= XFASTINT (Flength (varlist
));
938 SAFE_ALLOCA_LISP (temps
, varlist_len
);
939 ptrdiff_t nvars
= varlist_len
;
941 /* Compute the values and store them in `temps'. */
943 for (argnum
= 0; argnum
< nvars
&& CONSP (varlist
); argnum
++)
946 elt
= XCAR (varlist
);
947 varlist
= XCDR (varlist
);
949 temps
[argnum
] = Qnil
;
950 else if (! NILP (Fcdr (Fcdr (elt
))))
951 signal_error ("`let' bindings can have only one value-form", elt
);
953 temps
[argnum
] = eval_sub (Fcar (Fcdr (elt
)));
957 lexenv
= Vinternal_interpreter_environment
;
959 varlist
= XCAR (args
);
960 for (argnum
= 0; argnum
< nvars
&& CONSP (varlist
); argnum
++)
964 elt
= XCAR (varlist
);
965 varlist
= XCDR (varlist
);
966 var
= SYMBOLP (elt
) ? elt
: Fcar (elt
);
969 if (!NILP (lexenv
) && SYMBOLP (var
)
970 && !XSYMBOL (var
)->u
.s
.declared_special
971 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
972 /* Lexically bind VAR by adding it to the lexenv alist. */
973 lexenv
= Fcons (Fcons (var
, tem
), lexenv
);
975 /* Dynamically bind VAR. */
979 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
980 /* Instantiate a new lexical environment. */
981 specbind (Qinternal_interpreter_environment
, lexenv
);
983 elt
= Fprogn (XCDR (args
));
985 return unbind_to (count
, elt
);
988 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
989 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
990 The order of execution is thus TEST, BODY, TEST, BODY and so on
991 until TEST returns nil.
992 usage: (while TEST BODY...) */)
995 Lisp_Object test
, body
;
999 while (!NILP (eval_sub (test
)))
1008 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
1009 doc
: /* Return result of expanding macros at top level of FORM.
1010 If FORM is not a macro call, it is returned unchanged.
1011 Otherwise, the macro is expanded and the expansion is considered
1012 in place of FORM. When a non-macro-call results, it is returned.
1014 The second optional arg ENVIRONMENT specifies an environment of macro
1015 definitions to shadow the loaded ones for use in file byte-compilation. */)
1016 (Lisp_Object form
, Lisp_Object environment
)
1018 /* With cleanups from Hallvard Furuseth. */
1019 register Lisp_Object expander
, sym
, def
, tem
;
1023 /* Come back here each time we expand a macro call,
1024 in case it expands into another macro call. */
1027 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1028 def
= sym
= XCAR (form
);
1030 /* Trace symbols aliases to other symbols
1031 until we get a symbol that is not an alias. */
1032 while (SYMBOLP (def
))
1036 tem
= Fassq (sym
, environment
);
1039 def
= XSYMBOL (sym
)->u
.s
.function
;
1045 /* Right now TEM is the result from SYM in ENVIRONMENT,
1046 and if TEM is nil then DEF is SYM's function definition. */
1049 /* SYM is not mentioned in ENVIRONMENT.
1050 Look at its function definition. */
1051 def
= Fautoload_do_load (def
, sym
, Qmacro
);
1053 /* Not defined or definition not suitable. */
1055 if (!EQ (XCAR (def
), Qmacro
))
1057 else expander
= XCDR (def
);
1061 expander
= XCDR (tem
);
1062 if (NILP (expander
))
1066 Lisp_Object newform
= apply1 (expander
, XCDR (form
));
1067 if (EQ (form
, newform
))
1076 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1077 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1078 TAG is evalled to get the tag to use; it must not be nil.
1080 Then the BODY is executed.
1081 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
1082 If no throw happens, `catch' returns the value of the last BODY form.
1083 If a throw happens, it specifies the value to return from `catch'.
1084 usage: (catch TAG BODY...) */)
1087 Lisp_Object tag
= eval_sub (XCAR (args
));
1088 return internal_catch (tag
, Fprogn
, XCDR (args
));
1091 /* Assert that E is true, but do not evaluate E. Use this instead of
1092 eassert (E) when E contains variables that might be clobbered by a
1095 #define clobbered_eassert(E) verify (sizeof (E) != 0)
1097 /* Set up a catch, then call C function FUNC on argument ARG.
1098 FUNC should return a Lisp_Object.
1099 This is how catches are done from within C code. */
1102 internal_catch (Lisp_Object tag
,
1103 Lisp_Object (*func
) (Lisp_Object
), Lisp_Object arg
)
1105 /* This structure is made part of the chain `catchlist'. */
1106 struct handler
*c
= push_handler (tag
, CATCHER
);
1109 if (! sys_setjmp (c
->jmp
))
1111 Lisp_Object val
= func (arg
);
1112 eassert (handlerlist
== c
);
1113 handlerlist
= c
->next
;
1117 { /* Throw works by a longjmp that comes right here. */
1118 Lisp_Object val
= handlerlist
->val
;
1119 clobbered_eassert (handlerlist
== c
);
1120 handlerlist
= handlerlist
->next
;
1125 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1126 jump to that CATCH, returning VALUE as the value of that catch.
1128 This is the guts of Fthrow and Fsignal; they differ only in the way
1129 they choose the catch tag to throw to. A catch tag for a
1130 condition-case form has a TAG of Qnil.
1132 Before each catch is discarded, unbind all special bindings and
1133 execute all unwind-protect clauses made above that catch. Unwind
1134 the handler stack as we go, so that the proper handlers are in
1135 effect for each unwind-protect clause we run. At the end, restore
1136 some static info saved in CATCH, and longjmp to the location
1139 This is used for correct unwinding in Fthrow and Fsignal. */
1141 static _Noreturn
void
1142 unwind_to_catch (struct handler
*catch, Lisp_Object value
)
1146 eassert (catch->next
);
1148 /* Save the value in the tag. */
1151 /* Restore certain special C variables. */
1152 set_poll_suppress_count (catch->poll_suppress_count
);
1153 unblock_input_to (catch->interrupt_input_blocked
);
1157 /* Unwind the specpdl stack, and then restore the proper set of
1159 unbind_to (handlerlist
->pdlcount
, Qnil
);
1160 last_time
= handlerlist
== catch;
1162 handlerlist
= handlerlist
->next
;
1164 while (! last_time
);
1166 eassert (handlerlist
== catch);
1168 lisp_eval_depth
= catch->f_lisp_eval_depth
;
1170 sys_longjmp (catch->jmp
, 1);
1173 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1174 doc
: /* Throw to the catch for TAG and return VALUE from it.
1175 Both TAG and VALUE are evalled. */
1176 attributes
: noreturn
)
1177 (register Lisp_Object tag
, Lisp_Object value
)
1182 for (c
= handlerlist
; c
; c
= c
->next
)
1184 if (c
->type
== CATCHER_ALL
)
1185 unwind_to_catch (c
, Fcons (tag
, value
));
1186 if (c
->type
== CATCHER
&& EQ (c
->tag_or_ch
, tag
))
1187 unwind_to_catch (c
, value
);
1189 xsignal2 (Qno_catch
, tag
, value
);
1193 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1194 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1195 If BODYFORM completes normally, its value is returned
1196 after executing the UNWINDFORMS.
1197 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1198 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1202 ptrdiff_t count
= SPECPDL_INDEX ();
1204 record_unwind_protect (prog_ignore
, XCDR (args
));
1205 val
= eval_sub (XCAR (args
));
1206 return unbind_to (count
, val
);
1209 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1210 doc
: /* Regain control when an error is signaled.
1211 Executes BODYFORM and returns its value if no error happens.
1212 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1213 where the BODY is made of Lisp expressions.
1215 A handler is applicable to an error
1216 if CONDITION-NAME is one of the error's condition names.
1217 If an error happens, the first applicable handler is run.
1219 The car of a handler may be a list of condition names instead of a
1220 single condition name; then it handles all of them. If the special
1221 condition name `debug' is present in this list, it allows another
1222 condition in the list to run the debugger if `debug-on-error' and the
1223 other usual mechanisms says it should (otherwise, `condition-case'
1224 suppresses the debugger).
1226 When a handler handles an error, control returns to the `condition-case'
1227 and it executes the handler's BODY...
1228 with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
1229 \(If VAR is nil, the handler can't access that information.)
1230 Then the value of the last BODY form is returned from the `condition-case'
1233 See also the function `signal' for more info.
1234 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1237 Lisp_Object var
= XCAR (args
);
1238 Lisp_Object bodyform
= XCAR (XCDR (args
));
1239 Lisp_Object handlers
= XCDR (XCDR (args
));
1241 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1244 /* Like Fcondition_case, but the args are separate
1245 rather than passed in a list. Used by Fbyte_code. */
1248 internal_lisp_condition_case (Lisp_Object var
, Lisp_Object bodyform
,
1249 Lisp_Object handlers
)
1251 struct handler
*oldhandlerlist
= handlerlist
;
1252 ptrdiff_t CACHEABLE clausenb
= 0;
1256 for (Lisp_Object tail
= handlers
; CONSP (tail
); tail
= XCDR (tail
))
1258 Lisp_Object tem
= XCAR (tail
);
1262 && (SYMBOLP (XCAR (tem
))
1263 || CONSP (XCAR (tem
))))))
1264 error ("Invalid condition handler: %s",
1265 SDATA (Fprin1_to_string (tem
, Qt
)));
1268 /* The first clause is the one that should be checked first, so it
1269 should be added to handlerlist last. So build in CLAUSES a table
1270 that contains HANDLERS but in reverse order. CLAUSES is pointer
1271 to volatile to avoid issues with setjmp and local storage.
1272 SAFE_ALLOCA won't work here due to the setjmp, so impose a
1273 MAX_ALLOCA limit. */
1274 if (MAX_ALLOCA
/ word_size
< clausenb
)
1275 memory_full (SIZE_MAX
);
1276 Lisp_Object
volatile *clauses
= alloca (clausenb
* sizeof *clauses
);
1277 clauses
+= clausenb
;
1278 for (Lisp_Object tail
= handlers
; CONSP (tail
); tail
= XCDR (tail
))
1279 *--clauses
= XCAR (tail
);
1280 for (ptrdiff_t i
= 0; i
< clausenb
; i
++)
1282 Lisp_Object clause
= clauses
[i
];
1283 Lisp_Object condition
= CONSP (clause
) ? XCAR (clause
) : Qnil
;
1284 if (!CONSP (condition
))
1285 condition
= list1 (condition
);
1286 struct handler
*c
= push_handler (condition
, CONDITION_CASE
);
1287 if (sys_setjmp (c
->jmp
))
1289 Lisp_Object val
= handlerlist
->val
;
1290 Lisp_Object
volatile *chosen_clause
= clauses
;
1291 for (struct handler
*h
= handlerlist
->next
; h
!= oldhandlerlist
;
1294 Lisp_Object handler_body
= XCDR (*chosen_clause
);
1295 handlerlist
= oldhandlerlist
;
1298 return Fprogn (handler_body
);
1300 Lisp_Object handler_var
= var
;
1301 if (!NILP (Vinternal_interpreter_environment
))
1303 val
= Fcons (Fcons (var
, val
),
1304 Vinternal_interpreter_environment
);
1305 handler_var
= Qinternal_interpreter_environment
;
1308 /* Bind HANDLER_VAR to VAL while evaluating HANDLER_BODY.
1309 The unbind_to undoes just this binding; whoever longjumped
1310 to us unwound the stack to C->pdlcount before throwing. */
1311 ptrdiff_t count
= SPECPDL_INDEX ();
1312 specbind (handler_var
, val
);
1313 return unbind_to (count
, Fprogn (handler_body
));
1317 Lisp_Object result
= eval_sub (bodyform
);
1318 handlerlist
= oldhandlerlist
;
1322 /* Call the function BFUN with no arguments, catching errors within it
1323 according to HANDLERS. If there is an error, call HFUN with
1324 one argument which is the data that describes the error:
1327 HANDLERS can be a list of conditions to catch.
1328 If HANDLERS is Qt, catch all errors.
1329 If HANDLERS is Qerror, catch all errors
1330 but allow the debugger to run if that is enabled. */
1333 internal_condition_case (Lisp_Object (*bfun
) (void), Lisp_Object handlers
,
1334 Lisp_Object (*hfun
) (Lisp_Object
))
1336 struct handler
*c
= push_handler (handlers
, CONDITION_CASE
);
1337 if (sys_setjmp (c
->jmp
))
1339 Lisp_Object val
= handlerlist
->val
;
1340 clobbered_eassert (handlerlist
== c
);
1341 handlerlist
= handlerlist
->next
;
1346 Lisp_Object val
= bfun ();
1347 eassert (handlerlist
== c
);
1348 handlerlist
= c
->next
;
1353 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1356 internal_condition_case_1 (Lisp_Object (*bfun
) (Lisp_Object
), Lisp_Object arg
,
1357 Lisp_Object handlers
,
1358 Lisp_Object (*hfun
) (Lisp_Object
))
1360 struct handler
*c
= push_handler (handlers
, CONDITION_CASE
);
1361 if (sys_setjmp (c
->jmp
))
1363 Lisp_Object val
= handlerlist
->val
;
1364 clobbered_eassert (handlerlist
== c
);
1365 handlerlist
= handlerlist
->next
;
1370 Lisp_Object val
= bfun (arg
);
1371 eassert (handlerlist
== c
);
1372 handlerlist
= c
->next
;
1377 /* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as
1381 internal_condition_case_2 (Lisp_Object (*bfun
) (Lisp_Object
, Lisp_Object
),
1384 Lisp_Object handlers
,
1385 Lisp_Object (*hfun
) (Lisp_Object
))
1387 struct handler
*c
= push_handler (handlers
, CONDITION_CASE
);
1388 if (sys_setjmp (c
->jmp
))
1390 Lisp_Object val
= handlerlist
->val
;
1391 clobbered_eassert (handlerlist
== c
);
1392 handlerlist
= handlerlist
->next
;
1397 Lisp_Object val
= bfun (arg1
, arg2
);
1398 eassert (handlerlist
== c
);
1399 handlerlist
= c
->next
;
1404 /* Like internal_condition_case but call BFUN with NARGS as first,
1405 and ARGS as second argument. */
1408 internal_condition_case_n (Lisp_Object (*bfun
) (ptrdiff_t, Lisp_Object
*),
1411 Lisp_Object handlers
,
1412 Lisp_Object (*hfun
) (Lisp_Object err
,
1416 struct handler
*c
= push_handler (handlers
, CONDITION_CASE
);
1417 if (sys_setjmp (c
->jmp
))
1419 Lisp_Object val
= handlerlist
->val
;
1420 clobbered_eassert (handlerlist
== c
);
1421 handlerlist
= handlerlist
->next
;
1422 return hfun (val
, nargs
, args
);
1426 Lisp_Object val
= bfun (nargs
, args
);
1427 eassert (handlerlist
== c
);
1428 handlerlist
= c
->next
;
1434 internal_catch_all_1 (Lisp_Object (*function
) (void *), void *argument
)
1436 struct handler
*c
= push_handler_nosignal (Qt
, CATCHER_ALL
);
1438 return Qcatch_all_memory_full
;
1440 if (sys_setjmp (c
->jmp
) == 0)
1442 Lisp_Object val
= function (argument
);
1443 eassert (handlerlist
== c
);
1444 handlerlist
= c
->next
;
1449 eassert (handlerlist
== c
);
1450 Lisp_Object val
= c
->val
;
1451 handlerlist
= c
->next
;
1452 Fsignal (Qno_catch
, val
);
1456 /* Like a combination of internal_condition_case_1 and internal_catch.
1457 Catches all signals and throws. Never exits nonlocally; returns
1458 Qcatch_all_memory_full if no handler could be allocated. */
1461 internal_catch_all (Lisp_Object (*function
) (void *), void *argument
,
1462 Lisp_Object (*handler
) (Lisp_Object
))
1464 struct handler
*c
= push_handler_nosignal (Qt
, CONDITION_CASE
);
1466 return Qcatch_all_memory_full
;
1468 if (sys_setjmp (c
->jmp
) == 0)
1470 Lisp_Object val
= internal_catch_all_1 (function
, argument
);
1471 eassert (handlerlist
== c
);
1472 handlerlist
= c
->next
;
1477 eassert (handlerlist
== c
);
1478 Lisp_Object val
= c
->val
;
1479 handlerlist
= c
->next
;
1480 return handler (val
);
1485 push_handler (Lisp_Object tag_ch_val
, enum handlertype handlertype
)
1487 struct handler
*c
= push_handler_nosignal (tag_ch_val
, handlertype
);
1489 memory_full (sizeof *c
);
1494 push_handler_nosignal (Lisp_Object tag_ch_val
, enum handlertype handlertype
)
1496 struct handler
*CACHEABLE c
= handlerlist
->nextfree
;
1499 c
= malloc (sizeof *c
);
1502 if (profiler_memory_running
)
1503 malloc_probe (sizeof *c
);
1505 handlerlist
->nextfree
= c
;
1507 c
->type
= handlertype
;
1508 c
->tag_or_ch
= tag_ch_val
;
1510 c
->next
= handlerlist
;
1511 c
->f_lisp_eval_depth
= lisp_eval_depth
;
1512 c
->pdlcount
= SPECPDL_INDEX ();
1513 c
->poll_suppress_count
= poll_suppress_count
;
1514 c
->interrupt_input_blocked
= interrupt_input_blocked
;
1520 static Lisp_Object
signal_or_quit (Lisp_Object
, Lisp_Object
, bool);
1521 static Lisp_Object
find_handler_clause (Lisp_Object
, Lisp_Object
);
1522 static bool maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
,
1526 process_quit_flag (void)
1528 Lisp_Object flag
= Vquit_flag
;
1530 if (EQ (flag
, Qkill_emacs
))
1532 if (EQ (Vthrow_on_input
, flag
))
1533 Fthrow (Vthrow_on_input
, Qt
);
1537 /* Check quit-flag and quit if it is non-nil. Typing C-g does not
1538 directly cause a quit; it only sets Vquit_flag. So the program
1539 needs to call maybe_quit at times when it is safe to quit. Every
1540 loop that might run for a long time or might not exit ought to call
1541 maybe_quit at least once, at a safe place. Unless that is
1542 impossible, of course. But it is very desirable to avoid creating
1543 loops where maybe_quit is impossible.
1545 If quit-flag is set to `kill-emacs' the SIGINT handler has received
1546 a request to exit Emacs when it is safe to do.
1548 When not quitting, process any pending signals.
1550 If you change this function, also adapt module_should_quit in
1556 if (!NILP (Vquit_flag
) && NILP (Vinhibit_quit
))
1557 process_quit_flag ();
1558 else if (pending_signals
)
1559 process_pending_signals ();
1562 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1563 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1564 This function does not return.
1566 An error symbol is a symbol with an `error-conditions' property
1567 that is a list of condition names.
1568 A handler for any of those names will get to handle this signal.
1569 The symbol `error' should normally be one of them.
1571 DATA should be a list. Its elements are printed as part of the error message.
1572 See Info anchor `(elisp)Definition of signal' for some details on how this
1573 error message is constructed.
1574 If the signal is handled, DATA is made available to the handler.
1575 See also the function `condition-case'. */
1576 attributes
: noreturn
)
1577 (Lisp_Object error_symbol
, Lisp_Object data
)
1579 signal_or_quit (error_symbol
, data
, false);
1583 /* Quit, in response to a keyboard quit request. */
1587 return signal_or_quit (Qquit
, Qnil
, true);
1590 /* Signal an error, or quit. ERROR_SYMBOL and DATA are as with Fsignal.
1591 If KEYBOARD_QUIT, this is a quit; ERROR_SYMBOL should be
1592 Qquit and DATA should be Qnil, and this function may return.
1593 Otherwise this function is like Fsignal and does not return. */
1596 signal_or_quit (Lisp_Object error_symbol
, Lisp_Object data
, bool keyboard_quit
)
1598 /* When memory is full, ERROR-SYMBOL is nil,
1599 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1600 That is a special case--don't do this in other situations. */
1601 Lisp_Object conditions
;
1603 Lisp_Object real_error_symbol
1604 = (NILP (error_symbol
) ? Fcar (data
) : error_symbol
);
1605 Lisp_Object clause
= Qnil
;
1608 if (gc_in_progress
|| waiting_for_input
)
1611 #if 0 /* rms: I don't know why this was here,
1612 but it is surely wrong for an error that is handled. */
1613 #ifdef HAVE_WINDOW_SYSTEM
1614 if (display_hourglass_p
)
1615 cancel_hourglass ();
1619 /* This hook is used by edebug. */
1620 if (! NILP (Vsignal_hook_function
)
1621 && ! NILP (error_symbol
)
1622 /* Don't try to call a lisp function if we've already overflowed
1623 the specpdl stack. */
1624 && specpdl_ptr
< specpdl
+ specpdl_size
)
1626 /* Edebug takes care of restoring these variables when it exits. */
1627 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1628 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1630 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1631 max_specpdl_size
= SPECPDL_INDEX () + 40;
1633 call2 (Vsignal_hook_function
, error_symbol
, data
);
1636 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1638 /* Remember from where signal was called. Skip over the frame for
1639 `signal' itself. If a frame for `error' follows, skip that,
1640 too. Don't do this when ERROR_SYMBOL is nil, because that
1641 is a memory-full error. */
1642 Vsignaling_function
= Qnil
;
1643 if (!NILP (error_symbol
))
1645 union specbinding
*pdl
= backtrace_next (backtrace_top ());
1646 if (backtrace_p (pdl
) && EQ (backtrace_function (pdl
), Qerror
))
1647 pdl
= backtrace_next (pdl
);
1648 if (backtrace_p (pdl
))
1649 Vsignaling_function
= backtrace_function (pdl
);
1652 for (h
= handlerlist
; h
; h
= h
->next
)
1654 if (h
->type
!= CONDITION_CASE
)
1656 clause
= find_handler_clause (h
->tag_or_ch
, conditions
);
1661 if (/* Don't run the debugger for a memory-full error.
1662 (There is no room in memory to do that!) */
1663 !NILP (error_symbol
)
1664 && (!NILP (Vdebug_on_signal
)
1665 /* If no handler is present now, try to run the debugger. */
1667 /* A `debug' symbol in the handler list disables the normal
1668 suppression of the debugger. */
1669 || (CONSP (clause
) && !NILP (Fmemq (Qdebug
, clause
)))
1670 /* Special handler that means "print a message and run debugger
1672 || EQ (h
->tag_or_ch
, Qerror
)))
1674 bool debugger_called
1675 = maybe_call_debugger (conditions
, error_symbol
, data
);
1676 /* We can't return values to code which signaled an error, but we
1677 can continue code which has signaled a quit. */
1678 if (keyboard_quit
&& debugger_called
&& EQ (real_error_symbol
, Qquit
))
1684 Lisp_Object unwind_data
1685 = (NILP (error_symbol
) ? data
: Fcons (error_symbol
, data
));
1687 unwind_to_catch (h
, unwind_data
);
1691 if (handlerlist
!= handlerlist_sentinel
)
1692 /* FIXME: This will come right back here if there's no `top-level'
1693 catcher. A better solution would be to abort here, and instead
1694 add a catch-all condition handler so we never come here. */
1695 Fthrow (Qtop_level
, Qt
);
1698 if (! NILP (error_symbol
))
1699 data
= Fcons (error_symbol
, data
);
1701 string
= Ferror_message_string (data
);
1702 fatal ("%s", SDATA (string
));
1705 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1708 xsignal0 (Lisp_Object error_symbol
)
1710 xsignal (error_symbol
, Qnil
);
1714 xsignal1 (Lisp_Object error_symbol
, Lisp_Object arg
)
1716 xsignal (error_symbol
, list1 (arg
));
1720 xsignal2 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
)
1722 xsignal (error_symbol
, list2 (arg1
, arg2
));
1726 xsignal3 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
1728 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1731 /* Signal `error' with message S, and additional arg ARG.
1732 If ARG is not a genuine list, make it a one-element list. */
1735 signal_error (const char *s
, Lisp_Object arg
)
1737 Lisp_Object tortoise
, hare
;
1739 hare
= tortoise
= arg
;
1740 while (CONSP (hare
))
1747 tortoise
= XCDR (tortoise
);
1749 if (EQ (hare
, tortoise
))
1756 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1760 /* Return true if LIST is a non-nil atom or
1761 a list containing one of CONDITIONS. */
1764 wants_debugger (Lisp_Object list
, Lisp_Object conditions
)
1771 while (CONSP (conditions
))
1773 Lisp_Object
this, tail
;
1774 this = XCAR (conditions
);
1775 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1776 if (EQ (XCAR (tail
), this))
1778 conditions
= XCDR (conditions
);
1783 /* Return true if an error with condition-symbols CONDITIONS,
1784 and described by SIGNAL-DATA, should skip the debugger
1785 according to debugger-ignored-errors. */
1788 skip_debugger (Lisp_Object conditions
, Lisp_Object data
)
1791 bool first_string
= 1;
1792 Lisp_Object error_message
;
1794 error_message
= Qnil
;
1795 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1797 if (STRINGP (XCAR (tail
)))
1801 error_message
= Ferror_message_string (data
);
1805 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1810 Lisp_Object contail
;
1812 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1813 if (EQ (XCAR (tail
), XCAR (contail
)))
1821 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1822 SIG and DATA describe the signal. There are two ways to pass them:
1823 = SIG is the error symbol, and DATA is the rest of the data.
1824 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1825 This is for memory-full errors only. */
1827 maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
, Lisp_Object data
)
1829 Lisp_Object combined_data
;
1831 combined_data
= Fcons (sig
, data
);
1834 /* Don't try to run the debugger with interrupts blocked.
1835 The editing loop would return anyway. */
1836 ! input_blocked_p ()
1837 && NILP (Vinhibit_debugger
)
1838 /* Does user want to enter debugger for this kind of error? */
1841 : wants_debugger (Vdebug_on_error
, conditions
))
1842 && ! skip_debugger (conditions
, combined_data
)
1843 /* RMS: What's this for? */
1844 && when_entered_debugger
< num_nonmacro_input_events
)
1846 call_debugger (list2 (Qerror
, combined_data
));
1854 find_handler_clause (Lisp_Object handlers
, Lisp_Object conditions
)
1856 register Lisp_Object h
;
1858 /* t is used by handlers for all conditions, set up by C code. */
1859 if (EQ (handlers
, Qt
))
1862 /* error is used similarly, but means print an error message
1863 and run the debugger if that is enabled. */
1864 if (EQ (handlers
, Qerror
))
1867 for (h
= handlers
; CONSP (h
); h
= XCDR (h
))
1869 Lisp_Object handler
= XCAR (h
);
1870 if (!NILP (Fmemq (handler
, conditions
)))
1878 /* Format and return a string; called like vprintf. */
1880 vformat_string (const char *m
, va_list ap
)
1883 ptrdiff_t size
= sizeof buf
;
1884 ptrdiff_t size_max
= STRING_BYTES_BOUND
+ 1;
1889 used
= evxprintf (&buffer
, &size
, buf
, size_max
, m
, ap
);
1890 string
= make_string (buffer
, used
);
1897 /* Dump an error message; called like vprintf. */
1899 verror (const char *m
, va_list ap
)
1901 xsignal1 (Qerror
, vformat_string (m
, ap
));
1905 /* Dump an error message; called like printf. */
1909 error (const char *m
, ...)
1916 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
1917 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
1918 This means it contains a description for how to read arguments to give it.
1919 The value is nil for an invalid function or a symbol with no function
1922 Interactively callable functions include strings and vectors (treated
1923 as keyboard macros), lambda-expressions that contain a top-level call
1924 to `interactive', autoload definitions made by `autoload' with non-nil
1925 fourth argument, and some of the built-in functions of Lisp.
1927 Also, a symbol satisfies `commandp' if its function definition does so.
1929 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
1930 then strings and vectors are not accepted. */)
1931 (Lisp_Object function
, Lisp_Object for_call_interactively
)
1933 register Lisp_Object fun
;
1934 register Lisp_Object funcar
;
1935 Lisp_Object if_prop
= Qnil
;
1939 fun
= indirect_function (fun
); /* Check cycles. */
1943 /* Check an `interactive-form' property if present, analogous to the
1944 function-documentation property. */
1946 while (SYMBOLP (fun
))
1948 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
1951 fun
= Fsymbol_function (fun
);
1954 /* Emacs primitives are interactive if their DEFUN specifies an
1955 interactive spec. */
1957 return XSUBR (fun
)->intspec
? Qt
: if_prop
;
1959 /* Bytecode objects are interactive if they are long enough to
1960 have an element whose index is COMPILED_INTERACTIVE, which is
1961 where the interactive spec is stored. */
1962 else if (COMPILEDP (fun
))
1963 return (PVSIZE (fun
) > COMPILED_INTERACTIVE
? Qt
: if_prop
);
1965 /* Strings and vectors are keyboard macros. */
1966 if (STRINGP (fun
) || VECTORP (fun
))
1967 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
1969 /* Lists may represent commands. */
1972 funcar
= XCAR (fun
);
1973 if (EQ (funcar
, Qclosure
))
1974 return (!NILP (Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
)))))
1976 else if (EQ (funcar
, Qlambda
))
1977 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
1978 else if (EQ (funcar
, Qautoload
))
1979 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
1984 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1985 doc
: /* Define FUNCTION to autoload from FILE.
1986 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
1987 Third arg DOCSTRING is documentation for the function.
1988 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
1989 Fifth arg TYPE indicates the type of the object:
1990 nil or omitted says FUNCTION is a function,
1991 `keymap' says FUNCTION is really a keymap, and
1992 `macro' or t says FUNCTION is really a macro.
1993 Third through fifth args give info about the real definition.
1994 They default to nil.
1995 If FUNCTION is already defined other than as an autoload,
1996 this does nothing and returns nil. */)
1997 (Lisp_Object function
, Lisp_Object file
, Lisp_Object docstring
, Lisp_Object interactive
, Lisp_Object type
)
1999 CHECK_SYMBOL (function
);
2000 CHECK_STRING (file
);
2002 /* If function is defined and not as an autoload, don't override. */
2003 if (!NILP (XSYMBOL (function
)->u
.s
.function
)
2004 && !AUTOLOADP (XSYMBOL (function
)->u
.s
.function
))
2007 if (!NILP (Vpurify_flag
) && EQ (docstring
, make_number (0)))
2008 /* `read1' in lread.c has found the docstring starting with "\
2009 and assumed the docstring will be provided by Snarf-documentation, so it
2010 passed us 0 instead. But that leads to accidental sharing in purecopy's
2011 hash-consing, so we use a (hopefully) unique integer instead. */
2012 docstring
= make_number (XHASH (function
));
2013 return Fdefalias (function
,
2014 list5 (Qautoload
, file
, docstring
, interactive
, type
),
2019 un_autoload (Lisp_Object oldqueue
)
2021 Lisp_Object queue
, first
, second
;
2023 /* Queue to unwind is current value of Vautoload_queue.
2024 oldqueue is the shadowed value to leave in Vautoload_queue. */
2025 queue
= Vautoload_queue
;
2026 Vautoload_queue
= oldqueue
;
2027 while (CONSP (queue
))
2029 first
= XCAR (queue
);
2030 second
= Fcdr (first
);
2031 first
= Fcar (first
);
2032 if (EQ (first
, make_number (0)))
2035 Ffset (first
, second
);
2036 queue
= XCDR (queue
);
2040 /* Load an autoloaded function.
2041 FUNNAME is the symbol which is the function's name.
2042 FUNDEF is the autoload definition (a list). */
2044 DEFUN ("autoload-do-load", Fautoload_do_load
, Sautoload_do_load
, 1, 3, 0,
2045 doc
: /* Load FUNDEF which should be an autoload.
2046 If non-nil, FUNNAME should be the symbol whose function value is FUNDEF,
2047 in which case the function returns the new autoloaded function value.
2048 If equal to `macro', MACRO-ONLY specifies that FUNDEF should only be loaded if
2049 it defines a macro. */)
2050 (Lisp_Object fundef
, Lisp_Object funname
, Lisp_Object macro_only
)
2052 ptrdiff_t count
= SPECPDL_INDEX ();
2054 if (!CONSP (fundef
) || !EQ (Qautoload
, XCAR (fundef
)))
2057 Lisp_Object kind
= Fnth (make_number (4), fundef
);
2058 if (EQ (macro_only
, Qmacro
)
2059 && !(EQ (kind
, Qt
) || EQ (kind
, Qmacro
)))
2062 /* This is to make sure that loadup.el gives a clear picture
2063 of what files are preloaded and when. */
2064 if (! NILP (Vpurify_flag
))
2065 error ("Attempt to autoload %s while preparing to dump",
2066 SDATA (SYMBOL_NAME (funname
)));
2068 CHECK_SYMBOL (funname
);
2070 /* Preserve the match data. */
2071 record_unwind_save_match_data ();
2073 /* If autoloading gets an error (which includes the error of failing
2074 to define the function being called), we use Vautoload_queue
2075 to undo function definitions and `provide' calls made by
2076 the function. We do this in the specific case of autoloading
2077 because autoloading is not an explicit request "load this file",
2078 but rather a request to "call this function".
2080 The value saved here is to be restored into Vautoload_queue. */
2081 record_unwind_protect (un_autoload
, Vautoload_queue
);
2082 Vautoload_queue
= Qt
;
2083 /* If `macro_only' is set and fundef isn't a macro, assume this autoload to
2084 be a "best-effort" (e.g. to try and find a compiler macro),
2085 so don't signal an error if autoloading fails. */
2086 Lisp_Object ignore_errors
2087 = (EQ (kind
, Qt
) || EQ (kind
, Qmacro
)) ? Qnil
: macro_only
;
2088 Fload (Fcar (Fcdr (fundef
)), ignore_errors
, Qt
, Qnil
, Qt
);
2090 /* Once loading finishes, don't undo it. */
2091 Vautoload_queue
= Qt
;
2092 unbind_to (count
, Qnil
);
2094 if (NILP (funname
) || !NILP (ignore_errors
))
2098 Lisp_Object fun
= Findirect_function (funname
, Qnil
);
2100 if (!NILP (Fequal (fun
, fundef
)))
2101 error ("Autoloading file %s failed to define function %s",
2102 SDATA (Fcar (Fcar (Vload_history
))),
2103 SDATA (SYMBOL_NAME (funname
)));
2110 DEFUN ("eval", Feval
, Seval
, 1, 2, 0,
2111 doc
: /* Evaluate FORM and return its value.
2112 If LEXICAL is t, evaluate using lexical scoping.
2113 LEXICAL can also be an actual lexical environment, in the form of an
2114 alist mapping symbols to their value. */)
2115 (Lisp_Object form
, Lisp_Object lexical
)
2117 ptrdiff_t count
= SPECPDL_INDEX ();
2118 specbind (Qinternal_interpreter_environment
,
2119 CONSP (lexical
) || NILP (lexical
) ? lexical
: list1 (Qt
));
2120 return unbind_to (count
, eval_sub (form
));
2123 /* Grow the specpdl stack by one entry.
2124 The caller should have already initialized the entry.
2125 Signal an error on stack overflow.
2127 Make sure that there is always one unused entry past the top of the
2128 stack, so that the just-initialized entry is safely unwound if
2129 memory exhausted and an error is signaled here. Also, allocate a
2130 never-used entry just before the bottom of the stack; sometimes its
2131 address is taken. */
2138 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2140 ptrdiff_t count
= SPECPDL_INDEX ();
2141 ptrdiff_t max_size
= min (max_specpdl_size
, PTRDIFF_MAX
- 1000);
2142 union specbinding
*pdlvec
= specpdl
- 1;
2143 ptrdiff_t pdlvecsize
= specpdl_size
+ 1;
2144 if (max_size
<= specpdl_size
)
2146 if (max_specpdl_size
< 400)
2147 max_size
= max_specpdl_size
= 400;
2148 if (max_size
<= specpdl_size
)
2149 signal_error ("Variable binding depth exceeds max-specpdl-size",
2152 pdlvec
= xpalloc (pdlvec
, &pdlvecsize
, 1, max_size
+ 1, sizeof *specpdl
);
2153 specpdl
= pdlvec
+ 1;
2154 specpdl_size
= pdlvecsize
- 1;
2155 specpdl_ptr
= specpdl
+ count
;
2160 record_in_backtrace (Lisp_Object function
, Lisp_Object
*args
, ptrdiff_t nargs
)
2162 ptrdiff_t count
= SPECPDL_INDEX ();
2164 eassert (nargs
>= UNEVALLED
);
2165 specpdl_ptr
->bt
.kind
= SPECPDL_BACKTRACE
;
2166 specpdl_ptr
->bt
.debug_on_exit
= false;
2167 specpdl_ptr
->bt
.function
= function
;
2168 current_thread
->stack_top
= specpdl_ptr
->bt
.args
= args
;
2169 specpdl_ptr
->bt
.nargs
= nargs
;
2175 /* Eval a sub-expression of the current expression (i.e. in the same
2178 eval_sub (Lisp_Object form
)
2180 Lisp_Object fun
, val
, original_fun
, original_args
;
2184 /* Declare here, as this array may be accessed by call_debugger near
2185 the end of this function. See Bug#21245. */
2186 Lisp_Object argvals
[8];
2190 /* Look up its binding in the lexical environment.
2191 We do not pay attention to the declared_special flag here, since we
2192 already did that when let-binding the variable. */
2193 Lisp_Object lex_binding
2194 = !NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
2195 ? Fassq (form
, Vinternal_interpreter_environment
)
2197 if (CONSP (lex_binding
))
2198 return XCDR (lex_binding
);
2200 return Fsymbol_value (form
);
2210 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2212 if (max_lisp_eval_depth
< 100)
2213 max_lisp_eval_depth
= 100;
2214 if (lisp_eval_depth
> max_lisp_eval_depth
)
2215 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2218 original_fun
= XCAR (form
);
2219 original_args
= XCDR (form
);
2220 CHECK_LIST (original_args
);
2222 /* This also protects them from gc. */
2223 count
= record_in_backtrace (original_fun
, &original_args
, UNEVALLED
);
2225 if (debug_on_next_call
)
2226 do_debug_on_call (Qt
, count
);
2228 /* At this point, only original_fun and original_args
2229 have values that will be used below. */
2232 /* Optimize for no indirection. */
2235 fun
= Ffunction (Fcons (fun
, Qnil
));
2236 else if (!NILP (fun
) && (fun
= XSYMBOL (fun
)->u
.s
.function
, SYMBOLP (fun
)))
2237 fun
= indirect_function (fun
);
2241 Lisp_Object args_left
= original_args
;
2242 Lisp_Object numargs
= Flength (args_left
);
2246 if (XINT (numargs
) < XSUBR (fun
)->min_args
2247 || (XSUBR (fun
)->max_args
>= 0
2248 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2249 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2251 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2252 val
= (XSUBR (fun
)->function
.aUNEVALLED
) (args_left
);
2253 else if (XSUBR (fun
)->max_args
== MANY
)
2255 /* Pass a vector of evaluated arguments. */
2257 ptrdiff_t argnum
= 0;
2260 SAFE_ALLOCA_LISP (vals
, XINT (numargs
));
2262 while (CONSP (args_left
) && argnum
< XINT (numargs
))
2264 Lisp_Object arg
= XCAR (args_left
);
2265 args_left
= XCDR (args_left
);
2266 vals
[argnum
++] = eval_sub (arg
);
2269 set_backtrace_args (specpdl
+ count
, vals
, argnum
);
2271 val
= XSUBR (fun
)->function
.aMANY (argnum
, vals
);
2275 /* Do the debug-on-exit now, while VALS still exists. */
2276 if (backtrace_debug_on_exit (specpdl
+ count
))
2277 val
= call_debugger (list2 (Qexit
, val
));
2284 int i
, maxargs
= XSUBR (fun
)->max_args
;
2286 for (i
= 0; i
< maxargs
; i
++)
2288 argvals
[i
] = eval_sub (Fcar (args_left
));
2289 args_left
= Fcdr (args_left
);
2292 set_backtrace_args (specpdl
+ count
, argvals
, XINT (numargs
));
2297 val
= (XSUBR (fun
)->function
.a0 ());
2300 val
= (XSUBR (fun
)->function
.a1 (argvals
[0]));
2303 val
= (XSUBR (fun
)->function
.a2 (argvals
[0], argvals
[1]));
2306 val
= (XSUBR (fun
)->function
.a3
2307 (argvals
[0], argvals
[1], argvals
[2]));
2310 val
= (XSUBR (fun
)->function
.a4
2311 (argvals
[0], argvals
[1], argvals
[2], argvals
[3]));
2314 val
= (XSUBR (fun
)->function
.a5
2315 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2319 val
= (XSUBR (fun
)->function
.a6
2320 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2321 argvals
[4], argvals
[5]));
2324 val
= (XSUBR (fun
)->function
.a7
2325 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2326 argvals
[4], argvals
[5], argvals
[6]));
2330 val
= (XSUBR (fun
)->function
.a8
2331 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2332 argvals
[4], argvals
[5], argvals
[6], argvals
[7]));
2336 /* Someone has created a subr that takes more arguments than
2337 is supported by this code. We need to either rewrite the
2338 subr to use a different argument protocol, or add more
2339 cases to this switch. */
2344 else if (COMPILEDP (fun
) || MODULE_FUNCTIONP (fun
))
2345 return apply_lambda (fun
, original_args
, count
);
2349 xsignal1 (Qvoid_function
, original_fun
);
2351 xsignal1 (Qinvalid_function
, original_fun
);
2352 funcar
= XCAR (fun
);
2353 if (!SYMBOLP (funcar
))
2354 xsignal1 (Qinvalid_function
, original_fun
);
2355 if (EQ (funcar
, Qautoload
))
2357 Fautoload_do_load (fun
, original_fun
, Qnil
);
2360 if (EQ (funcar
, Qmacro
))
2362 ptrdiff_t count1
= SPECPDL_INDEX ();
2364 /* Bind lexical-binding during expansion of the macro, so the
2365 macro can know reliably if the code it outputs will be
2366 interpreted using lexical-binding or not. */
2367 specbind (Qlexical_binding
,
2368 NILP (Vinternal_interpreter_environment
) ? Qnil
: Qt
);
2369 exp
= apply1 (Fcdr (fun
), original_args
);
2370 unbind_to (count1
, Qnil
);
2371 val
= eval_sub (exp
);
2373 else if (EQ (funcar
, Qlambda
)
2374 || EQ (funcar
, Qclosure
))
2375 return apply_lambda (fun
, original_args
, count
);
2377 xsignal1 (Qinvalid_function
, original_fun
);
2382 if (backtrace_debug_on_exit (specpdl
+ count
))
2383 val
= call_debugger (list2 (Qexit
, val
));
2389 DEFUN ("apply", Fapply
, Sapply
, 1, MANY
, 0,
2390 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2391 Then return the value FUNCTION returns.
2392 Thus, (apply \\='+ 1 2 \\='(3 4)) returns 10.
2393 usage: (apply FUNCTION &rest ARGUMENTS) */)
2394 (ptrdiff_t nargs
, Lisp_Object
*args
)
2396 ptrdiff_t i
, numargs
, funcall_nargs
;
2397 register Lisp_Object
*funcall_args
= NULL
;
2398 register Lisp_Object spread_arg
= args
[nargs
- 1];
2399 Lisp_Object fun
= args
[0];
2403 CHECK_LIST (spread_arg
);
2405 numargs
= XINT (Flength (spread_arg
));
2408 return Ffuncall (nargs
- 1, args
);
2409 else if (numargs
== 1)
2411 args
[nargs
- 1] = XCAR (spread_arg
);
2412 return Ffuncall (nargs
, args
);
2415 numargs
+= nargs
- 2;
2417 /* Optimize for no indirection. */
2418 if (SYMBOLP (fun
) && !NILP (fun
)
2419 && (fun
= XSYMBOL (fun
)->u
.s
.function
, SYMBOLP (fun
)))
2421 fun
= indirect_function (fun
);
2423 /* Let funcall get the error. */
2427 if (SUBRP (fun
) && XSUBR (fun
)->max_args
> numargs
2428 /* Don't hide an error by adding missing arguments. */
2429 && numargs
>= XSUBR (fun
)->min_args
)
2431 /* Avoid making funcall cons up a yet another new vector of arguments
2432 by explicitly supplying nil's for optional values. */
2433 SAFE_ALLOCA_LISP (funcall_args
, 1 + XSUBR (fun
)->max_args
);
2434 memclear (funcall_args
+ numargs
+ 1,
2435 (XSUBR (fun
)->max_args
- numargs
) * word_size
);
2436 funcall_nargs
= 1 + XSUBR (fun
)->max_args
;
2439 { /* We add 1 to numargs because funcall_args includes the
2440 function itself as well as its arguments. */
2441 SAFE_ALLOCA_LISP (funcall_args
, 1 + numargs
);
2442 funcall_nargs
= 1 + numargs
;
2445 memcpy (funcall_args
, args
, nargs
* word_size
);
2446 /* Spread the last arg we got. Its first element goes in
2447 the slot that it used to occupy, hence this value of I. */
2449 while (!NILP (spread_arg
))
2451 funcall_args
[i
++] = XCAR (spread_arg
);
2452 spread_arg
= XCDR (spread_arg
);
2455 retval
= Ffuncall (funcall_nargs
, funcall_args
);
2461 /* Run hook variables in various ways. */
2464 funcall_nil (ptrdiff_t nargs
, Lisp_Object
*args
)
2466 Ffuncall (nargs
, args
);
2470 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2471 doc
: /* Run each hook in HOOKS.
2472 Each argument should be a symbol, a hook variable.
2473 These symbols are processed in the order specified.
2474 If a hook symbol has a non-nil value, that value may be a function
2475 or a list of functions to be called to run the hook.
2476 If the value is a function, it is called with no arguments.
2477 If it is a list, the elements are called, in order, with no arguments.
2479 Major modes should not use this function directly to run their mode
2480 hook; they should use `run-mode-hooks' instead.
2482 Do not use `make-local-variable' to make a hook variable buffer-local.
2483 Instead, use `add-hook' and specify t for the LOCAL argument.
2484 usage: (run-hooks &rest HOOKS) */)
2485 (ptrdiff_t nargs
, Lisp_Object
*args
)
2489 for (i
= 0; i
< nargs
; i
++)
2495 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2496 Srun_hook_with_args
, 1, MANY
, 0,
2497 doc
: /* Run HOOK with the specified arguments ARGS.
2498 HOOK should be a symbol, a hook variable. The value of HOOK
2499 may be nil, a function, or a list of functions. Call each
2500 function in order with arguments ARGS. The final return value
2503 Do not use `make-local-variable' to make a hook variable buffer-local.
2504 Instead, use `add-hook' and specify t for the LOCAL argument.
2505 usage: (run-hook-with-args HOOK &rest ARGS) */)
2506 (ptrdiff_t nargs
, Lisp_Object
*args
)
2508 return run_hook_with_args (nargs
, args
, funcall_nil
);
2511 /* NB this one still documents a specific non-nil return value.
2512 (As did run-hook-with-args and run-hook-with-args-until-failure
2513 until they were changed in 24.1.) */
2514 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2515 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2516 doc
: /* Run HOOK with the specified arguments ARGS.
2517 HOOK should be a symbol, a hook variable. The value of HOOK
2518 may be nil, a function, or a list of functions. Call each
2519 function in order with arguments ARGS, stopping at the first
2520 one that returns non-nil, and return that value. Otherwise (if
2521 all functions return nil, or if there are no functions to call),
2524 Do not use `make-local-variable' to make a hook variable buffer-local.
2525 Instead, use `add-hook' and specify t for the LOCAL argument.
2526 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2527 (ptrdiff_t nargs
, Lisp_Object
*args
)
2529 return run_hook_with_args (nargs
, args
, Ffuncall
);
2533 funcall_not (ptrdiff_t nargs
, Lisp_Object
*args
)
2535 return NILP (Ffuncall (nargs
, args
)) ? Qt
: Qnil
;
2538 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2539 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2540 doc
: /* Run HOOK with the specified arguments ARGS.
2541 HOOK should be a symbol, a hook variable. The value of HOOK
2542 may be nil, a function, or a list of functions. Call each
2543 function in order with arguments ARGS, stopping at the first
2544 one that returns nil, and return nil. Otherwise (if all functions
2545 return non-nil, or if there are no functions to call), return non-nil
2546 \(do not rely on the precise return value in this case).
2548 Do not use `make-local-variable' to make a hook variable buffer-local.
2549 Instead, use `add-hook' and specify t for the LOCAL argument.
2550 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2551 (ptrdiff_t nargs
, Lisp_Object
*args
)
2553 return NILP (run_hook_with_args (nargs
, args
, funcall_not
)) ? Qt
: Qnil
;
2557 run_hook_wrapped_funcall (ptrdiff_t nargs
, Lisp_Object
*args
)
2559 Lisp_Object tmp
= args
[0], ret
;
2562 ret
= Ffuncall (nargs
, args
);
2568 DEFUN ("run-hook-wrapped", Frun_hook_wrapped
, Srun_hook_wrapped
, 2, MANY
, 0,
2569 doc
: /* Run HOOK, passing each function through WRAP-FUNCTION.
2570 I.e. instead of calling each function FUN directly with arguments ARGS,
2571 it calls WRAP-FUNCTION with arguments FUN and ARGS.
2572 As soon as a call to WRAP-FUNCTION returns non-nil, `run-hook-wrapped'
2573 aborts and returns that value.
2574 usage: (run-hook-wrapped HOOK WRAP-FUNCTION &rest ARGS) */)
2575 (ptrdiff_t nargs
, Lisp_Object
*args
)
2577 return run_hook_with_args (nargs
, args
, run_hook_wrapped_funcall
);
2580 /* ARGS[0] should be a hook symbol.
2581 Call each of the functions in the hook value, passing each of them
2582 as arguments all the rest of ARGS (all NARGS - 1 elements).
2583 FUNCALL specifies how to call each function on the hook. */
2586 run_hook_with_args (ptrdiff_t nargs
, Lisp_Object
*args
,
2587 Lisp_Object (*funcall
) (ptrdiff_t nargs
, Lisp_Object
*args
))
2589 Lisp_Object sym
, val
, ret
= Qnil
;
2591 /* If we are dying or still initializing,
2592 don't do anything--it would probably crash if we tried. */
2593 if (NILP (Vrun_hooks
))
2597 val
= find_symbol_value (sym
);
2599 if (EQ (val
, Qunbound
) || NILP (val
))
2601 else if (!CONSP (val
) || FUNCTIONP (val
))
2604 return funcall (nargs
, args
);
2608 Lisp_Object global_vals
= Qnil
;
2611 CONSP (val
) && NILP (ret
);
2614 if (EQ (XCAR (val
), Qt
))
2616 /* t indicates this hook has a local binding;
2617 it means to run the global binding too. */
2618 global_vals
= Fdefault_value (sym
);
2619 if (NILP (global_vals
)) continue;
2621 if (!CONSP (global_vals
) || EQ (XCAR (global_vals
), Qlambda
))
2623 args
[0] = global_vals
;
2624 ret
= funcall (nargs
, args
);
2629 CONSP (global_vals
) && NILP (ret
);
2630 global_vals
= XCDR (global_vals
))
2632 args
[0] = XCAR (global_vals
);
2633 /* In a global value, t should not occur. If it does, we
2634 must ignore it to avoid an endless loop. */
2635 if (!EQ (args
[0], Qt
))
2636 ret
= funcall (nargs
, args
);
2642 args
[0] = XCAR (val
);
2643 ret
= funcall (nargs
, args
);
2651 /* Run the hook HOOK, giving each function no args. */
2654 run_hook (Lisp_Object hook
)
2656 Frun_hook_with_args (1, &hook
);
2659 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2662 run_hook_with_args_2 (Lisp_Object hook
, Lisp_Object arg1
, Lisp_Object arg2
)
2664 CALLN (Frun_hook_with_args
, hook
, arg1
, arg2
);
2667 /* Apply fn to arg. */
2669 apply1 (Lisp_Object fn
, Lisp_Object arg
)
2671 return NILP (arg
) ? Ffuncall (1, &fn
) : CALLN (Fapply
, fn
, arg
);
2674 /* Call function fn on no arguments. */
2676 call0 (Lisp_Object fn
)
2678 return Ffuncall (1, &fn
);
2681 /* Call function fn with 1 argument arg1. */
2684 call1 (Lisp_Object fn
, Lisp_Object arg1
)
2686 return CALLN (Ffuncall
, fn
, arg1
);
2689 /* Call function fn with 2 arguments arg1, arg2. */
2692 call2 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
)
2694 return CALLN (Ffuncall
, fn
, arg1
, arg2
);
2697 /* Call function fn with 3 arguments arg1, arg2, arg3. */
2700 call3 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2702 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
);
2705 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
2708 call4 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2711 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
);
2714 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
2717 call5 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2718 Lisp_Object arg4
, Lisp_Object arg5
)
2720 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
);
2723 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
2726 call6 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2727 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
)
2729 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
);
2732 /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
2735 call7 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2736 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
)
2738 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
);
2741 /* Call function fn with 8 arguments arg1, arg2, arg3, arg4, arg5,
2742 arg6, arg7, arg8. */
2745 call8 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2746 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
,
2749 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
, arg8
);
2752 DEFUN ("functionp", Ffunctionp
, Sfunctionp
, 1, 1, 0,
2753 doc
: /* Return t if OBJECT is a function. */)
2754 (Lisp_Object object
)
2756 if (FUNCTIONP (object
))
2762 FUNCTIONP (Lisp_Object object
)
2764 if (SYMBOLP (object
) && !NILP (Ffboundp (object
)))
2766 object
= Findirect_function (object
, Qt
);
2768 if (CONSP (object
) && EQ (XCAR (object
), Qautoload
))
2770 /* Autoloaded symbols are functions, except if they load
2771 macros or keymaps. */
2772 for (int i
= 0; i
< 4 && CONSP (object
); i
++)
2773 object
= XCDR (object
);
2775 return ! (CONSP (object
) && !NILP (XCAR (object
)));
2780 return XSUBR (object
)->max_args
!= UNEVALLED
;
2781 else if (COMPILEDP (object
) || MODULE_FUNCTIONP (object
))
2783 else if (CONSP (object
))
2785 Lisp_Object car
= XCAR (object
);
2786 return EQ (car
, Qlambda
) || EQ (car
, Qclosure
);
2792 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2793 doc
: /* Call first argument as a function, passing remaining arguments to it.
2794 Return the value that function returns.
2795 Thus, (funcall \\='cons \\='x \\='y) returns (x . y).
2796 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2797 (ptrdiff_t nargs
, Lisp_Object
*args
)
2799 Lisp_Object fun
, original_fun
;
2801 ptrdiff_t numargs
= nargs
- 1;
2807 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2809 if (max_lisp_eval_depth
< 100)
2810 max_lisp_eval_depth
= 100;
2811 if (lisp_eval_depth
> max_lisp_eval_depth
)
2812 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2815 count
= record_in_backtrace (args
[0], &args
[1], nargs
- 1);
2819 if (debug_on_next_call
)
2820 do_debug_on_call (Qlambda
, count
);
2824 original_fun
= args
[0];
2828 /* Optimize for no indirection. */
2830 if (SYMBOLP (fun
) && !NILP (fun
)
2831 && (fun
= XSYMBOL (fun
)->u
.s
.function
, SYMBOLP (fun
)))
2832 fun
= indirect_function (fun
);
2835 val
= funcall_subr (XSUBR (fun
), numargs
, args
+ 1);
2836 else if (COMPILEDP (fun
) || MODULE_FUNCTIONP (fun
))
2837 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2841 xsignal1 (Qvoid_function
, original_fun
);
2843 xsignal1 (Qinvalid_function
, original_fun
);
2844 funcar
= XCAR (fun
);
2845 if (!SYMBOLP (funcar
))
2846 xsignal1 (Qinvalid_function
, original_fun
);
2847 if (EQ (funcar
, Qlambda
)
2848 || EQ (funcar
, Qclosure
))
2849 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2850 else if (EQ (funcar
, Qautoload
))
2852 Fautoload_do_load (fun
, original_fun
, Qnil
);
2857 xsignal1 (Qinvalid_function
, original_fun
);
2861 if (backtrace_debug_on_exit (specpdl
+ count
))
2862 val
= call_debugger (list2 (Qexit
, val
));
2868 /* Apply a C subroutine SUBR to the NUMARGS evaluated arguments in ARG_VECTOR
2869 and return the result of evaluation. */
2872 funcall_subr (struct Lisp_Subr
*subr
, ptrdiff_t numargs
, Lisp_Object
*args
)
2874 if (numargs
< subr
->min_args
2875 || (subr
->max_args
>= 0 && subr
->max_args
< numargs
))
2878 XSETSUBR (fun
, subr
);
2879 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (numargs
));
2882 else if (subr
->max_args
== UNEVALLED
)
2885 XSETSUBR (fun
, subr
);
2886 xsignal1 (Qinvalid_function
, fun
);
2889 else if (subr
->max_args
== MANY
)
2890 return (subr
->function
.aMANY
) (numargs
, args
);
2893 Lisp_Object internal_argbuf
[8];
2894 Lisp_Object
*internal_args
;
2895 if (subr
->max_args
> numargs
)
2897 eassert (subr
->max_args
<= ARRAYELTS (internal_argbuf
));
2898 internal_args
= internal_argbuf
;
2899 memcpy (internal_args
, args
, numargs
* word_size
);
2900 memclear (internal_args
+ numargs
,
2901 (subr
->max_args
- numargs
) * word_size
);
2904 internal_args
= args
;
2905 switch (subr
->max_args
)
2908 return (subr
->function
.a0 ());
2910 return (subr
->function
.a1 (internal_args
[0]));
2912 return (subr
->function
.a2
2913 (internal_args
[0], internal_args
[1]));
2915 return (subr
->function
.a3
2916 (internal_args
[0], internal_args
[1], internal_args
[2]));
2918 return (subr
->function
.a4
2919 (internal_args
[0], internal_args
[1], internal_args
[2],
2922 return (subr
->function
.a5
2923 (internal_args
[0], internal_args
[1], internal_args
[2],
2924 internal_args
[3], internal_args
[4]));
2926 return (subr
->function
.a6
2927 (internal_args
[0], internal_args
[1], internal_args
[2],
2928 internal_args
[3], internal_args
[4], internal_args
[5]));
2930 return (subr
->function
.a7
2931 (internal_args
[0], internal_args
[1], internal_args
[2],
2932 internal_args
[3], internal_args
[4], internal_args
[5],
2935 return (subr
->function
.a8
2936 (internal_args
[0], internal_args
[1], internal_args
[2],
2937 internal_args
[3], internal_args
[4], internal_args
[5],
2938 internal_args
[6], internal_args
[7]));
2942 /* If a subr takes more than 8 arguments without using MANY
2943 or UNEVALLED, we need to extend this function to support it.
2944 Until this is done, there is no way to call the function. */
2951 apply_lambda (Lisp_Object fun
, Lisp_Object args
, ptrdiff_t count
)
2953 Lisp_Object args_left
;
2956 Lisp_Object
*arg_vector
;
2960 numargs
= XFASTINT (Flength (args
));
2961 SAFE_ALLOCA_LISP (arg_vector
, numargs
);
2964 for (i
= 0; i
< numargs
; )
2966 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2967 tem
= eval_sub (tem
);
2968 arg_vector
[i
++] = tem
;
2971 set_backtrace_args (specpdl
+ count
, arg_vector
, i
);
2972 tem
= funcall_lambda (fun
, numargs
, arg_vector
);
2976 /* Do the debug-on-exit now, while arg_vector still exists. */
2977 if (backtrace_debug_on_exit (specpdl
+ count
))
2978 tem
= call_debugger (list2 (Qexit
, tem
));
2984 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2985 and return the result of evaluation.
2986 FUN must be either a lambda-expression, a compiled-code object,
2987 or a module function. */
2990 funcall_lambda (Lisp_Object fun
, ptrdiff_t nargs
,
2991 register Lisp_Object
*arg_vector
)
2993 Lisp_Object val
, syms_left
, next
, lexenv
;
2994 ptrdiff_t count
= SPECPDL_INDEX ();
2996 bool optional
, rest
;
3000 if (EQ (XCAR (fun
), Qclosure
))
3002 Lisp_Object cdr
= XCDR (fun
); /* Drop `closure'. */
3004 xsignal1 (Qinvalid_function
, fun
);
3006 lexenv
= XCAR (fun
);
3010 syms_left
= XCDR (fun
);
3011 if (CONSP (syms_left
))
3012 syms_left
= XCAR (syms_left
);
3014 xsignal1 (Qinvalid_function
, fun
);
3016 else if (COMPILEDP (fun
))
3018 ptrdiff_t size
= PVSIZE (fun
);
3019 if (size
<= COMPILED_STACK_DEPTH
)
3020 xsignal1 (Qinvalid_function
, fun
);
3021 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3022 if (INTEGERP (syms_left
))
3023 /* A byte-code object with an integer args template means we
3024 shouldn't bind any arguments, instead just call the byte-code
3025 interpreter directly; it will push arguments as necessary.
3027 Byte-code objects with a nil args template (the default)
3028 have dynamically-bound arguments, and use the
3029 argument-binding code below instead (as do all interpreted
3030 functions, even lexically bound ones). */
3032 /* If we have not actually read the bytecode string
3033 and constants vector yet, fetch them from the file. */
3034 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3035 Ffetch_bytecode (fun
);
3036 return exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
3037 AREF (fun
, COMPILED_CONSTANTS
),
3038 AREF (fun
, COMPILED_STACK_DEPTH
),
3045 else if (MODULE_FUNCTIONP (fun
))
3046 return funcall_module (fun
, nargs
, arg_vector
);
3051 i
= optional
= rest
= 0;
3052 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3056 next
= XCAR (syms_left
);
3057 if (!SYMBOLP (next
))
3058 xsignal1 (Qinvalid_function
, fun
);
3060 if (EQ (next
, Qand_rest
))
3063 xsignal1 (Qinvalid_function
, fun
);
3066 else if (EQ (next
, Qand_optional
))
3068 if (optional
|| rest
)
3069 xsignal1 (Qinvalid_function
, fun
);
3077 arg
= Flist (nargs
- i
, &arg_vector
[i
]);
3081 arg
= arg_vector
[i
++];
3083 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3087 /* Bind the argument. */
3088 if (!NILP (lexenv
) && SYMBOLP (next
))
3089 /* Lexically bind NEXT by adding it to the lexenv alist. */
3090 lexenv
= Fcons (Fcons (next
, arg
), lexenv
);
3092 /* Dynamically bind NEXT. */
3093 specbind (next
, arg
);
3097 if (!NILP (syms_left
))
3098 xsignal1 (Qinvalid_function
, fun
);
3100 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3102 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
3103 /* Instantiate a new lexical environment. */
3104 specbind (Qinternal_interpreter_environment
, lexenv
);
3107 val
= Fprogn (XCDR (XCDR (fun
)));
3110 /* If we have not actually read the bytecode string
3111 and constants vector yet, fetch them from the file. */
3112 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3113 Ffetch_bytecode (fun
);
3114 val
= exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
3115 AREF (fun
, COMPILED_CONSTANTS
),
3116 AREF (fun
, COMPILED_STACK_DEPTH
),
3120 return unbind_to (count
, val
);
3123 DEFUN ("func-arity", Ffunc_arity
, Sfunc_arity
, 1, 1, 0,
3124 doc
: /* Return minimum and maximum number of args allowed for FUNCTION.
3125 FUNCTION must be a function of some kind.
3126 The returned value is a cons cell (MIN . MAX). MIN is the minimum number
3127 of args. MAX is the maximum number, or the symbol `many', for a
3128 function with `&rest' args, or `unevalled' for a special form. */)
3129 (Lisp_Object function
)
3131 Lisp_Object original
;
3135 original
= function
;
3139 /* Optimize for no indirection. */
3140 function
= original
;
3141 if (SYMBOLP (function
) && !NILP (function
))
3143 function
= XSYMBOL (function
)->u
.s
.function
;
3144 if (SYMBOLP (function
))
3145 function
= indirect_function (function
);
3148 if (CONSP (function
) && EQ (XCAR (function
), Qmacro
))
3149 function
= XCDR (function
);
3151 if (SUBRP (function
))
3152 result
= Fsubr_arity (function
);
3153 else if (COMPILEDP (function
))
3154 result
= lambda_arity (function
);
3156 else if (MODULE_FUNCTIONP (function
))
3157 result
= module_function_arity (XMODULE_FUNCTION (function
));
3161 if (NILP (function
))
3162 xsignal1 (Qvoid_function
, original
);
3163 if (!CONSP (function
))
3164 xsignal1 (Qinvalid_function
, original
);
3165 funcar
= XCAR (function
);
3166 if (!SYMBOLP (funcar
))
3167 xsignal1 (Qinvalid_function
, original
);
3168 if (EQ (funcar
, Qlambda
)
3169 || EQ (funcar
, Qclosure
))
3170 result
= lambda_arity (function
);
3171 else if (EQ (funcar
, Qautoload
))
3173 Fautoload_do_load (function
, original
, Qnil
);
3177 xsignal1 (Qinvalid_function
, original
);
3182 /* FUN must be either a lambda-expression or a compiled-code object. */
3184 lambda_arity (Lisp_Object fun
)
3186 Lisp_Object syms_left
;
3190 if (EQ (XCAR (fun
), Qclosure
))
3192 fun
= XCDR (fun
); /* Drop `closure'. */
3195 syms_left
= XCDR (fun
);
3196 if (CONSP (syms_left
))
3197 syms_left
= XCAR (syms_left
);
3199 xsignal1 (Qinvalid_function
, fun
);
3201 else if (COMPILEDP (fun
))
3203 ptrdiff_t size
= PVSIZE (fun
);
3204 if (size
<= COMPILED_STACK_DEPTH
)
3205 xsignal1 (Qinvalid_function
, fun
);
3206 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3207 if (INTEGERP (syms_left
))
3208 return get_byte_code_arity (syms_left
);
3213 EMACS_INT minargs
= 0, maxargs
= 0;
3214 bool optional
= false;
3215 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3217 Lisp_Object next
= XCAR (syms_left
);
3218 if (!SYMBOLP (next
))
3219 xsignal1 (Qinvalid_function
, fun
);
3221 if (EQ (next
, Qand_rest
))
3222 return Fcons (make_number (minargs
), Qmany
);
3223 else if (EQ (next
, Qand_optional
))
3233 if (!NILP (syms_left
))
3234 xsignal1 (Qinvalid_function
, fun
);
3236 return Fcons (make_number (minargs
), make_number (maxargs
));
3239 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3241 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3242 (Lisp_Object object
)
3246 if (COMPILEDP (object
))
3248 ptrdiff_t size
= PVSIZE (object
);
3249 if (size
<= COMPILED_STACK_DEPTH
)
3250 xsignal1 (Qinvalid_function
, object
);
3251 if (CONSP (AREF (object
, COMPILED_BYTECODE
)))
3253 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3256 tem
= AREF (object
, COMPILED_BYTECODE
);
3257 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3258 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3260 error ("Invalid byte code");
3262 ASET (object
, COMPILED_BYTECODE
, XCAR (tem
));
3263 ASET (object
, COMPILED_CONSTANTS
, XCDR (tem
));
3269 /* Return true if SYMBOL currently has a let-binding
3270 which was made in the buffer that is now current. */
3273 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
3275 union specbinding
*p
;
3276 Lisp_Object buf
= Fcurrent_buffer ();
3278 for (p
= specpdl_ptr
; p
> specpdl
; )
3279 if ((--p
)->kind
> SPECPDL_LET
)
3281 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (specpdl_symbol (p
));
3282 eassert (let_bound_symbol
->u
.s
.redirect
!= SYMBOL_VARALIAS
);
3283 if (symbol
== let_bound_symbol
3284 && EQ (specpdl_where (p
), buf
))
3292 do_specbind (struct Lisp_Symbol
*sym
, union specbinding
*bind
,
3293 Lisp_Object value
, enum Set_Internal_Bind bindflag
)
3295 switch (sym
->u
.s
.redirect
)
3297 case SYMBOL_PLAINVAL
:
3298 if (!sym
->u
.s
.trapped_write
)
3299 SET_SYMBOL_VAL (sym
, value
);
3301 set_internal (specpdl_symbol (bind
), value
, Qnil
, bindflag
);
3304 case SYMBOL_FORWARDED
:
3305 if (BUFFER_OBJFWDP (SYMBOL_FWD (sym
))
3306 && specpdl_kind (bind
) == SPECPDL_LET_DEFAULT
)
3308 set_default_internal (specpdl_symbol (bind
), value
, bindflag
);
3312 case SYMBOL_LOCALIZED
:
3313 set_internal (specpdl_symbol (bind
), value
, Qnil
, bindflag
);
3321 /* `specpdl_ptr' describes which variable is
3322 let-bound, so it can be properly undone when we unbind_to.
3323 It can be either a plain SPECPDL_LET or a SPECPDL_LET_LOCAL/DEFAULT.
3324 - SYMBOL is the variable being bound. Note that it should not be
3325 aliased (i.e. when let-binding V1 that's aliased to V2, we want
3327 - WHERE tells us in which buffer the binding took place.
3328 This is used for SPECPDL_LET_LOCAL bindings (i.e. bindings to a
3329 buffer-local variable) as well as for SPECPDL_LET_DEFAULT bindings,
3330 i.e. bindings to the default value of a variable which can be
3334 specbind (Lisp_Object symbol
, Lisp_Object value
)
3336 struct Lisp_Symbol
*sym
;
3338 CHECK_SYMBOL (symbol
);
3339 sym
= XSYMBOL (symbol
);
3342 switch (sym
->u
.s
.redirect
)
3344 case SYMBOL_VARALIAS
:
3345 sym
= indirect_variable (sym
); XSETSYMBOL (symbol
, sym
); goto start
;
3346 case SYMBOL_PLAINVAL
:
3347 /* The most common case is that of a non-constant symbol with a
3348 trivial value. Make that as fast as we can. */
3349 specpdl_ptr
->let
.kind
= SPECPDL_LET
;
3350 specpdl_ptr
->let
.symbol
= symbol
;
3351 specpdl_ptr
->let
.old_value
= SYMBOL_VAL (sym
);
3352 specpdl_ptr
->let
.saved_value
= Qnil
;
3354 do_specbind (sym
, specpdl_ptr
- 1, value
, SET_INTERNAL_BIND
);
3356 case SYMBOL_LOCALIZED
:
3357 case SYMBOL_FORWARDED
:
3359 Lisp_Object ovalue
= find_symbol_value (symbol
);
3360 specpdl_ptr
->let
.kind
= SPECPDL_LET_LOCAL
;
3361 specpdl_ptr
->let
.symbol
= symbol
;
3362 specpdl_ptr
->let
.old_value
= ovalue
;
3363 specpdl_ptr
->let
.where
= Fcurrent_buffer ();
3364 specpdl_ptr
->let
.saved_value
= Qnil
;
3366 eassert (sym
->u
.s
.redirect
!= SYMBOL_LOCALIZED
3367 || (EQ (SYMBOL_BLV (sym
)->where
, Fcurrent_buffer ())));
3369 if (sym
->u
.s
.redirect
== SYMBOL_LOCALIZED
)
3371 if (!blv_found (SYMBOL_BLV (sym
)))
3372 specpdl_ptr
->let
.kind
= SPECPDL_LET_DEFAULT
;
3374 else if (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)))
3376 /* If SYMBOL is a per-buffer variable which doesn't have a
3377 buffer-local value here, make the `let' change the global
3378 value by changing the value of SYMBOL in all buffers not
3379 having their own value. This is consistent with what
3380 happens with other buffer-local variables. */
3381 if (NILP (Flocal_variable_p (symbol
, Qnil
)))
3383 specpdl_ptr
->let
.kind
= SPECPDL_LET_DEFAULT
;
3385 do_specbind (sym
, specpdl_ptr
- 1, value
, SET_INTERNAL_BIND
);
3390 specpdl_ptr
->let
.kind
= SPECPDL_LET
;
3393 do_specbind (sym
, specpdl_ptr
- 1, value
, SET_INTERNAL_BIND
);
3396 default: emacs_abort ();
3400 /* Push unwind-protect entries of various types. */
3403 record_unwind_protect (void (*function
) (Lisp_Object
), Lisp_Object arg
)
3405 specpdl_ptr
->unwind
.kind
= SPECPDL_UNWIND
;
3406 specpdl_ptr
->unwind
.func
= function
;
3407 specpdl_ptr
->unwind
.arg
= arg
;
3412 record_unwind_protect_array (Lisp_Object
*array
, ptrdiff_t nelts
)
3414 specpdl_ptr
->unwind_array
.kind
= SPECPDL_UNWIND_ARRAY
;
3415 specpdl_ptr
->unwind_array
.array
= array
;
3416 specpdl_ptr
->unwind_array
.nelts
= nelts
;
3421 record_unwind_protect_ptr (void (*function
) (void *), void *arg
)
3423 specpdl_ptr
->unwind_ptr
.kind
= SPECPDL_UNWIND_PTR
;
3424 specpdl_ptr
->unwind_ptr
.func
= function
;
3425 specpdl_ptr
->unwind_ptr
.arg
= arg
;
3430 record_unwind_protect_int (void (*function
) (int), int arg
)
3432 specpdl_ptr
->unwind_int
.kind
= SPECPDL_UNWIND_INT
;
3433 specpdl_ptr
->unwind_int
.func
= function
;
3434 specpdl_ptr
->unwind_int
.arg
= arg
;
3439 record_unwind_protect_excursion (void)
3441 specpdl_ptr
->unwind_excursion
.kind
= SPECPDL_UNWIND_EXCURSION
;
3442 save_excursion_save (specpdl_ptr
);
3447 record_unwind_protect_void (void (*function
) (void))
3449 specpdl_ptr
->unwind_void
.kind
= SPECPDL_UNWIND_VOID
;
3450 specpdl_ptr
->unwind_void
.func
= function
;
3455 rebind_for_thread_switch (void)
3457 union specbinding
*bind
;
3459 for (bind
= specpdl
; bind
!= specpdl_ptr
; ++bind
)
3461 if (bind
->kind
>= SPECPDL_LET
)
3463 Lisp_Object value
= specpdl_saved_value (bind
);
3464 Lisp_Object sym
= specpdl_symbol (bind
);
3465 bind
->let
.saved_value
= Qnil
;
3466 do_specbind (XSYMBOL (sym
), bind
, value
,
3467 SET_INTERNAL_THREAD_SWITCH
);
3473 do_one_unbind (union specbinding
*this_binding
, bool unwinding
,
3474 enum Set_Internal_Bind bindflag
)
3476 eassert (unwinding
|| this_binding
->kind
>= SPECPDL_LET
);
3477 switch (this_binding
->kind
)
3479 case SPECPDL_UNWIND
:
3480 this_binding
->unwind
.func (this_binding
->unwind
.arg
);
3482 case SPECPDL_UNWIND_ARRAY
:
3483 xfree (this_binding
->unwind_array
.array
);
3485 case SPECPDL_UNWIND_PTR
:
3486 this_binding
->unwind_ptr
.func (this_binding
->unwind_ptr
.arg
);
3488 case SPECPDL_UNWIND_INT
:
3489 this_binding
->unwind_int
.func (this_binding
->unwind_int
.arg
);
3491 case SPECPDL_UNWIND_VOID
:
3492 this_binding
->unwind_void
.func ();
3494 case SPECPDL_UNWIND_EXCURSION
:
3495 save_excursion_restore (this_binding
->unwind_excursion
.marker
,
3496 this_binding
->unwind_excursion
.window
);
3498 case SPECPDL_BACKTRACE
:
3501 { /* If variable has a trivial value (no forwarding), and isn't
3502 trapped, we can just set it. */
3503 Lisp_Object sym
= specpdl_symbol (this_binding
);
3504 if (SYMBOLP (sym
) && XSYMBOL (sym
)->u
.s
.redirect
== SYMBOL_PLAINVAL
)
3506 if (XSYMBOL (sym
)->u
.s
.trapped_write
== SYMBOL_UNTRAPPED_WRITE
)
3507 SET_SYMBOL_VAL (XSYMBOL (sym
), specpdl_old_value (this_binding
));
3509 set_internal (sym
, specpdl_old_value (this_binding
),
3514 /* Come here only if make_local_foo was used for the first time
3515 on this var within this let. */
3517 case SPECPDL_LET_DEFAULT
:
3518 set_default_internal (specpdl_symbol (this_binding
),
3519 specpdl_old_value (this_binding
),
3522 case SPECPDL_LET_LOCAL
:
3524 Lisp_Object symbol
= specpdl_symbol (this_binding
);
3525 Lisp_Object where
= specpdl_where (this_binding
);
3526 Lisp_Object old_value
= specpdl_old_value (this_binding
);
3527 eassert (BUFFERP (where
));
3529 /* If this was a local binding, reset the value in the appropriate
3530 buffer, but only if that buffer's binding still exists. */
3531 if (!NILP (Flocal_variable_p (symbol
, where
)))
3532 set_internal (symbol
, old_value
, where
, bindflag
);
3542 /* Push an unwind-protect entry that does nothing, so that
3543 set_unwind_protect_ptr can overwrite it later. */
3546 record_unwind_protect_nothing (void)
3548 record_unwind_protect_void (do_nothing
);
3551 /* Clear the unwind-protect entry COUNT, so that it does nothing.
3552 It need not be at the top of the stack. */
3555 clear_unwind_protect (ptrdiff_t count
)
3557 union specbinding
*p
= specpdl
+ count
;
3558 p
->unwind_void
.kind
= SPECPDL_UNWIND_VOID
;
3559 p
->unwind_void
.func
= do_nothing
;
3562 /* Set the unwind-protect entry COUNT so that it invokes FUNC (ARG).
3563 It need not be at the top of the stack. Discard the entry's
3564 previous value without invoking it. */
3567 set_unwind_protect (ptrdiff_t count
, void (*func
) (Lisp_Object
),
3570 union specbinding
*p
= specpdl
+ count
;
3571 p
->unwind
.kind
= SPECPDL_UNWIND
;
3572 p
->unwind
.func
= func
;
3573 p
->unwind
.arg
= arg
;
3577 set_unwind_protect_ptr (ptrdiff_t count
, void (*func
) (void *), void *arg
)
3579 union specbinding
*p
= specpdl
+ count
;
3580 p
->unwind_ptr
.kind
= SPECPDL_UNWIND_PTR
;
3581 p
->unwind_ptr
.func
= func
;
3582 p
->unwind_ptr
.arg
= arg
;
3585 /* Pop and execute entries from the unwind-protect stack until the
3586 depth COUNT is reached. Return VALUE. */
3589 unbind_to (ptrdiff_t count
, Lisp_Object value
)
3591 Lisp_Object quitf
= Vquit_flag
;
3595 while (specpdl_ptr
!= specpdl
+ count
)
3597 /* Copy the binding, and decrement specpdl_ptr, before we do
3598 the work to unbind it. We decrement first
3599 so that an error in unbinding won't try to unbind
3600 the same entry again, and we copy the binding first
3601 in case more bindings are made during some of the code we run. */
3603 union specbinding this_binding
;
3604 this_binding
= *--specpdl_ptr
;
3606 do_one_unbind (&this_binding
, true, SET_INTERNAL_UNBIND
);
3609 if (NILP (Vquit_flag
) && !NILP (quitf
))
3616 unbind_for_thread_switch (struct thread_state
*thr
)
3618 union specbinding
*bind
;
3620 for (bind
= thr
->m_specpdl_ptr
; bind
> thr
->m_specpdl
;)
3622 if ((--bind
)->kind
>= SPECPDL_LET
)
3624 Lisp_Object sym
= specpdl_symbol (bind
);
3625 bind
->let
.saved_value
= find_symbol_value (sym
);
3626 do_one_unbind (bind
, false, SET_INTERNAL_THREAD_SWITCH
);
3631 DEFUN ("special-variable-p", Fspecial_variable_p
, Sspecial_variable_p
, 1, 1, 0,
3632 doc
: /* Return non-nil if SYMBOL's global binding has been declared special.
3633 A special variable is one that will be bound dynamically, even in a
3634 context where binding is lexical by default. */)
3635 (Lisp_Object symbol
)
3637 CHECK_SYMBOL (symbol
);
3638 return XSYMBOL (symbol
)->u
.s
.declared_special
? Qt
: Qnil
;
3642 static union specbinding
*
3643 get_backtrace_starting_at (Lisp_Object base
)
3645 union specbinding
*pdl
= backtrace_top ();
3648 { /* Skip up to `base'. */
3649 base
= Findirect_function (base
, Qt
);
3650 while (backtrace_p (pdl
)
3651 && !EQ (base
, Findirect_function (backtrace_function (pdl
), Qt
)))
3652 pdl
= backtrace_next (pdl
);
3658 static union specbinding
*
3659 get_backtrace_frame (Lisp_Object nframes
, Lisp_Object base
)
3661 register EMACS_INT i
;
3663 CHECK_NATNUM (nframes
);
3664 union specbinding
*pdl
= get_backtrace_starting_at (base
);
3666 /* Find the frame requested. */
3667 for (i
= XFASTINT (nframes
); i
> 0 && backtrace_p (pdl
); i
--)
3668 pdl
= backtrace_next (pdl
);
3674 backtrace_frame_apply (Lisp_Object function
, union specbinding
*pdl
)
3676 if (!backtrace_p (pdl
))
3679 Lisp_Object flags
= Qnil
;
3680 if (backtrace_debug_on_exit (pdl
))
3681 flags
= Fcons (QCdebug_on_exit
, Fcons (Qt
, Qnil
));
3683 if (backtrace_nargs (pdl
) == UNEVALLED
)
3684 return call4 (function
, Qnil
, backtrace_function (pdl
), *backtrace_args (pdl
), flags
);
3687 Lisp_Object tem
= Flist (backtrace_nargs (pdl
), backtrace_args (pdl
));
3688 return call4 (function
, Qt
, backtrace_function (pdl
), tem
, flags
);
3692 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3693 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3694 The debugger is entered when that frame exits, if the flag is non-nil. */)
3695 (Lisp_Object level
, Lisp_Object flag
)
3697 CHECK_NUMBER (level
);
3698 union specbinding
*pdl
= get_backtrace_frame(level
, Qnil
);
3700 if (backtrace_p (pdl
))
3701 set_backtrace_debug_on_exit (pdl
, !NILP (flag
));
3706 DEFUN ("mapbacktrace", Fmapbacktrace
, Smapbacktrace
, 1, 2, 0,
3707 doc
: /* Call FUNCTION for each frame in backtrace.
3708 If BASE is non-nil, it should be a function and iteration will start
3709 from its nearest activation frame.
3710 FUNCTION is called with 4 arguments: EVALD, FUNC, ARGS, and FLAGS. If
3711 a frame has not evaluated its arguments yet or is a special form,
3712 EVALD is nil and ARGS is a list of forms. If a frame has evaluated
3713 its arguments and called its function already, EVALD is t and ARGS is
3715 FLAGS is a plist of properties of the current frame: currently, the
3716 only supported property is :debug-on-exit. `mapbacktrace' always
3718 (Lisp_Object function
, Lisp_Object base
)
3720 union specbinding
*pdl
= get_backtrace_starting_at (base
);
3722 while (backtrace_p (pdl
))
3724 ptrdiff_t i
= pdl
- specpdl
;
3725 backtrace_frame_apply (function
, pdl
);
3726 /* Beware! PDL is no longer valid here because FUNCTION might
3727 have caused grow_specpdl to reallocate pdlvec. We must use
3728 the saved index, cf. Bug#27258. */
3729 pdl
= backtrace_next (&specpdl
[i
]);
3735 DEFUN ("backtrace-frame--internal", Fbacktrace_frame_internal
,
3736 Sbacktrace_frame_internal
, 3, 3, NULL
,
3737 doc
: /* Call FUNCTION on stack frame NFRAMES away from BASE.
3738 Return the result of FUNCTION, or nil if no matching frame could be found. */)
3739 (Lisp_Object function
, Lisp_Object nframes
, Lisp_Object base
)
3741 return backtrace_frame_apply (function
, get_backtrace_frame (nframes
, base
));
3744 /* For backtrace-eval, we want to temporarily unwind the last few elements of
3745 the specpdl stack, and then rewind them. We store the pre-unwind values
3746 directly in the pre-existing specpdl elements (i.e. we swap the current
3747 value and the old value stored in the specpdl), kind of like the inplace
3748 pointer-reversal trick. As it turns out, the rewind does the same as the
3749 unwind, except it starts from the other end of the specpdl stack, so we use
3750 the same function for both unwind and rewind. */
3752 backtrace_eval_unrewind (int distance
)
3754 union specbinding
*tmp
= specpdl_ptr
;
3757 { /* It's a rewind rather than unwind. */
3758 tmp
+= distance
- 1;
3760 distance
= -distance
;
3763 for (; distance
> 0; distance
--)
3768 /* FIXME: Ideally we'd like to "temporarily unwind" (some of) those
3769 unwind_protect, but the problem is that we don't know how to
3770 rewind them afterwards. */
3771 case SPECPDL_UNWIND
:
3772 if (tmp
->unwind
.func
== set_buffer_if_live
)
3774 Lisp_Object oldarg
= tmp
->unwind
.arg
;
3775 tmp
->unwind
.arg
= Fcurrent_buffer ();
3776 set_buffer_if_live (oldarg
);
3779 case SPECPDL_UNWIND_EXCURSION
:
3781 Lisp_Object marker
= tmp
->unwind_excursion
.marker
;
3782 Lisp_Object window
= tmp
->unwind_excursion
.window
;
3783 save_excursion_save (tmp
);
3784 save_excursion_restore (marker
, window
);
3787 case SPECPDL_UNWIND_ARRAY
:
3788 case SPECPDL_UNWIND_PTR
:
3789 case SPECPDL_UNWIND_INT
:
3790 case SPECPDL_UNWIND_VOID
:
3791 case SPECPDL_BACKTRACE
:
3794 { /* If variable has a trivial value (no forwarding), we can
3795 just set it. No need to check for constant symbols here,
3796 since that was already done by specbind. */
3797 Lisp_Object sym
= specpdl_symbol (tmp
);
3799 && XSYMBOL (sym
)->u
.s
.redirect
== SYMBOL_PLAINVAL
)
3801 Lisp_Object old_value
= specpdl_old_value (tmp
);
3802 set_specpdl_old_value (tmp
, SYMBOL_VAL (XSYMBOL (sym
)));
3803 SET_SYMBOL_VAL (XSYMBOL (sym
), old_value
);
3807 /* Come here only if make_local_foo was used for the first
3808 time on this var within this let. */
3810 case SPECPDL_LET_DEFAULT
:
3812 Lisp_Object sym
= specpdl_symbol (tmp
);
3813 Lisp_Object old_value
= specpdl_old_value (tmp
);
3814 set_specpdl_old_value (tmp
, Fdefault_value (sym
));
3815 Fset_default (sym
, old_value
);
3818 case SPECPDL_LET_LOCAL
:
3820 Lisp_Object symbol
= specpdl_symbol (tmp
);
3821 Lisp_Object where
= specpdl_where (tmp
);
3822 Lisp_Object old_value
= specpdl_old_value (tmp
);
3823 eassert (BUFFERP (where
));
3825 /* If this was a local binding, reset the value in the appropriate
3826 buffer, but only if that buffer's binding still exists. */
3827 if (!NILP (Flocal_variable_p (symbol
, where
)))
3829 set_specpdl_old_value
3830 (tmp
, Fbuffer_local_value (symbol
, where
));
3831 set_internal (symbol
, old_value
, where
, SET_INTERNAL_UNBIND
);
3839 DEFUN ("backtrace-eval", Fbacktrace_eval
, Sbacktrace_eval
, 2, 3, NULL
,
3840 doc
: /* Evaluate EXP in the context of some activation frame.
3841 NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */)
3842 (Lisp_Object exp
, Lisp_Object nframes
, Lisp_Object base
)
3844 union specbinding
*pdl
= get_backtrace_frame (nframes
, base
);
3845 ptrdiff_t count
= SPECPDL_INDEX ();
3846 ptrdiff_t distance
= specpdl_ptr
- pdl
;
3847 eassert (distance
>= 0);
3849 if (!backtrace_p (pdl
))
3850 error ("Activation frame not found!");
3852 backtrace_eval_unrewind (distance
);
3853 record_unwind_protect_int (backtrace_eval_unrewind
, -distance
);
3855 /* Use eval_sub rather than Feval since the main motivation behind
3856 backtrace-eval is to be able to get/set the value of lexical variables
3857 from the debugger. */
3858 return unbind_to (count
, eval_sub (exp
));
3861 DEFUN ("backtrace--locals", Fbacktrace__locals
, Sbacktrace__locals
, 1, 2, NULL
,
3862 doc
: /* Return names and values of local variables of a stack frame.
3863 NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */)
3864 (Lisp_Object nframes
, Lisp_Object base
)
3866 union specbinding
*frame
= get_backtrace_frame (nframes
, base
);
3867 union specbinding
*prevframe
3868 = get_backtrace_frame (make_number (XFASTINT (nframes
) - 1), base
);
3869 ptrdiff_t distance
= specpdl_ptr
- frame
;
3870 Lisp_Object result
= Qnil
;
3871 eassert (distance
>= 0);
3873 if (!backtrace_p (prevframe
))
3874 error ("Activation frame not found!");
3875 if (!backtrace_p (frame
))
3876 error ("Activation frame not found!");
3878 /* The specpdl entries normally contain the symbol being bound along with its
3879 `old_value', so it can be restored. The new value to which it is bound is
3880 available in one of two places: either in the current value of the
3881 variable (if it hasn't been rebound yet) or in the `old_value' slot of the
3882 next specpdl entry for it.
3883 `backtrace_eval_unrewind' happens to swap the role of `old_value'
3884 and "new value", so we abuse it here, to fetch the new value.
3885 It's ugly (we'd rather not modify global data) and a bit inefficient,
3886 but it does the job for now. */
3887 backtrace_eval_unrewind (distance
);
3891 union specbinding
*tmp
= prevframe
;
3892 for (; tmp
> frame
; tmp
--)
3897 case SPECPDL_LET_DEFAULT
:
3898 case SPECPDL_LET_LOCAL
:
3900 Lisp_Object sym
= specpdl_symbol (tmp
);
3901 Lisp_Object val
= specpdl_old_value (tmp
);
3902 if (EQ (sym
, Qinternal_interpreter_environment
))
3904 Lisp_Object env
= val
;
3905 for (; CONSP (env
); env
= XCDR (env
))
3907 Lisp_Object binding
= XCAR (env
);
3908 if (CONSP (binding
))
3909 result
= Fcons (Fcons (XCAR (binding
),
3915 result
= Fcons (Fcons (sym
, val
), result
);
3919 case SPECPDL_UNWIND
:
3920 case SPECPDL_UNWIND_ARRAY
:
3921 case SPECPDL_UNWIND_PTR
:
3922 case SPECPDL_UNWIND_INT
:
3923 case SPECPDL_UNWIND_EXCURSION
:
3924 case SPECPDL_UNWIND_VOID
:
3925 case SPECPDL_BACKTRACE
:
3934 /* Restore values from specpdl to original place. */
3935 backtrace_eval_unrewind (-distance
);
3942 mark_specpdl (union specbinding
*first
, union specbinding
*ptr
)
3944 union specbinding
*pdl
;
3945 for (pdl
= first
; pdl
!= ptr
; pdl
++)
3949 case SPECPDL_UNWIND
:
3950 mark_object (specpdl_arg (pdl
));
3953 case SPECPDL_UNWIND_ARRAY
:
3954 mark_maybe_objects (pdl
->unwind_array
.array
, pdl
->unwind_array
.nelts
);
3957 case SPECPDL_UNWIND_EXCURSION
:
3958 mark_object (pdl
->unwind_excursion
.marker
);
3959 mark_object (pdl
->unwind_excursion
.window
);
3962 case SPECPDL_BACKTRACE
:
3964 ptrdiff_t nargs
= backtrace_nargs (pdl
);
3965 mark_object (backtrace_function (pdl
));
3966 if (nargs
== UNEVALLED
)
3969 mark_object (backtrace_args (pdl
)[nargs
]);
3973 case SPECPDL_LET_DEFAULT
:
3974 case SPECPDL_LET_LOCAL
:
3975 mark_object (specpdl_where (pdl
));
3978 mark_object (specpdl_symbol (pdl
));
3979 mark_object (specpdl_old_value (pdl
));
3980 mark_object (specpdl_saved_value (pdl
));
3983 case SPECPDL_UNWIND_PTR
:
3984 case SPECPDL_UNWIND_INT
:
3985 case SPECPDL_UNWIND_VOID
:
3995 get_backtrace (Lisp_Object array
)
3997 union specbinding
*pdl
= backtrace_next (backtrace_top ());
3998 ptrdiff_t i
= 0, asize
= ASIZE (array
);
4000 /* Copy the backtrace contents into working memory. */
4001 for (; i
< asize
; i
++)
4003 if (backtrace_p (pdl
))
4005 ASET (array
, i
, backtrace_function (pdl
));
4006 pdl
= backtrace_next (pdl
);
4009 ASET (array
, i
, Qnil
);
4013 Lisp_Object
backtrace_top_function (void)
4015 union specbinding
*pdl
= backtrace_top ();
4016 return (backtrace_p (pdl
) ? backtrace_function (pdl
) : Qnil
);
4022 DEFVAR_INT ("max-specpdl-size", max_specpdl_size
,
4023 doc
: /* Limit on number of Lisp variable bindings and `unwind-protect's.
4024 If Lisp code tries to increase the total number past this amount,
4025 an error is signaled.
4026 You can safely use a value considerably larger than the default value,
4027 if that proves inconveniently small. However, if you increase it too far,
4028 Emacs could run out of memory trying to make the stack bigger.
4029 Note that this limit may be silently increased by the debugger
4030 if `debug-on-error' or `debug-on-quit' is set. */);
4032 DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth
,
4033 doc
: /* Limit on depth in `eval', `apply' and `funcall' before error.
4035 This limit serves to catch infinite recursions for you before they cause
4036 actual stack overflow in C, which would be fatal for Emacs.
4037 You can safely make it considerably larger than its default value,
4038 if that proves inconveniently small. However, if you increase it too far,
4039 Emacs could overflow the real C stack, and crash. */);
4041 DEFVAR_LISP ("quit-flag", Vquit_flag
,
4042 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
4043 If the value is t, that means do an ordinary quit.
4044 If the value equals `throw-on-input', that means quit by throwing
4045 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
4046 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
4047 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
4050 DEFVAR_LISP ("inhibit-quit", Vinhibit_quit
,
4051 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
4052 Note that `quit-flag' will still be set by typing C-g,
4053 so a quit will be signaled as soon as `inhibit-quit' is nil.
4054 To prevent this happening, set `quit-flag' to nil
4055 before making `inhibit-quit' nil. */);
4056 Vinhibit_quit
= Qnil
;
4058 DEFSYM (Qsetq
, "setq");
4059 DEFSYM (Qinhibit_quit
, "inhibit-quit");
4060 DEFSYM (Qautoload
, "autoload");
4061 DEFSYM (Qinhibit_debugger
, "inhibit-debugger");
4062 DEFSYM (Qmacro
, "macro");
4064 /* Note that the process handling also uses Qexit, but we don't want
4065 to staticpro it twice, so we just do it here. */
4066 DEFSYM (Qexit
, "exit");
4068 DEFSYM (Qinteractive
, "interactive");
4069 DEFSYM (Qcommandp
, "commandp");
4070 DEFSYM (Qand_rest
, "&rest");
4071 DEFSYM (Qand_optional
, "&optional");
4072 DEFSYM (Qclosure
, "closure");
4073 DEFSYM (QCdocumentation
, ":documentation");
4074 DEFSYM (Qdebug
, "debug");
4076 DEFVAR_LISP ("inhibit-debugger", Vinhibit_debugger
,
4077 doc
: /* Non-nil means never enter the debugger.
4078 Normally set while the debugger is already active, to avoid recursive
4080 Vinhibit_debugger
= Qnil
;
4082 DEFVAR_LISP ("debug-on-error", Vdebug_on_error
,
4083 doc
: /* Non-nil means enter debugger if an error is signaled.
4084 Does not apply to errors handled by `condition-case' or those
4085 matched by `debug-ignored-errors'.
4086 If the value is a list, an error only means to enter the debugger
4087 if one of its condition symbols appears in the list.
4088 When you evaluate an expression interactively, this variable
4089 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
4090 The command `toggle-debug-on-error' toggles this.
4091 See also the variable `debug-on-quit' and `inhibit-debugger'. */);
4092 Vdebug_on_error
= Qnil
;
4094 DEFVAR_LISP ("debug-ignored-errors", Vdebug_ignored_errors
,
4095 doc
: /* List of errors for which the debugger should not be called.
4096 Each element may be a condition-name or a regexp that matches error messages.
4097 If any element applies to a given error, that error skips the debugger
4098 and just returns to top level.
4099 This overrides the variable `debug-on-error'.
4100 It does not apply to errors handled by `condition-case'. */);
4101 Vdebug_ignored_errors
= Qnil
;
4103 DEFVAR_BOOL ("debug-on-quit", debug_on_quit
,
4104 doc
: /* Non-nil means enter debugger if quit is signaled (C-g, for example).
4105 Does not apply if quit is handled by a `condition-case'. */);
4108 DEFVAR_BOOL ("debug-on-next-call", debug_on_next_call
,
4109 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
4111 DEFVAR_BOOL ("debugger-may-continue", debugger_may_continue
,
4112 doc
: /* Non-nil means debugger may continue execution.
4113 This is nil when the debugger is called under circumstances where it
4114 might not be safe to continue. */);
4115 debugger_may_continue
= 1;
4117 DEFVAR_BOOL ("debugger-stack-frame-as-list", debugger_stack_frame_as_list
,
4118 doc
: /* Non-nil means display call stack frames as lists. */);
4119 debugger_stack_frame_as_list
= 0;
4121 DEFVAR_LISP ("debugger", Vdebugger
,
4122 doc
: /* Function to call to invoke debugger.
4123 If due to frame exit, args are `exit' and the value being returned;
4124 this function's value will be returned instead of that.
4125 If due to error, args are `error' and a list of the args to `signal'.
4126 If due to `apply' or `funcall' entry, one arg, `lambda'.
4127 If due to `eval' entry, one arg, t. */);
4130 DEFVAR_LISP ("signal-hook-function", Vsignal_hook_function
,
4131 doc
: /* If non-nil, this is a function for `signal' to call.
4132 It receives the same arguments that `signal' was given.
4133 The Edebug package uses this to regain control. */);
4134 Vsignal_hook_function
= Qnil
;
4136 DEFVAR_LISP ("debug-on-signal", Vdebug_on_signal
,
4137 doc
: /* Non-nil means call the debugger regardless of condition handlers.
4138 Note that `debug-on-error', `debug-on-quit' and friends
4139 still determine whether to handle the particular condition. */);
4140 Vdebug_on_signal
= Qnil
;
4142 /* When lexical binding is being used,
4143 Vinternal_interpreter_environment is non-nil, and contains an alist
4144 of lexically-bound variable, or (t), indicating an empty
4145 environment. The lisp name of this variable would be
4146 `internal-interpreter-environment' if it weren't hidden.
4147 Every element of this list can be either a cons (VAR . VAL)
4148 specifying a lexical binding, or a single symbol VAR indicating
4149 that this variable should use dynamic scoping. */
4150 DEFSYM (Qinternal_interpreter_environment
,
4151 "internal-interpreter-environment");
4152 DEFVAR_LISP ("internal-interpreter-environment",
4153 Vinternal_interpreter_environment
,
4154 doc
: /* If non-nil, the current lexical environment of the lisp interpreter.
4155 When lexical binding is not being used, this variable is nil.
4156 A value of `(t)' indicates an empty environment, otherwise it is an
4157 alist of active lexical bindings. */);
4158 Vinternal_interpreter_environment
= Qnil
;
4159 /* Don't export this variable to Elisp, so no one can mess with it
4160 (Just imagine if someone makes it buffer-local). */
4161 Funintern (Qinternal_interpreter_environment
, Qnil
);
4163 Vrun_hooks
= intern_c_string ("run-hooks");
4164 staticpro (&Vrun_hooks
);
4166 staticpro (&Vautoload_queue
);
4167 Vautoload_queue
= Qnil
;
4168 staticpro (&Vsignaling_function
);
4169 Vsignaling_function
= Qnil
;
4171 inhibit_lisp_code
= Qnil
;
4173 DEFSYM (Qcatch_all_memory_full
, "catch-all-memory-full");
4174 Funintern (Qcatch_all_memory_full
, Qnil
);
4185 defsubr (&Sfunction
);
4186 defsubr (&Sdefault_toplevel_value
);
4187 defsubr (&Sset_default_toplevel_value
);
4189 defsubr (&Sdefvaralias
);
4190 DEFSYM (Qdefvaralias
, "defvaralias");
4191 defsubr (&Sdefconst
);
4192 defsubr (&Smake_var_non_special
);
4196 defsubr (&Smacroexpand
);
4199 defsubr (&Sunwind_protect
);
4200 defsubr (&Scondition_case
);
4202 defsubr (&Scommandp
);
4203 defsubr (&Sautoload
);
4204 defsubr (&Sautoload_do_load
);
4207 defsubr (&Sfuncall
);
4208 defsubr (&Sfunc_arity
);
4209 defsubr (&Srun_hooks
);
4210 defsubr (&Srun_hook_with_args
);
4211 defsubr (&Srun_hook_with_args_until_success
);
4212 defsubr (&Srun_hook_with_args_until_failure
);
4213 defsubr (&Srun_hook_wrapped
);
4214 defsubr (&Sfetch_bytecode
);
4215 defsubr (&Sbacktrace_debug
);
4216 DEFSYM (QCdebug_on_exit
, ":debug-on-exit");
4217 defsubr (&Smapbacktrace
);
4218 defsubr (&Sbacktrace_frame_internal
);
4219 defsubr (&Sbacktrace_eval
);
4220 defsubr (&Sbacktrace__locals
);
4221 defsubr (&Sspecial_variable_p
);
4222 defsubr (&Sfunctionp
);