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 Lisp_Object arg
= XCAR (args
);
359 val
= eval_sub (arg
);
367 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
368 doc
: /* Eval args until one of them yields nil, then return nil.
369 The remaining args are not evalled at all.
370 If no arg yields nil, return the last arg's value.
371 usage: (and CONDITIONS...) */)
374 Lisp_Object val
= Qt
;
378 Lisp_Object arg
= XCAR (args
);
380 val
= eval_sub (arg
);
388 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
389 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
390 Returns the value of THEN or the value of the last of the ELSE's.
391 THEN must be one expression, but ELSE... can be zero or more expressions.
392 If COND yields nil, and there are no ELSE's, the value is nil.
393 usage: (if COND THEN ELSE...) */)
398 cond
= eval_sub (XCAR (args
));
401 return eval_sub (Fcar (XCDR (args
)));
402 return Fprogn (Fcdr (XCDR (args
)));
405 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
406 doc
: /* Try each clause until one succeeds.
407 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
408 and, if the value is non-nil, this clause succeeds:
409 then the expressions in BODY are evaluated and the last one's
410 value is the value of the cond-form.
411 If a clause has one element, as in (CONDITION), then the cond-form
412 returns CONDITION's value, if that is non-nil.
413 If no clause succeeds, cond returns nil.
414 usage: (cond CLAUSES...) */)
417 Lisp_Object val
= args
;
421 Lisp_Object clause
= XCAR (args
);
422 val
= eval_sub (Fcar (clause
));
425 if (!NILP (XCDR (clause
)))
426 val
= Fprogn (XCDR (clause
));
435 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
436 doc
: /* Eval BODY forms sequentially and return value of last one.
437 usage: (progn BODY...) */)
440 Lisp_Object val
= Qnil
;
444 Lisp_Object form
= XCAR (body
);
446 val
= eval_sub (form
);
452 /* Evaluate BODY sequentially, discarding its value. */
455 prog_ignore (Lisp_Object body
)
460 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
461 doc
: /* Eval FIRST and BODY sequentially; return value from FIRST.
462 The value of FIRST is saved during the evaluation of the remaining args,
463 whose values are discarded.
464 usage: (prog1 FIRST BODY...) */)
467 Lisp_Object val
= eval_sub (XCAR (args
));
468 prog_ignore (XCDR (args
));
472 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
473 doc
: /* Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
474 The value of FORM2 is saved during the evaluation of the
475 remaining args, whose values are discarded.
476 usage: (prog2 FORM1 FORM2 BODY...) */)
479 eval_sub (XCAR (args
));
480 return Fprog1 (XCDR (args
));
483 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
484 doc
: /* Set each SYM to the value of its VAL.
485 The symbols SYM are variables; they are literal (not evaluated).
486 The values VAL are expressions; they are evaluated.
487 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
488 The second VAL is not computed until after the first SYM is set, and so on;
489 each VAL can use the new value of variables set earlier in the `setq'.
490 The return value of the `setq' form is the value of the last VAL.
491 usage: (setq [SYM VAL]...) */)
494 Lisp_Object val
= args
, tail
= args
;
496 for (EMACS_INT nargs
= 0; CONSP (tail
); nargs
+= 2)
498 Lisp_Object sym
= XCAR (tail
), lex_binding
;
501 xsignal2 (Qwrong_number_of_arguments
, Qsetq
, make_number (nargs
+ 1));
502 Lisp_Object arg
= XCAR (tail
);
504 val
= eval_sub (arg
);
505 /* Like for eval_sub, we do not check declared_special here since
506 it's been done when let-binding. */
507 if (!NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
509 && !NILP (lex_binding
510 = Fassq (sym
, Vinternal_interpreter_environment
)))
511 XSETCDR (lex_binding
, val
); /* SYM is lexically bound. */
513 Fset (sym
, val
); /* SYM is dynamically bound. */
519 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
520 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
521 Warning: `quote' does not construct its return value, but just returns
522 the value that was pre-constructed by the Lisp reader (see info node
523 `(elisp)Printed Representation').
524 This means that \\='(a . b) is not identical to (cons \\='a \\='b): the former
525 does not cons. Quoting should be reserved for constants that will
526 never be modified by side-effects, unless you like self-modifying code.
527 See the common pitfall in info node `(elisp)Rearrangement' for an example
528 of unexpected results when a quoted object is modified.
529 usage: (quote ARG) */)
532 if (!NILP (XCDR (args
)))
533 xsignal2 (Qwrong_number_of_arguments
, Qquote
, Flength (args
));
537 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
538 doc
: /* Like `quote', but preferred for objects which are functions.
539 In byte compilation, `function' causes its argument to be compiled.
540 `quote' cannot do that.
541 usage: (function ARG) */)
544 Lisp_Object quoted
= XCAR (args
);
546 if (!NILP (XCDR (args
)))
547 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
549 if (!NILP (Vinternal_interpreter_environment
)
551 && EQ (XCAR (quoted
), Qlambda
))
552 { /* This is a lambda expression within a lexical environment;
553 return an interpreted closure instead of a simple lambda. */
554 Lisp_Object cdr
= XCDR (quoted
);
555 Lisp_Object tmp
= cdr
;
557 && (tmp
= XCDR (tmp
), CONSP (tmp
))
558 && (tmp
= XCAR (tmp
), CONSP (tmp
))
559 && (EQ (QCdocumentation
, XCAR (tmp
))))
560 { /* Handle the special (:documentation <form>) to build the docstring
562 Lisp_Object docstring
= eval_sub (Fcar (XCDR (tmp
)));
563 CHECK_STRING (docstring
);
564 cdr
= Fcons (XCAR (cdr
), Fcons (docstring
, XCDR (XCDR (cdr
))));
566 return Fcons (Qclosure
, Fcons (Vinternal_interpreter_environment
,
570 /* Simply quote the argument. */
575 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
576 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
577 Aliased variables always have the same value; setting one sets the other.
578 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
579 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
580 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
581 itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
582 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
583 The return value is BASE-VARIABLE. */)
584 (Lisp_Object new_alias
, Lisp_Object base_variable
, Lisp_Object docstring
)
586 struct Lisp_Symbol
*sym
;
588 CHECK_SYMBOL (new_alias
);
589 CHECK_SYMBOL (base_variable
);
591 if (SYMBOL_CONSTANT_P (new_alias
))
592 /* Making it an alias effectively changes its value. */
593 error ("Cannot make a constant an alias");
595 sym
= XSYMBOL (new_alias
);
597 switch (sym
->redirect
)
599 case SYMBOL_FORWARDED
:
600 error ("Cannot make an internal variable an alias");
601 case SYMBOL_LOCALIZED
:
602 error ("Don't know how to make a localized variable an alias");
603 case SYMBOL_PLAINVAL
:
604 case SYMBOL_VARALIAS
:
610 /* http://lists.gnu.org/archive/html/emacs-devel/2008-04/msg00834.html
611 If n_a is bound, but b_v is not, set the value of b_v to n_a,
612 so that old-code that affects n_a before the aliasing is setup
614 if (NILP (Fboundp (base_variable
)))
615 set_internal (base_variable
, find_symbol_value (new_alias
),
616 Qnil
, SET_INTERNAL_BIND
);
618 union specbinding
*p
;
620 for (p
= specpdl_ptr
; p
> specpdl
; )
621 if ((--p
)->kind
>= SPECPDL_LET
622 && (EQ (new_alias
, specpdl_symbol (p
))))
623 error ("Don't know how to make a let-bound variable an alias");
626 if (sym
->trapped_write
== SYMBOL_TRAPPED_WRITE
)
627 notify_variable_watchers (new_alias
, base_variable
, Qdefvaralias
, Qnil
);
629 sym
->declared_special
= 1;
630 XSYMBOL (base_variable
)->declared_special
= 1;
631 sym
->redirect
= SYMBOL_VARALIAS
;
632 SET_SYMBOL_ALIAS (sym
, XSYMBOL (base_variable
));
633 sym
->trapped_write
= XSYMBOL (base_variable
)->trapped_write
;
634 LOADHIST_ATTACH (new_alias
);
635 /* Even if docstring is nil: remove old docstring. */
636 Fput (new_alias
, Qvariable_documentation
, docstring
);
638 return base_variable
;
641 static union specbinding
*
642 default_toplevel_binding (Lisp_Object symbol
)
644 union specbinding
*binding
= NULL
;
645 union specbinding
*pdl
= specpdl_ptr
;
646 while (pdl
> specpdl
)
648 switch ((--pdl
)->kind
)
650 case SPECPDL_LET_DEFAULT
:
652 if (EQ (specpdl_symbol (pdl
), symbol
))
657 case SPECPDL_UNWIND_PTR
:
658 case SPECPDL_UNWIND_INT
:
659 case SPECPDL_UNWIND_VOID
:
660 case SPECPDL_BACKTRACE
:
661 case SPECPDL_LET_LOCAL
:
671 DEFUN ("default-toplevel-value", Fdefault_toplevel_value
, Sdefault_toplevel_value
, 1, 1, 0,
672 doc
: /* Return SYMBOL's toplevel default value.
673 "Toplevel" means outside of any let binding. */)
676 union specbinding
*binding
= default_toplevel_binding (symbol
);
678 = binding
? specpdl_old_value (binding
) : Fdefault_value (symbol
);
679 if (!EQ (value
, Qunbound
))
681 xsignal1 (Qvoid_variable
, symbol
);
684 DEFUN ("set-default-toplevel-value", Fset_default_toplevel_value
,
685 Sset_default_toplevel_value
, 2, 2, 0,
686 doc
: /* Set SYMBOL's toplevel default value to VALUE.
687 "Toplevel" means outside of any let binding. */)
688 (Lisp_Object symbol
, Lisp_Object value
)
690 union specbinding
*binding
= default_toplevel_binding (symbol
);
692 set_specpdl_old_value (binding
, value
);
694 Fset_default (symbol
, value
);
698 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
699 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
700 You are not required to define a variable in order to use it, but
701 defining it lets you supply an initial value and documentation, which
702 can be referred to by the Emacs help facilities and other programming
703 tools. The `defvar' form also declares the variable as \"special\",
704 so that it is always dynamically bound even if `lexical-binding' is t.
706 If SYMBOL's value is void and the optional argument INITVALUE is
707 provided, INITVALUE is evaluated and the result used to set SYMBOL's
708 value. If SYMBOL is buffer-local, its default value is what is set;
709 buffer-local values are not affected. If INITVALUE is missing,
710 SYMBOL's value is not set.
712 If SYMBOL has a local binding, then this form affects the local
713 binding. This is usually not what you want. Thus, if you need to
714 load a file defining variables, with this form or with `defconst' or
715 `defcustom', you should always load that file _outside_ any bindings
716 for these variables. (`defconst' and `defcustom' behave similarly in
719 The optional argument DOCSTRING is a documentation string for the
722 To define a user option, use `defcustom' instead of `defvar'.
723 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
726 Lisp_Object sym
, tem
, tail
;
733 if (!NILP (XCDR (tail
)) && !NILP (XCDR (XCDR (tail
))))
734 error ("Too many arguments");
736 tem
= Fdefault_boundp (sym
);
738 /* Do it before evaluating the initial value, for self-references. */
739 XSYMBOL (sym
)->declared_special
= 1;
742 Fset_default (sym
, eval_sub (XCAR (tail
)));
744 { /* Check if there is really a global binding rather than just a let
745 binding that shadows the global unboundness of the var. */
746 union specbinding
*binding
= default_toplevel_binding (sym
);
747 if (binding
&& EQ (specpdl_old_value (binding
), Qunbound
))
749 set_specpdl_old_value (binding
, eval_sub (XCAR (tail
)));
756 if (!NILP (Vpurify_flag
))
757 tem
= Fpurecopy (tem
);
758 Fput (sym
, Qvariable_documentation
, tem
);
760 LOADHIST_ATTACH (sym
);
762 else if (!NILP (Vinternal_interpreter_environment
)
763 && !XSYMBOL (sym
)->declared_special
)
764 /* A simple (defvar foo) with lexical scoping does "nothing" except
765 declare that var to be dynamically scoped *locally* (i.e. within
766 the current file or let-block). */
767 Vinternal_interpreter_environment
768 = Fcons (sym
, Vinternal_interpreter_environment
);
771 /* Simple (defvar <var>) should not count as a definition at all.
772 It could get in the way of other definitions, and unloading this
773 package could try to make the variable unbound. */
779 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
780 doc
: /* Define SYMBOL as a constant variable.
781 This declares that neither programs nor users should ever change the
782 value. This constancy is not actually enforced by Emacs Lisp, but
783 SYMBOL is marked as a special variable so that it is never lexically
786 The `defconst' form always sets the value of SYMBOL to the result of
787 evalling INITVALUE. If SYMBOL is buffer-local, its default value is
788 what is set; buffer-local values are not affected. If SYMBOL has a
789 local binding, then this form sets the local binding's value.
790 However, you should normally not make local bindings for variables
791 defined with this form.
793 The optional DOCSTRING specifies the variable's documentation string.
794 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
797 Lisp_Object sym
, tem
;
800 Lisp_Object docstring
= Qnil
;
801 if (!NILP (XCDR (XCDR (args
))))
803 if (!NILP (XCDR (XCDR (XCDR (args
)))))
804 error ("Too many arguments");
805 docstring
= XCAR (XCDR (XCDR (args
)));
808 tem
= eval_sub (XCAR (XCDR (args
)));
809 if (!NILP (Vpurify_flag
))
810 tem
= Fpurecopy (tem
);
811 Fset_default (sym
, tem
);
812 XSYMBOL (sym
)->declared_special
= 1;
813 if (!NILP (docstring
))
815 if (!NILP (Vpurify_flag
))
816 docstring
= Fpurecopy (docstring
);
817 Fput (sym
, Qvariable_documentation
, docstring
);
819 Fput (sym
, Qrisky_local_variable
, Qt
);
820 LOADHIST_ATTACH (sym
);
824 /* Make SYMBOL lexically scoped. */
825 DEFUN ("internal-make-var-non-special", Fmake_var_non_special
,
826 Smake_var_non_special
, 1, 1, 0,
827 doc
: /* Internal function. */)
830 CHECK_SYMBOL (symbol
);
831 XSYMBOL (symbol
)->declared_special
= 0;
836 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
837 doc
: /* Bind variables according to VARLIST then eval BODY.
838 The value of the last form in BODY is returned.
839 Each element of VARLIST is a symbol (which is bound to nil)
840 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
841 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
842 usage: (let* VARLIST BODY...) */)
845 Lisp_Object var
, val
, elt
, lexenv
;
846 ptrdiff_t count
= SPECPDL_INDEX ();
848 lexenv
= Vinternal_interpreter_environment
;
850 Lisp_Object varlist
= XCAR (args
);
851 while (CONSP (varlist
))
855 elt
= XCAR (varlist
);
856 varlist
= XCDR (varlist
);
865 if (! NILP (Fcdr (XCDR (elt
))))
866 signal_error ("`let' bindings can have only one value-form", elt
);
867 val
= eval_sub (Fcar (XCDR (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 EMACS_INT varlist_len
= XFASTINT (Flength (varlist
));
915 SAFE_ALLOCA_LISP (temps
, varlist_len
);
916 ptrdiff_t nvars
= varlist_len
;
918 /* Compute the values and store them in `temps'. */
920 for (argnum
= 0; argnum
< nvars
&& CONSP (varlist
); argnum
++)
923 elt
= XCAR (varlist
);
924 varlist
= XCDR (varlist
);
926 temps
[argnum
] = Qnil
;
927 else if (! NILP (Fcdr (Fcdr (elt
))))
928 signal_error ("`let' bindings can have only one value-form", elt
);
930 temps
[argnum
] = eval_sub (Fcar (Fcdr (elt
)));
934 lexenv
= Vinternal_interpreter_environment
;
936 varlist
= XCAR (args
);
937 for (argnum
= 0; argnum
< nvars
&& CONSP (varlist
); argnum
++)
941 elt
= XCAR (varlist
);
942 varlist
= XCDR (varlist
);
943 var
= SYMBOLP (elt
) ? elt
: Fcar (elt
);
946 if (!NILP (lexenv
) && SYMBOLP (var
)
947 && !XSYMBOL (var
)->declared_special
948 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
949 /* Lexically bind VAR by adding it to the lexenv alist. */
950 lexenv
= Fcons (Fcons (var
, tem
), lexenv
);
952 /* Dynamically bind VAR. */
956 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
957 /* Instantiate a new lexical environment. */
958 specbind (Qinternal_interpreter_environment
, lexenv
);
960 elt
= Fprogn (XCDR (args
));
962 return unbind_to (count
, elt
);
965 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
966 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
967 The order of execution is thus TEST, BODY, TEST, BODY and so on
968 until TEST returns nil.
969 usage: (while TEST BODY...) */)
972 Lisp_Object test
, body
;
976 while (!NILP (eval_sub (test
)))
985 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
986 doc
: /* Return result of expanding macros at top level of FORM.
987 If FORM is not a macro call, it is returned unchanged.
988 Otherwise, the macro is expanded and the expansion is considered
989 in place of FORM. When a non-macro-call results, it is returned.
991 The second optional arg ENVIRONMENT specifies an environment of macro
992 definitions to shadow the loaded ones for use in file byte-compilation. */)
993 (Lisp_Object form
, Lisp_Object environment
)
995 /* With cleanups from Hallvard Furuseth. */
996 register Lisp_Object expander
, sym
, def
, tem
;
1000 /* Come back here each time we expand a macro call,
1001 in case it expands into another macro call. */
1004 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1005 def
= sym
= XCAR (form
);
1007 /* Trace symbols aliases to other symbols
1008 until we get a symbol that is not an alias. */
1009 while (SYMBOLP (def
))
1013 tem
= Fassq (sym
, environment
);
1016 def
= XSYMBOL (sym
)->function
;
1022 /* Right now TEM is the result from SYM in ENVIRONMENT,
1023 and if TEM is nil then DEF is SYM's function definition. */
1026 /* SYM is not mentioned in ENVIRONMENT.
1027 Look at its function definition. */
1028 def
= Fautoload_do_load (def
, sym
, Qmacro
);
1030 /* Not defined or definition not suitable. */
1032 if (!EQ (XCAR (def
), Qmacro
))
1034 else expander
= XCDR (def
);
1038 expander
= XCDR (tem
);
1039 if (NILP (expander
))
1043 Lisp_Object newform
= apply1 (expander
, XCDR (form
));
1044 if (EQ (form
, newform
))
1053 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1054 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1055 TAG is evalled to get the tag to use; it must not be nil.
1057 Then the BODY is executed.
1058 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
1059 If no throw happens, `catch' returns the value of the last BODY form.
1060 If a throw happens, it specifies the value to return from `catch'.
1061 usage: (catch TAG BODY...) */)
1064 Lisp_Object tag
= eval_sub (XCAR (args
));
1065 return internal_catch (tag
, Fprogn
, XCDR (args
));
1068 /* Assert that E is true, but do not evaluate E. Use this instead of
1069 eassert (E) when E contains variables that might be clobbered by a
1072 #define clobbered_eassert(E) verify (sizeof (E) != 0)
1074 /* Set up a catch, then call C function FUNC on argument ARG.
1075 FUNC should return a Lisp_Object.
1076 This is how catches are done from within C code. */
1079 internal_catch (Lisp_Object tag
,
1080 Lisp_Object (*func
) (Lisp_Object
), Lisp_Object arg
)
1082 /* This structure is made part of the chain `catchlist'. */
1083 struct handler
*c
= push_handler (tag
, CATCHER
);
1086 if (! sys_setjmp (c
->jmp
))
1088 Lisp_Object val
= func (arg
);
1089 eassert (handlerlist
== c
);
1090 handlerlist
= c
->next
;
1094 { /* Throw works by a longjmp that comes right here. */
1095 Lisp_Object val
= handlerlist
->val
;
1096 clobbered_eassert (handlerlist
== c
);
1097 handlerlist
= handlerlist
->next
;
1102 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1103 jump to that CATCH, returning VALUE as the value of that catch.
1105 This is the guts of Fthrow and Fsignal; they differ only in the way
1106 they choose the catch tag to throw to. A catch tag for a
1107 condition-case form has a TAG of Qnil.
1109 Before each catch is discarded, unbind all special bindings and
1110 execute all unwind-protect clauses made above that catch. Unwind
1111 the handler stack as we go, so that the proper handlers are in
1112 effect for each unwind-protect clause we run. At the end, restore
1113 some static info saved in CATCH, and longjmp to the location
1116 This is used for correct unwinding in Fthrow and Fsignal. */
1118 static _Noreturn
void
1119 unwind_to_catch (struct handler
*catch, Lisp_Object value
)
1123 eassert (catch->next
);
1125 /* Save the value in the tag. */
1128 /* Restore certain special C variables. */
1129 set_poll_suppress_count (catch->poll_suppress_count
);
1130 unblock_input_to (catch->interrupt_input_blocked
);
1134 /* Unwind the specpdl stack, and then restore the proper set of
1136 unbind_to (handlerlist
->pdlcount
, Qnil
);
1137 last_time
= handlerlist
== catch;
1139 handlerlist
= handlerlist
->next
;
1141 while (! last_time
);
1143 eassert (handlerlist
== catch);
1145 lisp_eval_depth
= catch->f_lisp_eval_depth
;
1147 sys_longjmp (catch->jmp
, 1);
1150 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1151 doc
: /* Throw to the catch for TAG and return VALUE from it.
1152 Both TAG and VALUE are evalled. */
1153 attributes
: noreturn
)
1154 (register Lisp_Object tag
, Lisp_Object value
)
1159 for (c
= handlerlist
; c
; c
= c
->next
)
1161 if (c
->type
== CATCHER_ALL
)
1162 unwind_to_catch (c
, Fcons (tag
, value
));
1163 if (c
->type
== CATCHER
&& EQ (c
->tag_or_ch
, tag
))
1164 unwind_to_catch (c
, value
);
1166 xsignal2 (Qno_catch
, tag
, value
);
1170 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1171 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1172 If BODYFORM completes normally, its value is returned
1173 after executing the UNWINDFORMS.
1174 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1175 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1179 ptrdiff_t count
= SPECPDL_INDEX ();
1181 record_unwind_protect (prog_ignore
, XCDR (args
));
1182 val
= eval_sub (XCAR (args
));
1183 return unbind_to (count
, val
);
1186 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1187 doc
: /* Regain control when an error is signaled.
1188 Executes BODYFORM and returns its value if no error happens.
1189 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1190 where the BODY is made of Lisp expressions.
1192 A handler is applicable to an error
1193 if CONDITION-NAME is one of the error's condition names.
1194 If an error happens, the first applicable handler is run.
1196 The car of a handler may be a list of condition names instead of a
1197 single condition name; then it handles all of them. If the special
1198 condition name `debug' is present in this list, it allows another
1199 condition in the list to run the debugger if `debug-on-error' and the
1200 other usual mechanisms says it should (otherwise, `condition-case'
1201 suppresses the debugger).
1203 When a handler handles an error, control returns to the `condition-case'
1204 and it executes the handler's BODY...
1205 with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
1206 \(If VAR is nil, the handler can't access that information.)
1207 Then the value of the last BODY form is returned from the `condition-case'
1210 See also the function `signal' for more info.
1211 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1214 Lisp_Object var
= XCAR (args
);
1215 Lisp_Object bodyform
= XCAR (XCDR (args
));
1216 Lisp_Object handlers
= XCDR (XCDR (args
));
1218 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1221 /* Like Fcondition_case, but the args are separate
1222 rather than passed in a list. Used by Fbyte_code. */
1225 internal_lisp_condition_case (Lisp_Object var
, Lisp_Object bodyform
,
1226 Lisp_Object handlers
)
1228 struct handler
*oldhandlerlist
= handlerlist
;
1229 ptrdiff_t clausenb
= 0;
1233 for (Lisp_Object tail
= handlers
; CONSP (tail
); tail
= XCDR (tail
))
1235 Lisp_Object tem
= XCAR (tail
);
1239 && (SYMBOLP (XCAR (tem
))
1240 || CONSP (XCAR (tem
))))))
1241 error ("Invalid condition handler: %s",
1242 SDATA (Fprin1_to_string (tem
, Qt
)));
1245 /* The first clause is the one that should be checked first, so it
1246 should be added to handlerlist last. So build in CLAUSES a table
1247 that contains HANDLERS but in reverse order. CLAUSES is pointer
1248 to volatile to avoid issues with setjmp and local storage.
1249 SAFE_ALLOCA won't work here due to the setjmp, so impose a
1250 MAX_ALLOCA limit. */
1251 if (MAX_ALLOCA
/ word_size
< clausenb
)
1252 memory_full (SIZE_MAX
);
1253 Lisp_Object
volatile *clauses
= alloca (clausenb
* sizeof *clauses
);
1254 clauses
+= clausenb
;
1255 for (Lisp_Object tail
= handlers
; CONSP (tail
); tail
= XCDR (tail
))
1256 *--clauses
= XCAR (tail
);
1257 for (ptrdiff_t i
= 0; i
< clausenb
; i
++)
1259 Lisp_Object clause
= clauses
[i
];
1260 Lisp_Object condition
= CONSP (clause
) ? XCAR (clause
) : Qnil
;
1261 if (!CONSP (condition
))
1262 condition
= list1 (condition
);
1263 struct handler
*c
= push_handler (condition
, CONDITION_CASE
);
1264 if (sys_setjmp (c
->jmp
))
1266 Lisp_Object val
= handlerlist
->val
;
1267 Lisp_Object
volatile *chosen_clause
= clauses
;
1268 for (struct handler
*h
= handlerlist
->next
; h
!= oldhandlerlist
;
1271 Lisp_Object handler_body
= XCDR (*chosen_clause
);
1272 handlerlist
= oldhandlerlist
;
1275 return Fprogn (handler_body
);
1277 Lisp_Object handler_var
= var
;
1278 if (!NILP (Vinternal_interpreter_environment
))
1280 val
= Fcons (Fcons (var
, val
),
1281 Vinternal_interpreter_environment
);
1282 handler_var
= Qinternal_interpreter_environment
;
1285 /* Bind HANDLER_VAR to VAL while evaluating HANDLER_BODY.
1286 The unbind_to undoes just this binding; whoever longjumped
1287 to us unwound the stack to C->pdlcount before throwing. */
1288 ptrdiff_t count
= SPECPDL_INDEX ();
1289 specbind (handler_var
, val
);
1290 return unbind_to (count
, Fprogn (handler_body
));
1294 Lisp_Object result
= eval_sub (bodyform
);
1295 handlerlist
= oldhandlerlist
;
1299 /* Call the function BFUN with no arguments, catching errors within it
1300 according to HANDLERS. If there is an error, call HFUN with
1301 one argument which is the data that describes the error:
1304 HANDLERS can be a list of conditions to catch.
1305 If HANDLERS is Qt, catch all errors.
1306 If HANDLERS is Qerror, catch all errors
1307 but allow the debugger to run if that is enabled. */
1310 internal_condition_case (Lisp_Object (*bfun
) (void), Lisp_Object handlers
,
1311 Lisp_Object (*hfun
) (Lisp_Object
))
1313 struct handler
*c
= push_handler (handlers
, CONDITION_CASE
);
1314 if (sys_setjmp (c
->jmp
))
1316 Lisp_Object val
= handlerlist
->val
;
1317 clobbered_eassert (handlerlist
== c
);
1318 handlerlist
= handlerlist
->next
;
1323 Lisp_Object val
= bfun ();
1324 eassert (handlerlist
== c
);
1325 handlerlist
= c
->next
;
1330 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1333 internal_condition_case_1 (Lisp_Object (*bfun
) (Lisp_Object
), Lisp_Object arg
,
1334 Lisp_Object handlers
,
1335 Lisp_Object (*hfun
) (Lisp_Object
))
1337 struct handler
*c
= push_handler (handlers
, CONDITION_CASE
);
1338 if (sys_setjmp (c
->jmp
))
1340 Lisp_Object val
= handlerlist
->val
;
1341 clobbered_eassert (handlerlist
== c
);
1342 handlerlist
= handlerlist
->next
;
1347 Lisp_Object val
= bfun (arg
);
1348 eassert (handlerlist
== c
);
1349 handlerlist
= c
->next
;
1354 /* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as
1358 internal_condition_case_2 (Lisp_Object (*bfun
) (Lisp_Object
, Lisp_Object
),
1361 Lisp_Object handlers
,
1362 Lisp_Object (*hfun
) (Lisp_Object
))
1364 struct handler
*c
= push_handler (handlers
, CONDITION_CASE
);
1365 if (sys_setjmp (c
->jmp
))
1367 Lisp_Object val
= handlerlist
->val
;
1368 clobbered_eassert (handlerlist
== c
);
1369 handlerlist
= handlerlist
->next
;
1374 Lisp_Object val
= bfun (arg1
, arg2
);
1375 eassert (handlerlist
== c
);
1376 handlerlist
= c
->next
;
1381 /* Like internal_condition_case but call BFUN with NARGS as first,
1382 and ARGS as second argument. */
1385 internal_condition_case_n (Lisp_Object (*bfun
) (ptrdiff_t, Lisp_Object
*),
1388 Lisp_Object handlers
,
1389 Lisp_Object (*hfun
) (Lisp_Object err
,
1393 struct handler
*c
= push_handler (handlers
, CONDITION_CASE
);
1394 if (sys_setjmp (c
->jmp
))
1396 Lisp_Object val
= handlerlist
->val
;
1397 clobbered_eassert (handlerlist
== c
);
1398 handlerlist
= handlerlist
->next
;
1399 return hfun (val
, nargs
, args
);
1403 Lisp_Object val
= bfun (nargs
, args
);
1404 eassert (handlerlist
== c
);
1405 handlerlist
= c
->next
;
1411 push_handler (Lisp_Object tag_ch_val
, enum handlertype handlertype
)
1413 struct handler
*c
= push_handler_nosignal (tag_ch_val
, handlertype
);
1415 memory_full (sizeof *c
);
1420 push_handler_nosignal (Lisp_Object tag_ch_val
, enum handlertype handlertype
)
1422 struct handler
*c
= handlerlist
->nextfree
;
1425 c
= malloc (sizeof *c
);
1428 if (profiler_memory_running
)
1429 malloc_probe (sizeof *c
);
1431 handlerlist
->nextfree
= c
;
1433 c
->type
= handlertype
;
1434 c
->tag_or_ch
= tag_ch_val
;
1436 c
->next
= handlerlist
;
1437 c
->f_lisp_eval_depth
= lisp_eval_depth
;
1438 c
->pdlcount
= SPECPDL_INDEX ();
1439 c
->poll_suppress_count
= poll_suppress_count
;
1440 c
->interrupt_input_blocked
= interrupt_input_blocked
;
1446 static Lisp_Object
signal_or_quit (Lisp_Object
, Lisp_Object
, bool);
1447 static Lisp_Object
find_handler_clause (Lisp_Object
, Lisp_Object
);
1448 static bool maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
,
1452 process_quit_flag (void)
1454 Lisp_Object flag
= Vquit_flag
;
1456 if (EQ (flag
, Qkill_emacs
))
1458 if (EQ (Vthrow_on_input
, flag
))
1459 Fthrow (Vthrow_on_input
, Qt
);
1463 /* Check quit-flag and quit if it is non-nil. Typing C-g does not
1464 directly cause a quit; it only sets Vquit_flag. So the program
1465 needs to call maybe_quit at times when it is safe to quit. Every
1466 loop that might run for a long time or might not exit ought to call
1467 maybe_quit at least once, at a safe place. Unless that is
1468 impossible, of course. But it is very desirable to avoid creating
1469 loops where maybe_quit is impossible.
1471 If quit-flag is set to `kill-emacs' the SIGINT handler has received
1472 a request to exit Emacs when it is safe to do.
1474 When not quitting, process any pending signals.
1476 If you change this function, also adapt module_should_quit in
1482 if (!NILP (Vquit_flag
) && NILP (Vinhibit_quit
))
1483 process_quit_flag ();
1484 else if (pending_signals
)
1485 process_pending_signals ();
1488 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1489 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1490 This function does not return.
1492 An error symbol is a symbol with an `error-conditions' property
1493 that is a list of condition names.
1494 A handler for any of those names will get to handle this signal.
1495 The symbol `error' should normally be one of them.
1497 DATA should be a list. Its elements are printed as part of the error message.
1498 See Info anchor `(elisp)Definition of signal' for some details on how this
1499 error message is constructed.
1500 If the signal is handled, DATA is made available to the handler.
1501 See also the function `condition-case'. */
1502 attributes
: noreturn
)
1503 (Lisp_Object error_symbol
, Lisp_Object data
)
1505 signal_or_quit (error_symbol
, data
, false);
1509 /* Quit, in response to a keyboard quit request. */
1513 return signal_or_quit (Qquit
, Qnil
, true);
1516 /* Signal an error, or quit. ERROR_SYMBOL and DATA are as with Fsignal.
1517 If KEYBOARD_QUIT, this is a quit; ERROR_SYMBOL should be
1518 Qquit and DATA should be Qnil, and this function may return.
1519 Otherwise this function is like Fsignal and does not return. */
1522 signal_or_quit (Lisp_Object error_symbol
, Lisp_Object data
, bool keyboard_quit
)
1524 /* When memory is full, ERROR-SYMBOL is nil,
1525 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1526 That is a special case--don't do this in other situations. */
1527 Lisp_Object conditions
;
1529 Lisp_Object real_error_symbol
1530 = (NILP (error_symbol
) ? Fcar (data
) : error_symbol
);
1531 Lisp_Object clause
= Qnil
;
1534 if (gc_in_progress
|| waiting_for_input
)
1537 #if 0 /* rms: I don't know why this was here,
1538 but it is surely wrong for an error that is handled. */
1539 #ifdef HAVE_WINDOW_SYSTEM
1540 if (display_hourglass_p
)
1541 cancel_hourglass ();
1545 /* This hook is used by edebug. */
1546 if (! NILP (Vsignal_hook_function
)
1547 && ! NILP (error_symbol
))
1549 /* Edebug takes care of restoring these variables when it exits. */
1550 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1551 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1553 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1554 max_specpdl_size
= SPECPDL_INDEX () + 40;
1556 call2 (Vsignal_hook_function
, error_symbol
, data
);
1559 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1561 /* Remember from where signal was called. Skip over the frame for
1562 `signal' itself. If a frame for `error' follows, skip that,
1563 too. Don't do this when ERROR_SYMBOL is nil, because that
1564 is a memory-full error. */
1565 Vsignaling_function
= Qnil
;
1566 if (!NILP (error_symbol
))
1568 union specbinding
*pdl
= backtrace_next (backtrace_top ());
1569 if (backtrace_p (pdl
) && EQ (backtrace_function (pdl
), Qerror
))
1570 pdl
= backtrace_next (pdl
);
1571 if (backtrace_p (pdl
))
1572 Vsignaling_function
= backtrace_function (pdl
);
1575 for (h
= handlerlist
; h
; h
= h
->next
)
1577 if (h
->type
!= CONDITION_CASE
)
1579 clause
= find_handler_clause (h
->tag_or_ch
, conditions
);
1584 if (/* Don't run the debugger for a memory-full error.
1585 (There is no room in memory to do that!) */
1586 !NILP (error_symbol
)
1587 && (!NILP (Vdebug_on_signal
)
1588 /* If no handler is present now, try to run the debugger. */
1590 /* A `debug' symbol in the handler list disables the normal
1591 suppression of the debugger. */
1592 || (CONSP (clause
) && !NILP (Fmemq (Qdebug
, clause
)))
1593 /* Special handler that means "print a message and run debugger
1595 || EQ (h
->tag_or_ch
, Qerror
)))
1597 bool debugger_called
1598 = maybe_call_debugger (conditions
, error_symbol
, data
);
1599 /* We can't return values to code which signaled an error, but we
1600 can continue code which has signaled a quit. */
1601 if (keyboard_quit
&& debugger_called
&& EQ (real_error_symbol
, Qquit
))
1607 Lisp_Object unwind_data
1608 = (NILP (error_symbol
) ? data
: Fcons (error_symbol
, data
));
1610 unwind_to_catch (h
, unwind_data
);
1614 if (handlerlist
!= handlerlist_sentinel
)
1615 /* FIXME: This will come right back here if there's no `top-level'
1616 catcher. A better solution would be to abort here, and instead
1617 add a catch-all condition handler so we never come here. */
1618 Fthrow (Qtop_level
, Qt
);
1621 if (! NILP (error_symbol
))
1622 data
= Fcons (error_symbol
, data
);
1624 string
= Ferror_message_string (data
);
1625 fatal ("%s", SDATA (string
));
1628 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1631 xsignal0 (Lisp_Object error_symbol
)
1633 xsignal (error_symbol
, Qnil
);
1637 xsignal1 (Lisp_Object error_symbol
, Lisp_Object arg
)
1639 xsignal (error_symbol
, list1 (arg
));
1643 xsignal2 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
)
1645 xsignal (error_symbol
, list2 (arg1
, arg2
));
1649 xsignal3 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
1651 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1654 /* Signal `error' with message S, and additional arg ARG.
1655 If ARG is not a genuine list, make it a one-element list. */
1658 signal_error (const char *s
, Lisp_Object arg
)
1660 Lisp_Object tortoise
, hare
;
1662 hare
= tortoise
= arg
;
1663 while (CONSP (hare
))
1670 tortoise
= XCDR (tortoise
);
1672 if (EQ (hare
, tortoise
))
1679 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1683 /* Return true if LIST is a non-nil atom or
1684 a list containing one of CONDITIONS. */
1687 wants_debugger (Lisp_Object list
, Lisp_Object conditions
)
1694 while (CONSP (conditions
))
1696 Lisp_Object
this, tail
;
1697 this = XCAR (conditions
);
1698 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1699 if (EQ (XCAR (tail
), this))
1701 conditions
= XCDR (conditions
);
1706 /* Return true if an error with condition-symbols CONDITIONS,
1707 and described by SIGNAL-DATA, should skip the debugger
1708 according to debugger-ignored-errors. */
1711 skip_debugger (Lisp_Object conditions
, Lisp_Object data
)
1714 bool first_string
= 1;
1715 Lisp_Object error_message
;
1717 error_message
= Qnil
;
1718 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1720 if (STRINGP (XCAR (tail
)))
1724 error_message
= Ferror_message_string (data
);
1728 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1733 Lisp_Object contail
;
1735 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1736 if (EQ (XCAR (tail
), XCAR (contail
)))
1744 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1745 SIG and DATA describe the signal. There are two ways to pass them:
1746 = SIG is the error symbol, and DATA is the rest of the data.
1747 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1748 This is for memory-full errors only. */
1750 maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
, Lisp_Object data
)
1752 Lisp_Object combined_data
;
1754 combined_data
= Fcons (sig
, data
);
1757 /* Don't try to run the debugger with interrupts blocked.
1758 The editing loop would return anyway. */
1759 ! input_blocked_p ()
1760 && NILP (Vinhibit_debugger
)
1761 /* Does user want to enter debugger for this kind of error? */
1764 : wants_debugger (Vdebug_on_error
, conditions
))
1765 && ! skip_debugger (conditions
, combined_data
)
1766 /* RMS: What's this for? */
1767 && when_entered_debugger
< num_nonmacro_input_events
)
1769 call_debugger (list2 (Qerror
, combined_data
));
1777 find_handler_clause (Lisp_Object handlers
, Lisp_Object conditions
)
1779 register Lisp_Object h
;
1781 /* t is used by handlers for all conditions, set up by C code. */
1782 if (EQ (handlers
, Qt
))
1785 /* error is used similarly, but means print an error message
1786 and run the debugger if that is enabled. */
1787 if (EQ (handlers
, Qerror
))
1790 for (h
= handlers
; CONSP (h
); h
= XCDR (h
))
1792 Lisp_Object handler
= XCAR (h
);
1793 if (!NILP (Fmemq (handler
, conditions
)))
1801 /* Format and return a string; called like vprintf. */
1803 vformat_string (const char *m
, va_list ap
)
1806 ptrdiff_t size
= sizeof buf
;
1807 ptrdiff_t size_max
= STRING_BYTES_BOUND
+ 1;
1812 used
= evxprintf (&buffer
, &size
, buf
, size_max
, m
, ap
);
1813 string
= make_string (buffer
, used
);
1820 /* Dump an error message; called like vprintf. */
1822 verror (const char *m
, va_list ap
)
1824 xsignal1 (Qerror
, vformat_string (m
, ap
));
1828 /* Dump an error message; called like printf. */
1832 error (const char *m
, ...)
1839 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
1840 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
1841 This means it contains a description for how to read arguments to give it.
1842 The value is nil for an invalid function or a symbol with no function
1845 Interactively callable functions include strings and vectors (treated
1846 as keyboard macros), lambda-expressions that contain a top-level call
1847 to `interactive', autoload definitions made by `autoload' with non-nil
1848 fourth argument, and some of the built-in functions of Lisp.
1850 Also, a symbol satisfies `commandp' if its function definition does so.
1852 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
1853 then strings and vectors are not accepted. */)
1854 (Lisp_Object function
, Lisp_Object for_call_interactively
)
1856 register Lisp_Object fun
;
1857 register Lisp_Object funcar
;
1858 Lisp_Object if_prop
= Qnil
;
1862 fun
= indirect_function (fun
); /* Check cycles. */
1866 /* Check an `interactive-form' property if present, analogous to the
1867 function-documentation property. */
1869 while (SYMBOLP (fun
))
1871 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
1874 fun
= Fsymbol_function (fun
);
1877 /* Emacs primitives are interactive if their DEFUN specifies an
1878 interactive spec. */
1880 return XSUBR (fun
)->intspec
? Qt
: if_prop
;
1882 /* Bytecode objects are interactive if they are long enough to
1883 have an element whose index is COMPILED_INTERACTIVE, which is
1884 where the interactive spec is stored. */
1885 else if (COMPILEDP (fun
))
1886 return (PVSIZE (fun
) > COMPILED_INTERACTIVE
? Qt
: if_prop
);
1888 /* Strings and vectors are keyboard macros. */
1889 if (STRINGP (fun
) || VECTORP (fun
))
1890 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
1892 /* Lists may represent commands. */
1895 funcar
= XCAR (fun
);
1896 if (EQ (funcar
, Qclosure
))
1897 return (!NILP (Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
)))))
1899 else if (EQ (funcar
, Qlambda
))
1900 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
1901 else if (EQ (funcar
, Qautoload
))
1902 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
1907 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1908 doc
: /* Define FUNCTION to autoload from FILE.
1909 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
1910 Third arg DOCSTRING is documentation for the function.
1911 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
1912 Fifth arg TYPE indicates the type of the object:
1913 nil or omitted says FUNCTION is a function,
1914 `keymap' says FUNCTION is really a keymap, and
1915 `macro' or t says FUNCTION is really a macro.
1916 Third through fifth args give info about the real definition.
1917 They default to nil.
1918 If FUNCTION is already defined other than as an autoload,
1919 this does nothing and returns nil. */)
1920 (Lisp_Object function
, Lisp_Object file
, Lisp_Object docstring
, Lisp_Object interactive
, Lisp_Object type
)
1922 CHECK_SYMBOL (function
);
1923 CHECK_STRING (file
);
1925 /* If function is defined and not as an autoload, don't override. */
1926 if (!NILP (XSYMBOL (function
)->function
)
1927 && !AUTOLOADP (XSYMBOL (function
)->function
))
1930 if (!NILP (Vpurify_flag
) && EQ (docstring
, make_number (0)))
1931 /* `read1' in lread.c has found the docstring starting with "\
1932 and assumed the docstring will be provided by Snarf-documentation, so it
1933 passed us 0 instead. But that leads to accidental sharing in purecopy's
1934 hash-consing, so we use a (hopefully) unique integer instead. */
1935 docstring
= make_number (XHASH (function
));
1936 return Fdefalias (function
,
1937 list5 (Qautoload
, file
, docstring
, interactive
, type
),
1942 un_autoload (Lisp_Object oldqueue
)
1944 Lisp_Object queue
, first
, second
;
1946 /* Queue to unwind is current value of Vautoload_queue.
1947 oldqueue is the shadowed value to leave in Vautoload_queue. */
1948 queue
= Vautoload_queue
;
1949 Vautoload_queue
= oldqueue
;
1950 while (CONSP (queue
))
1952 first
= XCAR (queue
);
1953 second
= Fcdr (first
);
1954 first
= Fcar (first
);
1955 if (EQ (first
, make_number (0)))
1958 Ffset (first
, second
);
1959 queue
= XCDR (queue
);
1963 /* Load an autoloaded function.
1964 FUNNAME is the symbol which is the function's name.
1965 FUNDEF is the autoload definition (a list). */
1967 DEFUN ("autoload-do-load", Fautoload_do_load
, Sautoload_do_load
, 1, 3, 0,
1968 doc
: /* Load FUNDEF which should be an autoload.
1969 If non-nil, FUNNAME should be the symbol whose function value is FUNDEF,
1970 in which case the function returns the new autoloaded function value.
1971 If equal to `macro', MACRO-ONLY specifies that FUNDEF should only be loaded if
1972 it defines a macro. */)
1973 (Lisp_Object fundef
, Lisp_Object funname
, Lisp_Object macro_only
)
1975 ptrdiff_t count
= SPECPDL_INDEX ();
1977 if (!CONSP (fundef
) || !EQ (Qautoload
, XCAR (fundef
)))
1980 if (EQ (macro_only
, Qmacro
))
1982 Lisp_Object kind
= Fnth (make_number (4), fundef
);
1983 if (! (EQ (kind
, Qt
) || EQ (kind
, Qmacro
)))
1987 /* This is to make sure that loadup.el gives a clear picture
1988 of what files are preloaded and when. */
1989 if (! NILP (Vpurify_flag
))
1990 error ("Attempt to autoload %s while preparing to dump",
1991 SDATA (SYMBOL_NAME (funname
)));
1993 CHECK_SYMBOL (funname
);
1995 /* Preserve the match data. */
1996 record_unwind_save_match_data ();
1998 /* If autoloading gets an error (which includes the error of failing
1999 to define the function being called), we use Vautoload_queue
2000 to undo function definitions and `provide' calls made by
2001 the function. We do this in the specific case of autoloading
2002 because autoloading is not an explicit request "load this file",
2003 but rather a request to "call this function".
2005 The value saved here is to be restored into Vautoload_queue. */
2006 record_unwind_protect (un_autoload
, Vautoload_queue
);
2007 Vautoload_queue
= Qt
;
2008 /* If `macro_only', assume this autoload to be a "best-effort",
2009 so don't signal an error if autoloading fails. */
2010 Fload (Fcar (Fcdr (fundef
)), macro_only
, Qt
, Qnil
, Qt
);
2012 /* Once loading finishes, don't undo it. */
2013 Vautoload_queue
= Qt
;
2014 unbind_to (count
, Qnil
);
2020 Lisp_Object fun
= Findirect_function (funname
, Qnil
);
2022 if (!NILP (Fequal (fun
, fundef
)))
2023 error ("Autoloading file %s failed to define function %s",
2024 SDATA (Fcar (Fcar (Vload_history
))),
2025 SDATA (SYMBOL_NAME (funname
)));
2032 DEFUN ("eval", Feval
, Seval
, 1, 2, 0,
2033 doc
: /* Evaluate FORM and return its value.
2034 If LEXICAL is t, evaluate using lexical scoping.
2035 LEXICAL can also be an actual lexical environment, in the form of an
2036 alist mapping symbols to their value. */)
2037 (Lisp_Object form
, Lisp_Object lexical
)
2039 ptrdiff_t count
= SPECPDL_INDEX ();
2040 specbind (Qinternal_interpreter_environment
,
2041 CONSP (lexical
) || NILP (lexical
) ? lexical
: list1 (Qt
));
2042 return unbind_to (count
, eval_sub (form
));
2045 /* Grow the specpdl stack by one entry.
2046 The caller should have already initialized the entry.
2047 Signal an error on stack overflow.
2049 Make sure that there is always one unused entry past the top of the
2050 stack, so that the just-initialized entry is safely unwound if
2051 memory exhausted and an error is signaled here. Also, allocate a
2052 never-used entry just before the bottom of the stack; sometimes its
2053 address is taken. */
2060 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2062 ptrdiff_t count
= SPECPDL_INDEX ();
2063 ptrdiff_t max_size
= min (max_specpdl_size
, PTRDIFF_MAX
- 1000);
2064 union specbinding
*pdlvec
= specpdl
- 1;
2065 ptrdiff_t pdlvecsize
= specpdl_size
+ 1;
2066 if (max_size
<= specpdl_size
)
2068 if (max_specpdl_size
< 400)
2069 max_size
= max_specpdl_size
= 400;
2070 if (max_size
<= specpdl_size
)
2071 signal_error ("Variable binding depth exceeds max-specpdl-size",
2074 pdlvec
= xpalloc (pdlvec
, &pdlvecsize
, 1, max_size
+ 1, sizeof *specpdl
);
2075 specpdl
= pdlvec
+ 1;
2076 specpdl_size
= pdlvecsize
- 1;
2077 specpdl_ptr
= specpdl
+ count
;
2082 record_in_backtrace (Lisp_Object function
, Lisp_Object
*args
, ptrdiff_t nargs
)
2084 ptrdiff_t count
= SPECPDL_INDEX ();
2086 eassert (nargs
>= UNEVALLED
);
2087 specpdl_ptr
->bt
.kind
= SPECPDL_BACKTRACE
;
2088 specpdl_ptr
->bt
.debug_on_exit
= false;
2089 specpdl_ptr
->bt
.function
= function
;
2090 current_thread
->stack_top
= specpdl_ptr
->bt
.args
= args
;
2091 specpdl_ptr
->bt
.nargs
= nargs
;
2097 /* Eval a sub-expression of the current expression (i.e. in the same
2100 eval_sub (Lisp_Object form
)
2102 Lisp_Object fun
, val
, original_fun
, original_args
;
2106 /* Declare here, as this array may be accessed by call_debugger near
2107 the end of this function. See Bug#21245. */
2108 Lisp_Object argvals
[8];
2112 /* Look up its binding in the lexical environment.
2113 We do not pay attention to the declared_special flag here, since we
2114 already did that when let-binding the variable. */
2115 Lisp_Object lex_binding
2116 = !NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
2117 ? Fassq (form
, Vinternal_interpreter_environment
)
2119 if (CONSP (lex_binding
))
2120 return XCDR (lex_binding
);
2122 return Fsymbol_value (form
);
2132 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2134 if (max_lisp_eval_depth
< 100)
2135 max_lisp_eval_depth
= 100;
2136 if (lisp_eval_depth
> max_lisp_eval_depth
)
2137 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2140 original_fun
= XCAR (form
);
2141 original_args
= XCDR (form
);
2142 CHECK_LIST (original_args
);
2144 /* This also protects them from gc. */
2145 count
= record_in_backtrace (original_fun
, &original_args
, UNEVALLED
);
2147 if (debug_on_next_call
)
2148 do_debug_on_call (Qt
, count
);
2150 /* At this point, only original_fun and original_args
2151 have values that will be used below. */
2154 /* Optimize for no indirection. */
2157 fun
= Ffunction (Fcons (fun
, Qnil
));
2158 else if (!NILP (fun
) && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2159 fun
= indirect_function (fun
);
2163 Lisp_Object args_left
= original_args
;
2164 Lisp_Object numargs
= Flength (args_left
);
2168 if (XINT (numargs
) < XSUBR (fun
)->min_args
2169 || (XSUBR (fun
)->max_args
>= 0
2170 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2171 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2173 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2174 val
= (XSUBR (fun
)->function
.aUNEVALLED
) (args_left
);
2175 else if (XSUBR (fun
)->max_args
== MANY
)
2177 /* Pass a vector of evaluated arguments. */
2179 ptrdiff_t argnum
= 0;
2182 SAFE_ALLOCA_LISP (vals
, XINT (numargs
));
2184 while (CONSP (args_left
) && argnum
< XINT (numargs
))
2186 Lisp_Object arg
= XCAR (args_left
);
2187 args_left
= XCDR (args_left
);
2188 vals
[argnum
++] = eval_sub (arg
);
2191 set_backtrace_args (specpdl
+ count
, vals
, argnum
);
2193 val
= XSUBR (fun
)->function
.aMANY (argnum
, vals
);
2197 /* Do the debug-on-exit now, while VALS still exists. */
2198 if (backtrace_debug_on_exit (specpdl
+ count
))
2199 val
= call_debugger (list2 (Qexit
, val
));
2206 int i
, maxargs
= XSUBR (fun
)->max_args
;
2208 for (i
= 0; i
< maxargs
; i
++)
2210 argvals
[i
] = eval_sub (Fcar (args_left
));
2211 args_left
= Fcdr (args_left
);
2214 set_backtrace_args (specpdl
+ count
, argvals
, XINT (numargs
));
2219 val
= (XSUBR (fun
)->function
.a0 ());
2222 val
= (XSUBR (fun
)->function
.a1 (argvals
[0]));
2225 val
= (XSUBR (fun
)->function
.a2 (argvals
[0], argvals
[1]));
2228 val
= (XSUBR (fun
)->function
.a3
2229 (argvals
[0], argvals
[1], argvals
[2]));
2232 val
= (XSUBR (fun
)->function
.a4
2233 (argvals
[0], argvals
[1], argvals
[2], argvals
[3]));
2236 val
= (XSUBR (fun
)->function
.a5
2237 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2241 val
= (XSUBR (fun
)->function
.a6
2242 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2243 argvals
[4], argvals
[5]));
2246 val
= (XSUBR (fun
)->function
.a7
2247 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2248 argvals
[4], argvals
[5], argvals
[6]));
2252 val
= (XSUBR (fun
)->function
.a8
2253 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2254 argvals
[4], argvals
[5], argvals
[6], argvals
[7]));
2258 /* Someone has created a subr that takes more arguments than
2259 is supported by this code. We need to either rewrite the
2260 subr to use a different argument protocol, or add more
2261 cases to this switch. */
2266 else if (COMPILEDP (fun
) || MODULE_FUNCTIONP (fun
))
2267 return apply_lambda (fun
, original_args
, count
);
2271 xsignal1 (Qvoid_function
, original_fun
);
2273 xsignal1 (Qinvalid_function
, original_fun
);
2274 funcar
= XCAR (fun
);
2275 if (!SYMBOLP (funcar
))
2276 xsignal1 (Qinvalid_function
, original_fun
);
2277 if (EQ (funcar
, Qautoload
))
2279 Fautoload_do_load (fun
, original_fun
, Qnil
);
2282 if (EQ (funcar
, Qmacro
))
2284 ptrdiff_t count1
= SPECPDL_INDEX ();
2286 /* Bind lexical-binding during expansion of the macro, so the
2287 macro can know reliably if the code it outputs will be
2288 interpreted using lexical-binding or not. */
2289 specbind (Qlexical_binding
,
2290 NILP (Vinternal_interpreter_environment
) ? Qnil
: Qt
);
2291 exp
= apply1 (Fcdr (fun
), original_args
);
2292 unbind_to (count1
, Qnil
);
2293 val
= eval_sub (exp
);
2295 else if (EQ (funcar
, Qlambda
)
2296 || EQ (funcar
, Qclosure
))
2297 return apply_lambda (fun
, original_args
, count
);
2299 xsignal1 (Qinvalid_function
, original_fun
);
2304 if (backtrace_debug_on_exit (specpdl
+ count
))
2305 val
= call_debugger (list2 (Qexit
, val
));
2311 DEFUN ("apply", Fapply
, Sapply
, 1, MANY
, 0,
2312 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2313 Then return the value FUNCTION returns.
2314 Thus, (apply \\='+ 1 2 \\='(3 4)) returns 10.
2315 usage: (apply FUNCTION &rest ARGUMENTS) */)
2316 (ptrdiff_t nargs
, Lisp_Object
*args
)
2318 ptrdiff_t i
, numargs
, funcall_nargs
;
2319 register Lisp_Object
*funcall_args
= NULL
;
2320 register Lisp_Object spread_arg
= args
[nargs
- 1];
2321 Lisp_Object fun
= args
[0];
2325 CHECK_LIST (spread_arg
);
2327 numargs
= XINT (Flength (spread_arg
));
2330 return Ffuncall (nargs
- 1, args
);
2331 else if (numargs
== 1)
2333 args
[nargs
- 1] = XCAR (spread_arg
);
2334 return Ffuncall (nargs
, args
);
2337 numargs
+= nargs
- 2;
2339 /* Optimize for no indirection. */
2340 if (SYMBOLP (fun
) && !NILP (fun
)
2341 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2343 fun
= indirect_function (fun
);
2345 /* Let funcall get the error. */
2349 if (SUBRP (fun
) && XSUBR (fun
)->max_args
> numargs
2350 /* Don't hide an error by adding missing arguments. */
2351 && numargs
>= XSUBR (fun
)->min_args
)
2353 /* Avoid making funcall cons up a yet another new vector of arguments
2354 by explicitly supplying nil's for optional values. */
2355 SAFE_ALLOCA_LISP (funcall_args
, 1 + XSUBR (fun
)->max_args
);
2356 memclear (funcall_args
+ numargs
+ 1,
2357 (XSUBR (fun
)->max_args
- numargs
) * word_size
);
2358 funcall_nargs
= 1 + XSUBR (fun
)->max_args
;
2361 { /* We add 1 to numargs because funcall_args includes the
2362 function itself as well as its arguments. */
2363 SAFE_ALLOCA_LISP (funcall_args
, 1 + numargs
);
2364 funcall_nargs
= 1 + numargs
;
2367 memcpy (funcall_args
, args
, nargs
* word_size
);
2368 /* Spread the last arg we got. Its first element goes in
2369 the slot that it used to occupy, hence this value of I. */
2371 while (!NILP (spread_arg
))
2373 funcall_args
[i
++] = XCAR (spread_arg
);
2374 spread_arg
= XCDR (spread_arg
);
2377 retval
= Ffuncall (funcall_nargs
, funcall_args
);
2383 /* Run hook variables in various ways. */
2386 funcall_nil (ptrdiff_t nargs
, Lisp_Object
*args
)
2388 Ffuncall (nargs
, args
);
2392 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2393 doc
: /* Run each hook in HOOKS.
2394 Each argument should be a symbol, a hook variable.
2395 These symbols are processed in the order specified.
2396 If a hook symbol has a non-nil value, that value may be a function
2397 or a list of functions to be called to run the hook.
2398 If the value is a function, it is called with no arguments.
2399 If it is a list, the elements are called, in order, with no arguments.
2401 Major modes should not use this function directly to run their mode
2402 hook; they should use `run-mode-hooks' instead.
2404 Do not use `make-local-variable' to make a hook variable buffer-local.
2405 Instead, use `add-hook' and specify t for the LOCAL argument.
2406 usage: (run-hooks &rest HOOKS) */)
2407 (ptrdiff_t nargs
, Lisp_Object
*args
)
2411 for (i
= 0; i
< nargs
; i
++)
2417 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2418 Srun_hook_with_args
, 1, MANY
, 0,
2419 doc
: /* Run HOOK with the specified arguments ARGS.
2420 HOOK should be a symbol, a hook variable. The value of HOOK
2421 may be nil, a function, or a list of functions. Call each
2422 function in order with arguments ARGS. The final return value
2425 Do not use `make-local-variable' to make a hook variable buffer-local.
2426 Instead, use `add-hook' and specify t for the LOCAL argument.
2427 usage: (run-hook-with-args HOOK &rest ARGS) */)
2428 (ptrdiff_t nargs
, Lisp_Object
*args
)
2430 return run_hook_with_args (nargs
, args
, funcall_nil
);
2433 /* NB this one still documents a specific non-nil return value.
2434 (As did run-hook-with-args and run-hook-with-args-until-failure
2435 until they were changed in 24.1.) */
2436 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2437 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2438 doc
: /* Run HOOK with the specified arguments ARGS.
2439 HOOK should be a symbol, a hook variable. The value of HOOK
2440 may be nil, a function, or a list of functions. Call each
2441 function in order with arguments ARGS, stopping at the first
2442 one that returns non-nil, and return that value. Otherwise (if
2443 all functions return nil, or if there are no functions to call),
2446 Do not use `make-local-variable' to make a hook variable buffer-local.
2447 Instead, use `add-hook' and specify t for the LOCAL argument.
2448 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2449 (ptrdiff_t nargs
, Lisp_Object
*args
)
2451 return run_hook_with_args (nargs
, args
, Ffuncall
);
2455 funcall_not (ptrdiff_t nargs
, Lisp_Object
*args
)
2457 return NILP (Ffuncall (nargs
, args
)) ? Qt
: Qnil
;
2460 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2461 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2462 doc
: /* Run HOOK with the specified arguments ARGS.
2463 HOOK should be a symbol, a hook variable. The value of HOOK
2464 may be nil, a function, or a list of functions. Call each
2465 function in order with arguments ARGS, stopping at the first
2466 one that returns nil, and return nil. Otherwise (if all functions
2467 return non-nil, or if there are no functions to call), return non-nil
2468 \(do not rely on the precise return value in this case).
2470 Do not use `make-local-variable' to make a hook variable buffer-local.
2471 Instead, use `add-hook' and specify t for the LOCAL argument.
2472 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2473 (ptrdiff_t nargs
, Lisp_Object
*args
)
2475 return NILP (run_hook_with_args (nargs
, args
, funcall_not
)) ? Qt
: Qnil
;
2479 run_hook_wrapped_funcall (ptrdiff_t nargs
, Lisp_Object
*args
)
2481 Lisp_Object tmp
= args
[0], ret
;
2484 ret
= Ffuncall (nargs
, args
);
2490 DEFUN ("run-hook-wrapped", Frun_hook_wrapped
, Srun_hook_wrapped
, 2, MANY
, 0,
2491 doc
: /* Run HOOK, passing each function through WRAP-FUNCTION.
2492 I.e. instead of calling each function FUN directly with arguments ARGS,
2493 it calls WRAP-FUNCTION with arguments FUN and ARGS.
2494 As soon as a call to WRAP-FUNCTION returns non-nil, `run-hook-wrapped'
2495 aborts and returns that value.
2496 usage: (run-hook-wrapped HOOK WRAP-FUNCTION &rest ARGS) */)
2497 (ptrdiff_t nargs
, Lisp_Object
*args
)
2499 return run_hook_with_args (nargs
, args
, run_hook_wrapped_funcall
);
2502 /* ARGS[0] should be a hook symbol.
2503 Call each of the functions in the hook value, passing each of them
2504 as arguments all the rest of ARGS (all NARGS - 1 elements).
2505 FUNCALL specifies how to call each function on the hook. */
2508 run_hook_with_args (ptrdiff_t nargs
, Lisp_Object
*args
,
2509 Lisp_Object (*funcall
) (ptrdiff_t nargs
, Lisp_Object
*args
))
2511 Lisp_Object sym
, val
, ret
= Qnil
;
2513 /* If we are dying or still initializing,
2514 don't do anything--it would probably crash if we tried. */
2515 if (NILP (Vrun_hooks
))
2519 val
= find_symbol_value (sym
);
2521 if (EQ (val
, Qunbound
) || NILP (val
))
2523 else if (!CONSP (val
) || FUNCTIONP (val
))
2526 return funcall (nargs
, args
);
2530 Lisp_Object global_vals
= Qnil
;
2533 CONSP (val
) && NILP (ret
);
2536 if (EQ (XCAR (val
), Qt
))
2538 /* t indicates this hook has a local binding;
2539 it means to run the global binding too. */
2540 global_vals
= Fdefault_value (sym
);
2541 if (NILP (global_vals
)) continue;
2543 if (!CONSP (global_vals
) || EQ (XCAR (global_vals
), Qlambda
))
2545 args
[0] = global_vals
;
2546 ret
= funcall (nargs
, args
);
2551 CONSP (global_vals
) && NILP (ret
);
2552 global_vals
= XCDR (global_vals
))
2554 args
[0] = XCAR (global_vals
);
2555 /* In a global value, t should not occur. If it does, we
2556 must ignore it to avoid an endless loop. */
2557 if (!EQ (args
[0], Qt
))
2558 ret
= funcall (nargs
, args
);
2564 args
[0] = XCAR (val
);
2565 ret
= funcall (nargs
, args
);
2573 /* Run the hook HOOK, giving each function no args. */
2576 run_hook (Lisp_Object hook
)
2578 Frun_hook_with_args (1, &hook
);
2581 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2584 run_hook_with_args_2 (Lisp_Object hook
, Lisp_Object arg1
, Lisp_Object arg2
)
2586 CALLN (Frun_hook_with_args
, hook
, arg1
, arg2
);
2589 /* Apply fn to arg. */
2591 apply1 (Lisp_Object fn
, Lisp_Object arg
)
2593 return NILP (arg
) ? Ffuncall (1, &fn
) : CALLN (Fapply
, fn
, arg
);
2596 /* Call function fn on no arguments. */
2598 call0 (Lisp_Object fn
)
2600 return Ffuncall (1, &fn
);
2603 /* Call function fn with 1 argument arg1. */
2606 call1 (Lisp_Object fn
, Lisp_Object arg1
)
2608 return CALLN (Ffuncall
, fn
, arg1
);
2611 /* Call function fn with 2 arguments arg1, arg2. */
2614 call2 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
)
2616 return CALLN (Ffuncall
, fn
, arg1
, arg2
);
2619 /* Call function fn with 3 arguments arg1, arg2, arg3. */
2622 call3 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2624 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
);
2627 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
2630 call4 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2633 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
);
2636 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
2639 call5 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2640 Lisp_Object arg4
, Lisp_Object arg5
)
2642 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
);
2645 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
2648 call6 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2649 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
)
2651 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
);
2654 /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
2657 call7 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2658 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
)
2660 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
);
2663 /* Call function fn with 8 arguments arg1, arg2, arg3, arg4, arg5,
2664 arg6, arg7, arg8. */
2667 call8 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2668 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
,
2671 return CALLN (Ffuncall
, fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
, arg8
);
2674 DEFUN ("functionp", Ffunctionp
, Sfunctionp
, 1, 1, 0,
2675 doc
: /* Non-nil if OBJECT is a function. */)
2676 (Lisp_Object object
)
2678 if (FUNCTIONP (object
))
2684 FUNCTIONP (Lisp_Object object
)
2686 if (SYMBOLP (object
) && !NILP (Ffboundp (object
)))
2688 object
= Findirect_function (object
, Qt
);
2690 if (CONSP (object
) && EQ (XCAR (object
), Qautoload
))
2692 /* Autoloaded symbols are functions, except if they load
2693 macros or keymaps. */
2694 for (int i
= 0; i
< 4 && CONSP (object
); i
++)
2695 object
= XCDR (object
);
2697 return ! (CONSP (object
) && !NILP (XCAR (object
)));
2702 return XSUBR (object
)->max_args
!= UNEVALLED
;
2703 else if (COMPILEDP (object
) || MODULE_FUNCTIONP (object
))
2705 else if (CONSP (object
))
2707 Lisp_Object car
= XCAR (object
);
2708 return EQ (car
, Qlambda
) || EQ (car
, Qclosure
);
2714 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2715 doc
: /* Call first argument as a function, passing remaining arguments to it.
2716 Return the value that function returns.
2717 Thus, (funcall \\='cons \\='x \\='y) returns (x . y).
2718 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2719 (ptrdiff_t nargs
, Lisp_Object
*args
)
2721 Lisp_Object fun
, original_fun
;
2723 ptrdiff_t numargs
= nargs
- 1;
2729 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2731 if (max_lisp_eval_depth
< 100)
2732 max_lisp_eval_depth
= 100;
2733 if (lisp_eval_depth
> max_lisp_eval_depth
)
2734 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2737 count
= record_in_backtrace (args
[0], &args
[1], nargs
- 1);
2741 if (debug_on_next_call
)
2742 do_debug_on_call (Qlambda
, count
);
2746 original_fun
= args
[0];
2750 /* Optimize for no indirection. */
2752 if (SYMBOLP (fun
) && !NILP (fun
)
2753 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2754 fun
= indirect_function (fun
);
2757 val
= funcall_subr (XSUBR (fun
), numargs
, args
+ 1);
2758 else if (COMPILEDP (fun
) || MODULE_FUNCTIONP (fun
))
2759 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2763 xsignal1 (Qvoid_function
, original_fun
);
2765 xsignal1 (Qinvalid_function
, original_fun
);
2766 funcar
= XCAR (fun
);
2767 if (!SYMBOLP (funcar
))
2768 xsignal1 (Qinvalid_function
, original_fun
);
2769 if (EQ (funcar
, Qlambda
)
2770 || EQ (funcar
, Qclosure
))
2771 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2772 else if (EQ (funcar
, Qautoload
))
2774 Fautoload_do_load (fun
, original_fun
, Qnil
);
2779 xsignal1 (Qinvalid_function
, original_fun
);
2783 if (backtrace_debug_on_exit (specpdl
+ count
))
2784 val
= call_debugger (list2 (Qexit
, val
));
2790 /* Apply a C subroutine SUBR to the NUMARGS evaluated arguments in ARG_VECTOR
2791 and return the result of evaluation. */
2794 funcall_subr (struct Lisp_Subr
*subr
, ptrdiff_t numargs
, Lisp_Object
*args
)
2796 if (numargs
< subr
->min_args
2797 || (subr
->max_args
>= 0 && subr
->max_args
< numargs
))
2800 XSETSUBR (fun
, subr
);
2801 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (numargs
));
2804 else if (subr
->max_args
== UNEVALLED
)
2807 XSETSUBR (fun
, subr
);
2808 xsignal1 (Qinvalid_function
, fun
);
2811 else if (subr
->max_args
== MANY
)
2812 return (subr
->function
.aMANY
) (numargs
, args
);
2815 Lisp_Object internal_argbuf
[8];
2816 Lisp_Object
*internal_args
;
2817 if (subr
->max_args
> numargs
)
2819 eassert (subr
->max_args
<= ARRAYELTS (internal_argbuf
));
2820 internal_args
= internal_argbuf
;
2821 memcpy (internal_args
, args
, numargs
* word_size
);
2822 memclear (internal_args
+ numargs
,
2823 (subr
->max_args
- numargs
) * word_size
);
2826 internal_args
= args
;
2827 switch (subr
->max_args
)
2830 return (subr
->function
.a0 ());
2832 return (subr
->function
.a1 (internal_args
[0]));
2834 return (subr
->function
.a2
2835 (internal_args
[0], internal_args
[1]));
2837 return (subr
->function
.a3
2838 (internal_args
[0], internal_args
[1], internal_args
[2]));
2840 return (subr
->function
.a4
2841 (internal_args
[0], internal_args
[1], internal_args
[2],
2844 return (subr
->function
.a5
2845 (internal_args
[0], internal_args
[1], internal_args
[2],
2846 internal_args
[3], internal_args
[4]));
2848 return (subr
->function
.a6
2849 (internal_args
[0], internal_args
[1], internal_args
[2],
2850 internal_args
[3], internal_args
[4], internal_args
[5]));
2852 return (subr
->function
.a7
2853 (internal_args
[0], internal_args
[1], internal_args
[2],
2854 internal_args
[3], internal_args
[4], internal_args
[5],
2857 return (subr
->function
.a8
2858 (internal_args
[0], internal_args
[1], internal_args
[2],
2859 internal_args
[3], internal_args
[4], internal_args
[5],
2860 internal_args
[6], internal_args
[7]));
2864 /* If a subr takes more than 8 arguments without using MANY
2865 or UNEVALLED, we need to extend this function to support it.
2866 Until this is done, there is no way to call the function. */
2873 apply_lambda (Lisp_Object fun
, Lisp_Object args
, ptrdiff_t count
)
2875 Lisp_Object args_left
;
2878 Lisp_Object
*arg_vector
;
2882 numargs
= XFASTINT (Flength (args
));
2883 SAFE_ALLOCA_LISP (arg_vector
, numargs
);
2886 for (i
= 0; i
< numargs
; )
2888 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2889 tem
= eval_sub (tem
);
2890 arg_vector
[i
++] = tem
;
2893 set_backtrace_args (specpdl
+ count
, arg_vector
, i
);
2894 tem
= funcall_lambda (fun
, numargs
, arg_vector
);
2898 /* Do the debug-on-exit now, while arg_vector still exists. */
2899 if (backtrace_debug_on_exit (specpdl
+ count
))
2900 tem
= call_debugger (list2 (Qexit
, tem
));
2906 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2907 and return the result of evaluation.
2908 FUN must be either a lambda-expression, a compiled-code object,
2909 or a module function. */
2912 funcall_lambda (Lisp_Object fun
, ptrdiff_t nargs
,
2913 register Lisp_Object
*arg_vector
)
2915 Lisp_Object val
, syms_left
, next
, lexenv
;
2916 ptrdiff_t count
= SPECPDL_INDEX ();
2918 bool optional
, rest
;
2922 if (EQ (XCAR (fun
), Qclosure
))
2924 Lisp_Object cdr
= XCDR (fun
); /* Drop `closure'. */
2926 xsignal1 (Qinvalid_function
, fun
);
2928 lexenv
= XCAR (fun
);
2932 syms_left
= XCDR (fun
);
2933 if (CONSP (syms_left
))
2934 syms_left
= XCAR (syms_left
);
2936 xsignal1 (Qinvalid_function
, fun
);
2938 else if (COMPILEDP (fun
))
2940 ptrdiff_t size
= PVSIZE (fun
);
2941 if (size
<= COMPILED_STACK_DEPTH
)
2942 xsignal1 (Qinvalid_function
, fun
);
2943 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
2944 if (INTEGERP (syms_left
))
2945 /* A byte-code object with an integer args template means we
2946 shouldn't bind any arguments, instead just call the byte-code
2947 interpreter directly; it will push arguments as necessary.
2949 Byte-code objects with a nil args template (the default)
2950 have dynamically-bound arguments, and use the
2951 argument-binding code below instead (as do all interpreted
2952 functions, even lexically bound ones). */
2954 /* If we have not actually read the bytecode string
2955 and constants vector yet, fetch them from the file. */
2956 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
2957 Ffetch_bytecode (fun
);
2958 return exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
2959 AREF (fun
, COMPILED_CONSTANTS
),
2960 AREF (fun
, COMPILED_STACK_DEPTH
),
2967 else if (MODULE_FUNCTIONP (fun
))
2968 return funcall_module (fun
, nargs
, arg_vector
);
2973 i
= optional
= rest
= 0;
2974 bool previous_optional_or_rest
= false;
2975 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
2979 next
= XCAR (syms_left
);
2980 if (!SYMBOLP (next
))
2981 xsignal1 (Qinvalid_function
, fun
);
2983 if (EQ (next
, Qand_rest
))
2985 if (rest
|| previous_optional_or_rest
)
2986 xsignal1 (Qinvalid_function
, fun
);
2988 previous_optional_or_rest
= true;
2990 else if (EQ (next
, Qand_optional
))
2992 if (optional
|| rest
|| previous_optional_or_rest
)
2993 xsignal1 (Qinvalid_function
, fun
);
2995 previous_optional_or_rest
= true;
3002 arg
= Flist (nargs
- i
, &arg_vector
[i
]);
3006 arg
= arg_vector
[i
++];
3008 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3012 /* Bind the argument. */
3013 if (!NILP (lexenv
) && SYMBOLP (next
))
3014 /* Lexically bind NEXT by adding it to the lexenv alist. */
3015 lexenv
= Fcons (Fcons (next
, arg
), lexenv
);
3017 /* Dynamically bind NEXT. */
3018 specbind (next
, arg
);
3019 previous_optional_or_rest
= false;
3023 if (!NILP (syms_left
) || previous_optional_or_rest
)
3024 xsignal1 (Qinvalid_function
, fun
);
3026 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3028 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
3029 /* Instantiate a new lexical environment. */
3030 specbind (Qinternal_interpreter_environment
, lexenv
);
3033 val
= Fprogn (XCDR (XCDR (fun
)));
3036 /* If we have not actually read the bytecode string
3037 and constants vector yet, fetch them from the file. */
3038 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3039 Ffetch_bytecode (fun
);
3040 val
= exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
3041 AREF (fun
, COMPILED_CONSTANTS
),
3042 AREF (fun
, COMPILED_STACK_DEPTH
),
3046 return unbind_to (count
, val
);
3049 DEFUN ("func-arity", Ffunc_arity
, Sfunc_arity
, 1, 1, 0,
3050 doc
: /* Return minimum and maximum number of args allowed for FUNCTION.
3051 FUNCTION must be a function of some kind.
3052 The returned value is a cons cell (MIN . MAX). MIN is the minimum number
3053 of args. MAX is the maximum number, or the symbol `many', for a
3054 function with `&rest' args, or `unevalled' for a special form. */)
3055 (Lisp_Object function
)
3057 Lisp_Object original
;
3061 original
= function
;
3065 /* Optimize for no indirection. */
3066 function
= original
;
3067 if (SYMBOLP (function
) && !NILP (function
))
3069 function
= XSYMBOL (function
)->function
;
3070 if (SYMBOLP (function
))
3071 function
= indirect_function (function
);
3074 if (CONSP (function
) && EQ (XCAR (function
), Qmacro
))
3075 function
= XCDR (function
);
3077 if (SUBRP (function
))
3078 result
= Fsubr_arity (function
);
3079 else if (COMPILEDP (function
))
3080 result
= lambda_arity (function
);
3082 else if (MODULE_FUNCTIONP (function
))
3083 result
= module_function_arity (XMODULE_FUNCTION (function
));
3087 if (NILP (function
))
3088 xsignal1 (Qvoid_function
, original
);
3089 if (!CONSP (function
))
3090 xsignal1 (Qinvalid_function
, original
);
3091 funcar
= XCAR (function
);
3092 if (!SYMBOLP (funcar
))
3093 xsignal1 (Qinvalid_function
, original
);
3094 if (EQ (funcar
, Qlambda
)
3095 || EQ (funcar
, Qclosure
))
3096 result
= lambda_arity (function
);
3097 else if (EQ (funcar
, Qautoload
))
3099 Fautoload_do_load (function
, original
, Qnil
);
3103 xsignal1 (Qinvalid_function
, original
);
3108 /* FUN must be either a lambda-expression or a compiled-code object. */
3110 lambda_arity (Lisp_Object fun
)
3112 Lisp_Object syms_left
;
3116 if (EQ (XCAR (fun
), Qclosure
))
3118 fun
= XCDR (fun
); /* Drop `closure'. */
3121 syms_left
= XCDR (fun
);
3122 if (CONSP (syms_left
))
3123 syms_left
= XCAR (syms_left
);
3125 xsignal1 (Qinvalid_function
, fun
);
3127 else if (COMPILEDP (fun
))
3129 ptrdiff_t size
= PVSIZE (fun
);
3130 if (size
<= COMPILED_STACK_DEPTH
)
3131 xsignal1 (Qinvalid_function
, fun
);
3132 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3133 if (INTEGERP (syms_left
))
3134 return get_byte_code_arity (syms_left
);
3139 EMACS_INT minargs
= 0, maxargs
= 0;
3140 bool optional
= false;
3141 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3143 Lisp_Object next
= XCAR (syms_left
);
3144 if (!SYMBOLP (next
))
3145 xsignal1 (Qinvalid_function
, fun
);
3147 if (EQ (next
, Qand_rest
))
3148 return Fcons (make_number (minargs
), Qmany
);
3149 else if (EQ (next
, Qand_optional
))
3159 if (!NILP (syms_left
))
3160 xsignal1 (Qinvalid_function
, fun
);
3162 return Fcons (make_number (minargs
), make_number (maxargs
));
3165 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3167 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3168 (Lisp_Object object
)
3172 if (COMPILEDP (object
))
3174 ptrdiff_t size
= PVSIZE (object
);
3175 if (size
<= COMPILED_STACK_DEPTH
)
3176 xsignal1 (Qinvalid_function
, object
);
3177 if (CONSP (AREF (object
, COMPILED_BYTECODE
)))
3179 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3182 tem
= AREF (object
, COMPILED_BYTECODE
);
3183 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3184 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3186 error ("Invalid byte code");
3188 ASET (object
, COMPILED_BYTECODE
, XCAR (tem
));
3189 ASET (object
, COMPILED_CONSTANTS
, XCDR (tem
));
3195 /* Return true if SYMBOL currently has a let-binding
3196 which was made in the buffer that is now current. */
3199 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
3201 union specbinding
*p
;
3202 Lisp_Object buf
= Fcurrent_buffer ();
3204 for (p
= specpdl_ptr
; p
> specpdl
; )
3205 if ((--p
)->kind
> SPECPDL_LET
)
3207 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (specpdl_symbol (p
));
3208 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
3209 if (symbol
== let_bound_symbol
3210 && EQ (specpdl_where (p
), buf
))
3218 do_specbind (struct Lisp_Symbol
*sym
, union specbinding
*bind
,
3219 Lisp_Object value
, enum Set_Internal_Bind bindflag
)
3221 switch (sym
->redirect
)
3223 case SYMBOL_PLAINVAL
:
3224 if (!sym
->trapped_write
)
3225 SET_SYMBOL_VAL (sym
, value
);
3227 set_internal (specpdl_symbol (bind
), value
, Qnil
, bindflag
);
3230 case SYMBOL_FORWARDED
:
3231 if (BUFFER_OBJFWDP (SYMBOL_FWD (sym
))
3232 && specpdl_kind (bind
) == SPECPDL_LET_DEFAULT
)
3234 set_default_internal (specpdl_symbol (bind
), value
, bindflag
);
3238 case SYMBOL_LOCALIZED
:
3239 set_internal (specpdl_symbol (bind
), value
, Qnil
, bindflag
);
3247 /* `specpdl_ptr' describes which variable is
3248 let-bound, so it can be properly undone when we unbind_to.
3249 It can be either a plain SPECPDL_LET or a SPECPDL_LET_LOCAL/DEFAULT.
3250 - SYMBOL is the variable being bound. Note that it should not be
3251 aliased (i.e. when let-binding V1 that's aliased to V2, we want
3253 - WHERE tells us in which buffer the binding took place.
3254 This is used for SPECPDL_LET_LOCAL bindings (i.e. bindings to a
3255 buffer-local variable) as well as for SPECPDL_LET_DEFAULT bindings,
3256 i.e. bindings to the default value of a variable which can be
3260 specbind (Lisp_Object symbol
, Lisp_Object value
)
3262 struct Lisp_Symbol
*sym
;
3264 CHECK_SYMBOL (symbol
);
3265 sym
= XSYMBOL (symbol
);
3268 switch (sym
->redirect
)
3270 case SYMBOL_VARALIAS
:
3271 sym
= indirect_variable (sym
); XSETSYMBOL (symbol
, sym
); goto start
;
3272 case SYMBOL_PLAINVAL
:
3273 /* The most common case is that of a non-constant symbol with a
3274 trivial value. Make that as fast as we can. */
3275 specpdl_ptr
->let
.kind
= SPECPDL_LET
;
3276 specpdl_ptr
->let
.symbol
= symbol
;
3277 specpdl_ptr
->let
.old_value
= SYMBOL_VAL (sym
);
3278 specpdl_ptr
->let
.saved_value
= Qnil
;
3280 do_specbind (sym
, specpdl_ptr
- 1, value
, SET_INTERNAL_BIND
);
3282 case SYMBOL_LOCALIZED
:
3283 case SYMBOL_FORWARDED
:
3285 Lisp_Object ovalue
= find_symbol_value (symbol
);
3286 specpdl_ptr
->let
.kind
= SPECPDL_LET_LOCAL
;
3287 specpdl_ptr
->let
.symbol
= symbol
;
3288 specpdl_ptr
->let
.old_value
= ovalue
;
3289 specpdl_ptr
->let
.where
= Fcurrent_buffer ();
3290 specpdl_ptr
->let
.saved_value
= Qnil
;
3292 eassert (sym
->redirect
!= SYMBOL_LOCALIZED
3293 || (EQ (SYMBOL_BLV (sym
)->where
, Fcurrent_buffer ())));
3295 if (sym
->redirect
== SYMBOL_LOCALIZED
)
3297 if (!blv_found (SYMBOL_BLV (sym
)))
3298 specpdl_ptr
->let
.kind
= SPECPDL_LET_DEFAULT
;
3300 else if (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)))
3302 /* If SYMBOL is a per-buffer variable which doesn't have a
3303 buffer-local value here, make the `let' change the global
3304 value by changing the value of SYMBOL in all buffers not
3305 having their own value. This is consistent with what
3306 happens with other buffer-local variables. */
3307 if (NILP (Flocal_variable_p (symbol
, Qnil
)))
3309 specpdl_ptr
->let
.kind
= SPECPDL_LET_DEFAULT
;
3311 do_specbind (sym
, specpdl_ptr
- 1, value
, SET_INTERNAL_BIND
);
3316 specpdl_ptr
->let
.kind
= SPECPDL_LET
;
3319 do_specbind (sym
, specpdl_ptr
- 1, value
, SET_INTERNAL_BIND
);
3322 default: emacs_abort ();
3326 /* Push unwind-protect entries of various types. */
3329 record_unwind_protect (void (*function
) (Lisp_Object
), Lisp_Object arg
)
3331 specpdl_ptr
->unwind
.kind
= SPECPDL_UNWIND
;
3332 specpdl_ptr
->unwind
.func
= function
;
3333 specpdl_ptr
->unwind
.arg
= arg
;
3338 record_unwind_protect_ptr (void (*function
) (void *), void *arg
)
3340 specpdl_ptr
->unwind_ptr
.kind
= SPECPDL_UNWIND_PTR
;
3341 specpdl_ptr
->unwind_ptr
.func
= function
;
3342 specpdl_ptr
->unwind_ptr
.arg
= arg
;
3347 record_unwind_protect_int (void (*function
) (int), int arg
)
3349 specpdl_ptr
->unwind_int
.kind
= SPECPDL_UNWIND_INT
;
3350 specpdl_ptr
->unwind_int
.func
= function
;
3351 specpdl_ptr
->unwind_int
.arg
= arg
;
3356 record_unwind_protect_void (void (*function
) (void))
3358 specpdl_ptr
->unwind_void
.kind
= SPECPDL_UNWIND_VOID
;
3359 specpdl_ptr
->unwind_void
.func
= function
;
3364 rebind_for_thread_switch (void)
3366 union specbinding
*bind
;
3368 for (bind
= specpdl
; bind
!= specpdl_ptr
; ++bind
)
3370 if (bind
->kind
>= SPECPDL_LET
)
3372 Lisp_Object value
= specpdl_saved_value (bind
);
3373 Lisp_Object sym
= specpdl_symbol (bind
);
3374 bind
->let
.saved_value
= Qnil
;
3375 do_specbind (XSYMBOL (sym
), bind
, value
,
3376 SET_INTERNAL_THREAD_SWITCH
);
3382 do_one_unbind (union specbinding
*this_binding
, bool unwinding
,
3383 enum Set_Internal_Bind bindflag
)
3385 eassert (unwinding
|| this_binding
->kind
>= SPECPDL_LET
);
3386 switch (this_binding
->kind
)
3388 case SPECPDL_UNWIND
:
3389 this_binding
->unwind
.func (this_binding
->unwind
.arg
);
3391 case SPECPDL_UNWIND_PTR
:
3392 this_binding
->unwind_ptr
.func (this_binding
->unwind_ptr
.arg
);
3394 case SPECPDL_UNWIND_INT
:
3395 this_binding
->unwind_int
.func (this_binding
->unwind_int
.arg
);
3397 case SPECPDL_UNWIND_VOID
:
3398 this_binding
->unwind_void
.func ();
3400 case SPECPDL_BACKTRACE
:
3403 { /* If variable has a trivial value (no forwarding), and isn't
3404 trapped, we can just set it. */
3405 Lisp_Object sym
= specpdl_symbol (this_binding
);
3406 if (SYMBOLP (sym
) && XSYMBOL (sym
)->redirect
== SYMBOL_PLAINVAL
)
3408 if (XSYMBOL (sym
)->trapped_write
== SYMBOL_UNTRAPPED_WRITE
)
3409 SET_SYMBOL_VAL (XSYMBOL (sym
), specpdl_old_value (this_binding
));
3411 set_internal (sym
, specpdl_old_value (this_binding
),
3416 /* Come here only if make_local_foo was used for the first time
3417 on this var within this let. */
3419 case SPECPDL_LET_DEFAULT
:
3420 set_default_internal (specpdl_symbol (this_binding
),
3421 specpdl_old_value (this_binding
),
3424 case SPECPDL_LET_LOCAL
:
3426 Lisp_Object symbol
= specpdl_symbol (this_binding
);
3427 Lisp_Object where
= specpdl_where (this_binding
);
3428 Lisp_Object old_value
= specpdl_old_value (this_binding
);
3429 eassert (BUFFERP (where
));
3431 /* If this was a local binding, reset the value in the appropriate
3432 buffer, but only if that buffer's binding still exists. */
3433 if (!NILP (Flocal_variable_p (symbol
, where
)))
3434 set_internal (symbol
, old_value
, where
, bindflag
);
3444 /* Push an unwind-protect entry that does nothing, so that
3445 set_unwind_protect_ptr can overwrite it later. */
3448 record_unwind_protect_nothing (void)
3450 record_unwind_protect_void (do_nothing
);
3453 /* Clear the unwind-protect entry COUNT, so that it does nothing.
3454 It need not be at the top of the stack. */
3457 clear_unwind_protect (ptrdiff_t count
)
3459 union specbinding
*p
= specpdl
+ count
;
3460 p
->unwind_void
.kind
= SPECPDL_UNWIND_VOID
;
3461 p
->unwind_void
.func
= do_nothing
;
3464 /* Set the unwind-protect entry COUNT so that it invokes FUNC (ARG).
3465 It need not be at the top of the stack. Discard the entry's
3466 previous value without invoking it. */
3469 set_unwind_protect (ptrdiff_t count
, void (*func
) (Lisp_Object
),
3472 union specbinding
*p
= specpdl
+ count
;
3473 p
->unwind
.kind
= SPECPDL_UNWIND
;
3474 p
->unwind
.func
= func
;
3475 p
->unwind
.arg
= arg
;
3479 set_unwind_protect_ptr (ptrdiff_t count
, void (*func
) (void *), void *arg
)
3481 union specbinding
*p
= specpdl
+ count
;
3482 p
->unwind_ptr
.kind
= SPECPDL_UNWIND_PTR
;
3483 p
->unwind_ptr
.func
= func
;
3484 p
->unwind_ptr
.arg
= arg
;
3487 /* Pop and execute entries from the unwind-protect stack until the
3488 depth COUNT is reached. Return VALUE. */
3491 unbind_to (ptrdiff_t count
, Lisp_Object value
)
3493 Lisp_Object quitf
= Vquit_flag
;
3497 while (specpdl_ptr
!= specpdl
+ count
)
3499 /* Copy the binding, and decrement specpdl_ptr, before we do
3500 the work to unbind it. We decrement first
3501 so that an error in unbinding won't try to unbind
3502 the same entry again, and we copy the binding first
3503 in case more bindings are made during some of the code we run. */
3505 union specbinding this_binding
;
3506 this_binding
= *--specpdl_ptr
;
3508 do_one_unbind (&this_binding
, true, SET_INTERNAL_UNBIND
);
3511 if (NILP (Vquit_flag
) && !NILP (quitf
))
3518 unbind_for_thread_switch (struct thread_state
*thr
)
3520 union specbinding
*bind
;
3522 for (bind
= thr
->m_specpdl_ptr
; bind
> thr
->m_specpdl
;)
3524 if ((--bind
)->kind
>= SPECPDL_LET
)
3526 Lisp_Object sym
= specpdl_symbol (bind
);
3527 bind
->let
.saved_value
= find_symbol_value (sym
);
3528 do_one_unbind (bind
, false, SET_INTERNAL_THREAD_SWITCH
);
3533 DEFUN ("special-variable-p", Fspecial_variable_p
, Sspecial_variable_p
, 1, 1, 0,
3534 doc
: /* Return non-nil if SYMBOL's global binding has been declared special.
3535 A special variable is one that will be bound dynamically, even in a
3536 context where binding is lexical by default. */)
3537 (Lisp_Object symbol
)
3539 CHECK_SYMBOL (symbol
);
3540 return XSYMBOL (symbol
)->declared_special
? Qt
: Qnil
;
3544 static union specbinding
*
3545 get_backtrace_starting_at (Lisp_Object base
)
3547 union specbinding
*pdl
= backtrace_top ();
3550 { /* Skip up to `base'. */
3551 base
= Findirect_function (base
, Qt
);
3552 while (backtrace_p (pdl
)
3553 && !EQ (base
, Findirect_function (backtrace_function (pdl
), Qt
)))
3554 pdl
= backtrace_next (pdl
);
3560 static union specbinding
*
3561 get_backtrace_frame (Lisp_Object nframes
, Lisp_Object base
)
3563 register EMACS_INT i
;
3565 CHECK_NATNUM (nframes
);
3566 union specbinding
*pdl
= get_backtrace_starting_at (base
);
3568 /* Find the frame requested. */
3569 for (i
= XFASTINT (nframes
); i
> 0 && backtrace_p (pdl
); i
--)
3570 pdl
= backtrace_next (pdl
);
3576 backtrace_frame_apply (Lisp_Object function
, union specbinding
*pdl
)
3578 if (!backtrace_p (pdl
))
3581 Lisp_Object flags
= Qnil
;
3582 if (backtrace_debug_on_exit (pdl
))
3583 flags
= Fcons (QCdebug_on_exit
, Fcons (Qt
, Qnil
));
3585 if (backtrace_nargs (pdl
) == UNEVALLED
)
3586 return call4 (function
, Qnil
, backtrace_function (pdl
), *backtrace_args (pdl
), flags
);
3589 Lisp_Object tem
= Flist (backtrace_nargs (pdl
), backtrace_args (pdl
));
3590 return call4 (function
, Qt
, backtrace_function (pdl
), tem
, flags
);
3594 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3595 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3596 The debugger is entered when that frame exits, if the flag is non-nil. */)
3597 (Lisp_Object level
, Lisp_Object flag
)
3599 CHECK_NUMBER (level
);
3600 union specbinding
*pdl
= get_backtrace_frame(level
, Qnil
);
3602 if (backtrace_p (pdl
))
3603 set_backtrace_debug_on_exit (pdl
, !NILP (flag
));
3608 DEFUN ("mapbacktrace", Fmapbacktrace
, Smapbacktrace
, 1, 2, 0,
3609 doc
: /* Call FUNCTION for each frame in backtrace.
3610 If BASE is non-nil, it should be a function and iteration will start
3611 from its nearest activation frame.
3612 FUNCTION is called with 4 arguments: EVALD, FUNC, ARGS, and FLAGS. If
3613 a frame has not evaluated its arguments yet or is a special form,
3614 EVALD is nil and ARGS is a list of forms. If a frame has evaluated
3615 its arguments and called its function already, EVALD is t and ARGS is
3617 FLAGS is a plist of properties of the current frame: currently, the
3618 only supported property is :debug-on-exit. `mapbacktrace' always
3620 (Lisp_Object function
, Lisp_Object base
)
3622 union specbinding
*pdl
= get_backtrace_starting_at (base
);
3624 while (backtrace_p (pdl
))
3626 ptrdiff_t i
= pdl
- specpdl
;
3627 backtrace_frame_apply (function
, pdl
);
3628 /* Beware! PDL is no longer valid here because FUNCTION might
3629 have caused grow_specpdl to reallocate pdlvec. We must use
3630 the saved index, cf. Bug#27258. */
3631 pdl
= backtrace_next (&specpdl
[i
]);
3637 DEFUN ("backtrace-frame--internal", Fbacktrace_frame_internal
,
3638 Sbacktrace_frame_internal
, 3, 3, NULL
,
3639 doc
: /* Call FUNCTION on stack frame NFRAMES away from BASE.
3640 Return the result of FUNCTION, or nil if no matching frame could be found. */)
3641 (Lisp_Object function
, Lisp_Object nframes
, Lisp_Object base
)
3643 return backtrace_frame_apply (function
, get_backtrace_frame (nframes
, base
));
3646 /* For backtrace-eval, we want to temporarily unwind the last few elements of
3647 the specpdl stack, and then rewind them. We store the pre-unwind values
3648 directly in the pre-existing specpdl elements (i.e. we swap the current
3649 value and the old value stored in the specpdl), kind of like the inplace
3650 pointer-reversal trick. As it turns out, the rewind does the same as the
3651 unwind, except it starts from the other end of the specpdl stack, so we use
3652 the same function for both unwind and rewind. */
3654 backtrace_eval_unrewind (int distance
)
3656 union specbinding
*tmp
= specpdl_ptr
;
3659 { /* It's a rewind rather than unwind. */
3660 tmp
+= distance
- 1;
3662 distance
= -distance
;
3665 for (; distance
> 0; distance
--)
3670 /* FIXME: Ideally we'd like to "temporarily unwind" (some of) those
3671 unwind_protect, but the problem is that we don't know how to
3672 rewind them afterwards. */
3673 case SPECPDL_UNWIND
:
3675 Lisp_Object oldarg
= tmp
->unwind
.arg
;
3676 if (tmp
->unwind
.func
== set_buffer_if_live
)
3677 tmp
->unwind
.arg
= Fcurrent_buffer ();
3678 else if (tmp
->unwind
.func
== save_excursion_restore
)
3679 tmp
->unwind
.arg
= save_excursion_save ();
3682 tmp
->unwind
.func (oldarg
);
3686 case SPECPDL_UNWIND_PTR
:
3687 case SPECPDL_UNWIND_INT
:
3688 case SPECPDL_UNWIND_VOID
:
3689 case SPECPDL_BACKTRACE
:
3692 { /* If variable has a trivial value (no forwarding), we can
3693 just set it. No need to check for constant symbols here,
3694 since that was already done by specbind. */
3695 Lisp_Object sym
= specpdl_symbol (tmp
);
3696 if (SYMBOLP (sym
) && XSYMBOL (sym
)->redirect
== SYMBOL_PLAINVAL
)
3698 Lisp_Object old_value
= specpdl_old_value (tmp
);
3699 set_specpdl_old_value (tmp
, SYMBOL_VAL (XSYMBOL (sym
)));
3700 SET_SYMBOL_VAL (XSYMBOL (sym
), old_value
);
3704 /* Come here only if make_local_foo was used for the first
3705 time on this var within this let. */
3707 case SPECPDL_LET_DEFAULT
:
3709 Lisp_Object sym
= specpdl_symbol (tmp
);
3710 Lisp_Object old_value
= specpdl_old_value (tmp
);
3711 set_specpdl_old_value (tmp
, Fdefault_value (sym
));
3712 Fset_default (sym
, old_value
);
3715 case SPECPDL_LET_LOCAL
:
3717 Lisp_Object symbol
= specpdl_symbol (tmp
);
3718 Lisp_Object where
= specpdl_where (tmp
);
3719 Lisp_Object old_value
= specpdl_old_value (tmp
);
3720 eassert (BUFFERP (where
));
3722 /* If this was a local binding, reset the value in the appropriate
3723 buffer, but only if that buffer's binding still exists. */
3724 if (!NILP (Flocal_variable_p (symbol
, where
)))
3726 set_specpdl_old_value
3727 (tmp
, Fbuffer_local_value (symbol
, where
));
3728 set_internal (symbol
, old_value
, where
, SET_INTERNAL_UNBIND
);
3736 DEFUN ("backtrace-eval", Fbacktrace_eval
, Sbacktrace_eval
, 2, 3, NULL
,
3737 doc
: /* Evaluate EXP in the context of some activation frame.
3738 NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */)
3739 (Lisp_Object exp
, Lisp_Object nframes
, Lisp_Object base
)
3741 union specbinding
*pdl
= get_backtrace_frame (nframes
, base
);
3742 ptrdiff_t count
= SPECPDL_INDEX ();
3743 ptrdiff_t distance
= specpdl_ptr
- pdl
;
3744 eassert (distance
>= 0);
3746 if (!backtrace_p (pdl
))
3747 error ("Activation frame not found!");
3749 backtrace_eval_unrewind (distance
);
3750 record_unwind_protect_int (backtrace_eval_unrewind
, -distance
);
3752 /* Use eval_sub rather than Feval since the main motivation behind
3753 backtrace-eval is to be able to get/set the value of lexical variables
3754 from the debugger. */
3755 return unbind_to (count
, eval_sub (exp
));
3758 DEFUN ("backtrace--locals", Fbacktrace__locals
, Sbacktrace__locals
, 1, 2, NULL
,
3759 doc
: /* Return names and values of local variables of a stack frame.
3760 NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */)
3761 (Lisp_Object nframes
, Lisp_Object base
)
3763 union specbinding
*frame
= get_backtrace_frame (nframes
, base
);
3764 union specbinding
*prevframe
3765 = get_backtrace_frame (make_number (XFASTINT (nframes
) - 1), base
);
3766 ptrdiff_t distance
= specpdl_ptr
- frame
;
3767 Lisp_Object result
= Qnil
;
3768 eassert (distance
>= 0);
3770 if (!backtrace_p (prevframe
))
3771 error ("Activation frame not found!");
3772 if (!backtrace_p (frame
))
3773 error ("Activation frame not found!");
3775 /* The specpdl entries normally contain the symbol being bound along with its
3776 `old_value', so it can be restored. The new value to which it is bound is
3777 available in one of two places: either in the current value of the
3778 variable (if it hasn't been rebound yet) or in the `old_value' slot of the
3779 next specpdl entry for it.
3780 `backtrace_eval_unrewind' happens to swap the role of `old_value'
3781 and "new value", so we abuse it here, to fetch the new value.
3782 It's ugly (we'd rather not modify global data) and a bit inefficient,
3783 but it does the job for now. */
3784 backtrace_eval_unrewind (distance
);
3788 union specbinding
*tmp
= prevframe
;
3789 for (; tmp
> frame
; tmp
--)
3794 case SPECPDL_LET_DEFAULT
:
3795 case SPECPDL_LET_LOCAL
:
3797 Lisp_Object sym
= specpdl_symbol (tmp
);
3798 Lisp_Object val
= specpdl_old_value (tmp
);
3799 if (EQ (sym
, Qinternal_interpreter_environment
))
3801 Lisp_Object env
= val
;
3802 for (; CONSP (env
); env
= XCDR (env
))
3804 Lisp_Object binding
= XCAR (env
);
3805 if (CONSP (binding
))
3806 result
= Fcons (Fcons (XCAR (binding
),
3812 result
= Fcons (Fcons (sym
, val
), result
);
3816 case SPECPDL_UNWIND
:
3817 case SPECPDL_UNWIND_PTR
:
3818 case SPECPDL_UNWIND_INT
:
3819 case SPECPDL_UNWIND_VOID
:
3820 case SPECPDL_BACKTRACE
:
3829 /* Restore values from specpdl to original place. */
3830 backtrace_eval_unrewind (-distance
);
3837 mark_specpdl (union specbinding
*first
, union specbinding
*ptr
)
3839 union specbinding
*pdl
;
3840 for (pdl
= first
; pdl
!= ptr
; pdl
++)
3844 case SPECPDL_UNWIND
:
3845 mark_object (specpdl_arg (pdl
));
3848 case SPECPDL_BACKTRACE
:
3850 ptrdiff_t nargs
= backtrace_nargs (pdl
);
3851 mark_object (backtrace_function (pdl
));
3852 if (nargs
== UNEVALLED
)
3855 mark_object (backtrace_args (pdl
)[nargs
]);
3859 case SPECPDL_LET_DEFAULT
:
3860 case SPECPDL_LET_LOCAL
:
3861 mark_object (specpdl_where (pdl
));
3864 mark_object (specpdl_symbol (pdl
));
3865 mark_object (specpdl_old_value (pdl
));
3866 mark_object (specpdl_saved_value (pdl
));
3869 case SPECPDL_UNWIND_PTR
:
3870 case SPECPDL_UNWIND_INT
:
3871 case SPECPDL_UNWIND_VOID
:
3881 get_backtrace (Lisp_Object array
)
3883 union specbinding
*pdl
= backtrace_next (backtrace_top ());
3884 ptrdiff_t i
= 0, asize
= ASIZE (array
);
3886 /* Copy the backtrace contents into working memory. */
3887 for (; i
< asize
; i
++)
3889 if (backtrace_p (pdl
))
3891 ASET (array
, i
, backtrace_function (pdl
));
3892 pdl
= backtrace_next (pdl
);
3895 ASET (array
, i
, Qnil
);
3899 Lisp_Object
backtrace_top_function (void)
3901 union specbinding
*pdl
= backtrace_top ();
3902 return (backtrace_p (pdl
) ? backtrace_function (pdl
) : Qnil
);
3908 DEFVAR_INT ("max-specpdl-size", max_specpdl_size
,
3909 doc
: /* Limit on number of Lisp variable bindings and `unwind-protect's.
3910 If Lisp code tries to increase the total number past this amount,
3911 an error is signaled.
3912 You can safely use a value considerably larger than the default value,
3913 if that proves inconveniently small. However, if you increase it too far,
3914 Emacs could run out of memory trying to make the stack bigger.
3915 Note that this limit may be silently increased by the debugger
3916 if `debug-on-error' or `debug-on-quit' is set. */);
3918 DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth
,
3919 doc
: /* Limit on depth in `eval', `apply' and `funcall' before error.
3921 This limit serves to catch infinite recursions for you before they cause
3922 actual stack overflow in C, which would be fatal for Emacs.
3923 You can safely make it considerably larger than its default value,
3924 if that proves inconveniently small. However, if you increase it too far,
3925 Emacs could overflow the real C stack, and crash. */);
3927 DEFVAR_LISP ("quit-flag", Vquit_flag
,
3928 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3929 If the value is t, that means do an ordinary quit.
3930 If the value equals `throw-on-input', that means quit by throwing
3931 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3932 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3933 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3936 DEFVAR_LISP ("inhibit-quit", Vinhibit_quit
,
3937 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3938 Note that `quit-flag' will still be set by typing C-g,
3939 so a quit will be signaled as soon as `inhibit-quit' is nil.
3940 To prevent this happening, set `quit-flag' to nil
3941 before making `inhibit-quit' nil. */);
3942 Vinhibit_quit
= Qnil
;
3944 DEFSYM (Qsetq
, "setq");
3945 DEFSYM (Qinhibit_quit
, "inhibit-quit");
3946 DEFSYM (Qautoload
, "autoload");
3947 DEFSYM (Qinhibit_debugger
, "inhibit-debugger");
3948 DEFSYM (Qmacro
, "macro");
3950 /* Note that the process handling also uses Qexit, but we don't want
3951 to staticpro it twice, so we just do it here. */
3952 DEFSYM (Qexit
, "exit");
3954 DEFSYM (Qinteractive
, "interactive");
3955 DEFSYM (Qcommandp
, "commandp");
3956 DEFSYM (Qand_rest
, "&rest");
3957 DEFSYM (Qand_optional
, "&optional");
3958 DEFSYM (Qclosure
, "closure");
3959 DEFSYM (QCdocumentation
, ":documentation");
3960 DEFSYM (Qdebug
, "debug");
3962 DEFVAR_LISP ("inhibit-debugger", Vinhibit_debugger
,
3963 doc
: /* Non-nil means never enter the debugger.
3964 Normally set while the debugger is already active, to avoid recursive
3966 Vinhibit_debugger
= Qnil
;
3968 DEFVAR_LISP ("debug-on-error", Vdebug_on_error
,
3969 doc
: /* Non-nil means enter debugger if an error is signaled.
3970 Does not apply to errors handled by `condition-case' or those
3971 matched by `debug-ignored-errors'.
3972 If the value is a list, an error only means to enter the debugger
3973 if one of its condition symbols appears in the list.
3974 When you evaluate an expression interactively, this variable
3975 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3976 The command `toggle-debug-on-error' toggles this.
3977 See also the variable `debug-on-quit' and `inhibit-debugger'. */);
3978 Vdebug_on_error
= Qnil
;
3980 DEFVAR_LISP ("debug-ignored-errors", Vdebug_ignored_errors
,
3981 doc
: /* List of errors for which the debugger should not be called.
3982 Each element may be a condition-name or a regexp that matches error messages.
3983 If any element applies to a given error, that error skips the debugger
3984 and just returns to top level.
3985 This overrides the variable `debug-on-error'.
3986 It does not apply to errors handled by `condition-case'. */);
3987 Vdebug_ignored_errors
= Qnil
;
3989 DEFVAR_BOOL ("debug-on-quit", debug_on_quit
,
3990 doc
: /* Non-nil means enter debugger if quit is signaled (C-g, for example).
3991 Does not apply if quit is handled by a `condition-case'. */);
3994 DEFVAR_BOOL ("debug-on-next-call", debug_on_next_call
,
3995 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3997 DEFVAR_BOOL ("debugger-may-continue", debugger_may_continue
,
3998 doc
: /* Non-nil means debugger may continue execution.
3999 This is nil when the debugger is called under circumstances where it
4000 might not be safe to continue. */);
4001 debugger_may_continue
= 1;
4003 DEFVAR_BOOL ("debugger-stack-frame-as-list", debugger_stack_frame_as_list
,
4004 doc
: /* Non-nil means display call stack frames as lists. */);
4005 debugger_stack_frame_as_list
= 0;
4007 DEFVAR_LISP ("debugger", Vdebugger
,
4008 doc
: /* Function to call to invoke debugger.
4009 If due to frame exit, args are `exit' and the value being returned;
4010 this function's value will be returned instead of that.
4011 If due to error, args are `error' and a list of the args to `signal'.
4012 If due to `apply' or `funcall' entry, one arg, `lambda'.
4013 If due to `eval' entry, one arg, t. */);
4016 DEFVAR_LISP ("signal-hook-function", Vsignal_hook_function
,
4017 doc
: /* If non-nil, this is a function for `signal' to call.
4018 It receives the same arguments that `signal' was given.
4019 The Edebug package uses this to regain control. */);
4020 Vsignal_hook_function
= Qnil
;
4022 DEFVAR_LISP ("debug-on-signal", Vdebug_on_signal
,
4023 doc
: /* Non-nil means call the debugger regardless of condition handlers.
4024 Note that `debug-on-error', `debug-on-quit' and friends
4025 still determine whether to handle the particular condition. */);
4026 Vdebug_on_signal
= Qnil
;
4028 /* When lexical binding is being used,
4029 Vinternal_interpreter_environment is non-nil, and contains an alist
4030 of lexically-bound variable, or (t), indicating an empty
4031 environment. The lisp name of this variable would be
4032 `internal-interpreter-environment' if it weren't hidden.
4033 Every element of this list can be either a cons (VAR . VAL)
4034 specifying a lexical binding, or a single symbol VAR indicating
4035 that this variable should use dynamic scoping. */
4036 DEFSYM (Qinternal_interpreter_environment
,
4037 "internal-interpreter-environment");
4038 DEFVAR_LISP ("internal-interpreter-environment",
4039 Vinternal_interpreter_environment
,
4040 doc
: /* If non-nil, the current lexical environment of the lisp interpreter.
4041 When lexical binding is not being used, this variable is nil.
4042 A value of `(t)' indicates an empty environment, otherwise it is an
4043 alist of active lexical bindings. */);
4044 Vinternal_interpreter_environment
= Qnil
;
4045 /* Don't export this variable to Elisp, so no one can mess with it
4046 (Just imagine if someone makes it buffer-local). */
4047 Funintern (Qinternal_interpreter_environment
, Qnil
);
4049 Vrun_hooks
= intern_c_string ("run-hooks");
4050 staticpro (&Vrun_hooks
);
4052 staticpro (&Vautoload_queue
);
4053 Vautoload_queue
= Qnil
;
4054 staticpro (&Vsignaling_function
);
4055 Vsignaling_function
= Qnil
;
4057 inhibit_lisp_code
= Qnil
;
4068 defsubr (&Sfunction
);
4069 defsubr (&Sdefault_toplevel_value
);
4070 defsubr (&Sset_default_toplevel_value
);
4072 defsubr (&Sdefvaralias
);
4073 DEFSYM (Qdefvaralias
, "defvaralias");
4074 defsubr (&Sdefconst
);
4075 defsubr (&Smake_var_non_special
);
4079 defsubr (&Smacroexpand
);
4082 defsubr (&Sunwind_protect
);
4083 defsubr (&Scondition_case
);
4085 defsubr (&Scommandp
);
4086 defsubr (&Sautoload
);
4087 defsubr (&Sautoload_do_load
);
4090 defsubr (&Sfuncall
);
4091 defsubr (&Sfunc_arity
);
4092 defsubr (&Srun_hooks
);
4093 defsubr (&Srun_hook_with_args
);
4094 defsubr (&Srun_hook_with_args_until_success
);
4095 defsubr (&Srun_hook_with_args_until_failure
);
4096 defsubr (&Srun_hook_wrapped
);
4097 defsubr (&Sfetch_bytecode
);
4098 defsubr (&Sbacktrace_debug
);
4099 DEFSYM (QCdebug_on_exit
, ":debug-on-exit");
4100 defsubr (&Smapbacktrace
);
4101 defsubr (&Sbacktrace_frame_internal
);
4102 defsubr (&Sbacktrace_eval
);
4103 defsubr (&Sbacktrace__locals
);
4104 defsubr (&Sspecial_variable_p
);
4105 defsubr (&Sfunctionp
);