1 /* Evaluator for GNU Emacs Lisp interpreter.
3 Copyright (C) 1985-1987, 1993-1995, 1999-2017 Free Software Foundation,
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or (at
11 your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
27 #include "blockinput.h"
30 #include "dispextern.h"
33 /* Chain of condition and catch handlers currently in effect. */
35 /* struct handler *handlerlist; */
37 /* Non-nil means record all fset's and provide's, to be undone
38 if the file being autoloaded is not fully loaded.
39 They are recorded by being consed onto the front of Vautoload_queue:
40 (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide. */
42 Lisp_Object Vautoload_queue
;
44 /* This holds either the symbol `run-hooks' or nil.
45 It is nil at an early stage of startup, and when Emacs
47 Lisp_Object Vrun_hooks
;
49 /* The commented-out variables below are macros defined in thread.h. */
51 /* Current number of specbindings allocated in specpdl, not counting
52 the dummy entry specpdl[-1]. */
54 /* ptrdiff_t specpdl_size; */
56 /* Pointer to beginning of specpdl. A dummy entry specpdl[-1] exists
57 only so that its address can be taken. */
59 /* union specbinding *specpdl; */
61 /* Pointer to first unused element in specpdl. */
63 /* union specbinding *specpdl_ptr; */
65 /* Depth in Lisp evaluations and function calls. */
67 /* static EMACS_INT lisp_eval_depth; */
69 /* The value of num_nonmacro_input_events as of the last time we
70 started to enter the debugger. If we decide to enter the debugger
71 again when this is still equal to num_nonmacro_input_events, then we
72 know that the debugger itself has an error, and we should just
73 signal the error instead of entering an infinite loop of debugger
76 static EMACS_INT when_entered_debugger
;
78 /* The function from which the last `signal' was called. Set in
80 /* FIXME: We should probably get rid of this! */
81 Lisp_Object Vsignaling_function
;
83 /* If non-nil, Lisp code must not be run since some part of Emacs is in
84 an inconsistent state. Currently unused. */
85 Lisp_Object inhibit_lisp_code
;
87 /* These would ordinarily be static, but they need to be visible to GDB. */
88 bool backtrace_p (union specbinding
*) EXTERNALLY_VISIBLE
;
89 Lisp_Object
*backtrace_args (union specbinding
*) EXTERNALLY_VISIBLE
;
90 Lisp_Object
backtrace_function (union specbinding
*) EXTERNALLY_VISIBLE
;
91 union specbinding
*backtrace_next (union specbinding
*) EXTERNALLY_VISIBLE
;
92 union specbinding
*backtrace_top (void) EXTERNALLY_VISIBLE
;
94 static Lisp_Object
funcall_lambda (Lisp_Object
, ptrdiff_t, Lisp_Object
*);
95 static Lisp_Object
apply_lambda (Lisp_Object
, Lisp_Object
, ptrdiff_t);
96 static Lisp_Object
lambda_arity (Lisp_Object
);
99 specpdl_symbol (union specbinding
*pdl
)
101 eassert (pdl
->kind
>= SPECPDL_LET
);
102 return pdl
->let
.symbol
;
105 static enum specbind_tag
106 specpdl_kind (union specbinding
*pdl
)
108 eassert (pdl
->kind
>= SPECPDL_LET
);
109 return pdl
->let
.kind
;
113 specpdl_old_value (union specbinding
*pdl
)
115 eassert (pdl
->kind
>= SPECPDL_LET
);
116 return pdl
->let
.old_value
;
120 set_specpdl_old_value (union specbinding
*pdl
, Lisp_Object val
)
122 eassert (pdl
->kind
>= SPECPDL_LET
);
123 pdl
->let
.old_value
= val
;
127 specpdl_where (union specbinding
*pdl
)
129 eassert (pdl
->kind
> SPECPDL_LET
);
130 return pdl
->let
.where
;
134 specpdl_saved_value (union specbinding
*pdl
)
136 eassert (pdl
->kind
>= SPECPDL_LET
);
137 return pdl
->let
.saved_value
;
141 specpdl_arg (union specbinding
*pdl
)
143 eassert (pdl
->kind
== SPECPDL_UNWIND
);
144 return pdl
->unwind
.arg
;
148 backtrace_function (union specbinding
*pdl
)
150 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
151 return pdl
->bt
.function
;
155 backtrace_nargs (union specbinding
*pdl
)
157 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
158 return pdl
->bt
.nargs
;
162 backtrace_args (union specbinding
*pdl
)
164 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
169 backtrace_debug_on_exit (union specbinding
*pdl
)
171 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
172 return pdl
->bt
.debug_on_exit
;
175 /* Functions to modify slots of backtrace records. */
178 set_backtrace_args (union specbinding
*pdl
, Lisp_Object
*args
, ptrdiff_t nargs
)
180 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
182 pdl
->bt
.nargs
= nargs
;
186 set_backtrace_debug_on_exit (union specbinding
*pdl
, bool doe
)
188 eassert (pdl
->kind
== SPECPDL_BACKTRACE
);
189 pdl
->bt
.debug_on_exit
= doe
;
192 /* Helper functions to scan the backtrace. */
195 backtrace_p (union specbinding
*pdl
)
196 { return pdl
>= specpdl
; }
201 union specbinding
*pdl
= specpdl_ptr
- 1;
202 while (backtrace_p (pdl
) && pdl
->kind
!= SPECPDL_BACKTRACE
)
208 backtrace_next (union specbinding
*pdl
)
211 while (backtrace_p (pdl
) && pdl
->kind
!= SPECPDL_BACKTRACE
)
217 init_eval_once (void)
220 union specbinding
*pdlvec
= xmalloc ((size
+ 1) * sizeof *specpdl
);
222 specpdl
= specpdl_ptr
= pdlvec
+ 1;
223 /* Don't forget to update docs (lispref node "Local Variables"). */
224 max_specpdl_size
= 1300; /* 1000 is not enough for CEDET's c-by.el. */
225 max_lisp_eval_depth
= 800;
230 /* static struct handler handlerlist_sentinel; */
235 specpdl_ptr
= specpdl
;
236 { /* Put a dummy catcher at top-level so that handlerlist is never NULL.
237 This is important since handlerlist->nextfree holds the freelist
238 which would otherwise leak every time we unwind back to top-level. */
239 handlerlist_sentinel
= xzalloc (sizeof (struct handler
));
240 handlerlist
= handlerlist_sentinel
->nextfree
= handlerlist_sentinel
;
241 struct handler
*c
= push_handler (Qunbound
, CATCHER
);
242 eassert (c
== handlerlist_sentinel
);
243 handlerlist_sentinel
->nextfree
= NULL
;
244 handlerlist_sentinel
->next
= NULL
;
247 debug_on_next_call
= 0;
249 /* This is less than the initial value of num_nonmacro_input_events. */
250 when_entered_debugger
= -1;
253 /* Unwind-protect function used by call_debugger. */
256 restore_stack_limits (Lisp_Object data
)
258 max_specpdl_size
= XINT (XCAR (data
));
259 max_lisp_eval_depth
= XINT (XCDR (data
));
262 static void grow_specpdl (void);
264 /* Call the Lisp debugger, giving it argument ARG. */
267 call_debugger (Lisp_Object arg
)
269 bool debug_while_redisplaying
;
270 ptrdiff_t count
= SPECPDL_INDEX ();
272 EMACS_INT old_depth
= max_lisp_eval_depth
;
273 /* Do not allow max_specpdl_size less than actual depth (Bug#16603). */
274 EMACS_INT old_max
= max (max_specpdl_size
, count
);
276 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
277 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
279 /* While debugging Bug#16603, previous value of 100 was found
280 too small to avoid specpdl overflow in the debugger itself. */
281 if (max_specpdl_size
- 200 < count
)
282 max_specpdl_size
= count
+ 200;
284 if (old_max
== count
)
286 /* We can enter the debugger due to specpdl overflow (Bug#16603). */
291 /* Restore limits after leaving the debugger. */
292 record_unwind_protect (restore_stack_limits
,
293 Fcons (make_number (old_max
),
294 make_number (old_depth
)));
296 #ifdef HAVE_WINDOW_SYSTEM
297 if (display_hourglass_p
)
301 debug_on_next_call
= 0;
302 when_entered_debugger
= num_nonmacro_input_events
;
304 /* Resetting redisplaying_p to 0 makes sure that debug output is
305 displayed if the debugger is invoked during redisplay. */
306 debug_while_redisplaying
= redisplaying_p
;
308 specbind (intern ("debugger-may-continue"),
309 debug_while_redisplaying
? Qnil
: Qt
);
310 specbind (Qinhibit_redisplay
, Qnil
);
311 specbind (Qinhibit_debugger
, Qt
);
313 /* If we are debugging an error while `inhibit-changing-match-data'
314 is bound to non-nil (e.g., within a call to `string-match-p'),
315 then make sure debugger code can still use match data. */
316 specbind (Qinhibit_changing_match_data
, Qnil
);
318 #if 0 /* Binding this prevents execution of Lisp code during
319 redisplay, which necessarily leads to display problems. */
320 specbind (Qinhibit_eval_during_redisplay
, Qt
);
323 val
= apply1 (Vdebugger
, arg
);
325 /* Interrupting redisplay and resuming it later is not safe under
326 all circumstances. So, when the debugger returns, abort the
327 interrupted redisplay by going back to the top-level. */
328 if (debug_while_redisplaying
)
331 return unbind_to (count
, val
);
335 do_debug_on_call (Lisp_Object code
, ptrdiff_t count
)
337 debug_on_next_call
= 0;
338 set_backtrace_debug_on_exit (specpdl
+ count
, true);
339 call_debugger (list1 (code
));
342 /* NOTE!!! Every function that can call EVAL must protect its args
343 and temporaries from garbage collection while it needs them.
344 The definition of `For' shows what you have to do. */
346 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
347 doc
: /* Eval args until one of them yields non-nil, then return that value.
348 The remaining args are not evalled at all.
349 If all args return nil, return nil.
350 usage: (or CONDITIONS...) */)
353 Lisp_Object val
= Qnil
;
357 val
= eval_sub (XCAR (args
));
366 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
367 doc
: /* Eval args until one of them yields nil, then return nil.
368 The remaining args are not evalled at all.
369 If no arg yields nil, return the last arg's value.
370 usage: (and CONDITIONS...) */)
373 Lisp_Object val
= Qt
;
377 val
= eval_sub (XCAR (args
));
386 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
387 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
388 Returns the value of THEN or the value of the last of the ELSE's.
389 THEN must be one expression, but ELSE... can be zero or more expressions.
390 If COND yields nil, and there are no ELSE's, the value is nil.
391 usage: (if COND THEN ELSE...) */)
396 cond
= eval_sub (XCAR (args
));
399 return eval_sub (Fcar (XCDR (args
)));
400 return Fprogn (XCDR (XCDR (args
)));
403 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
404 doc
: /* Try each clause until one succeeds.
405 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
406 and, if the value is non-nil, this clause succeeds:
407 then the expressions in BODY are evaluated and the last one's
408 value is the value of the cond-form.
409 If a clause has one element, as in (CONDITION), then the cond-form
410 returns CONDITION's value, if that is non-nil.
411 If no clause succeeds, cond returns nil.
412 usage: (cond CLAUSES...) */)
415 Lisp_Object val
= args
;
419 Lisp_Object clause
= XCAR (args
);
420 val
= eval_sub (Fcar (clause
));
423 if (!NILP (XCDR (clause
)))
424 val
= Fprogn (XCDR (clause
));
433 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
434 doc
: /* Eval BODY forms sequentially and return value of last one.
435 usage: (progn BODY...) */)
438 Lisp_Object val
= Qnil
;
442 val
= eval_sub (XCAR (body
));
449 /* Evaluate BODY sequentially, discarding its value. */
452 prog_ignore (Lisp_Object body
)
457 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
458 doc
: /* Eval FIRST and BODY sequentially; return value from FIRST.
459 The value of FIRST is saved during the evaluation of the remaining args,
460 whose values are discarded.
461 usage: (prog1 FIRST BODY...) */)
464 Lisp_Object val
= eval_sub (XCAR (args
));
465 prog_ignore (XCDR (args
));
469 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
470 doc
: /* Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
471 The value of FORM2 is saved during the evaluation of the
472 remaining args, whose values are discarded.
473 usage: (prog2 FORM1 FORM2 BODY...) */)
476 eval_sub (XCAR (args
));
477 return Fprog1 (XCDR (args
));
480 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
481 doc
: /* Set each SYM to the value of its VAL.
482 The symbols SYM are variables; they are literal (not evaluated).
483 The values VAL are expressions; they are evaluated.
484 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
485 The second VAL is not computed until after the first SYM is set, and so on;
486 each VAL can use the new value of variables set earlier in the `setq'.
487 The return value of the `setq' form is the value of the last VAL.
488 usage: (setq [SYM VAL]...) */)
491 Lisp_Object val
, sym
, lex_binding
;
496 Lisp_Object args_left
= args
;
497 Lisp_Object numargs
= Flength (args
);
499 if (XINT (numargs
) & 1)
500 xsignal2 (Qwrong_number_of_arguments
, Qsetq
, numargs
);
504 val
= eval_sub (Fcar (XCDR (args_left
)));
505 sym
= XCAR (args_left
);
507 /* Like for eval_sub, we do not check declared_special here since
508 it's been done when let-binding. */
509 if (!NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
511 && !NILP (lex_binding
512 = Fassq (sym
, Vinternal_interpreter_environment
)))
513 XSETCDR (lex_binding
, val
); /* SYM is lexically bound. */
515 Fset (sym
, val
); /* SYM is dynamically bound. */
517 args_left
= Fcdr (XCDR (args_left
));
519 while (CONSP (args_left
));
525 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
526 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
527 Warning: `quote' does not construct its return value, but just returns
528 the value that was pre-constructed by the Lisp reader (see info node
529 `(elisp)Printed Representation').
530 This means that \\='(a . b) is not identical to (cons \\='a \\='b): the former
531 does not cons. Quoting should be reserved for constants that will
532 never be modified by side-effects, unless you like self-modifying code.
533 See the common pitfall in info node `(elisp)Rearrangement' for an example
534 of unexpected results when a quoted object is modified.
535 usage: (quote ARG) */)
538 if (CONSP (XCDR (args
)))
539 xsignal2 (Qwrong_number_of_arguments
, Qquote
, Flength (args
));
543 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
544 doc
: /* Like `quote', but preferred for objects which are functions.
545 In byte compilation, `function' causes its argument to be compiled.
546 `quote' cannot do that.
547 usage: (function ARG) */)
550 Lisp_Object quoted
= XCAR (args
);
552 if (CONSP (XCDR (args
)))
553 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
555 if (!NILP (Vinternal_interpreter_environment
)
557 && EQ (XCAR (quoted
), Qlambda
))
558 { /* This is a lambda expression within a lexical environment;
559 return an interpreted closure instead of a simple lambda. */
560 Lisp_Object cdr
= XCDR (quoted
);
561 Lisp_Object tmp
= cdr
;
563 && (tmp
= XCDR (tmp
), CONSP (tmp
))
564 && (tmp
= XCAR (tmp
), CONSP (tmp
))
565 && (EQ (QCdocumentation
, XCAR (tmp
))))
566 { /* Handle the special (:documentation <form>) to build the docstring
568 Lisp_Object docstring
= eval_sub (Fcar (XCDR (tmp
)));
569 CHECK_STRING (docstring
);
570 cdr
= Fcons (XCAR (cdr
), Fcons (docstring
, XCDR (XCDR (cdr
))));
572 return Fcons (Qclosure
, Fcons (Vinternal_interpreter_environment
,
576 /* Simply quote the argument. */
581 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
582 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
583 Aliased variables always have the same value; setting one sets the other.
584 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
585 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
586 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
587 itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
588 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
589 The return value is BASE-VARIABLE. */)
590 (Lisp_Object new_alias
, Lisp_Object base_variable
, Lisp_Object docstring
)
592 struct Lisp_Symbol
*sym
;
594 CHECK_SYMBOL (new_alias
);
595 CHECK_SYMBOL (base_variable
);
597 if (SYMBOL_CONSTANT_P (new_alias
))
598 /* Making it an alias effectively changes its value. */
599 error ("Cannot make a constant an alias");
601 sym
= XSYMBOL (new_alias
);
603 switch (sym
->redirect
)
605 case SYMBOL_FORWARDED
:
606 error ("Cannot make an internal variable an alias");
607 case SYMBOL_LOCALIZED
:
608 error ("Don't know how to make a localized variable an alias");
609 case SYMBOL_PLAINVAL
:
610 case SYMBOL_VARALIAS
:
616 /* http://lists.gnu.org/archive/html/emacs-devel/2008-04/msg00834.html
617 If n_a is bound, but b_v is not, set the value of b_v to n_a,
618 so that old-code that affects n_a before the aliasing is setup
620 if (NILP (Fboundp (base_variable
)))
621 set_internal (base_variable
, find_symbol_value (new_alias
),
622 Qnil
, SET_INTERNAL_BIND
);
624 union specbinding
*p
;
626 for (p
= specpdl_ptr
; p
> specpdl
; )
627 if ((--p
)->kind
>= SPECPDL_LET
628 && (EQ (new_alias
, specpdl_symbol (p
))))
629 error ("Don't know how to make a let-bound variable an alias");
632 if (sym
->trapped_write
== SYMBOL_TRAPPED_WRITE
)
633 notify_variable_watchers (new_alias
, base_variable
, Qdefvaralias
, Qnil
);
635 sym
->declared_special
= 1;
636 XSYMBOL (base_variable
)->declared_special
= 1;
637 sym
->redirect
= SYMBOL_VARALIAS
;
638 SET_SYMBOL_ALIAS (sym
, XSYMBOL (base_variable
));
639 sym
->trapped_write
= XSYMBOL (base_variable
)->trapped_write
;
640 LOADHIST_ATTACH (new_alias
);
641 /* Even if docstring is nil: remove old docstring. */
642 Fput (new_alias
, Qvariable_documentation
, docstring
);
644 return base_variable
;
647 static union specbinding
*
648 default_toplevel_binding (Lisp_Object symbol
)
650 union specbinding
*binding
= NULL
;
651 union specbinding
*pdl
= specpdl_ptr
;
652 while (pdl
> specpdl
)
654 switch ((--pdl
)->kind
)
656 case SPECPDL_LET_DEFAULT
:
658 if (EQ (specpdl_symbol (pdl
), symbol
))
663 case SPECPDL_UNWIND_PTR
:
664 case SPECPDL_UNWIND_INT
:
665 case SPECPDL_UNWIND_VOID
:
666 case SPECPDL_BACKTRACE
:
667 case SPECPDL_LET_LOCAL
:
677 DEFUN ("default-toplevel-value", Fdefault_toplevel_value
, Sdefault_toplevel_value
, 1, 1, 0,
678 doc
: /* Return SYMBOL's toplevel default value.
679 "Toplevel" means outside of any let binding. */)
682 union specbinding
*binding
= default_toplevel_binding (symbol
);
684 = binding
? specpdl_old_value (binding
) : Fdefault_value (symbol
);
685 if (!EQ (value
, Qunbound
))
687 xsignal1 (Qvoid_variable
, symbol
);
690 DEFUN ("set-default-toplevel-value", Fset_default_toplevel_value
,
691 Sset_default_toplevel_value
, 2, 2, 0,
692 doc
: /* Set SYMBOL's toplevel default value to VALUE.
693 "Toplevel" means outside of any let binding. */)
694 (Lisp_Object symbol
, Lisp_Object value
)
696 union specbinding
*binding
= default_toplevel_binding (symbol
);
698 set_specpdl_old_value (binding
, value
);
700 Fset_default (symbol
, value
);
704 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
705 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
706 You are not required to define a variable in order to use it, but
707 defining it lets you supply an initial value and documentation, which
708 can be referred to by the Emacs help facilities and other programming
709 tools. The `defvar' form also declares the variable as \"special\",
710 so that it is always dynamically bound even if `lexical-binding' is t.
712 If SYMBOL's value is void and the optional argument INITVALUE is
713 provided, INITVALUE is evaluated and the result used to set SYMBOL's
714 value. If SYMBOL is buffer-local, its default value is what is set;
715 buffer-local values are not affected. If INITVALUE is missing,
716 SYMBOL's value is not set.
718 If SYMBOL has a local binding, then this form affects the local
719 binding. This is usually not what you want. Thus, if you need to
720 load a file defining variables, with this form or with `defconst' or
721 `defcustom', you should always load that file _outside_ any bindings
722 for these variables. (`defconst' and `defcustom' behave similarly in
725 The optional argument DOCSTRING is a documentation string for the
728 To define a user option, use `defcustom' instead of `defvar'.
729 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
732 Lisp_Object sym
, tem
, tail
;
739 if (CONSP (XCDR (tail
)) && CONSP (XCDR (XCDR (tail
))))
740 error ("Too many arguments");
742 tem
= Fdefault_boundp (sym
);
744 /* Do it before evaluating the initial value, for self-references. */
745 XSYMBOL (sym
)->declared_special
= 1;
748 Fset_default (sym
, eval_sub (XCAR (tail
)));
750 { /* Check if there is really a global binding rather than just a let
751 binding that shadows the global unboundness of the var. */
752 union specbinding
*binding
= default_toplevel_binding (sym
);
753 if (binding
&& EQ (specpdl_old_value (binding
), Qunbound
))
755 set_specpdl_old_value (binding
, eval_sub (XCAR (tail
)));
762 if (!NILP (Vpurify_flag
))
763 tem
= Fpurecopy (tem
);
764 Fput (sym
, Qvariable_documentation
, tem
);
766 LOADHIST_ATTACH (sym
);
768 else if (!NILP (Vinternal_interpreter_environment
)
769 && !XSYMBOL (sym
)->declared_special
)
770 /* A simple (defvar foo) with lexical scoping does "nothing" except
771 declare that var to be dynamically scoped *locally* (i.e. within
772 the current file or let-block). */
773 Vinternal_interpreter_environment
774 = Fcons (sym
, Vinternal_interpreter_environment
);
777 /* Simple (defvar <var>) should not count as a definition at all.
778 It could get in the way of other definitions, and unloading this
779 package could try to make the variable unbound. */
785 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
786 doc
: /* Define SYMBOL as a constant variable.
787 This declares that neither programs nor users should ever change the
788 value. This constancy is not actually enforced by Emacs Lisp, but
789 SYMBOL is marked as a special variable so that it is never lexically
792 The `defconst' form always sets the value of SYMBOL to the result of
793 evalling INITVALUE. If SYMBOL is buffer-local, its default value is
794 what is set; buffer-local values are not affected. If SYMBOL has a
795 local binding, then this form sets the local binding's value.
796 However, you should normally not make local bindings for variables
797 defined with this form.
799 The optional DOCSTRING specifies the variable's documentation string.
800 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
803 Lisp_Object sym
, tem
;
806 if (CONSP (Fcdr (XCDR (XCDR (args
)))))
807 error ("Too many arguments");
809 tem
= eval_sub (Fcar (XCDR (args
)));
810 if (!NILP (Vpurify_flag
))
811 tem
= Fpurecopy (tem
);
812 Fset_default (sym
, tem
);
813 XSYMBOL (sym
)->declared_special
= 1;
814 tem
= Fcar (XCDR (XCDR (args
)));
817 if (!NILP (Vpurify_flag
))
818 tem
= Fpurecopy (tem
);
819 Fput (sym
, Qvariable_documentation
, tem
);
821 Fput (sym
, Qrisky_local_variable
, Qt
);
822 LOADHIST_ATTACH (sym
);
826 /* Make SYMBOL lexically scoped. */
827 DEFUN ("internal-make-var-non-special", Fmake_var_non_special
,
828 Smake_var_non_special
, 1, 1, 0,
829 doc
: /* Internal function. */)
832 CHECK_SYMBOL (symbol
);
833 XSYMBOL (symbol
)->declared_special
= 0;
838 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
839 doc
: /* Bind variables according to VARLIST then eval BODY.
840 The value of the last form in BODY is returned.
841 Each element of VARLIST is a symbol (which is bound to nil)
842 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
843 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
844 usage: (let* VARLIST BODY...) */)
847 Lisp_Object varlist
, var
, val
, elt
, lexenv
;
848 ptrdiff_t count
= SPECPDL_INDEX ();
850 lexenv
= Vinternal_interpreter_environment
;
852 for (varlist
= XCAR (args
); CONSP (varlist
); varlist
= XCDR (varlist
))
856 elt
= XCAR (varlist
);
862 else if (! NILP (Fcdr (Fcdr (elt
))))
863 signal_error ("`let' bindings can have only one value-form", elt
);
867 val
= eval_sub (Fcar (Fcdr (elt
)));
870 if (!NILP (lexenv
) && SYMBOLP (var
)
871 && !XSYMBOL (var
)->declared_special
872 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
873 /* Lexically bind VAR by adding it to the interpreter's binding
877 = Fcons (Fcons (var
, val
), Vinternal_interpreter_environment
);
878 if (EQ (Vinternal_interpreter_environment
, lexenv
))
879 /* Save the old lexical environment on the specpdl stack,
880 but only for the first lexical binding, since we'll never
881 need to revert to one of the intermediate ones. */
882 specbind (Qinternal_interpreter_environment
, newenv
);
884 Vinternal_interpreter_environment
= newenv
;
889 CHECK_LIST_END (varlist
, XCAR (args
));
891 val
= Fprogn (XCDR (args
));
892 return unbind_to (count
, val
);
895 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
896 doc
: /* Bind variables according to VARLIST then eval BODY.
897 The value of the last form in BODY is returned.
898 Each element of VARLIST is a symbol (which is bound to nil)
899 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
900 All the VALUEFORMs are evalled before any symbols are bound.
901 usage: (let VARLIST BODY...) */)
904 Lisp_Object
*temps
, tem
, lexenv
;
905 Lisp_Object elt
, varlist
;
906 ptrdiff_t count
= SPECPDL_INDEX ();
910 varlist
= XCAR (args
);
911 CHECK_LIST (varlist
);
913 /* Make space to hold the values to give the bound variables. */
914 elt
= Flength (varlist
);
915 SAFE_ALLOCA_LISP (temps
, XFASTINT (elt
));
917 /* Compute the values and store them in `temps'. */
919 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
922 elt
= XCAR (varlist
);
924 temps
[argnum
++] = Qnil
;
925 else if (! NILP (Fcdr (Fcdr (elt
))))
926 signal_error ("`let' bindings can have only one value-form", elt
);
928 temps
[argnum
++] = eval_sub (Fcar (Fcdr (elt
)));
931 lexenv
= Vinternal_interpreter_environment
;
933 varlist
= XCAR (args
);
934 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
938 elt
= XCAR (varlist
);
939 var
= SYMBOLP (elt
) ? elt
: Fcar (elt
);
940 tem
= temps
[argnum
++];
942 if (!NILP (lexenv
) && SYMBOLP (var
)
943 && !XSYMBOL (var
)->declared_special
944 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
945 /* Lexically bind VAR by adding it to the lexenv alist. */
946 lexenv
= Fcons (Fcons (var
, tem
), lexenv
);
948 /* Dynamically bind VAR. */
952 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
953 /* Instantiate a new lexical environment. */
954 specbind (Qinternal_interpreter_environment
, lexenv
);
956 elt
= Fprogn (XCDR (args
));
958 return unbind_to (count
, elt
);
961 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
962 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
963 The order of execution is thus TEST, BODY, TEST, BODY and so on
964 until TEST returns nil.
965 usage: (while TEST BODY...) */)
968 Lisp_Object test
, body
;
972 while (!NILP (eval_sub (test
)))
981 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
982 doc
: /* Return result of expanding macros at top level of FORM.
983 If FORM is not a macro call, it is returned unchanged.
984 Otherwise, the macro is expanded and the expansion is considered
985 in place of FORM. When a non-macro-call results, it is returned.
987 The second optional arg ENVIRONMENT specifies an environment of macro
988 definitions to shadow the loaded ones for use in file byte-compilation. */)
989 (Lisp_Object form
, Lisp_Object environment
)
991 /* With cleanups from Hallvard Furuseth. */
992 register Lisp_Object expander
, sym
, def
, tem
;
996 /* Come back here each time we expand a macro call,
997 in case it expands into another macro call. */
1000 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1001 def
= sym
= XCAR (form
);
1003 /* Trace symbols aliases to other symbols
1004 until we get a symbol that is not an alias. */
1005 while (SYMBOLP (def
))
1009 tem
= Fassq (sym
, environment
);
1012 def
= XSYMBOL (sym
)->function
;
1018 /* Right now TEM is the result from SYM in ENVIRONMENT,
1019 and if TEM is nil then DEF is SYM's function definition. */
1022 /* SYM is not mentioned in ENVIRONMENT.
1023 Look at its function definition. */
1024 def
= Fautoload_do_load (def
, sym
, Qmacro
);
1026 /* Not defined or definition not suitable. */
1028 if (!EQ (XCAR (def
), Qmacro
))
1030 else expander
= XCDR (def
);
1034 expander
= XCDR (tem
);
1035 if (NILP (expander
))
1039 Lisp_Object newform
= apply1 (expander
, XCDR (form
));
1040 if (EQ (form
, newform
))
1049 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1050 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1051 TAG is evalled to get the tag to use; it must not be nil.
1053 Then the BODY is executed.
1054 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
1055 If no throw happens, `catch' returns the value of the last BODY form.
1056 If a throw happens, it specifies the value to return from `catch'.
1057 usage: (catch TAG BODY...) */)
1060 Lisp_Object tag
= eval_sub (XCAR (args
));
1061 return internal_catch (tag
, Fprogn
, XCDR (args
));
1064 /* Assert that E is true, but do not evaluate E. Use this instead of
1065 eassert (E) when E contains variables that might be clobbered by a
1068 #define clobbered_eassert(E) verify (sizeof (E) != 0)
1070 /* Set up a catch, then call C function FUNC on argument ARG.
1071 FUNC should return a Lisp_Object.
1072 This is how catches are done from within C code. */
1075 internal_catch (Lisp_Object tag
,
1076 Lisp_Object (*func
) (Lisp_Object
), Lisp_Object arg
)
1078 /* This structure is made part of the chain `catchlist'. */
1079 struct handler
*c
= push_handler (tag
, CATCHER
);
1082 if (! sys_setjmp (c
->jmp
))
1084 Lisp_Object val
= func (arg
);
1085 eassert (handlerlist
== c
);
1086 handlerlist
= c
->next
;
1090 { /* Throw works by a longjmp that comes right here. */
1091 Lisp_Object val
= handlerlist
->val
;
1092 clobbered_eassert (handlerlist
== c
);
1093 handlerlist
= handlerlist
->next
;
1098 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1099 jump to that CATCH, returning VALUE as the value of that catch.
1101 This is the guts of Fthrow and Fsignal; they differ only in the way
1102 they choose the catch tag to throw to. A catch tag for a
1103 condition-case form has a TAG of Qnil.
1105 Before each catch is discarded, unbind all special bindings and
1106 execute all unwind-protect clauses made above that catch. Unwind
1107 the handler stack as we go, so that the proper handlers are in
1108 effect for each unwind-protect clause we run. At the end, restore
1109 some static info saved in CATCH, and longjmp to the location
1112 This is used for correct unwinding in Fthrow and Fsignal. */
1114 static _Noreturn
void
1115 unwind_to_catch (struct handler
*catch, Lisp_Object value
)
1119 eassert (catch->next
);
1121 /* Save the value in the tag. */
1124 /* Restore certain special C variables. */
1125 set_poll_suppress_count (catch->poll_suppress_count
);
1126 unblock_input_to (catch->interrupt_input_blocked
);
1130 /* Unwind the specpdl stack, and then restore the proper set of
1132 unbind_to (handlerlist
->pdlcount
, Qnil
);
1133 last_time
= handlerlist
== catch;
1135 handlerlist
= handlerlist
->next
;
1137 while (! last_time
);
1139 eassert (handlerlist
== catch);
1141 lisp_eval_depth
= catch->f_lisp_eval_depth
;
1143 sys_longjmp (catch->jmp
, 1);
1146 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1147 doc
: /* Throw to the catch for TAG and return VALUE from it.
1148 Both TAG and VALUE are evalled. */
1149 attributes
: noreturn
)
1150 (register Lisp_Object tag
, Lisp_Object value
)
1155 for (c
= handlerlist
; c
; c
= c
->next
)
1157 if (c
->type
== CATCHER_ALL
)
1158 unwind_to_catch (c
, Fcons (tag
, value
));
1159 if (c
->type
== CATCHER
&& EQ (c
->tag_or_ch
, tag
))
1160 unwind_to_catch (c
, value
);
1162 xsignal2 (Qno_catch
, tag
, value
);
1166 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1167 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1168 If BODYFORM completes normally, its value is returned
1169 after executing the UNWINDFORMS.
1170 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1171 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1175 ptrdiff_t count
= SPECPDL_INDEX ();
1177 record_unwind_protect (prog_ignore
, XCDR (args
));
1178 val
= eval_sub (XCAR (args
));
1179 return unbind_to (count
, val
);
1182 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1183 doc
: /* Regain control when an error is signaled.
1184 Executes BODYFORM and returns its value if no error happens.
1185 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1186 where the BODY is made of Lisp expressions.
1188 A handler is applicable to an error
1189 if CONDITION-NAME is one of the error's condition names.
1190 If an error happens, the first applicable handler is run.
1192 The car of a handler may be a list of condition names instead of a
1193 single condition name; then it handles all of them. If the special
1194 condition name `debug' is present in this list, it allows another
1195 condition in the list to run the debugger if `debug-on-error' and the
1196 other usual mechanisms says it should (otherwise, `condition-case'
1197 suppresses the debugger).
1199 When a handler handles an error, control returns to the `condition-case'
1200 and it executes the handler's BODY...
1201 with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
1202 \(If VAR is nil, the handler can't access that information.)
1203 Then the value of the last BODY form is returned from the `condition-case'
1206 See also the function `signal' for more info.
1207 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1210 Lisp_Object var
= XCAR (args
);
1211 Lisp_Object bodyform
= XCAR (XCDR (args
));
1212 Lisp_Object handlers
= XCDR (XCDR (args
));
1214 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1217 /* Like Fcondition_case, but the args are separate
1218 rather than passed in a list. Used by Fbyte_code. */
1221 internal_lisp_condition_case (Lisp_Object var
, Lisp_Object bodyform
,
1222 Lisp_Object handlers
)
1224 struct handler
*oldhandlerlist
= handlerlist
;
1225 ptrdiff_t clausenb
= 0;
1229 for (Lisp_Object tail
= handlers
; CONSP (tail
); tail
= XCDR (tail
))
1231 Lisp_Object tem
= XCAR (tail
);
1235 && (SYMBOLP (XCAR (tem
))
1236 || CONSP (XCAR (tem
))))))
1237 error ("Invalid condition handler: %s",
1238 SDATA (Fprin1_to_string (tem
, Qt
)));
1241 /* The first clause is the one that should be checked first, so it
1242 should be added to handlerlist last. So build in CLAUSES a table
1243 that contains HANDLERS but in reverse order. CLAUSES is pointer
1244 to volatile to avoid issues with setjmp and local storage.
1245 SAFE_ALLOCA won't work here due to the setjmp, so impose a
1246 MAX_ALLOCA limit. */
1247 if (MAX_ALLOCA
/ word_size
< clausenb
)
1248 memory_full (SIZE_MAX
);
1249 Lisp_Object
volatile *clauses
= alloca (clausenb
* sizeof *clauses
);
1250 clauses
+= clausenb
;
1251 for (Lisp_Object tail
= handlers
; CONSP (tail
); tail
= XCDR (tail
))
1252 *--clauses
= XCAR (tail
);
1253 for (ptrdiff_t i
= 0; i
< clausenb
; i
++)
1255 Lisp_Object clause
= clauses
[i
];
1256 Lisp_Object condition
= CONSP (clause
) ? XCAR (clause
) : Qnil
;
1257 if (!CONSP (condition
))
1258 condition
= list1 (condition
);
1259 struct handler
*c
= push_handler (condition
, CONDITION_CASE
);
1260 if (sys_setjmp (c
->jmp
))
1262 Lisp_Object val
= handlerlist
->val
;
1263 Lisp_Object
volatile *chosen_clause
= clauses
;
1264 for (struct handler
*h
= handlerlist
->next
; h
!= oldhandlerlist
;
1267 Lisp_Object handler_body
= XCDR (*chosen_clause
);
1268 handlerlist
= oldhandlerlist
;
1271 return Fprogn (handler_body
);
1273 Lisp_Object handler_var
= var
;
1274 if (!NILP (Vinternal_interpreter_environment
))
1276 val
= Fcons (Fcons (var
, val
),
1277 Vinternal_interpreter_environment
);
1278 handler_var
= Qinternal_interpreter_environment
;
1281 /* Bind HANDLER_VAR to VAL while evaluating HANDLER_BODY.
1282 The unbind_to undoes just this binding; whoever longjumped
1283 to us unwound the stack to C->pdlcount before throwing. */
1284 ptrdiff_t count
= SPECPDL_INDEX ();
1285 specbind (handler_var
, val
);
1286 return unbind_to (count
, Fprogn (handler_body
));
1290 Lisp_Object result
= eval_sub (bodyform
);
1291 handlerlist
= oldhandlerlist
;
1295 /* Call the function BFUN with no arguments, catching errors within it
1296 according to HANDLERS. If there is an error, call HFUN with
1297 one argument which is the data that describes the error:
1300 HANDLERS can be a list of conditions to catch.
1301 If HANDLERS is Qt, catch all errors.
1302 If HANDLERS is Qerror, catch all errors
1303 but allow the debugger to run if that is enabled. */
1306 internal_condition_case (Lisp_Object (*bfun
) (void), Lisp_Object handlers
,
1307 Lisp_Object (*hfun
) (Lisp_Object
))
1309 struct handler
*c
= push_handler (handlers
, CONDITION_CASE
);
1310 if (sys_setjmp (c
->jmp
))
1312 Lisp_Object val
= handlerlist
->val
;
1313 clobbered_eassert (handlerlist
== c
);
1314 handlerlist
= handlerlist
->next
;
1319 Lisp_Object val
= bfun ();
1320 eassert (handlerlist
== c
);
1321 handlerlist
= c
->next
;
1326 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1329 internal_condition_case_1 (Lisp_Object (*bfun
) (Lisp_Object
), Lisp_Object arg
,
1330 Lisp_Object handlers
,
1331 Lisp_Object (*hfun
) (Lisp_Object
))
1333 struct handler
*c
= push_handler (handlers
, CONDITION_CASE
);
1334 if (sys_setjmp (c
->jmp
))
1336 Lisp_Object val
= handlerlist
->val
;
1337 clobbered_eassert (handlerlist
== c
);
1338 handlerlist
= handlerlist
->next
;
1343 Lisp_Object val
= bfun (arg
);
1344 eassert (handlerlist
== c
);
1345 handlerlist
= c
->next
;
1350 /* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as
1354 internal_condition_case_2 (Lisp_Object (*bfun
) (Lisp_Object
, Lisp_Object
),
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 (arg1
, arg2
);
1371 eassert (handlerlist
== c
);
1372 handlerlist
= c
->next
;
1377 /* Like internal_condition_case but call BFUN with NARGS as first,
1378 and ARGS as second argument. */
1381 internal_condition_case_n (Lisp_Object (*bfun
) (ptrdiff_t, Lisp_Object
*),
1384 Lisp_Object handlers
,
1385 Lisp_Object (*hfun
) (Lisp_Object err
,
1389 struct handler
*c
= push_handler (handlers
, CONDITION_CASE
);
1390 if (sys_setjmp (c
->jmp
))
1392 Lisp_Object val
= handlerlist
->val
;
1393 clobbered_eassert (handlerlist
== c
);
1394 handlerlist
= handlerlist
->next
;
1395 return hfun (val
, nargs
, args
);
1399 Lisp_Object val
= bfun (nargs
, args
);
1400 eassert (handlerlist
== c
);
1401 handlerlist
= c
->next
;
1407 push_handler (Lisp_Object tag_ch_val
, enum handlertype handlertype
)
1409 struct handler
*c
= push_handler_nosignal (tag_ch_val
, handlertype
);
1411 memory_full (sizeof *c
);
1416 push_handler_nosignal (Lisp_Object tag_ch_val
, enum handlertype handlertype
)
1418 struct handler
*c
= handlerlist
->nextfree
;
1421 c
= malloc (sizeof *c
);
1424 if (profiler_memory_running
)
1425 malloc_probe (sizeof *c
);
1427 handlerlist
->nextfree
= c
;
1429 c
->type
= handlertype
;
1430 c
->tag_or_ch
= tag_ch_val
;
1432 c
->next
= handlerlist
;
1433 c
->f_lisp_eval_depth
= lisp_eval_depth
;
1434 c
->pdlcount
= SPECPDL_INDEX ();
1435 c
->poll_suppress_count
= poll_suppress_count
;
1436 c
->interrupt_input_blocked
= interrupt_input_blocked
;
1442 static Lisp_Object
signal_or_quit (Lisp_Object
, Lisp_Object
, bool);
1443 static Lisp_Object
find_handler_clause (Lisp_Object
, Lisp_Object
);
1444 static bool maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
,
1448 process_quit_flag (void)
1450 Lisp_Object flag
= Vquit_flag
;
1452 if (EQ (flag
, Qkill_emacs
))
1454 if (EQ (Vthrow_on_input
, flag
))
1455 Fthrow (Vthrow_on_input
, Qt
);
1459 /* Check quit-flag and quit if it is non-nil. Typing C-g does not
1460 directly cause a quit; it only sets Vquit_flag. So the program
1461 needs to call maybe_quit at times when it is safe to quit. Every
1462 loop that might run for a long time or might not exit ought to call
1463 maybe_quit at least once, at a safe place. Unless that is
1464 impossible, of course. But it is very desirable to avoid creating
1465 loops where maybe_quit is impossible.
1467 If quit-flag is set to `kill-emacs' the SIGINT handler has received
1468 a request to exit Emacs when it is safe to do.
1470 When not quitting, process any pending signals.
1472 If you change this function, also adapt module_should_quit in
1478 if (!NILP (Vquit_flag
) && NILP (Vinhibit_quit
))
1479 process_quit_flag ();
1480 else if (pending_signals
)
1481 process_pending_signals ();
1484 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1485 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1486 This function does not return.
1488 An error symbol is a symbol with an `error-conditions' property
1489 that is a list of condition names.
1490 A handler for any of those names will get to handle this signal.
1491 The symbol `error' should normally be one of them.
1493 DATA should be a list. Its elements are printed as part of the error message.
1494 See Info anchor `(elisp)Definition of signal' for some details on how this
1495 error message is constructed.
1496 If the signal is handled, DATA is made available to the handler.
1497 See also the function `condition-case'. */
1498 attributes
: noreturn
)
1499 (Lisp_Object error_symbol
, Lisp_Object data
)
1501 signal_or_quit (error_symbol
, data
, false);
1505 /* Quit, in response to a keyboard quit request. */
1509 return signal_or_quit (Qquit
, Qnil
, true);
1512 /* Signal an error, or quit. ERROR_SYMBOL and DATA are as with Fsignal.
1513 If KEYBOARD_QUIT, this is a quit; ERROR_SYMBOL should be
1514 Qquit and DATA should be Qnil, and this function may return.
1515 Otherwise this function is like Fsignal and does not return. */
1518 signal_or_quit (Lisp_Object error_symbol
, Lisp_Object data
, bool keyboard_quit
)
1520 /* When memory is full, ERROR-SYMBOL is nil,
1521 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1522 That is a special case--don't do this in other situations. */
1523 Lisp_Object conditions
;
1525 Lisp_Object real_error_symbol
1526 = (NILP (error_symbol
) ? Fcar (data
) : error_symbol
);
1527 Lisp_Object clause
= Qnil
;
1530 if (gc_in_progress
|| waiting_for_input
)
1533 #if 0 /* rms: I don't know why this was here,
1534 but it is surely wrong for an error that is handled. */
1535 #ifdef HAVE_WINDOW_SYSTEM
1536 if (display_hourglass_p
)
1537 cancel_hourglass ();
1541 /* This hook is used by edebug. */
1542 if (! NILP (Vsignal_hook_function
)
1543 && ! NILP (error_symbol
))
1545 /* Edebug takes care of restoring these variables when it exits. */
1546 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1547 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1549 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1550 max_specpdl_size
= SPECPDL_INDEX () + 40;
1552 call2 (Vsignal_hook_function
, error_symbol
, data
);
1555 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1557 /* Remember from where signal was called. Skip over the frame for
1558 `signal' itself. If a frame for `error' follows, skip that,
1559 too. Don't do this when ERROR_SYMBOL is nil, because that
1560 is a memory-full error. */
1561 Vsignaling_function
= Qnil
;
1562 if (!NILP (error_symbol
))
1564 union specbinding
*pdl
= backtrace_next (backtrace_top ());
1565 if (backtrace_p (pdl
) && EQ (backtrace_function (pdl
), Qerror
))
1566 pdl
= backtrace_next (pdl
);
1567 if (backtrace_p (pdl
))
1568 Vsignaling_function
= backtrace_function (pdl
);
1571 for (h
= handlerlist
; h
; h
= h
->next
)
1573 if (h
->type
!= CONDITION_CASE
)
1575 clause
= find_handler_clause (h
->tag_or_ch
, conditions
);
1580 if (/* Don't run the debugger for a memory-full error.
1581 (There is no room in memory to do that!) */
1582 !NILP (error_symbol
)
1583 && (!NILP (Vdebug_on_signal
)
1584 /* If no handler is present now, try to run the debugger. */
1586 /* A `debug' symbol in the handler list disables the normal
1587 suppression of the debugger. */
1588 || (CONSP (clause
) && !NILP (Fmemq (Qdebug
, clause
)))
1589 /* Special handler that means "print a message and run debugger
1591 || EQ (h
->tag_or_ch
, Qerror
)))
1593 bool debugger_called
1594 = maybe_call_debugger (conditions
, error_symbol
, data
);
1595 /* We can't return values to code which signaled an error, but we
1596 can continue code which has signaled a quit. */
1597 if (keyboard_quit
&& debugger_called
&& EQ (real_error_symbol
, Qquit
))
1603 Lisp_Object unwind_data
1604 = (NILP (error_symbol
) ? data
: Fcons (error_symbol
, data
));
1606 unwind_to_catch (h
, unwind_data
);
1610 if (handlerlist
!= handlerlist_sentinel
)
1611 /* FIXME: This will come right back here if there's no `top-level'
1612 catcher. A better solution would be to abort here, and instead
1613 add a catch-all condition handler so we never come here. */
1614 Fthrow (Qtop_level
, Qt
);
1617 if (! NILP (error_symbol
))
1618 data
= Fcons (error_symbol
, data
);
1620 string
= Ferror_message_string (data
);
1621 fatal ("%s", SDATA (string
));
1624 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1627 xsignal0 (Lisp_Object error_symbol
)
1629 xsignal (error_symbol
, Qnil
);
1633 xsignal1 (Lisp_Object error_symbol
, Lisp_Object arg
)
1635 xsignal (error_symbol
, list1 (arg
));
1639 xsignal2 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
)
1641 xsignal (error_symbol
, list2 (arg1
, arg2
));
1645 xsignal3 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
1647 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1650 /* Signal `error' with message S, and additional arg ARG.
1651 If ARG is not a genuine list, make it a one-element list. */
1654 signal_error (const char *s
, Lisp_Object arg
)
1656 Lisp_Object tortoise
, hare
;
1658 hare
= tortoise
= arg
;
1659 while (CONSP (hare
))
1666 tortoise
= XCDR (tortoise
);
1668 if (EQ (hare
, tortoise
))
1675 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1679 /* Return true if LIST is a non-nil atom or
1680 a list containing one of CONDITIONS. */
1683 wants_debugger (Lisp_Object list
, Lisp_Object conditions
)
1690 while (CONSP (conditions
))
1692 Lisp_Object
this, tail
;
1693 this = XCAR (conditions
);
1694 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1695 if (EQ (XCAR (tail
), this))
1697 conditions
= XCDR (conditions
);
1702 /* Return true if an error with condition-symbols CONDITIONS,
1703 and described by SIGNAL-DATA, should skip the debugger
1704 according to debugger-ignored-errors. */
1707 skip_debugger (Lisp_Object conditions
, Lisp_Object data
)
1710 bool first_string
= 1;
1711 Lisp_Object error_message
;
1713 error_message
= Qnil
;
1714 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1716 if (STRINGP (XCAR (tail
)))
1720 error_message
= Ferror_message_string (data
);
1724 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1729 Lisp_Object contail
;
1731 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1732 if (EQ (XCAR (tail
), XCAR (contail
)))
1740 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1741 SIG and DATA describe the signal. There are two ways to pass them:
1742 = SIG is the error symbol, and DATA is the rest of the data.
1743 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1744 This is for memory-full errors only. */
1746 maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
, Lisp_Object data
)
1748 Lisp_Object combined_data
;
1750 combined_data
= Fcons (sig
, data
);
1753 /* Don't try to run the debugger with interrupts blocked.
1754 The editing loop would return anyway. */
1755 ! input_blocked_p ()
1756 && NILP (Vinhibit_debugger
)
1757 /* Does user want to enter debugger for this kind of error? */
1760 : wants_debugger (Vdebug_on_error
, conditions
))
1761 && ! skip_debugger (conditions
, combined_data
)
1762 /* RMS: What's this for? */
1763 && when_entered_debugger
< num_nonmacro_input_events
)
1765 call_debugger (list2 (Qerror
, combined_data
));
1773 find_handler_clause (Lisp_Object handlers
, Lisp_Object conditions
)
1775 register Lisp_Object h
;
1777 /* t is used by handlers for all conditions, set up by C code. */
1778 if (EQ (handlers
, Qt
))
1781 /* error is used similarly, but means print an error message
1782 and run the debugger if that is enabled. */
1783 if (EQ (handlers
, Qerror
))
1786 for (h
= handlers
; CONSP (h
); h
= XCDR (h
))
1788 Lisp_Object handler
= XCAR (h
);
1789 if (!NILP (Fmemq (handler
, conditions
)))
1797 /* Format and return a string; called like vprintf. */
1799 vformat_string (const char *m
, va_list ap
)
1802 ptrdiff_t size
= sizeof buf
;
1803 ptrdiff_t size_max
= STRING_BYTES_BOUND
+ 1;
1808 used
= evxprintf (&buffer
, &size
, buf
, size_max
, m
, ap
);
1809 string
= make_string (buffer
, used
);
1816 /* Dump an error message; called like vprintf. */
1818 verror (const char *m
, va_list ap
)
1820 xsignal1 (Qerror
, vformat_string (m
, ap
));
1824 /* Dump an error message; called like printf. */
1828 error (const char *m
, ...)
1835 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
1836 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
1837 This means it contains a description for how to read arguments to give it.
1838 The value is nil for an invalid function or a symbol with no function
1841 Interactively callable functions include strings and vectors (treated
1842 as keyboard macros), lambda-expressions that contain a top-level call
1843 to `interactive', autoload definitions made by `autoload' with non-nil
1844 fourth argument, and some of the built-in functions of Lisp.
1846 Also, a symbol satisfies `commandp' if its function definition does so.
1848 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
1849 then strings and vectors are not accepted. */)
1850 (Lisp_Object function
, Lisp_Object for_call_interactively
)
1852 register Lisp_Object fun
;
1853 register Lisp_Object funcar
;
1854 Lisp_Object if_prop
= Qnil
;
1858 fun
= indirect_function (fun
); /* Check cycles. */
1862 /* Check an `interactive-form' property if present, analogous to the
1863 function-documentation property. */
1865 while (SYMBOLP (fun
))
1867 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
1870 fun
= Fsymbol_function (fun
);
1873 /* Emacs primitives are interactive if their DEFUN specifies an
1874 interactive spec. */
1876 return XSUBR (fun
)->intspec
? Qt
: if_prop
;
1878 /* Bytecode objects are interactive if they are long enough to
1879 have an element whose index is COMPILED_INTERACTIVE, which is
1880 where the interactive spec is stored. */
1881 else if (COMPILEDP (fun
))
1882 return (PVSIZE (fun
) > COMPILED_INTERACTIVE
? Qt
: if_prop
);
1884 /* Strings and vectors are keyboard macros. */
1885 if (STRINGP (fun
) || VECTORP (fun
))
1886 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
1888 /* Lists may represent commands. */
1891 funcar
= XCAR (fun
);
1892 if (EQ (funcar
, Qclosure
))
1893 return (!NILP (Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
)))))
1895 else if (EQ (funcar
, Qlambda
))
1896 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
1897 else if (EQ (funcar
, Qautoload
))
1898 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
1903 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1904 doc
: /* Define FUNCTION to autoload from FILE.
1905 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
1906 Third arg DOCSTRING is documentation for the function.
1907 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
1908 Fifth arg TYPE indicates the type of the object:
1909 nil or omitted says FUNCTION is a function,
1910 `keymap' says FUNCTION is really a keymap, and
1911 `macro' or t says FUNCTION is really a macro.
1912 Third through fifth args give info about the real definition.
1913 They default to nil.
1914 If FUNCTION is already defined other than as an autoload,
1915 this does nothing and returns nil. */)
1916 (Lisp_Object function
, Lisp_Object file
, Lisp_Object docstring
, Lisp_Object interactive
, Lisp_Object type
)
1918 CHECK_SYMBOL (function
);
1919 CHECK_STRING (file
);
1921 /* If function is defined and not as an autoload, don't override. */
1922 if (!NILP (XSYMBOL (function
)->function
)
1923 && !AUTOLOADP (XSYMBOL (function
)->function
))
1926 if (!NILP (Vpurify_flag
) && EQ (docstring
, make_number (0)))
1927 /* `read1' in lread.c has found the docstring starting with "\
1928 and assumed the docstring will be provided by Snarf-documentation, so it
1929 passed us 0 instead. But that leads to accidental sharing in purecopy's
1930 hash-consing, so we use a (hopefully) unique integer instead. */
1931 docstring
= make_number (XHASH (function
));
1932 return Fdefalias (function
,
1933 list5 (Qautoload
, file
, docstring
, interactive
, type
),
1938 un_autoload (Lisp_Object oldqueue
)
1940 Lisp_Object queue
, first
, second
;
1942 /* Queue to unwind is current value of Vautoload_queue.
1943 oldqueue is the shadowed value to leave in Vautoload_queue. */
1944 queue
= Vautoload_queue
;
1945 Vautoload_queue
= oldqueue
;
1946 while (CONSP (queue
))
1948 first
= XCAR (queue
);
1949 second
= Fcdr (first
);
1950 first
= Fcar (first
);
1951 if (EQ (first
, make_number (0)))
1954 Ffset (first
, second
);
1955 queue
= XCDR (queue
);
1959 /* Load an autoloaded function.
1960 FUNNAME is the symbol which is the function's name.
1961 FUNDEF is the autoload definition (a list). */
1963 DEFUN ("autoload-do-load", Fautoload_do_load
, Sautoload_do_load
, 1, 3, 0,
1964 doc
: /* Load FUNDEF which should be an autoload.
1965 If non-nil, FUNNAME should be the symbol whose function value is FUNDEF,
1966 in which case the function returns the new autoloaded function value.
1967 If equal to `macro', MACRO-ONLY specifies that FUNDEF should only be loaded if
1968 it defines a macro. */)
1969 (Lisp_Object fundef
, Lisp_Object funname
, Lisp_Object macro_only
)
1971 ptrdiff_t count
= SPECPDL_INDEX ();
1973 if (!CONSP (fundef
) || !EQ (Qautoload
, XCAR (fundef
)))
1976 if (EQ (macro_only
, Qmacro
))
1978 Lisp_Object kind
= Fnth (make_number (4), fundef
);
1979 if (! (EQ (kind
, Qt
) || EQ (kind
, Qmacro
)))
1983 /* This is to make sure that loadup.el gives a clear picture
1984 of what files are preloaded and when. */
1985 if (! NILP (Vpurify_flag
))
1986 error ("Attempt to autoload %s while preparing to dump",
1987 SDATA (SYMBOL_NAME (funname
)));
1989 CHECK_SYMBOL (funname
);
1991 /* Preserve the match data. */
1992 record_unwind_save_match_data ();
1994 /* If autoloading gets an error (which includes the error of failing
1995 to define the function being called), we use Vautoload_queue
1996 to undo function definitions and `provide' calls made by
1997 the function. We do this in the specific case of autoloading
1998 because autoloading is not an explicit request "load this file",
1999 but rather a request to "call this function".
2001 The value saved here is to be restored into Vautoload_queue. */
2002 record_unwind_protect (un_autoload
, Vautoload_queue
);
2003 Vautoload_queue
= Qt
;
2004 /* If `macro_only', assume this autoload to be a "best-effort",
2005 so don't signal an error if autoloading fails. */
2006 Fload (Fcar (Fcdr (fundef
)), macro_only
, Qt
, Qnil
, Qt
);
2008 /* Once loading finishes, don't undo it. */
2009 Vautoload_queue
= Qt
;
2010 unbind_to (count
, Qnil
);
2016 Lisp_Object fun
= Findirect_function (funname
, Qnil
);
2018 if (!NILP (Fequal (fun
, fundef
)))
2019 error ("Autoloading file %s failed to define function %s",
2020 SDATA (Fcar (Fcar (Vload_history
))),
2021 SDATA (SYMBOL_NAME (funname
)));
2028 DEFUN ("eval", Feval
, Seval
, 1, 2, 0,
2029 doc
: /* Evaluate FORM and return its value.
2030 If LEXICAL is t, evaluate using lexical scoping.
2031 LEXICAL can also be an actual lexical environment, in the form of an
2032 alist mapping symbols to their value. */)
2033 (Lisp_Object form
, Lisp_Object lexical
)
2035 ptrdiff_t count
= SPECPDL_INDEX ();
2036 specbind (Qinternal_interpreter_environment
,
2037 CONSP (lexical
) || NILP (lexical
) ? lexical
: list1 (Qt
));
2038 return unbind_to (count
, eval_sub (form
));
2041 /* Grow the specpdl stack by one entry.
2042 The caller should have already initialized the entry.
2043 Signal an error on stack overflow.
2045 Make sure that there is always one unused entry past the top of the
2046 stack, so that the just-initialized entry is safely unwound if
2047 memory exhausted and an error is signaled here. Also, allocate a
2048 never-used entry just before the bottom of the stack; sometimes its
2049 address is taken. */
2056 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2058 ptrdiff_t count
= SPECPDL_INDEX ();
2059 ptrdiff_t max_size
= min (max_specpdl_size
, PTRDIFF_MAX
- 1000);
2060 union specbinding
*pdlvec
= specpdl
- 1;
2061 ptrdiff_t pdlvecsize
= specpdl_size
+ 1;
2062 if (max_size
<= specpdl_size
)
2064 if (max_specpdl_size
< 400)
2065 max_size
= max_specpdl_size
= 400;
2066 if (max_size
<= specpdl_size
)
2067 signal_error ("Variable binding depth exceeds max-specpdl-size",
2070 pdlvec
= xpalloc (pdlvec
, &pdlvecsize
, 1, max_size
+ 1, sizeof *specpdl
);
2071 specpdl
= pdlvec
+ 1;
2072 specpdl_size
= pdlvecsize
- 1;
2073 specpdl_ptr
= specpdl
+ count
;
2078 record_in_backtrace (Lisp_Object function
, Lisp_Object
*args
, ptrdiff_t nargs
)
2080 ptrdiff_t count
= SPECPDL_INDEX ();
2082 eassert (nargs
>= UNEVALLED
);
2083 specpdl_ptr
->bt
.kind
= SPECPDL_BACKTRACE
;
2084 specpdl_ptr
->bt
.debug_on_exit
= false;
2085 specpdl_ptr
->bt
.function
= function
;
2086 current_thread
->stack_top
= specpdl_ptr
->bt
.args
= args
;
2087 specpdl_ptr
->bt
.nargs
= nargs
;
2093 /* Eval a sub-expression of the current expression (i.e. in the same
2096 eval_sub (Lisp_Object form
)
2098 Lisp_Object fun
, val
, original_fun
, original_args
;
2102 /* Declare here, as this array may be accessed by call_debugger near
2103 the end of this function. See Bug#21245. */
2104 Lisp_Object argvals
[8];
2108 /* Look up its binding in the lexical environment.
2109 We do not pay attention to the declared_special flag here, since we
2110 already did that when let-binding the variable. */
2111 Lisp_Object lex_binding
2112 = !NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
2113 ? Fassq (form
, Vinternal_interpreter_environment
)
2115 if (CONSP (lex_binding
))
2116 return XCDR (lex_binding
);
2118 return Fsymbol_value (form
);
2128 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2130 if (max_lisp_eval_depth
< 100)
2131 max_lisp_eval_depth
= 100;
2132 if (lisp_eval_depth
> max_lisp_eval_depth
)
2133 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2136 original_fun
= XCAR (form
);
2137 original_args
= XCDR (form
);
2139 /* This also protects them from gc. */
2140 count
= record_in_backtrace (original_fun
, &original_args
, UNEVALLED
);
2142 if (debug_on_next_call
)
2143 do_debug_on_call (Qt
, count
);
2145 /* At this point, only original_fun and original_args
2146 have values that will be used below. */
2149 /* Optimize for no indirection. */
2152 fun
= Ffunction (Fcons (fun
, Qnil
));
2153 else if (!NILP (fun
) && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2154 fun
= indirect_function (fun
);
2158 Lisp_Object args_left
= original_args
;
2159 Lisp_Object numargs
= Flength (args_left
);
2163 if (XINT (numargs
) < XSUBR (fun
)->min_args
2164 || (XSUBR (fun
)->max_args
>= 0
2165 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2166 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2168 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2169 val
= (XSUBR (fun
)->function
.aUNEVALLED
) (args_left
);
2170 else if (XSUBR (fun
)->max_args
== MANY
)
2172 /* Pass a vector of evaluated arguments. */
2174 ptrdiff_t argnum
= 0;
2177 SAFE_ALLOCA_LISP (vals
, XINT (numargs
));
2179 while (!NILP (args_left
))
2181 vals
[argnum
++] = eval_sub (Fcar (args_left
));
2182 args_left
= Fcdr (args_left
);
2185 set_backtrace_args (specpdl
+ count
, vals
, XINT (numargs
));
2187 val
= (XSUBR (fun
)->function
.aMANY
) (XINT (numargs
), vals
);
2191 /* Do the debug-on-exit now, while VALS still exists. */
2192 if (backtrace_debug_on_exit (specpdl
+ count
))
2193 val
= call_debugger (list2 (Qexit
, val
));
2200 int i
, maxargs
= XSUBR (fun
)->max_args
;
2202 for (i
= 0; i
< maxargs
; i
++)
2204 argvals
[i
] = eval_sub (Fcar (args_left
));
2205 args_left
= Fcdr (args_left
);
2208 set_backtrace_args (specpdl
+ count
, argvals
, XINT (numargs
));
2213 val
= (XSUBR (fun
)->function
.a0 ());
2216 val
= (XSUBR (fun
)->function
.a1 (argvals
[0]));
2219 val
= (XSUBR (fun
)->function
.a2 (argvals
[0], argvals
[1]));
2222 val
= (XSUBR (fun
)->function
.a3
2223 (argvals
[0], argvals
[1], argvals
[2]));
2226 val
= (XSUBR (fun
)->function
.a4
2227 (argvals
[0], argvals
[1], argvals
[2], argvals
[3]));
2230 val
= (XSUBR (fun
)->function
.a5
2231 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2235 val
= (XSUBR (fun
)->function
.a6
2236 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2237 argvals
[4], argvals
[5]));
2240 val
= (XSUBR (fun
)->function
.a7
2241 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2242 argvals
[4], argvals
[5], argvals
[6]));
2246 val
= (XSUBR (fun
)->function
.a8
2247 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2248 argvals
[4], argvals
[5], argvals
[6], argvals
[7]));
2252 /* Someone has created a subr that takes more arguments than
2253 is supported by this code. We need to either rewrite the
2254 subr to use a different argument protocol, or add more
2255 cases to this switch. */
2260 else if (COMPILEDP (fun
) || MODULE_FUNCTIONP (fun
))
2261 return apply_lambda (fun
, original_args
, count
);
2265 xsignal1 (Qvoid_function
, original_fun
);
2267 xsignal1 (Qinvalid_function
, original_fun
);
2268 funcar
= XCAR (fun
);
2269 if (!SYMBOLP (funcar
))
2270 xsignal1 (Qinvalid_function
, original_fun
);
2271 if (EQ (funcar
, Qautoload
))
2273 Fautoload_do_load (fun
, original_fun
, Qnil
);
2276 if (EQ (funcar
, Qmacro
))
2278 ptrdiff_t count1
= SPECPDL_INDEX ();
2280 /* Bind lexical-binding during expansion of the macro, so the
2281 macro can know reliably if the code it outputs will be
2282 interpreted using lexical-binding or not. */
2283 specbind (Qlexical_binding
,
2284 NILP (Vinternal_interpreter_environment
) ? Qnil
: Qt
);
2285 exp
= apply1 (Fcdr (fun
), original_args
);
2286 unbind_to (count1
, Qnil
);
2287 val
= eval_sub (exp
);
2289 else if (EQ (funcar
, Qlambda
)
2290 || EQ (funcar
, Qclosure
))
2291 return apply_lambda (fun
, original_args
, count
);
2293 xsignal1 (Qinvalid_function
, original_fun
);
2298 if (backtrace_debug_on_exit (specpdl
+ count
))
2299 val
= call_debugger (list2 (Qexit
, val
));
2305 DEFUN ("apply", Fapply
, Sapply
, 1, MANY
, 0,
2306 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2307 Then return the value FUNCTION returns.
2308 Thus, (apply \\='+ 1 2 \\='(3 4)) returns 10.
2309 usage: (apply FUNCTION &rest ARGUMENTS) */)
2310 (ptrdiff_t nargs
, Lisp_Object
*args
)
2312 ptrdiff_t i
, numargs
, funcall_nargs
;
2313 register Lisp_Object
*funcall_args
= NULL
;
2314 register Lisp_Object spread_arg
= args
[nargs
- 1];
2315 Lisp_Object fun
= args
[0];
2319 CHECK_LIST (spread_arg
);
2321 numargs
= XINT (Flength (spread_arg
));
2324 return Ffuncall (nargs
- 1, args
);
2325 else if (numargs
== 1)
2327 args
[nargs
- 1] = XCAR (spread_arg
);
2328 return Ffuncall (nargs
, args
);
2331 numargs
+= nargs
- 2;
2333 /* Optimize for no indirection. */
2334 if (SYMBOLP (fun
) && !NILP (fun
)
2335 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2337 fun
= indirect_function (fun
);
2339 /* Let funcall get the error. */
2343 if (SUBRP (fun
) && XSUBR (fun
)->max_args
> numargs
2344 /* Don't hide an error by adding missing arguments. */
2345 && numargs
>= XSUBR (fun
)->min_args
)
2347 /* Avoid making funcall cons up a yet another new vector of arguments
2348 by explicitly supplying nil's for optional values. */
2349 SAFE_ALLOCA_LISP (funcall_args
, 1 + XSUBR (fun
)->max_args
);
2350 memclear (funcall_args
+ numargs
+ 1,
2351 (XSUBR (fun
)->max_args
- numargs
) * word_size
);
2352 funcall_nargs
= 1 + XSUBR (fun
)->max_args
;
2355 { /* We add 1 to numargs because funcall_args includes the
2356 function itself as well as its arguments. */
2357 SAFE_ALLOCA_LISP (funcall_args
, 1 + numargs
);
2358 funcall_nargs
= 1 + numargs
;
2361 memcpy (funcall_args
, args
, nargs
* word_size
);
2362 /* Spread the last arg we got. Its first element goes in
2363 the slot that it used to occupy, hence this value of I. */
2365 while (!NILP (spread_arg
))
2367 funcall_args
[i
++] = XCAR (spread_arg
);
2368 spread_arg
= XCDR (spread_arg
);
2371 retval
= Ffuncall (funcall_nargs
, funcall_args
);
2377 /* Run hook variables in various ways. */
2380 funcall_nil (ptrdiff_t nargs
, Lisp_Object
*args
)
2382 Ffuncall (nargs
, args
);
2386 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2387 doc
: /* Run each hook in HOOKS.
2388 Each argument should be a symbol, a hook variable.
2389 These symbols are processed in the order specified.
2390 If a hook symbol has a non-nil value, that value may be a function
2391 or a list of functions to be called to run the hook.
2392 If the value is a function, it is called with no arguments.
2393 If it is a list, the elements are called, in order, with no arguments.
2395 Major modes should not use this function directly to run their mode
2396 hook; they should use `run-mode-hooks' instead.
2398 Do not use `make-local-variable' to make a hook variable buffer-local.
2399 Instead, use `add-hook' and specify t for the LOCAL argument.
2400 usage: (run-hooks &rest HOOKS) */)
2401 (ptrdiff_t nargs
, Lisp_Object
*args
)
2405 for (i
= 0; i
< nargs
; i
++)
2411 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2412 Srun_hook_with_args
, 1, MANY
, 0,
2413 doc
: /* Run HOOK with the specified arguments ARGS.
2414 HOOK should be a symbol, a hook variable. The value of HOOK
2415 may be nil, a function, or a list of functions. Call each
2416 function in order with arguments ARGS. The final return value
2419 Do not use `make-local-variable' to make a hook variable buffer-local.
2420 Instead, use `add-hook' and specify t for the LOCAL argument.
2421 usage: (run-hook-with-args HOOK &rest ARGS) */)
2422 (ptrdiff_t nargs
, Lisp_Object
*args
)
2424 return run_hook_with_args (nargs
, args
, funcall_nil
);
2427 /* NB this one still documents a specific non-nil return value.
2428 (As did run-hook-with-args and run-hook-with-args-until-failure
2429 until they were changed in 24.1.) */
2430 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2431 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2432 doc
: /* Run HOOK with the specified arguments ARGS.
2433 HOOK should be a symbol, a hook variable. The value of HOOK
2434 may be nil, a function, or a list of functions. Call each
2435 function in order with arguments ARGS, stopping at the first
2436 one that returns non-nil, and return that value. Otherwise (if
2437 all functions return nil, or if there are no functions to call),
2440 Do not use `make-local-variable' to make a hook variable buffer-local.
2441 Instead, use `add-hook' and specify t for the LOCAL argument.
2442 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2443 (ptrdiff_t nargs
, Lisp_Object
*args
)
2445 return run_hook_with_args (nargs
, args
, Ffuncall
);
2449 funcall_not (ptrdiff_t nargs
, Lisp_Object
*args
)
2451 return NILP (Ffuncall (nargs
, args
)) ? Qt
: Qnil
;
2454 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2455 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2456 doc
: /* Run HOOK with the specified arguments ARGS.
2457 HOOK should be a symbol, a hook variable. The value of HOOK
2458 may be nil, a function, or a list of functions. Call each
2459 function in order with arguments ARGS, stopping at the first
2460 one that returns nil, and return nil. Otherwise (if all functions
2461 return non-nil, or if there are no functions to call), return non-nil
2462 \(do not rely on the precise return value in this case).
2464 Do not use `make-local-variable' to make a hook variable buffer-local.
2465 Instead, use `add-hook' and specify t for the LOCAL argument.
2466 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2467 (ptrdiff_t nargs
, Lisp_Object
*args
)
2469 return NILP (run_hook_with_args (nargs
, args
, funcall_not
)) ? Qt
: Qnil
;
2473 run_hook_wrapped_funcall (ptrdiff_t nargs
, Lisp_Object
*args
)
2475 Lisp_Object tmp
= args
[0], ret
;
2478 ret
= Ffuncall (nargs
, args
);
2484 DEFUN ("run-hook-wrapped", Frun_hook_wrapped
, Srun_hook_wrapped
, 2, MANY
, 0,
2485 doc
: /* Run HOOK, passing each function through WRAP-FUNCTION.
2486 I.e. instead of calling each function FUN directly with arguments ARGS,
2487 it calls WRAP-FUNCTION with arguments FUN and ARGS.
2488 As soon as a call to WRAP-FUNCTION returns non-nil, `run-hook-wrapped'
2489 aborts and returns that value.
2490 usage: (run-hook-wrapped HOOK WRAP-FUNCTION &rest ARGS) */)
2491 (ptrdiff_t nargs
, Lisp_Object
*args
)
2493 return run_hook_with_args (nargs
, args
, run_hook_wrapped_funcall
);
2496 /* ARGS[0] should be a hook symbol.
2497 Call each of the functions in the hook value, passing each of them
2498 as arguments all the rest of ARGS (all NARGS - 1 elements).
2499 FUNCALL specifies how to call each function on the hook. */
2502 run_hook_with_args (ptrdiff_t nargs
, Lisp_Object
*args
,
2503 Lisp_Object (*funcall
) (ptrdiff_t nargs
, Lisp_Object
*args
))
2505 Lisp_Object sym
, val
, ret
= Qnil
;
2507 /* If we are dying or still initializing,
2508 don't do anything--it would probably crash if we tried. */
2509 if (NILP (Vrun_hooks
))
2513 val
= find_symbol_value (sym
);
2515 if (EQ (val
, Qunbound
) || NILP (val
))
2517 else if (!CONSP (val
) || FUNCTIONP (val
))
2520 return funcall (nargs
, args
);
2524 Lisp_Object global_vals
= Qnil
;
2527 CONSP (val
) && NILP (ret
);
2530 if (EQ (XCAR (val
), Qt
))
2532 /* t indicates this hook has a local binding;
2533 it means to run the global binding too. */
2534 global_vals
= Fdefault_value (sym
);
2535 if (NILP (global_vals
)) continue;
2537 if (!CONSP (global_vals
) || EQ (XCAR (global_vals
), Qlambda
))
2539 args
[0] = global_vals
;
2540 ret
= funcall (nargs
, args
);
2545 CONSP (global_vals
) && NILP (ret
);
2546 global_vals
= XCDR (global_vals
))
2548 args
[0] = XCAR (global_vals
);
2549 /* In a global value, t should not occur. If it does, we
2550 must ignore it to avoid an endless loop. */
2551 if (!EQ (args
[0], Qt
))
2552 ret
= funcall (nargs
, args
);
2558 args
[0] = XCAR (val
);
2559 ret
= funcall (nargs
, args
);
2567 /* Run the hook HOOK, giving each function no args. */
2570 run_hook (Lisp_Object hook
)
2572 Frun_hook_with_args (1, &hook
);
2575 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2578 run_hook_with_args_2 (Lisp_Object hook
, Lisp_Object arg1
, Lisp_Object arg2
)
2580 CALLN (Frun_hook_with_args
, hook
, arg1
, arg2
);
2583 /* Apply fn to arg. */
2585 apply1 (Lisp_Object fn
, Lisp_Object arg
)
2587 return NILP (arg
) ? Ffuncall (1, &fn
) : CALLN (Fapply
, fn
, arg
);
2590 /* Call function fn on no arguments. */
2592 call0 (Lisp_Object fn
)
2594 return Ffuncall (1, &fn
);
2597 /* Call function fn with 1 argument arg1. */
2600 call1 (Lisp_Object fn
, Lisp_Object arg1
)
2602 return CALLN (Ffuncall
, fn
, arg1
);
2605 /* Call function fn with 2 arguments arg1, arg2. */
2608 call2 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
)
2610 return CALLN (Ffuncall
, fn
, arg1
, arg2
);
2613 /* Call function fn with 3 arguments arg1, arg2, arg3. */
2616 call3 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2618 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
);
2621 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
2624 call4 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2627 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
);
2630 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
2633 call5 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2634 Lisp_Object arg4
, Lisp_Object arg5
)
2636 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
);
2639 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
2642 call6 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2643 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
)
2645 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
);
2648 /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
2651 call7 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2652 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
)
2654 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
);
2657 DEFUN ("functionp", Ffunctionp
, Sfunctionp
, 1, 1, 0,
2658 doc
: /* Non-nil if OBJECT is a function. */)
2659 (Lisp_Object object
)
2661 if (FUNCTIONP (object
))
2667 FUNCTIONP (Lisp_Object object
)
2669 if (SYMBOLP (object
) && !NILP (Ffboundp (object
)))
2671 object
= Findirect_function (object
, Qt
);
2673 if (CONSP (object
) && EQ (XCAR (object
), Qautoload
))
2675 /* Autoloaded symbols are functions, except if they load
2676 macros or keymaps. */
2677 for (int i
= 0; i
< 4 && CONSP (object
); i
++)
2678 object
= XCDR (object
);
2680 return ! (CONSP (object
) && !NILP (XCAR (object
)));
2685 return XSUBR (object
)->max_args
!= UNEVALLED
;
2686 else if (COMPILEDP (object
) || MODULE_FUNCTIONP (object
))
2688 else if (CONSP (object
))
2690 Lisp_Object car
= XCAR (object
);
2691 return EQ (car
, Qlambda
) || EQ (car
, Qclosure
);
2697 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2698 doc
: /* Call first argument as a function, passing remaining arguments to it.
2699 Return the value that function returns.
2700 Thus, (funcall \\='cons \\='x \\='y) returns (x . y).
2701 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2702 (ptrdiff_t nargs
, Lisp_Object
*args
)
2704 Lisp_Object fun
, original_fun
;
2706 ptrdiff_t numargs
= nargs
- 1;
2712 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2714 if (max_lisp_eval_depth
< 100)
2715 max_lisp_eval_depth
= 100;
2716 if (lisp_eval_depth
> max_lisp_eval_depth
)
2717 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2720 count
= record_in_backtrace (args
[0], &args
[1], nargs
- 1);
2724 if (debug_on_next_call
)
2725 do_debug_on_call (Qlambda
, count
);
2729 original_fun
= args
[0];
2733 /* Optimize for no indirection. */
2735 if (SYMBOLP (fun
) && !NILP (fun
)
2736 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2737 fun
= indirect_function (fun
);
2740 val
= funcall_subr (XSUBR (fun
), numargs
, args
+ 1);
2741 else if (COMPILEDP (fun
) || MODULE_FUNCTIONP (fun
))
2742 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2746 xsignal1 (Qvoid_function
, original_fun
);
2748 xsignal1 (Qinvalid_function
, original_fun
);
2749 funcar
= XCAR (fun
);
2750 if (!SYMBOLP (funcar
))
2751 xsignal1 (Qinvalid_function
, original_fun
);
2752 if (EQ (funcar
, Qlambda
)
2753 || EQ (funcar
, Qclosure
))
2754 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2755 else if (EQ (funcar
, Qautoload
))
2757 Fautoload_do_load (fun
, original_fun
, Qnil
);
2762 xsignal1 (Qinvalid_function
, original_fun
);
2766 if (backtrace_debug_on_exit (specpdl
+ count
))
2767 val
= call_debugger (list2 (Qexit
, val
));
2773 /* Apply a C subroutine SUBR to the NUMARGS evaluated arguments in ARG_VECTOR
2774 and return the result of evaluation. */
2777 funcall_subr (struct Lisp_Subr
*subr
, ptrdiff_t numargs
, Lisp_Object
*args
)
2779 if (numargs
< subr
->min_args
2780 || (subr
->max_args
>= 0 && subr
->max_args
< numargs
))
2783 XSETSUBR (fun
, subr
);
2784 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (numargs
));
2787 else if (subr
->max_args
== UNEVALLED
)
2790 XSETSUBR (fun
, subr
);
2791 xsignal1 (Qinvalid_function
, fun
);
2794 else if (subr
->max_args
== MANY
)
2795 return (subr
->function
.aMANY
) (numargs
, args
);
2798 Lisp_Object internal_argbuf
[8];
2799 Lisp_Object
*internal_args
;
2800 if (subr
->max_args
> numargs
)
2802 eassert (subr
->max_args
<= ARRAYELTS (internal_argbuf
));
2803 internal_args
= internal_argbuf
;
2804 memcpy (internal_args
, args
, numargs
* word_size
);
2805 memclear (internal_args
+ numargs
,
2806 (subr
->max_args
- numargs
) * word_size
);
2809 internal_args
= args
;
2810 switch (subr
->max_args
)
2813 return (subr
->function
.a0 ());
2815 return (subr
->function
.a1 (internal_args
[0]));
2817 return (subr
->function
.a2
2818 (internal_args
[0], internal_args
[1]));
2820 return (subr
->function
.a3
2821 (internal_args
[0], internal_args
[1], internal_args
[2]));
2823 return (subr
->function
.a4
2824 (internal_args
[0], internal_args
[1], internal_args
[2],
2827 return (subr
->function
.a5
2828 (internal_args
[0], internal_args
[1], internal_args
[2],
2829 internal_args
[3], internal_args
[4]));
2831 return (subr
->function
.a6
2832 (internal_args
[0], internal_args
[1], internal_args
[2],
2833 internal_args
[3], internal_args
[4], internal_args
[5]));
2835 return (subr
->function
.a7
2836 (internal_args
[0], internal_args
[1], internal_args
[2],
2837 internal_args
[3], internal_args
[4], internal_args
[5],
2840 return (subr
->function
.a8
2841 (internal_args
[0], internal_args
[1], internal_args
[2],
2842 internal_args
[3], internal_args
[4], internal_args
[5],
2843 internal_args
[6], internal_args
[7]));
2847 /* If a subr takes more than 8 arguments without using MANY
2848 or UNEVALLED, we need to extend this function to support it.
2849 Until this is done, there is no way to call the function. */
2856 apply_lambda (Lisp_Object fun
, Lisp_Object args
, ptrdiff_t count
)
2858 Lisp_Object args_left
;
2861 Lisp_Object
*arg_vector
;
2865 numargs
= XFASTINT (Flength (args
));
2866 SAFE_ALLOCA_LISP (arg_vector
, numargs
);
2869 for (i
= 0; i
< numargs
; )
2871 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2872 tem
= eval_sub (tem
);
2873 arg_vector
[i
++] = tem
;
2876 set_backtrace_args (specpdl
+ count
, arg_vector
, i
);
2877 tem
= funcall_lambda (fun
, numargs
, arg_vector
);
2881 /* Do the debug-on-exit now, while arg_vector still exists. */
2882 if (backtrace_debug_on_exit (specpdl
+ count
))
2883 tem
= call_debugger (list2 (Qexit
, tem
));
2889 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2890 and return the result of evaluation.
2891 FUN must be either a lambda-expression, a compiled-code object,
2892 or a module function. */
2895 funcall_lambda (Lisp_Object fun
, ptrdiff_t nargs
,
2896 register Lisp_Object
*arg_vector
)
2898 Lisp_Object val
, syms_left
, next
, lexenv
;
2899 ptrdiff_t count
= SPECPDL_INDEX ();
2901 bool optional
, rest
;
2905 if (EQ (XCAR (fun
), Qclosure
))
2907 Lisp_Object cdr
= XCDR (fun
); /* Drop `closure'. */
2909 xsignal1 (Qinvalid_function
, fun
);
2911 lexenv
= XCAR (fun
);
2915 syms_left
= XCDR (fun
);
2916 if (CONSP (syms_left
))
2917 syms_left
= XCAR (syms_left
);
2919 xsignal1 (Qinvalid_function
, fun
);
2921 else if (COMPILEDP (fun
))
2923 ptrdiff_t size
= PVSIZE (fun
);
2924 if (size
<= COMPILED_STACK_DEPTH
)
2925 xsignal1 (Qinvalid_function
, fun
);
2926 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
2927 if (INTEGERP (syms_left
))
2928 /* A byte-code object with an integer args template means we
2929 shouldn't bind any arguments, instead just call the byte-code
2930 interpreter directly; it will push arguments as necessary.
2932 Byte-code objects with a nil args template (the default)
2933 have dynamically-bound arguments, and use the
2934 argument-binding code below instead (as do all interpreted
2935 functions, even lexically bound ones). */
2937 /* If we have not actually read the bytecode string
2938 and constants vector yet, fetch them from the file. */
2939 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
2940 Ffetch_bytecode (fun
);
2941 return exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
2942 AREF (fun
, COMPILED_CONSTANTS
),
2943 AREF (fun
, COMPILED_STACK_DEPTH
),
2950 else if (MODULE_FUNCTIONP (fun
))
2951 return funcall_module (fun
, nargs
, arg_vector
);
2956 i
= optional
= rest
= 0;
2957 bool previous_optional_or_rest
= false;
2958 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
2962 next
= XCAR (syms_left
);
2963 if (!SYMBOLP (next
))
2964 xsignal1 (Qinvalid_function
, fun
);
2966 if (EQ (next
, Qand_rest
))
2968 if (rest
|| previous_optional_or_rest
)
2969 xsignal1 (Qinvalid_function
, fun
);
2971 previous_optional_or_rest
= true;
2973 else if (EQ (next
, Qand_optional
))
2975 if (optional
|| rest
|| previous_optional_or_rest
)
2976 xsignal1 (Qinvalid_function
, fun
);
2978 previous_optional_or_rest
= true;
2985 arg
= Flist (nargs
- i
, &arg_vector
[i
]);
2989 arg
= arg_vector
[i
++];
2991 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
2995 /* Bind the argument. */
2996 if (!NILP (lexenv
) && SYMBOLP (next
))
2997 /* Lexically bind NEXT by adding it to the lexenv alist. */
2998 lexenv
= Fcons (Fcons (next
, arg
), lexenv
);
3000 /* Dynamically bind NEXT. */
3001 specbind (next
, arg
);
3002 previous_optional_or_rest
= false;
3006 if (!NILP (syms_left
) || previous_optional_or_rest
)
3007 xsignal1 (Qinvalid_function
, fun
);
3009 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3011 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
3012 /* Instantiate a new lexical environment. */
3013 specbind (Qinternal_interpreter_environment
, lexenv
);
3016 val
= Fprogn (XCDR (XCDR (fun
)));
3019 /* If we have not actually read the bytecode string
3020 and constants vector yet, fetch them from the file. */
3021 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3022 Ffetch_bytecode (fun
);
3023 val
= exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
3024 AREF (fun
, COMPILED_CONSTANTS
),
3025 AREF (fun
, COMPILED_STACK_DEPTH
),
3029 return unbind_to (count
, val
);
3032 DEFUN ("func-arity", Ffunc_arity
, Sfunc_arity
, 1, 1, 0,
3033 doc
: /* Return minimum and maximum number of args allowed for FUNCTION.
3034 FUNCTION must be a function of some kind.
3035 The returned value is a cons cell (MIN . MAX). MIN is the minimum number
3036 of args. MAX is the maximum number, or the symbol `many', for a
3037 function with `&rest' args, or `unevalled' for a special form. */)
3038 (Lisp_Object function
)
3040 Lisp_Object original
;
3044 original
= function
;
3048 /* Optimize for no indirection. */
3049 function
= original
;
3050 if (SYMBOLP (function
) && !NILP (function
))
3052 function
= XSYMBOL (function
)->function
;
3053 if (SYMBOLP (function
))
3054 function
= indirect_function (function
);
3057 if (CONSP (function
) && EQ (XCAR (function
), Qmacro
))
3058 function
= XCDR (function
);
3060 if (SUBRP (function
))
3061 result
= Fsubr_arity (function
);
3062 else if (COMPILEDP (function
))
3063 result
= lambda_arity (function
);
3065 else if (MODULE_FUNCTIONP (function
))
3066 result
= module_function_arity (XMODULE_FUNCTION (function
));
3070 if (NILP (function
))
3071 xsignal1 (Qvoid_function
, original
);
3072 if (!CONSP (function
))
3073 xsignal1 (Qinvalid_function
, original
);
3074 funcar
= XCAR (function
);
3075 if (!SYMBOLP (funcar
))
3076 xsignal1 (Qinvalid_function
, original
);
3077 if (EQ (funcar
, Qlambda
)
3078 || EQ (funcar
, Qclosure
))
3079 result
= lambda_arity (function
);
3080 else if (EQ (funcar
, Qautoload
))
3082 Fautoload_do_load (function
, original
, Qnil
);
3086 xsignal1 (Qinvalid_function
, original
);
3091 /* FUN must be either a lambda-expression or a compiled-code object. */
3093 lambda_arity (Lisp_Object fun
)
3095 Lisp_Object syms_left
;
3099 if (EQ (XCAR (fun
), Qclosure
))
3101 fun
= XCDR (fun
); /* Drop `closure'. */
3104 syms_left
= XCDR (fun
);
3105 if (CONSP (syms_left
))
3106 syms_left
= XCAR (syms_left
);
3108 xsignal1 (Qinvalid_function
, fun
);
3110 else if (COMPILEDP (fun
))
3112 ptrdiff_t size
= PVSIZE (fun
);
3113 if (size
<= COMPILED_STACK_DEPTH
)
3114 xsignal1 (Qinvalid_function
, fun
);
3115 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3116 if (INTEGERP (syms_left
))
3117 return get_byte_code_arity (syms_left
);
3122 EMACS_INT minargs
= 0, maxargs
= 0;
3123 bool optional
= false;
3124 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3126 Lisp_Object next
= XCAR (syms_left
);
3127 if (!SYMBOLP (next
))
3128 xsignal1 (Qinvalid_function
, fun
);
3130 if (EQ (next
, Qand_rest
))
3131 return Fcons (make_number (minargs
), Qmany
);
3132 else if (EQ (next
, Qand_optional
))
3142 if (!NILP (syms_left
))
3143 xsignal1 (Qinvalid_function
, fun
);
3145 return Fcons (make_number (minargs
), make_number (maxargs
));
3148 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3150 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3151 (Lisp_Object object
)
3155 if (COMPILEDP (object
))
3157 ptrdiff_t size
= PVSIZE (object
);
3158 if (size
<= COMPILED_STACK_DEPTH
)
3159 xsignal1 (Qinvalid_function
, object
);
3160 if (CONSP (AREF (object
, COMPILED_BYTECODE
)))
3162 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3165 tem
= AREF (object
, COMPILED_BYTECODE
);
3166 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3167 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3169 error ("Invalid byte code");
3171 ASET (object
, COMPILED_BYTECODE
, XCAR (tem
));
3172 ASET (object
, COMPILED_CONSTANTS
, XCDR (tem
));
3178 /* Return true if SYMBOL currently has a let-binding
3179 which was made in the buffer that is now current. */
3182 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
3184 union specbinding
*p
;
3185 Lisp_Object buf
= Fcurrent_buffer ();
3187 for (p
= specpdl_ptr
; p
> specpdl
; )
3188 if ((--p
)->kind
> SPECPDL_LET
)
3190 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (specpdl_symbol (p
));
3191 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
3192 if (symbol
== let_bound_symbol
3193 && EQ (specpdl_where (p
), buf
))
3201 do_specbind (struct Lisp_Symbol
*sym
, union specbinding
*bind
,
3202 Lisp_Object value
, enum Set_Internal_Bind bindflag
)
3204 switch (sym
->redirect
)
3206 case SYMBOL_PLAINVAL
:
3207 if (!sym
->trapped_write
)
3208 SET_SYMBOL_VAL (sym
, value
);
3210 set_internal (specpdl_symbol (bind
), value
, Qnil
, bindflag
);
3213 case SYMBOL_FORWARDED
:
3214 if (BUFFER_OBJFWDP (SYMBOL_FWD (sym
))
3215 && specpdl_kind (bind
) == SPECPDL_LET_DEFAULT
)
3217 set_default_internal (specpdl_symbol (bind
), value
, bindflag
);
3221 case SYMBOL_LOCALIZED
:
3222 set_internal (specpdl_symbol (bind
), value
, Qnil
, bindflag
);
3230 /* `specpdl_ptr' describes which variable is
3231 let-bound, so it can be properly undone when we unbind_to.
3232 It can be either a plain SPECPDL_LET or a SPECPDL_LET_LOCAL/DEFAULT.
3233 - SYMBOL is the variable being bound. Note that it should not be
3234 aliased (i.e. when let-binding V1 that's aliased to V2, we want
3236 - WHERE tells us in which buffer the binding took place.
3237 This is used for SPECPDL_LET_LOCAL bindings (i.e. bindings to a
3238 buffer-local variable) as well as for SPECPDL_LET_DEFAULT bindings,
3239 i.e. bindings to the default value of a variable which can be
3243 specbind (Lisp_Object symbol
, Lisp_Object value
)
3245 struct Lisp_Symbol
*sym
;
3247 CHECK_SYMBOL (symbol
);
3248 sym
= XSYMBOL (symbol
);
3251 switch (sym
->redirect
)
3253 case SYMBOL_VARALIAS
:
3254 sym
= indirect_variable (sym
); XSETSYMBOL (symbol
, sym
); goto start
;
3255 case SYMBOL_PLAINVAL
:
3256 /* The most common case is that of a non-constant symbol with a
3257 trivial value. Make that as fast as we can. */
3258 specpdl_ptr
->let
.kind
= SPECPDL_LET
;
3259 specpdl_ptr
->let
.symbol
= symbol
;
3260 specpdl_ptr
->let
.old_value
= SYMBOL_VAL (sym
);
3261 specpdl_ptr
->let
.saved_value
= Qnil
;
3263 do_specbind (sym
, specpdl_ptr
- 1, value
, SET_INTERNAL_BIND
);
3265 case SYMBOL_LOCALIZED
:
3266 case SYMBOL_FORWARDED
:
3268 Lisp_Object ovalue
= find_symbol_value (symbol
);
3269 specpdl_ptr
->let
.kind
= SPECPDL_LET_LOCAL
;
3270 specpdl_ptr
->let
.symbol
= symbol
;
3271 specpdl_ptr
->let
.old_value
= ovalue
;
3272 specpdl_ptr
->let
.where
= Fcurrent_buffer ();
3273 specpdl_ptr
->let
.saved_value
= Qnil
;
3275 eassert (sym
->redirect
!= SYMBOL_LOCALIZED
3276 || (EQ (SYMBOL_BLV (sym
)->where
, Fcurrent_buffer ())));
3278 if (sym
->redirect
== SYMBOL_LOCALIZED
)
3280 if (!blv_found (SYMBOL_BLV (sym
)))
3281 specpdl_ptr
->let
.kind
= SPECPDL_LET_DEFAULT
;
3283 else if (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)))
3285 /* If SYMBOL is a per-buffer variable which doesn't have a
3286 buffer-local value here, make the `let' change the global
3287 value by changing the value of SYMBOL in all buffers not
3288 having their own value. This is consistent with what
3289 happens with other buffer-local variables. */
3290 if (NILP (Flocal_variable_p (symbol
, Qnil
)))
3292 specpdl_ptr
->let
.kind
= SPECPDL_LET_DEFAULT
;
3294 do_specbind (sym
, specpdl_ptr
- 1, value
, SET_INTERNAL_BIND
);
3299 specpdl_ptr
->let
.kind
= SPECPDL_LET
;
3302 do_specbind (sym
, specpdl_ptr
- 1, value
, SET_INTERNAL_BIND
);
3305 default: emacs_abort ();
3309 /* Push unwind-protect entries of various types. */
3312 record_unwind_protect (void (*function
) (Lisp_Object
), Lisp_Object arg
)
3314 specpdl_ptr
->unwind
.kind
= SPECPDL_UNWIND
;
3315 specpdl_ptr
->unwind
.func
= function
;
3316 specpdl_ptr
->unwind
.arg
= arg
;
3321 record_unwind_protect_ptr (void (*function
) (void *), void *arg
)
3323 specpdl_ptr
->unwind_ptr
.kind
= SPECPDL_UNWIND_PTR
;
3324 specpdl_ptr
->unwind_ptr
.func
= function
;
3325 specpdl_ptr
->unwind_ptr
.arg
= arg
;
3330 record_unwind_protect_int (void (*function
) (int), int arg
)
3332 specpdl_ptr
->unwind_int
.kind
= SPECPDL_UNWIND_INT
;
3333 specpdl_ptr
->unwind_int
.func
= function
;
3334 specpdl_ptr
->unwind_int
.arg
= arg
;
3339 record_unwind_protect_void (void (*function
) (void))
3341 specpdl_ptr
->unwind_void
.kind
= SPECPDL_UNWIND_VOID
;
3342 specpdl_ptr
->unwind_void
.func
= function
;
3347 rebind_for_thread_switch (void)
3349 union specbinding
*bind
;
3351 for (bind
= specpdl
; bind
!= specpdl_ptr
; ++bind
)
3353 if (bind
->kind
>= SPECPDL_LET
)
3355 Lisp_Object value
= specpdl_saved_value (bind
);
3356 Lisp_Object sym
= specpdl_symbol (bind
);
3357 bind
->let
.saved_value
= Qnil
;
3358 do_specbind (XSYMBOL (sym
), bind
, value
,
3359 SET_INTERNAL_THREAD_SWITCH
);
3365 do_one_unbind (union specbinding
*this_binding
, bool unwinding
,
3366 enum Set_Internal_Bind bindflag
)
3368 eassert (unwinding
|| this_binding
->kind
>= SPECPDL_LET
);
3369 switch (this_binding
->kind
)
3371 case SPECPDL_UNWIND
:
3372 this_binding
->unwind
.func (this_binding
->unwind
.arg
);
3374 case SPECPDL_UNWIND_PTR
:
3375 this_binding
->unwind_ptr
.func (this_binding
->unwind_ptr
.arg
);
3377 case SPECPDL_UNWIND_INT
:
3378 this_binding
->unwind_int
.func (this_binding
->unwind_int
.arg
);
3380 case SPECPDL_UNWIND_VOID
:
3381 this_binding
->unwind_void
.func ();
3383 case SPECPDL_BACKTRACE
:
3386 { /* If variable has a trivial value (no forwarding), and isn't
3387 trapped, we can just set it. */
3388 Lisp_Object sym
= specpdl_symbol (this_binding
);
3389 if (SYMBOLP (sym
) && XSYMBOL (sym
)->redirect
== SYMBOL_PLAINVAL
)
3391 if (XSYMBOL (sym
)->trapped_write
== SYMBOL_UNTRAPPED_WRITE
)
3392 SET_SYMBOL_VAL (XSYMBOL (sym
), specpdl_old_value (this_binding
));
3394 set_internal (sym
, specpdl_old_value (this_binding
),
3399 /* Come here only if make_local_foo was used for the first time
3400 on this var within this let. */
3402 case SPECPDL_LET_DEFAULT
:
3403 set_default_internal (specpdl_symbol (this_binding
),
3404 specpdl_old_value (this_binding
),
3407 case SPECPDL_LET_LOCAL
:
3409 Lisp_Object symbol
= specpdl_symbol (this_binding
);
3410 Lisp_Object where
= specpdl_where (this_binding
);
3411 Lisp_Object old_value
= specpdl_old_value (this_binding
);
3412 eassert (BUFFERP (where
));
3414 /* If this was a local binding, reset the value in the appropriate
3415 buffer, but only if that buffer's binding still exists. */
3416 if (!NILP (Flocal_variable_p (symbol
, where
)))
3417 set_internal (symbol
, old_value
, where
, bindflag
);
3427 /* Push an unwind-protect entry that does nothing, so that
3428 set_unwind_protect_ptr can overwrite it later. */
3431 record_unwind_protect_nothing (void)
3433 record_unwind_protect_void (do_nothing
);
3436 /* Clear the unwind-protect entry COUNT, so that it does nothing.
3437 It need not be at the top of the stack. */
3440 clear_unwind_protect (ptrdiff_t count
)
3442 union specbinding
*p
= specpdl
+ count
;
3443 p
->unwind_void
.kind
= SPECPDL_UNWIND_VOID
;
3444 p
->unwind_void
.func
= do_nothing
;
3447 /* Set the unwind-protect entry COUNT so that it invokes FUNC (ARG).
3448 It need not be at the top of the stack. Discard the entry's
3449 previous value without invoking it. */
3452 set_unwind_protect (ptrdiff_t count
, void (*func
) (Lisp_Object
),
3455 union specbinding
*p
= specpdl
+ count
;
3456 p
->unwind
.kind
= SPECPDL_UNWIND
;
3457 p
->unwind
.func
= func
;
3458 p
->unwind
.arg
= arg
;
3462 set_unwind_protect_ptr (ptrdiff_t count
, void (*func
) (void *), void *arg
)
3464 union specbinding
*p
= specpdl
+ count
;
3465 p
->unwind_ptr
.kind
= SPECPDL_UNWIND_PTR
;
3466 p
->unwind_ptr
.func
= func
;
3467 p
->unwind_ptr
.arg
= arg
;
3470 /* Pop and execute entries from the unwind-protect stack until the
3471 depth COUNT is reached. Return VALUE. */
3474 unbind_to (ptrdiff_t count
, Lisp_Object value
)
3476 Lisp_Object quitf
= Vquit_flag
;
3480 while (specpdl_ptr
!= specpdl
+ count
)
3482 /* Copy the binding, and decrement specpdl_ptr, before we do
3483 the work to unbind it. We decrement first
3484 so that an error in unbinding won't try to unbind
3485 the same entry again, and we copy the binding first
3486 in case more bindings are made during some of the code we run. */
3488 union specbinding this_binding
;
3489 this_binding
= *--specpdl_ptr
;
3491 do_one_unbind (&this_binding
, true, SET_INTERNAL_UNBIND
);
3494 if (NILP (Vquit_flag
) && !NILP (quitf
))
3501 unbind_for_thread_switch (struct thread_state
*thr
)
3503 union specbinding
*bind
;
3505 for (bind
= thr
->m_specpdl_ptr
; bind
> thr
->m_specpdl
;)
3507 if ((--bind
)->kind
>= SPECPDL_LET
)
3509 Lisp_Object sym
= specpdl_symbol (bind
);
3510 bind
->let
.saved_value
= find_symbol_value (sym
);
3511 do_one_unbind (bind
, false, SET_INTERNAL_THREAD_SWITCH
);
3516 DEFUN ("special-variable-p", Fspecial_variable_p
, Sspecial_variable_p
, 1, 1, 0,
3517 doc
: /* Return non-nil if SYMBOL's global binding has been declared special.
3518 A special variable is one that will be bound dynamically, even in a
3519 context where binding is lexical by default. */)
3520 (Lisp_Object symbol
)
3522 CHECK_SYMBOL (symbol
);
3523 return XSYMBOL (symbol
)->declared_special
? Qt
: Qnil
;
3527 static union specbinding
*
3528 get_backtrace_starting_at (Lisp_Object base
)
3530 union specbinding
*pdl
= backtrace_top ();
3533 { /* Skip up to `base'. */
3534 base
= Findirect_function (base
, Qt
);
3535 while (backtrace_p (pdl
)
3536 && !EQ (base
, Findirect_function (backtrace_function (pdl
), Qt
)))
3537 pdl
= backtrace_next (pdl
);
3543 static union specbinding
*
3544 get_backtrace_frame (Lisp_Object nframes
, Lisp_Object base
)
3546 register EMACS_INT i
;
3548 CHECK_NATNUM (nframes
);
3549 union specbinding
*pdl
= get_backtrace_starting_at (base
);
3551 /* Find the frame requested. */
3552 for (i
= XFASTINT (nframes
); i
> 0 && backtrace_p (pdl
); i
--)
3553 pdl
= backtrace_next (pdl
);
3559 backtrace_frame_apply (Lisp_Object function
, union specbinding
*pdl
)
3561 if (!backtrace_p (pdl
))
3564 Lisp_Object flags
= Qnil
;
3565 if (backtrace_debug_on_exit (pdl
))
3566 flags
= Fcons (QCdebug_on_exit
, Fcons (Qt
, Qnil
));
3568 if (backtrace_nargs (pdl
) == UNEVALLED
)
3569 return call4 (function
, Qnil
, backtrace_function (pdl
), *backtrace_args (pdl
), flags
);
3572 Lisp_Object tem
= Flist (backtrace_nargs (pdl
), backtrace_args (pdl
));
3573 return call4 (function
, Qt
, backtrace_function (pdl
), tem
, flags
);
3577 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3578 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3579 The debugger is entered when that frame exits, if the flag is non-nil. */)
3580 (Lisp_Object level
, Lisp_Object flag
)
3582 CHECK_NUMBER (level
);
3583 union specbinding
*pdl
= get_backtrace_frame(level
, Qnil
);
3585 if (backtrace_p (pdl
))
3586 set_backtrace_debug_on_exit (pdl
, !NILP (flag
));
3591 DEFUN ("mapbacktrace", Fmapbacktrace
, Smapbacktrace
, 1, 2, 0,
3592 doc
: /* Call FUNCTION for each frame in backtrace.
3593 If BASE is non-nil, it should be a function and iteration will start
3594 from its nearest activation frame.
3595 FUNCTION is called with 4 arguments: EVALD, FUNC, ARGS, and FLAGS. If
3596 a frame has not evaluated its arguments yet or is a special form,
3597 EVALD is nil and ARGS is a list of forms. If a frame has evaluated
3598 its arguments and called its function already, EVALD is t and ARGS is
3600 FLAGS is a plist of properties of the current frame: currently, the
3601 only supported property is :debug-on-exit. `mapbacktrace' always
3603 (Lisp_Object function
, Lisp_Object base
)
3605 union specbinding
*pdl
= get_backtrace_starting_at (base
);
3607 while (backtrace_p (pdl
))
3609 ptrdiff_t i
= pdl
- specpdl
;
3610 backtrace_frame_apply (function
, pdl
);
3611 /* Beware! PDL is no longer valid here because FUNCTION might
3612 have caused grow_specpdl to reallocate pdlvec. We must use
3613 the saved index, cf. Bug#27258. */
3614 pdl
= backtrace_next (&specpdl
[i
]);
3620 DEFUN ("backtrace-frame--internal", Fbacktrace_frame_internal
,
3621 Sbacktrace_frame_internal
, 3, 3, NULL
,
3622 doc
: /* Call FUNCTION on stack frame NFRAMES away from BASE.
3623 Return the result of FUNCTION, or nil if no matching frame could be found. */)
3624 (Lisp_Object function
, Lisp_Object nframes
, Lisp_Object base
)
3626 return backtrace_frame_apply (function
, get_backtrace_frame (nframes
, base
));
3629 /* For backtrace-eval, we want to temporarily unwind the last few elements of
3630 the specpdl stack, and then rewind them. We store the pre-unwind values
3631 directly in the pre-existing specpdl elements (i.e. we swap the current
3632 value and the old value stored in the specpdl), kind of like the inplace
3633 pointer-reversal trick. As it turns out, the rewind does the same as the
3634 unwind, except it starts from the other end of the specpdl stack, so we use
3635 the same function for both unwind and rewind. */
3637 backtrace_eval_unrewind (int distance
)
3639 union specbinding
*tmp
= specpdl_ptr
;
3642 { /* It's a rewind rather than unwind. */
3643 tmp
+= distance
- 1;
3645 distance
= -distance
;
3648 for (; distance
> 0; distance
--)
3653 /* FIXME: Ideally we'd like to "temporarily unwind" (some of) those
3654 unwind_protect, but the problem is that we don't know how to
3655 rewind them afterwards. */
3656 case SPECPDL_UNWIND
:
3658 Lisp_Object oldarg
= tmp
->unwind
.arg
;
3659 if (tmp
->unwind
.func
== set_buffer_if_live
)
3660 tmp
->unwind
.arg
= Fcurrent_buffer ();
3661 else if (tmp
->unwind
.func
== save_excursion_restore
)
3662 tmp
->unwind
.arg
= save_excursion_save ();
3665 tmp
->unwind
.func (oldarg
);
3669 case SPECPDL_UNWIND_PTR
:
3670 case SPECPDL_UNWIND_INT
:
3671 case SPECPDL_UNWIND_VOID
:
3672 case SPECPDL_BACKTRACE
:
3675 { /* If variable has a trivial value (no forwarding), we can
3676 just set it. No need to check for constant symbols here,
3677 since that was already done by specbind. */
3678 Lisp_Object sym
= specpdl_symbol (tmp
);
3679 if (SYMBOLP (sym
) && XSYMBOL (sym
)->redirect
== SYMBOL_PLAINVAL
)
3681 Lisp_Object old_value
= specpdl_old_value (tmp
);
3682 set_specpdl_old_value (tmp
, SYMBOL_VAL (XSYMBOL (sym
)));
3683 SET_SYMBOL_VAL (XSYMBOL (sym
), old_value
);
3687 /* Come here only if make_local_foo was used for the first
3688 time on this var within this let. */
3690 case SPECPDL_LET_DEFAULT
:
3692 Lisp_Object sym
= specpdl_symbol (tmp
);
3693 Lisp_Object old_value
= specpdl_old_value (tmp
);
3694 set_specpdl_old_value (tmp
, Fdefault_value (sym
));
3695 Fset_default (sym
, old_value
);
3698 case SPECPDL_LET_LOCAL
:
3700 Lisp_Object symbol
= specpdl_symbol (tmp
);
3701 Lisp_Object where
= specpdl_where (tmp
);
3702 Lisp_Object old_value
= specpdl_old_value (tmp
);
3703 eassert (BUFFERP (where
));
3705 /* If this was a local binding, reset the value in the appropriate
3706 buffer, but only if that buffer's binding still exists. */
3707 if (!NILP (Flocal_variable_p (symbol
, where
)))
3709 set_specpdl_old_value
3710 (tmp
, Fbuffer_local_value (symbol
, where
));
3711 set_internal (symbol
, old_value
, where
, SET_INTERNAL_UNBIND
);
3719 DEFUN ("backtrace-eval", Fbacktrace_eval
, Sbacktrace_eval
, 2, 3, NULL
,
3720 doc
: /* Evaluate EXP in the context of some activation frame.
3721 NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */)
3722 (Lisp_Object exp
, Lisp_Object nframes
, Lisp_Object base
)
3724 union specbinding
*pdl
= get_backtrace_frame (nframes
, base
);
3725 ptrdiff_t count
= SPECPDL_INDEX ();
3726 ptrdiff_t distance
= specpdl_ptr
- pdl
;
3727 eassert (distance
>= 0);
3729 if (!backtrace_p (pdl
))
3730 error ("Activation frame not found!");
3732 backtrace_eval_unrewind (distance
);
3733 record_unwind_protect_int (backtrace_eval_unrewind
, -distance
);
3735 /* Use eval_sub rather than Feval since the main motivation behind
3736 backtrace-eval is to be able to get/set the value of lexical variables
3737 from the debugger. */
3738 return unbind_to (count
, eval_sub (exp
));
3741 DEFUN ("backtrace--locals", Fbacktrace__locals
, Sbacktrace__locals
, 1, 2, NULL
,
3742 doc
: /* Return names and values of local variables of a stack frame.
3743 NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */)
3744 (Lisp_Object nframes
, Lisp_Object base
)
3746 union specbinding
*frame
= get_backtrace_frame (nframes
, base
);
3747 union specbinding
*prevframe
3748 = get_backtrace_frame (make_number (XFASTINT (nframes
) - 1), base
);
3749 ptrdiff_t distance
= specpdl_ptr
- frame
;
3750 Lisp_Object result
= Qnil
;
3751 eassert (distance
>= 0);
3753 if (!backtrace_p (prevframe
))
3754 error ("Activation frame not found!");
3755 if (!backtrace_p (frame
))
3756 error ("Activation frame not found!");
3758 /* The specpdl entries normally contain the symbol being bound along with its
3759 `old_value', so it can be restored. The new value to which it is bound is
3760 available in one of two places: either in the current value of the
3761 variable (if it hasn't been rebound yet) or in the `old_value' slot of the
3762 next specpdl entry for it.
3763 `backtrace_eval_unrewind' happens to swap the role of `old_value'
3764 and "new value", so we abuse it here, to fetch the new value.
3765 It's ugly (we'd rather not modify global data) and a bit inefficient,
3766 but it does the job for now. */
3767 backtrace_eval_unrewind (distance
);
3771 union specbinding
*tmp
= prevframe
;
3772 for (; tmp
> frame
; tmp
--)
3777 case SPECPDL_LET_DEFAULT
:
3778 case SPECPDL_LET_LOCAL
:
3780 Lisp_Object sym
= specpdl_symbol (tmp
);
3781 Lisp_Object val
= specpdl_old_value (tmp
);
3782 if (EQ (sym
, Qinternal_interpreter_environment
))
3784 Lisp_Object env
= val
;
3785 for (; CONSP (env
); env
= XCDR (env
))
3787 Lisp_Object binding
= XCAR (env
);
3788 if (CONSP (binding
))
3789 result
= Fcons (Fcons (XCAR (binding
),
3795 result
= Fcons (Fcons (sym
, val
), result
);
3799 case SPECPDL_UNWIND
:
3800 case SPECPDL_UNWIND_PTR
:
3801 case SPECPDL_UNWIND_INT
:
3802 case SPECPDL_UNWIND_VOID
:
3803 case SPECPDL_BACKTRACE
:
3812 /* Restore values from specpdl to original place. */
3813 backtrace_eval_unrewind (-distance
);
3820 mark_specpdl (union specbinding
*first
, union specbinding
*ptr
)
3822 union specbinding
*pdl
;
3823 for (pdl
= first
; pdl
!= ptr
; pdl
++)
3827 case SPECPDL_UNWIND
:
3828 mark_object (specpdl_arg (pdl
));
3831 case SPECPDL_BACKTRACE
:
3833 ptrdiff_t nargs
= backtrace_nargs (pdl
);
3834 mark_object (backtrace_function (pdl
));
3835 if (nargs
== UNEVALLED
)
3838 mark_object (backtrace_args (pdl
)[nargs
]);
3842 case SPECPDL_LET_DEFAULT
:
3843 case SPECPDL_LET_LOCAL
:
3844 mark_object (specpdl_where (pdl
));
3847 mark_object (specpdl_symbol (pdl
));
3848 mark_object (specpdl_old_value (pdl
));
3849 mark_object (specpdl_saved_value (pdl
));
3852 case SPECPDL_UNWIND_PTR
:
3853 case SPECPDL_UNWIND_INT
:
3854 case SPECPDL_UNWIND_VOID
:
3864 get_backtrace (Lisp_Object array
)
3866 union specbinding
*pdl
= backtrace_next (backtrace_top ());
3867 ptrdiff_t i
= 0, asize
= ASIZE (array
);
3869 /* Copy the backtrace contents into working memory. */
3870 for (; i
< asize
; i
++)
3872 if (backtrace_p (pdl
))
3874 ASET (array
, i
, backtrace_function (pdl
));
3875 pdl
= backtrace_next (pdl
);
3878 ASET (array
, i
, Qnil
);
3882 Lisp_Object
backtrace_top_function (void)
3884 union specbinding
*pdl
= backtrace_top ();
3885 return (backtrace_p (pdl
) ? backtrace_function (pdl
) : Qnil
);
3891 DEFVAR_INT ("max-specpdl-size", max_specpdl_size
,
3892 doc
: /* Limit on number of Lisp variable bindings and `unwind-protect's.
3893 If Lisp code tries to increase the total number past this amount,
3894 an error is signaled.
3895 You can safely use a value considerably larger than the default value,
3896 if that proves inconveniently small. However, if you increase it too far,
3897 Emacs could run out of memory trying to make the stack bigger.
3898 Note that this limit may be silently increased by the debugger
3899 if `debug-on-error' or `debug-on-quit' is set. */);
3901 DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth
,
3902 doc
: /* Limit on depth in `eval', `apply' and `funcall' before error.
3904 This limit serves to catch infinite recursions for you before they cause
3905 actual stack overflow in C, which would be fatal for Emacs.
3906 You can safely make it considerably larger than its default value,
3907 if that proves inconveniently small. However, if you increase it too far,
3908 Emacs could overflow the real C stack, and crash. */);
3910 DEFVAR_LISP ("quit-flag", Vquit_flag
,
3911 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3912 If the value is t, that means do an ordinary quit.
3913 If the value equals `throw-on-input', that means quit by throwing
3914 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3915 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3916 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3919 DEFVAR_LISP ("inhibit-quit", Vinhibit_quit
,
3920 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3921 Note that `quit-flag' will still be set by typing C-g,
3922 so a quit will be signaled as soon as `inhibit-quit' is nil.
3923 To prevent this happening, set `quit-flag' to nil
3924 before making `inhibit-quit' nil. */);
3925 Vinhibit_quit
= Qnil
;
3927 DEFSYM (Qsetq
, "setq");
3928 DEFSYM (Qinhibit_quit
, "inhibit-quit");
3929 DEFSYM (Qautoload
, "autoload");
3930 DEFSYM (Qinhibit_debugger
, "inhibit-debugger");
3931 DEFSYM (Qmacro
, "macro");
3933 /* Note that the process handling also uses Qexit, but we don't want
3934 to staticpro it twice, so we just do it here. */
3935 DEFSYM (Qexit
, "exit");
3937 DEFSYM (Qinteractive
, "interactive");
3938 DEFSYM (Qcommandp
, "commandp");
3939 DEFSYM (Qand_rest
, "&rest");
3940 DEFSYM (Qand_optional
, "&optional");
3941 DEFSYM (Qclosure
, "closure");
3942 DEFSYM (QCdocumentation
, ":documentation");
3943 DEFSYM (Qdebug
, "debug");
3945 DEFVAR_LISP ("inhibit-debugger", Vinhibit_debugger
,
3946 doc
: /* Non-nil means never enter the debugger.
3947 Normally set while the debugger is already active, to avoid recursive
3949 Vinhibit_debugger
= Qnil
;
3951 DEFVAR_LISP ("debug-on-error", Vdebug_on_error
,
3952 doc
: /* Non-nil means enter debugger if an error is signaled.
3953 Does not apply to errors handled by `condition-case' or those
3954 matched by `debug-ignored-errors'.
3955 If the value is a list, an error only means to enter the debugger
3956 if one of its condition symbols appears in the list.
3957 When you evaluate an expression interactively, this variable
3958 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3959 The command `toggle-debug-on-error' toggles this.
3960 See also the variable `debug-on-quit' and `inhibit-debugger'. */);
3961 Vdebug_on_error
= Qnil
;
3963 DEFVAR_LISP ("debug-ignored-errors", Vdebug_ignored_errors
,
3964 doc
: /* List of errors for which the debugger should not be called.
3965 Each element may be a condition-name or a regexp that matches error messages.
3966 If any element applies to a given error, that error skips the debugger
3967 and just returns to top level.
3968 This overrides the variable `debug-on-error'.
3969 It does not apply to errors handled by `condition-case'. */);
3970 Vdebug_ignored_errors
= Qnil
;
3972 DEFVAR_BOOL ("debug-on-quit", debug_on_quit
,
3973 doc
: /* Non-nil means enter debugger if quit is signaled (C-g, for example).
3974 Does not apply if quit is handled by a `condition-case'. */);
3977 DEFVAR_BOOL ("debug-on-next-call", debug_on_next_call
,
3978 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3980 DEFVAR_BOOL ("debugger-may-continue", debugger_may_continue
,
3981 doc
: /* Non-nil means debugger may continue execution.
3982 This is nil when the debugger is called under circumstances where it
3983 might not be safe to continue. */);
3984 debugger_may_continue
= 1;
3986 DEFVAR_BOOL ("debugger-stack-frame-as-list", debugger_stack_frame_as_list
,
3987 doc
: /* Non-nil means display call stack frames as lists. */);
3988 debugger_stack_frame_as_list
= 0;
3990 DEFVAR_LISP ("debugger", Vdebugger
,
3991 doc
: /* Function to call to invoke debugger.
3992 If due to frame exit, args are `exit' and the value being returned;
3993 this function's value will be returned instead of that.
3994 If due to error, args are `error' and a list of the args to `signal'.
3995 If due to `apply' or `funcall' entry, one arg, `lambda'.
3996 If due to `eval' entry, one arg, t. */);
3999 DEFVAR_LISP ("signal-hook-function", Vsignal_hook_function
,
4000 doc
: /* If non-nil, this is a function for `signal' to call.
4001 It receives the same arguments that `signal' was given.
4002 The Edebug package uses this to regain control. */);
4003 Vsignal_hook_function
= Qnil
;
4005 DEFVAR_LISP ("debug-on-signal", Vdebug_on_signal
,
4006 doc
: /* Non-nil means call the debugger regardless of condition handlers.
4007 Note that `debug-on-error', `debug-on-quit' and friends
4008 still determine whether to handle the particular condition. */);
4009 Vdebug_on_signal
= Qnil
;
4011 /* When lexical binding is being used,
4012 Vinternal_interpreter_environment is non-nil, and contains an alist
4013 of lexically-bound variable, or (t), indicating an empty
4014 environment. The lisp name of this variable would be
4015 `internal-interpreter-environment' if it weren't hidden.
4016 Every element of this list can be either a cons (VAR . VAL)
4017 specifying a lexical binding, or a single symbol VAR indicating
4018 that this variable should use dynamic scoping. */
4019 DEFSYM (Qinternal_interpreter_environment
,
4020 "internal-interpreter-environment");
4021 DEFVAR_LISP ("internal-interpreter-environment",
4022 Vinternal_interpreter_environment
,
4023 doc
: /* If non-nil, the current lexical environment of the lisp interpreter.
4024 When lexical binding is not being used, this variable is nil.
4025 A value of `(t)' indicates an empty environment, otherwise it is an
4026 alist of active lexical bindings. */);
4027 Vinternal_interpreter_environment
= Qnil
;
4028 /* Don't export this variable to Elisp, so no one can mess with it
4029 (Just imagine if someone makes it buffer-local). */
4030 Funintern (Qinternal_interpreter_environment
, Qnil
);
4032 Vrun_hooks
= intern_c_string ("run-hooks");
4033 staticpro (&Vrun_hooks
);
4035 staticpro (&Vautoload_queue
);
4036 Vautoload_queue
= Qnil
;
4037 staticpro (&Vsignaling_function
);
4038 Vsignaling_function
= Qnil
;
4040 inhibit_lisp_code
= Qnil
;
4051 defsubr (&Sfunction
);
4052 defsubr (&Sdefault_toplevel_value
);
4053 defsubr (&Sset_default_toplevel_value
);
4055 defsubr (&Sdefvaralias
);
4056 DEFSYM (Qdefvaralias
, "defvaralias");
4057 defsubr (&Sdefconst
);
4058 defsubr (&Smake_var_non_special
);
4062 defsubr (&Smacroexpand
);
4065 defsubr (&Sunwind_protect
);
4066 defsubr (&Scondition_case
);
4068 defsubr (&Scommandp
);
4069 defsubr (&Sautoload
);
4070 defsubr (&Sautoload_do_load
);
4073 defsubr (&Sfuncall
);
4074 defsubr (&Sfunc_arity
);
4075 defsubr (&Srun_hooks
);
4076 defsubr (&Srun_hook_with_args
);
4077 defsubr (&Srun_hook_with_args_until_success
);
4078 defsubr (&Srun_hook_with_args_until_failure
);
4079 defsubr (&Srun_hook_wrapped
);
4080 defsubr (&Sfetch_bytecode
);
4081 defsubr (&Sbacktrace_debug
);
4082 DEFSYM (QCdebug_on_exit
, ":debug-on-exit");
4083 defsubr (&Smapbacktrace
);
4084 defsubr (&Sbacktrace_frame_internal
);
4085 defsubr (&Sbacktrace_eval
);
4086 defsubr (&Sbacktrace__locals
);
4087 defsubr (&Sspecial_variable_p
);
4088 defsubr (&Sfunctionp
);