* lisp/url/url-handlers.el: No need for subr-x at run-time.
[emacs.git] / src / eval.c
blob08a73b1e4a5281b463ed7e2e98ae6aad42518e37
1 /* Evaluator for GNU Emacs Lisp interpreter.
3 Copyright (C) 1985-1987, 1993-1995, 1999-2018 Free Software Foundation,
4 Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or (at
11 your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
22 #include <config.h>
23 #include <limits.h>
24 #include <stdio.h>
25 #include <stdlib.h>
26 #include "lisp.h"
27 #include "blockinput.h"
28 #include "commands.h"
29 #include "keyboard.h"
30 #include "dispextern.h"
31 #include "buffer.h"
33 /* CACHEABLE is ordinarily nothing, except it is 'volatile' if
34 necessary to cajole GCC into not warning incorrectly that a
35 variable should be volatile. */
36 #if defined GCC_LINT || defined lint
37 # define CACHEABLE volatile
38 #else
39 # define CACHEABLE /* empty */
40 #endif
42 /* Chain of condition and catch handlers currently in effect. */
44 /* struct handler *handlerlist; */
46 /* Non-nil means record all fset's and provide's, to be undone
47 if the file being autoloaded is not fully loaded.
48 They are recorded by being consed onto the front of Vautoload_queue:
49 (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide. */
51 Lisp_Object Vautoload_queue;
53 /* This holds either the symbol `run-hooks' or nil.
54 It is nil at an early stage of startup, and when Emacs
55 is shutting down. */
56 Lisp_Object Vrun_hooks;
58 /* The commented-out variables below are macros defined in thread.h. */
60 /* Current number of specbindings allocated in specpdl, not counting
61 the dummy entry specpdl[-1]. */
63 /* ptrdiff_t specpdl_size; */
65 /* Pointer to beginning of specpdl. A dummy entry specpdl[-1] exists
66 only so that its address can be taken. */
68 /* union specbinding *specpdl; */
70 /* Pointer to first unused element in specpdl. */
72 /* union specbinding *specpdl_ptr; */
74 /* Depth in Lisp evaluations and function calls. */
76 /* static EMACS_INT lisp_eval_depth; */
78 /* The value of num_nonmacro_input_events as of the last time we
79 started to enter the debugger. If we decide to enter the debugger
80 again when this is still equal to num_nonmacro_input_events, then we
81 know that the debugger itself has an error, and we should just
82 signal the error instead of entering an infinite loop of debugger
83 invocations. */
85 static EMACS_INT when_entered_debugger;
87 /* The function from which the last `signal' was called. Set in
88 Fsignal. */
89 /* FIXME: We should probably get rid of this! */
90 Lisp_Object Vsignaling_function;
92 /* If non-nil, Lisp code must not be run since some part of Emacs is in
93 an inconsistent state. Currently unused. */
94 Lisp_Object inhibit_lisp_code;
96 /* These would ordinarily be static, but they need to be visible to GDB. */
97 bool backtrace_p (union specbinding *) EXTERNALLY_VISIBLE;
98 Lisp_Object *backtrace_args (union specbinding *) EXTERNALLY_VISIBLE;
99 Lisp_Object backtrace_function (union specbinding *) EXTERNALLY_VISIBLE;
100 union specbinding *backtrace_next (union specbinding *) EXTERNALLY_VISIBLE;
101 union specbinding *backtrace_top (void) EXTERNALLY_VISIBLE;
103 static Lisp_Object funcall_lambda (Lisp_Object, ptrdiff_t, Lisp_Object *);
104 static Lisp_Object apply_lambda (Lisp_Object, Lisp_Object, ptrdiff_t);
105 static Lisp_Object lambda_arity (Lisp_Object);
107 static Lisp_Object
108 specpdl_symbol (union specbinding *pdl)
110 eassert (pdl->kind >= SPECPDL_LET);
111 return pdl->let.symbol;
114 static enum specbind_tag
115 specpdl_kind (union specbinding *pdl)
117 eassert (pdl->kind >= SPECPDL_LET);
118 return pdl->let.kind;
121 static Lisp_Object
122 specpdl_old_value (union specbinding *pdl)
124 eassert (pdl->kind >= SPECPDL_LET);
125 return pdl->let.old_value;
128 static void
129 set_specpdl_old_value (union specbinding *pdl, Lisp_Object val)
131 eassert (pdl->kind >= SPECPDL_LET);
132 pdl->let.old_value = val;
135 static Lisp_Object
136 specpdl_where (union specbinding *pdl)
138 eassert (pdl->kind > SPECPDL_LET);
139 return pdl->let.where;
142 static Lisp_Object
143 specpdl_saved_value (union specbinding *pdl)
145 eassert (pdl->kind >= SPECPDL_LET);
146 return pdl->let.saved_value;
149 static Lisp_Object
150 specpdl_arg (union specbinding *pdl)
152 eassert (pdl->kind == SPECPDL_UNWIND);
153 return pdl->unwind.arg;
156 Lisp_Object
157 backtrace_function (union specbinding *pdl)
159 eassert (pdl->kind == SPECPDL_BACKTRACE);
160 return pdl->bt.function;
163 static ptrdiff_t
164 backtrace_nargs (union specbinding *pdl)
166 eassert (pdl->kind == SPECPDL_BACKTRACE);
167 return pdl->bt.nargs;
170 Lisp_Object *
171 backtrace_args (union specbinding *pdl)
173 eassert (pdl->kind == SPECPDL_BACKTRACE);
174 return pdl->bt.args;
177 static bool
178 backtrace_debug_on_exit (union specbinding *pdl)
180 eassert (pdl->kind == SPECPDL_BACKTRACE);
181 return pdl->bt.debug_on_exit;
184 /* Functions to modify slots of backtrace records. */
186 static void
187 set_backtrace_args (union specbinding *pdl, Lisp_Object *args, ptrdiff_t nargs)
189 eassert (pdl->kind == SPECPDL_BACKTRACE);
190 pdl->bt.args = args;
191 pdl->bt.nargs = nargs;
194 static void
195 set_backtrace_debug_on_exit (union specbinding *pdl, bool doe)
197 eassert (pdl->kind == SPECPDL_BACKTRACE);
198 pdl->bt.debug_on_exit = doe;
201 /* Helper functions to scan the backtrace. */
203 bool
204 backtrace_p (union specbinding *pdl)
205 { return pdl >= specpdl; }
207 union specbinding *
208 backtrace_top (void)
210 union specbinding *pdl = specpdl_ptr - 1;
211 while (backtrace_p (pdl) && pdl->kind != SPECPDL_BACKTRACE)
212 pdl--;
213 return pdl;
216 union specbinding *
217 backtrace_next (union specbinding *pdl)
219 pdl--;
220 while (backtrace_p (pdl) && pdl->kind != SPECPDL_BACKTRACE)
221 pdl--;
222 return pdl;
225 void
226 init_eval_once (void)
228 enum { size = 50 };
229 union specbinding *pdlvec = xmalloc ((size + 1) * sizeof *specpdl);
230 specpdl_size = size;
231 specpdl = specpdl_ptr = pdlvec + 1;
232 /* Don't forget to update docs (lispref node "Local Variables"). */
233 max_specpdl_size = 1300; /* 1000 is not enough for CEDET's c-by.el. */
234 max_lisp_eval_depth = 800;
236 Vrun_hooks = Qnil;
239 /* static struct handler handlerlist_sentinel; */
241 void
242 init_eval (void)
244 specpdl_ptr = specpdl;
245 { /* Put a dummy catcher at top-level so that handlerlist is never NULL.
246 This is important since handlerlist->nextfree holds the freelist
247 which would otherwise leak every time we unwind back to top-level. */
248 handlerlist_sentinel = xzalloc (sizeof (struct handler));
249 handlerlist = handlerlist_sentinel->nextfree = handlerlist_sentinel;
250 struct handler *c = push_handler (Qunbound, CATCHER);
251 eassert (c == handlerlist_sentinel);
252 handlerlist_sentinel->nextfree = NULL;
253 handlerlist_sentinel->next = NULL;
255 Vquit_flag = Qnil;
256 debug_on_next_call = 0;
257 lisp_eval_depth = 0;
258 /* This is less than the initial value of num_nonmacro_input_events. */
259 when_entered_debugger = -1;
262 /* Unwind-protect function used by call_debugger. */
264 static void
265 restore_stack_limits (Lisp_Object data)
267 max_specpdl_size = XINT (XCAR (data));
268 max_lisp_eval_depth = XINT (XCDR (data));
271 static void grow_specpdl (void);
273 /* Call the Lisp debugger, giving it argument ARG. */
275 Lisp_Object
276 call_debugger (Lisp_Object arg)
278 bool debug_while_redisplaying;
279 ptrdiff_t count = SPECPDL_INDEX ();
280 Lisp_Object val;
281 EMACS_INT old_depth = max_lisp_eval_depth;
282 /* Do not allow max_specpdl_size less than actual depth (Bug#16603). */
283 EMACS_INT old_max = max (max_specpdl_size, count);
285 if (lisp_eval_depth + 40 > max_lisp_eval_depth)
286 max_lisp_eval_depth = lisp_eval_depth + 40;
288 /* While debugging Bug#16603, previous value of 100 was found
289 too small to avoid specpdl overflow in the debugger itself. */
290 if (max_specpdl_size - 200 < count)
291 max_specpdl_size = count + 200;
293 if (old_max == count)
295 /* We can enter the debugger due to specpdl overflow (Bug#16603). */
296 specpdl_ptr--;
297 grow_specpdl ();
300 /* Restore limits after leaving the debugger. */
301 record_unwind_protect (restore_stack_limits,
302 Fcons (make_number (old_max),
303 make_number (old_depth)));
305 #ifdef HAVE_WINDOW_SYSTEM
306 if (display_hourglass_p)
307 cancel_hourglass ();
308 #endif
310 debug_on_next_call = 0;
311 when_entered_debugger = num_nonmacro_input_events;
313 /* Resetting redisplaying_p to 0 makes sure that debug output is
314 displayed if the debugger is invoked during redisplay. */
315 debug_while_redisplaying = redisplaying_p;
316 redisplaying_p = 0;
317 specbind (intern ("debugger-may-continue"),
318 debug_while_redisplaying ? Qnil : Qt);
319 specbind (Qinhibit_redisplay, Qnil);
320 specbind (Qinhibit_debugger, Qt);
322 /* If we are debugging an error while `inhibit-changing-match-data'
323 is bound to non-nil (e.g., within a call to `string-match-p'),
324 then make sure debugger code can still use match data. */
325 specbind (Qinhibit_changing_match_data, Qnil);
327 #if 0 /* Binding this prevents execution of Lisp code during
328 redisplay, which necessarily leads to display problems. */
329 specbind (Qinhibit_eval_during_redisplay, Qt);
330 #endif
332 val = apply1 (Vdebugger, arg);
334 /* Interrupting redisplay and resuming it later is not safe under
335 all circumstances. So, when the debugger returns, abort the
336 interrupted redisplay by going back to the top-level. */
337 if (debug_while_redisplaying)
338 Ftop_level ();
340 return unbind_to (count, val);
343 static void
344 do_debug_on_call (Lisp_Object code, ptrdiff_t count)
346 debug_on_next_call = 0;
347 set_backtrace_debug_on_exit (specpdl + count, true);
348 call_debugger (list1 (code));
351 /* NOTE!!! Every function that can call EVAL must protect its args
352 and temporaries from garbage collection while it needs them.
353 The definition of `For' shows what you have to do. */
355 DEFUN ("or", For, Sor, 0, UNEVALLED, 0,
356 doc: /* Eval args until one of them yields non-nil, then return that value.
357 The remaining args are not evalled at all.
358 If all args return nil, return nil.
359 usage: (or CONDITIONS...) */)
360 (Lisp_Object args)
362 Lisp_Object val = Qnil;
364 while (CONSP (args))
366 Lisp_Object arg = XCAR (args);
367 args = XCDR (args);
368 val = eval_sub (arg);
369 if (!NILP (val))
370 break;
373 return val;
376 DEFUN ("and", Fand, Sand, 0, UNEVALLED, 0,
377 doc: /* Eval args until one of them yields nil, then return nil.
378 The remaining args are not evalled at all.
379 If no arg yields nil, return the last arg's value.
380 usage: (and CONDITIONS...) */)
381 (Lisp_Object args)
383 Lisp_Object val = Qt;
385 while (CONSP (args))
387 Lisp_Object arg = XCAR (args);
388 args = XCDR (args);
389 val = eval_sub (arg);
390 if (NILP (val))
391 break;
394 return val;
397 DEFUN ("if", Fif, Sif, 2, UNEVALLED, 0,
398 doc: /* If COND yields non-nil, do THEN, else do ELSE...
399 Returns the value of THEN or the value of the last of the ELSE's.
400 THEN must be one expression, but ELSE... can be zero or more expressions.
401 If COND yields nil, and there are no ELSE's, the value is nil.
402 usage: (if COND THEN ELSE...) */)
403 (Lisp_Object args)
405 Lisp_Object cond;
407 cond = eval_sub (XCAR (args));
409 if (!NILP (cond))
410 return eval_sub (Fcar (XCDR (args)));
411 return Fprogn (Fcdr (XCDR (args)));
414 DEFUN ("cond", Fcond, Scond, 0, UNEVALLED, 0,
415 doc: /* Try each clause until one succeeds.
416 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
417 and, if the value is non-nil, this clause succeeds:
418 then the expressions in BODY are evaluated and the last one's
419 value is the value of the cond-form.
420 If a clause has one element, as in (CONDITION), then the cond-form
421 returns CONDITION's value, if that is non-nil.
422 If no clause succeeds, cond returns nil.
423 usage: (cond CLAUSES...) */)
424 (Lisp_Object args)
426 Lisp_Object val = args;
428 while (CONSP (args))
430 Lisp_Object clause = XCAR (args);
431 val = eval_sub (Fcar (clause));
432 if (!NILP (val))
434 if (!NILP (XCDR (clause)))
435 val = Fprogn (XCDR (clause));
436 break;
438 args = XCDR (args);
441 return val;
444 DEFUN ("progn", Fprogn, Sprogn, 0, UNEVALLED, 0,
445 doc: /* Eval BODY forms sequentially and return value of last one.
446 usage: (progn BODY...) */)
447 (Lisp_Object body)
449 Lisp_Object val = Qnil;
451 while (CONSP (body))
453 Lisp_Object form = XCAR (body);
454 body = XCDR (body);
455 val = eval_sub (form);
458 return val;
461 /* Evaluate BODY sequentially, discarding its value. */
463 void
464 prog_ignore (Lisp_Object body)
466 Fprogn (body);
469 DEFUN ("prog1", Fprog1, Sprog1, 1, UNEVALLED, 0,
470 doc: /* Eval FIRST and BODY sequentially; return value from FIRST.
471 The value of FIRST is saved during the evaluation of the remaining args,
472 whose values are discarded.
473 usage: (prog1 FIRST BODY...) */)
474 (Lisp_Object args)
476 Lisp_Object val = eval_sub (XCAR (args));
477 prog_ignore (XCDR (args));
478 return val;
481 DEFUN ("prog2", Fprog2, Sprog2, 2, UNEVALLED, 0,
482 doc: /* Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
483 The value of FORM2 is saved during the evaluation of the
484 remaining args, whose values are discarded.
485 usage: (prog2 FORM1 FORM2 BODY...) */)
486 (Lisp_Object args)
488 eval_sub (XCAR (args));
489 return Fprog1 (XCDR (args));
492 DEFUN ("setq", Fsetq, Ssetq, 0, UNEVALLED, 0,
493 doc: /* Set each SYM to the value of its VAL.
494 The symbols SYM are variables; they are literal (not evaluated).
495 The values VAL are expressions; they are evaluated.
496 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
497 The second VAL is not computed until after the first SYM is set, and so on;
498 each VAL can use the new value of variables set earlier in the `setq'.
499 The return value of the `setq' form is the value of the last VAL.
500 usage: (setq [SYM VAL]...) */)
501 (Lisp_Object args)
503 Lisp_Object val = args, tail = args;
505 for (EMACS_INT nargs = 0; CONSP (tail); nargs += 2)
507 Lisp_Object sym = XCAR (tail), lex_binding;
508 tail = XCDR (tail);
509 if (!CONSP (tail))
510 xsignal2 (Qwrong_number_of_arguments, Qsetq, make_number (nargs + 1));
511 Lisp_Object arg = XCAR (tail);
512 tail = XCDR (tail);
513 val = eval_sub (arg);
514 /* Like for eval_sub, we do not check declared_special here since
515 it's been done when let-binding. */
516 if (!NILP (Vinternal_interpreter_environment) /* Mere optimization! */
517 && SYMBOLP (sym)
518 && !NILP (lex_binding
519 = Fassq (sym, Vinternal_interpreter_environment)))
520 XSETCDR (lex_binding, val); /* SYM is lexically bound. */
521 else
522 Fset (sym, val); /* SYM is dynamically bound. */
525 return val;
528 DEFUN ("quote", Fquote, Squote, 1, UNEVALLED, 0,
529 doc: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
530 Warning: `quote' does not construct its return value, but just returns
531 the value that was pre-constructed by the Lisp reader (see info node
532 `(elisp)Printed Representation').
533 This means that \\='(a . b) is not identical to (cons \\='a \\='b): the former
534 does not cons. Quoting should be reserved for constants that will
535 never be modified by side-effects, unless you like self-modifying code.
536 See the common pitfall in info node `(elisp)Rearrangement' for an example
537 of unexpected results when a quoted object is modified.
538 usage: (quote ARG) */)
539 (Lisp_Object args)
541 if (!NILP (XCDR (args)))
542 xsignal2 (Qwrong_number_of_arguments, Qquote, Flength (args));
543 return XCAR (args);
546 DEFUN ("function", Ffunction, Sfunction, 1, UNEVALLED, 0,
547 doc: /* Like `quote', but preferred for objects which are functions.
548 In byte compilation, `function' causes its argument to be compiled.
549 `quote' cannot do that.
550 usage: (function ARG) */)
551 (Lisp_Object args)
553 Lisp_Object quoted = XCAR (args);
555 if (!NILP (XCDR (args)))
556 xsignal2 (Qwrong_number_of_arguments, Qfunction, Flength (args));
558 if (!NILP (Vinternal_interpreter_environment)
559 && CONSP (quoted)
560 && EQ (XCAR (quoted), Qlambda))
561 { /* This is a lambda expression within a lexical environment;
562 return an interpreted closure instead of a simple lambda. */
563 Lisp_Object cdr = XCDR (quoted);
564 Lisp_Object tmp = cdr;
565 if (CONSP (tmp)
566 && (tmp = XCDR (tmp), CONSP (tmp))
567 && (tmp = XCAR (tmp), CONSP (tmp))
568 && (EQ (QCdocumentation, XCAR (tmp))))
569 { /* Handle the special (:documentation <form>) to build the docstring
570 dynamically. */
571 Lisp_Object docstring = eval_sub (Fcar (XCDR (tmp)));
572 CHECK_STRING (docstring);
573 cdr = Fcons (XCAR (cdr), Fcons (docstring, XCDR (XCDR (cdr))));
575 return Fcons (Qclosure, Fcons (Vinternal_interpreter_environment,
576 cdr));
578 else
579 /* Simply quote the argument. */
580 return quoted;
584 DEFUN ("defvaralias", Fdefvaralias, Sdefvaralias, 2, 3, 0,
585 doc: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
586 Aliased variables always have the same value; setting one sets the other.
587 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
588 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
589 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
590 itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
591 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
592 The return value is BASE-VARIABLE. */)
593 (Lisp_Object new_alias, Lisp_Object base_variable, Lisp_Object docstring)
595 struct Lisp_Symbol *sym;
597 CHECK_SYMBOL (new_alias);
598 CHECK_SYMBOL (base_variable);
600 if (SYMBOL_CONSTANT_P (new_alias))
601 /* Making it an alias effectively changes its value. */
602 error ("Cannot make a constant an alias");
604 sym = XSYMBOL (new_alias);
606 switch (sym->u.s.redirect)
608 case SYMBOL_FORWARDED:
609 error ("Cannot make an internal variable an alias");
610 case SYMBOL_LOCALIZED:
611 error ("Don't know how to make a localized variable an alias");
612 case SYMBOL_PLAINVAL:
613 case SYMBOL_VARALIAS:
614 break;
615 default:
616 emacs_abort ();
619 /* https://lists.gnu.org/r/emacs-devel/2008-04/msg00834.html
620 If n_a is bound, but b_v is not, set the value of b_v to n_a,
621 so that old-code that affects n_a before the aliasing is setup
622 still works. */
623 if (NILP (Fboundp (base_variable)))
624 set_internal (base_variable, find_symbol_value (new_alias),
625 Qnil, SET_INTERNAL_BIND);
627 union specbinding *p;
629 for (p = specpdl_ptr; p > specpdl; )
630 if ((--p)->kind >= SPECPDL_LET
631 && (EQ (new_alias, specpdl_symbol (p))))
632 error ("Don't know how to make a let-bound variable an alias");
635 if (sym->u.s.trapped_write == SYMBOL_TRAPPED_WRITE)
636 notify_variable_watchers (new_alias, base_variable, Qdefvaralias, Qnil);
638 sym->u.s.declared_special = true;
639 XSYMBOL (base_variable)->u.s.declared_special = true;
640 sym->u.s.redirect = SYMBOL_VARALIAS;
641 SET_SYMBOL_ALIAS (sym, XSYMBOL (base_variable));
642 sym->u.s.trapped_write = XSYMBOL (base_variable)->u.s.trapped_write;
643 LOADHIST_ATTACH (new_alias);
644 /* Even if docstring is nil: remove old docstring. */
645 Fput (new_alias, Qvariable_documentation, docstring);
647 return base_variable;
650 static union specbinding *
651 default_toplevel_binding (Lisp_Object symbol)
653 union specbinding *binding = NULL;
654 union specbinding *pdl = specpdl_ptr;
655 while (pdl > specpdl)
657 switch ((--pdl)->kind)
659 case SPECPDL_LET_DEFAULT:
660 case SPECPDL_LET:
661 if (EQ (specpdl_symbol (pdl), symbol))
662 binding = pdl;
663 break;
665 case SPECPDL_UNWIND:
666 case SPECPDL_UNWIND_PTR:
667 case SPECPDL_UNWIND_INT:
668 case SPECPDL_UNWIND_VOID:
669 case SPECPDL_BACKTRACE:
670 case SPECPDL_LET_LOCAL:
671 break;
673 default:
674 emacs_abort ();
677 return binding;
680 DEFUN ("default-toplevel-value", Fdefault_toplevel_value, Sdefault_toplevel_value, 1, 1, 0,
681 doc: /* Return SYMBOL's toplevel default value.
682 "Toplevel" means outside of any let binding. */)
683 (Lisp_Object symbol)
685 union specbinding *binding = default_toplevel_binding (symbol);
686 Lisp_Object value
687 = binding ? specpdl_old_value (binding) : Fdefault_value (symbol);
688 if (!EQ (value, Qunbound))
689 return value;
690 xsignal1 (Qvoid_variable, symbol);
693 DEFUN ("set-default-toplevel-value", Fset_default_toplevel_value,
694 Sset_default_toplevel_value, 2, 2, 0,
695 doc: /* Set SYMBOL's toplevel default value to VALUE.
696 "Toplevel" means outside of any let binding. */)
697 (Lisp_Object symbol, Lisp_Object value)
699 union specbinding *binding = default_toplevel_binding (symbol);
700 if (binding)
701 set_specpdl_old_value (binding, value);
702 else
703 Fset_default (symbol, value);
704 return Qnil;
707 DEFUN ("defvar", Fdefvar, Sdefvar, 1, UNEVALLED, 0,
708 doc: /* Define SYMBOL as a variable, and return SYMBOL.
709 You are not required to define a variable in order to use it, but
710 defining it lets you supply an initial value and documentation, which
711 can be referred to by the Emacs help facilities and other programming
712 tools. The `defvar' form also declares the variable as \"special\",
713 so that it is always dynamically bound even if `lexical-binding' is t.
715 If SYMBOL's value is void and the optional argument INITVALUE is
716 provided, INITVALUE is evaluated and the result used to set SYMBOL's
717 value. If SYMBOL is buffer-local, its default value is what is set;
718 buffer-local values are not affected. If INITVALUE is missing,
719 SYMBOL's value is not set.
721 If SYMBOL has a local binding, then this form affects the local
722 binding. This is usually not what you want. Thus, if you need to
723 load a file defining variables, with this form or with `defconst' or
724 `defcustom', you should always load that file _outside_ any bindings
725 for these variables. (`defconst' and `defcustom' behave similarly in
726 this respect.)
728 The optional argument DOCSTRING is a documentation string for the
729 variable.
731 To define a user option, use `defcustom' instead of `defvar'.
732 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
733 (Lisp_Object args)
735 Lisp_Object sym, tem, tail;
737 sym = XCAR (args);
738 tail = XCDR (args);
740 if (!NILP (tail))
742 if (!NILP (XCDR (tail)) && !NILP (XCDR (XCDR (tail))))
743 error ("Too many arguments");
745 tem = Fdefault_boundp (sym);
747 /* Do it before evaluating the initial value, for self-references. */
748 XSYMBOL (sym)->u.s.declared_special = true;
750 if (NILP (tem))
751 Fset_default (sym, eval_sub (XCAR (tail)));
752 else
753 { /* Check if there is really a global binding rather than just a let
754 binding that shadows the global unboundness of the var. */
755 union specbinding *binding = default_toplevel_binding (sym);
756 if (binding && EQ (specpdl_old_value (binding), Qunbound))
758 set_specpdl_old_value (binding, eval_sub (XCAR (tail)));
761 tail = XCDR (tail);
762 tem = Fcar (tail);
763 if (!NILP (tem))
765 if (!NILP (Vpurify_flag))
766 tem = Fpurecopy (tem);
767 Fput (sym, Qvariable_documentation, tem);
769 LOADHIST_ATTACH (sym);
771 else if (!NILP (Vinternal_interpreter_environment)
772 && !XSYMBOL (sym)->u.s.declared_special)
773 /* A simple (defvar foo) with lexical scoping does "nothing" except
774 declare that var to be dynamically scoped *locally* (i.e. within
775 the current file or let-block). */
776 Vinternal_interpreter_environment
777 = Fcons (sym, Vinternal_interpreter_environment);
778 else
780 /* Simple (defvar <var>) should not count as a definition at all.
781 It could get in the way of other definitions, and unloading this
782 package could try to make the variable unbound. */
785 return sym;
788 DEFUN ("defconst", Fdefconst, Sdefconst, 2, UNEVALLED, 0,
789 doc: /* Define SYMBOL as a constant variable.
790 This declares that neither programs nor users should ever change the
791 value. This constancy is not actually enforced by Emacs Lisp, but
792 SYMBOL is marked as a special variable so that it is never lexically
793 bound.
795 The `defconst' form always sets the value of SYMBOL to the result of
796 evalling INITVALUE. If SYMBOL is buffer-local, its default value is
797 what is set; buffer-local values are not affected. If SYMBOL has a
798 local binding, then this form sets the local binding's value.
799 However, you should normally not make local bindings for variables
800 defined with this form.
802 The optional DOCSTRING specifies the variable's documentation string.
803 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
804 (Lisp_Object args)
806 Lisp_Object sym, tem;
808 sym = XCAR (args);
809 Lisp_Object docstring = Qnil;
810 if (!NILP (XCDR (XCDR (args))))
812 if (!NILP (XCDR (XCDR (XCDR (args)))))
813 error ("Too many arguments");
814 docstring = XCAR (XCDR (XCDR (args)));
817 tem = eval_sub (XCAR (XCDR (args)));
818 if (!NILP (Vpurify_flag))
819 tem = Fpurecopy (tem);
820 Fset_default (sym, tem);
821 XSYMBOL (sym)->u.s.declared_special = true;
822 if (!NILP (docstring))
824 if (!NILP (Vpurify_flag))
825 docstring = Fpurecopy (docstring);
826 Fput (sym, Qvariable_documentation, docstring);
828 Fput (sym, Qrisky_local_variable, Qt);
829 LOADHIST_ATTACH (sym);
830 return sym;
833 /* Make SYMBOL lexically scoped. */
834 DEFUN ("internal-make-var-non-special", Fmake_var_non_special,
835 Smake_var_non_special, 1, 1, 0,
836 doc: /* Internal function. */)
837 (Lisp_Object symbol)
839 CHECK_SYMBOL (symbol);
840 XSYMBOL (symbol)->u.s.declared_special = false;
841 return Qnil;
845 DEFUN ("let*", FletX, SletX, 1, UNEVALLED, 0,
846 doc: /* Bind variables according to VARLIST then eval BODY.
847 The value of the last form in BODY is returned.
848 Each element of VARLIST is a symbol (which is bound to nil)
849 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
850 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
851 usage: (let* VARLIST BODY...) */)
852 (Lisp_Object args)
854 Lisp_Object var, val, elt, lexenv;
855 ptrdiff_t count = SPECPDL_INDEX ();
857 lexenv = Vinternal_interpreter_environment;
859 Lisp_Object varlist = XCAR (args);
860 while (CONSP (varlist))
862 maybe_quit ();
864 elt = XCAR (varlist);
865 varlist = XCDR (varlist);
866 if (SYMBOLP (elt))
868 var = elt;
869 val = Qnil;
871 else
873 var = Fcar (elt);
874 if (! NILP (Fcdr (XCDR (elt))))
875 signal_error ("`let' bindings can have only one value-form", elt);
876 val = eval_sub (Fcar (XCDR (elt)));
879 if (!NILP (lexenv) && SYMBOLP (var)
880 && !XSYMBOL (var)->u.s.declared_special
881 && NILP (Fmemq (var, Vinternal_interpreter_environment)))
882 /* Lexically bind VAR by adding it to the interpreter's binding
883 alist. */
885 Lisp_Object newenv
886 = Fcons (Fcons (var, val), Vinternal_interpreter_environment);
887 if (EQ (Vinternal_interpreter_environment, lexenv))
888 /* Save the old lexical environment on the specpdl stack,
889 but only for the first lexical binding, since we'll never
890 need to revert to one of the intermediate ones. */
891 specbind (Qinternal_interpreter_environment, newenv);
892 else
893 Vinternal_interpreter_environment = newenv;
895 else
896 specbind (var, val);
898 CHECK_LIST_END (varlist, XCAR (args));
900 val = Fprogn (XCDR (args));
901 return unbind_to (count, val);
904 DEFUN ("let", Flet, Slet, 1, UNEVALLED, 0,
905 doc: /* Bind variables according to VARLIST then eval BODY.
906 The value of the last form in BODY is returned.
907 Each element of VARLIST is a symbol (which is bound to nil)
908 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
909 All the VALUEFORMs are evalled before any symbols are bound.
910 usage: (let VARLIST BODY...) */)
911 (Lisp_Object args)
913 Lisp_Object *temps, tem, lexenv;
914 Lisp_Object elt, varlist;
915 ptrdiff_t count = SPECPDL_INDEX ();
916 ptrdiff_t argnum;
917 USE_SAFE_ALLOCA;
919 varlist = XCAR (args);
920 CHECK_LIST (varlist);
922 /* Make space to hold the values to give the bound variables. */
923 EMACS_INT varlist_len = XFASTINT (Flength (varlist));
924 SAFE_ALLOCA_LISP (temps, varlist_len);
925 ptrdiff_t nvars = varlist_len;
927 /* Compute the values and store them in `temps'. */
929 for (argnum = 0; argnum < nvars && CONSP (varlist); argnum++)
931 maybe_quit ();
932 elt = XCAR (varlist);
933 varlist = XCDR (varlist);
934 if (SYMBOLP (elt))
935 temps[argnum] = Qnil;
936 else if (! NILP (Fcdr (Fcdr (elt))))
937 signal_error ("`let' bindings can have only one value-form", elt);
938 else
939 temps[argnum] = eval_sub (Fcar (Fcdr (elt)));
941 nvars = argnum;
943 lexenv = Vinternal_interpreter_environment;
945 varlist = XCAR (args);
946 for (argnum = 0; argnum < nvars && CONSP (varlist); argnum++)
948 Lisp_Object var;
950 elt = XCAR (varlist);
951 varlist = XCDR (varlist);
952 var = SYMBOLP (elt) ? elt : Fcar (elt);
953 tem = temps[argnum];
955 if (!NILP (lexenv) && SYMBOLP (var)
956 && !XSYMBOL (var)->u.s.declared_special
957 && NILP (Fmemq (var, Vinternal_interpreter_environment)))
958 /* Lexically bind VAR by adding it to the lexenv alist. */
959 lexenv = Fcons (Fcons (var, tem), lexenv);
960 else
961 /* Dynamically bind VAR. */
962 specbind (var, tem);
965 if (!EQ (lexenv, Vinternal_interpreter_environment))
966 /* Instantiate a new lexical environment. */
967 specbind (Qinternal_interpreter_environment, lexenv);
969 elt = Fprogn (XCDR (args));
970 SAFE_FREE ();
971 return unbind_to (count, elt);
974 DEFUN ("while", Fwhile, Swhile, 1, UNEVALLED, 0,
975 doc: /* If TEST yields non-nil, eval BODY... and repeat.
976 The order of execution is thus TEST, BODY, TEST, BODY and so on
977 until TEST returns nil.
978 usage: (while TEST BODY...) */)
979 (Lisp_Object args)
981 Lisp_Object test, body;
983 test = XCAR (args);
984 body = XCDR (args);
985 while (!NILP (eval_sub (test)))
987 maybe_quit ();
988 prog_ignore (body);
991 return Qnil;
994 DEFUN ("macroexpand", Fmacroexpand, Smacroexpand, 1, 2, 0,
995 doc: /* Return result of expanding macros at top level of FORM.
996 If FORM is not a macro call, it is returned unchanged.
997 Otherwise, the macro is expanded and the expansion is considered
998 in place of FORM. When a non-macro-call results, it is returned.
1000 The second optional arg ENVIRONMENT specifies an environment of macro
1001 definitions to shadow the loaded ones for use in file byte-compilation. */)
1002 (Lisp_Object form, Lisp_Object environment)
1004 /* With cleanups from Hallvard Furuseth. */
1005 register Lisp_Object expander, sym, def, tem;
1007 while (1)
1009 /* Come back here each time we expand a macro call,
1010 in case it expands into another macro call. */
1011 if (!CONSP (form))
1012 break;
1013 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1014 def = sym = XCAR (form);
1015 tem = Qnil;
1016 /* Trace symbols aliases to other symbols
1017 until we get a symbol that is not an alias. */
1018 while (SYMBOLP (def))
1020 maybe_quit ();
1021 sym = def;
1022 tem = Fassq (sym, environment);
1023 if (NILP (tem))
1025 def = XSYMBOL (sym)->u.s.function;
1026 if (!NILP (def))
1027 continue;
1029 break;
1031 /* Right now TEM is the result from SYM in ENVIRONMENT,
1032 and if TEM is nil then DEF is SYM's function definition. */
1033 if (NILP (tem))
1035 /* SYM is not mentioned in ENVIRONMENT.
1036 Look at its function definition. */
1037 def = Fautoload_do_load (def, sym, Qmacro);
1038 if (!CONSP (def))
1039 /* Not defined or definition not suitable. */
1040 break;
1041 if (!EQ (XCAR (def), Qmacro))
1042 break;
1043 else expander = XCDR (def);
1045 else
1047 expander = XCDR (tem);
1048 if (NILP (expander))
1049 break;
1052 Lisp_Object newform = apply1 (expander, XCDR (form));
1053 if (EQ (form, newform))
1054 break;
1055 else
1056 form = newform;
1059 return form;
1062 DEFUN ("catch", Fcatch, Scatch, 1, UNEVALLED, 0,
1063 doc: /* Eval BODY allowing nonlocal exits using `throw'.
1064 TAG is evalled to get the tag to use; it must not be nil.
1066 Then the BODY is executed.
1067 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
1068 If no throw happens, `catch' returns the value of the last BODY form.
1069 If a throw happens, it specifies the value to return from `catch'.
1070 usage: (catch TAG BODY...) */)
1071 (Lisp_Object args)
1073 Lisp_Object tag = eval_sub (XCAR (args));
1074 return internal_catch (tag, Fprogn, XCDR (args));
1077 /* Assert that E is true, but do not evaluate E. Use this instead of
1078 eassert (E) when E contains variables that might be clobbered by a
1079 longjmp. */
1081 #define clobbered_eassert(E) verify (sizeof (E) != 0)
1083 /* Set up a catch, then call C function FUNC on argument ARG.
1084 FUNC should return a Lisp_Object.
1085 This is how catches are done from within C code. */
1087 Lisp_Object
1088 internal_catch (Lisp_Object tag,
1089 Lisp_Object (*func) (Lisp_Object), Lisp_Object arg)
1091 /* This structure is made part of the chain `catchlist'. */
1092 struct handler *c = push_handler (tag, CATCHER);
1094 /* Call FUNC. */
1095 if (! sys_setjmp (c->jmp))
1097 Lisp_Object val = func (arg);
1098 eassert (handlerlist == c);
1099 handlerlist = c->next;
1100 return val;
1102 else
1103 { /* Throw works by a longjmp that comes right here. */
1104 Lisp_Object val = handlerlist->val;
1105 clobbered_eassert (handlerlist == c);
1106 handlerlist = handlerlist->next;
1107 return val;
1111 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1112 jump to that CATCH, returning VALUE as the value of that catch.
1114 This is the guts of Fthrow and Fsignal; they differ only in the way
1115 they choose the catch tag to throw to. A catch tag for a
1116 condition-case form has a TAG of Qnil.
1118 Before each catch is discarded, unbind all special bindings and
1119 execute all unwind-protect clauses made above that catch. Unwind
1120 the handler stack as we go, so that the proper handlers are in
1121 effect for each unwind-protect clause we run. At the end, restore
1122 some static info saved in CATCH, and longjmp to the location
1123 specified there.
1125 This is used for correct unwinding in Fthrow and Fsignal. */
1127 static _Noreturn void
1128 unwind_to_catch (struct handler *catch, Lisp_Object value)
1130 bool last_time;
1132 eassert (catch->next);
1134 /* Save the value in the tag. */
1135 catch->val = value;
1137 /* Restore certain special C variables. */
1138 set_poll_suppress_count (catch->poll_suppress_count);
1139 unblock_input_to (catch->interrupt_input_blocked);
1143 /* Unwind the specpdl stack, and then restore the proper set of
1144 handlers. */
1145 unbind_to (handlerlist->pdlcount, Qnil);
1146 last_time = handlerlist == catch;
1147 if (! last_time)
1148 handlerlist = handlerlist->next;
1150 while (! last_time);
1152 eassert (handlerlist == catch);
1154 lisp_eval_depth = catch->f_lisp_eval_depth;
1156 sys_longjmp (catch->jmp, 1);
1159 DEFUN ("throw", Fthrow, Sthrow, 2, 2, 0,
1160 doc: /* Throw to the catch for TAG and return VALUE from it.
1161 Both TAG and VALUE are evalled. */
1162 attributes: noreturn)
1163 (register Lisp_Object tag, Lisp_Object value)
1165 struct handler *c;
1167 if (!NILP (tag))
1168 for (c = handlerlist; c; c = c->next)
1170 if (c->type == CATCHER_ALL)
1171 unwind_to_catch (c, Fcons (tag, value));
1172 if (c->type == CATCHER && EQ (c->tag_or_ch, tag))
1173 unwind_to_catch (c, value);
1175 xsignal2 (Qno_catch, tag, value);
1179 DEFUN ("unwind-protect", Funwind_protect, Sunwind_protect, 1, UNEVALLED, 0,
1180 doc: /* Do BODYFORM, protecting with UNWINDFORMS.
1181 If BODYFORM completes normally, its value is returned
1182 after executing the UNWINDFORMS.
1183 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1184 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1185 (Lisp_Object args)
1187 Lisp_Object val;
1188 ptrdiff_t count = SPECPDL_INDEX ();
1190 record_unwind_protect (prog_ignore, XCDR (args));
1191 val = eval_sub (XCAR (args));
1192 return unbind_to (count, val);
1195 DEFUN ("condition-case", Fcondition_case, Scondition_case, 2, UNEVALLED, 0,
1196 doc: /* Regain control when an error is signaled.
1197 Executes BODYFORM and returns its value if no error happens.
1198 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1199 where the BODY is made of Lisp expressions.
1201 A handler is applicable to an error
1202 if CONDITION-NAME is one of the error's condition names.
1203 If an error happens, the first applicable handler is run.
1205 The car of a handler may be a list of condition names instead of a
1206 single condition name; then it handles all of them. If the special
1207 condition name `debug' is present in this list, it allows another
1208 condition in the list to run the debugger if `debug-on-error' and the
1209 other usual mechanisms says it should (otherwise, `condition-case'
1210 suppresses the debugger).
1212 When a handler handles an error, control returns to the `condition-case'
1213 and it executes the handler's BODY...
1214 with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
1215 \(If VAR is nil, the handler can't access that information.)
1216 Then the value of the last BODY form is returned from the `condition-case'
1217 expression.
1219 See also the function `signal' for more info.
1220 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1221 (Lisp_Object args)
1223 Lisp_Object var = XCAR (args);
1224 Lisp_Object bodyform = XCAR (XCDR (args));
1225 Lisp_Object handlers = XCDR (XCDR (args));
1227 return internal_lisp_condition_case (var, bodyform, handlers);
1230 /* Like Fcondition_case, but the args are separate
1231 rather than passed in a list. Used by Fbyte_code. */
1233 Lisp_Object
1234 internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform,
1235 Lisp_Object handlers)
1237 struct handler *oldhandlerlist = handlerlist;
1238 ptrdiff_t CACHEABLE clausenb = 0;
1240 CHECK_SYMBOL (var);
1242 for (Lisp_Object tail = handlers; CONSP (tail); tail = XCDR (tail))
1244 Lisp_Object tem = XCAR (tail);
1245 clausenb++;
1246 if (! (NILP (tem)
1247 || (CONSP (tem)
1248 && (SYMBOLP (XCAR (tem))
1249 || CONSP (XCAR (tem))))))
1250 error ("Invalid condition handler: %s",
1251 SDATA (Fprin1_to_string (tem, Qt)));
1254 /* The first clause is the one that should be checked first, so it
1255 should be added to handlerlist last. So build in CLAUSES a table
1256 that contains HANDLERS but in reverse order. CLAUSES is pointer
1257 to volatile to avoid issues with setjmp and local storage.
1258 SAFE_ALLOCA won't work here due to the setjmp, so impose a
1259 MAX_ALLOCA limit. */
1260 if (MAX_ALLOCA / word_size < clausenb)
1261 memory_full (SIZE_MAX);
1262 Lisp_Object volatile *clauses = alloca (clausenb * sizeof *clauses);
1263 clauses += clausenb;
1264 for (Lisp_Object tail = handlers; CONSP (tail); tail = XCDR (tail))
1265 *--clauses = XCAR (tail);
1266 for (ptrdiff_t i = 0; i < clausenb; i++)
1268 Lisp_Object clause = clauses[i];
1269 Lisp_Object condition = CONSP (clause) ? XCAR (clause) : Qnil;
1270 if (!CONSP (condition))
1271 condition = list1 (condition);
1272 struct handler *c = push_handler (condition, CONDITION_CASE);
1273 if (sys_setjmp (c->jmp))
1275 Lisp_Object val = handlerlist->val;
1276 Lisp_Object volatile *chosen_clause = clauses;
1277 for (struct handler *h = handlerlist->next; h != oldhandlerlist;
1278 h = h->next)
1279 chosen_clause++;
1280 Lisp_Object handler_body = XCDR (*chosen_clause);
1281 handlerlist = oldhandlerlist;
1283 if (NILP (var))
1284 return Fprogn (handler_body);
1286 Lisp_Object handler_var = var;
1287 if (!NILP (Vinternal_interpreter_environment))
1289 val = Fcons (Fcons (var, val),
1290 Vinternal_interpreter_environment);
1291 handler_var = Qinternal_interpreter_environment;
1294 /* Bind HANDLER_VAR to VAL while evaluating HANDLER_BODY.
1295 The unbind_to undoes just this binding; whoever longjumped
1296 to us unwound the stack to C->pdlcount before throwing. */
1297 ptrdiff_t count = SPECPDL_INDEX ();
1298 specbind (handler_var, val);
1299 return unbind_to (count, Fprogn (handler_body));
1303 Lisp_Object result = eval_sub (bodyform);
1304 handlerlist = oldhandlerlist;
1305 return result;
1308 /* Call the function BFUN with no arguments, catching errors within it
1309 according to HANDLERS. If there is an error, call HFUN with
1310 one argument which is the data that describes the error:
1311 (SIGNALNAME . DATA)
1313 HANDLERS can be a list of conditions to catch.
1314 If HANDLERS is Qt, catch all errors.
1315 If HANDLERS is Qerror, catch all errors
1316 but allow the debugger to run if that is enabled. */
1318 Lisp_Object
1319 internal_condition_case (Lisp_Object (*bfun) (void), Lisp_Object handlers,
1320 Lisp_Object (*hfun) (Lisp_Object))
1322 struct handler *c = push_handler (handlers, CONDITION_CASE);
1323 if (sys_setjmp (c->jmp))
1325 Lisp_Object val = handlerlist->val;
1326 clobbered_eassert (handlerlist == c);
1327 handlerlist = handlerlist->next;
1328 return hfun (val);
1330 else
1332 Lisp_Object val = bfun ();
1333 eassert (handlerlist == c);
1334 handlerlist = c->next;
1335 return val;
1339 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1341 Lisp_Object
1342 internal_condition_case_1 (Lisp_Object (*bfun) (Lisp_Object), Lisp_Object arg,
1343 Lisp_Object handlers,
1344 Lisp_Object (*hfun) (Lisp_Object))
1346 struct handler *c = push_handler (handlers, CONDITION_CASE);
1347 if (sys_setjmp (c->jmp))
1349 Lisp_Object val = handlerlist->val;
1350 clobbered_eassert (handlerlist == c);
1351 handlerlist = handlerlist->next;
1352 return hfun (val);
1354 else
1356 Lisp_Object val = bfun (arg);
1357 eassert (handlerlist == c);
1358 handlerlist = c->next;
1359 return val;
1363 /* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as
1364 its arguments. */
1366 Lisp_Object
1367 internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object),
1368 Lisp_Object arg1,
1369 Lisp_Object arg2,
1370 Lisp_Object handlers,
1371 Lisp_Object (*hfun) (Lisp_Object))
1373 struct handler *c = push_handler (handlers, CONDITION_CASE);
1374 if (sys_setjmp (c->jmp))
1376 Lisp_Object val = handlerlist->val;
1377 clobbered_eassert (handlerlist == c);
1378 handlerlist = handlerlist->next;
1379 return hfun (val);
1381 else
1383 Lisp_Object val = bfun (arg1, arg2);
1384 eassert (handlerlist == c);
1385 handlerlist = c->next;
1386 return val;
1390 /* Like internal_condition_case but call BFUN with NARGS as first,
1391 and ARGS as second argument. */
1393 Lisp_Object
1394 internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *),
1395 ptrdiff_t nargs,
1396 Lisp_Object *args,
1397 Lisp_Object handlers,
1398 Lisp_Object (*hfun) (Lisp_Object err,
1399 ptrdiff_t nargs,
1400 Lisp_Object *args))
1402 struct handler *c = push_handler (handlers, CONDITION_CASE);
1403 if (sys_setjmp (c->jmp))
1405 Lisp_Object val = handlerlist->val;
1406 clobbered_eassert (handlerlist == c);
1407 handlerlist = handlerlist->next;
1408 return hfun (val, nargs, args);
1410 else
1412 Lisp_Object val = bfun (nargs, args);
1413 eassert (handlerlist == c);
1414 handlerlist = c->next;
1415 return val;
1419 static Lisp_Object
1420 internal_catch_all_1 (Lisp_Object (*function) (void *), void *argument)
1422 struct handler *c = push_handler_nosignal (Qt, CATCHER_ALL);
1423 if (c == NULL)
1424 return Qcatch_all_memory_full;
1426 if (sys_setjmp (c->jmp) == 0)
1428 Lisp_Object val = function (argument);
1429 eassert (handlerlist == c);
1430 handlerlist = c->next;
1431 return val;
1433 else
1435 eassert (handlerlist == c);
1436 Lisp_Object val = c->val;
1437 handlerlist = c->next;
1438 Fsignal (Qno_catch, val);
1442 /* Like a combination of internal_condition_case_1 and internal_catch.
1443 Catches all signals and throws. Never exits nonlocally; returns
1444 Qcatch_all_memory_full if no handler could be allocated. */
1446 Lisp_Object
1447 internal_catch_all (Lisp_Object (*function) (void *), void *argument,
1448 Lisp_Object (*handler) (Lisp_Object))
1450 struct handler *c = push_handler_nosignal (Qt, CONDITION_CASE);
1451 if (c == NULL)
1452 return Qcatch_all_memory_full;
1454 if (sys_setjmp (c->jmp) == 0)
1456 Lisp_Object val = internal_catch_all_1 (function, argument);
1457 eassert (handlerlist == c);
1458 handlerlist = c->next;
1459 return val;
1461 else
1463 eassert (handlerlist == c);
1464 Lisp_Object val = c->val;
1465 handlerlist = c->next;
1466 return handler (val);
1470 struct handler *
1471 push_handler (Lisp_Object tag_ch_val, enum handlertype handlertype)
1473 struct handler *c = push_handler_nosignal (tag_ch_val, handlertype);
1474 if (!c)
1475 memory_full (sizeof *c);
1476 return c;
1479 struct handler *
1480 push_handler_nosignal (Lisp_Object tag_ch_val, enum handlertype handlertype)
1482 struct handler *CACHEABLE c = handlerlist->nextfree;
1483 if (!c)
1485 c = malloc (sizeof *c);
1486 if (!c)
1487 return c;
1488 if (profiler_memory_running)
1489 malloc_probe (sizeof *c);
1490 c->nextfree = NULL;
1491 handlerlist->nextfree = c;
1493 c->type = handlertype;
1494 c->tag_or_ch = tag_ch_val;
1495 c->val = Qnil;
1496 c->next = handlerlist;
1497 c->f_lisp_eval_depth = lisp_eval_depth;
1498 c->pdlcount = SPECPDL_INDEX ();
1499 c->poll_suppress_count = poll_suppress_count;
1500 c->interrupt_input_blocked = interrupt_input_blocked;
1501 handlerlist = c;
1502 return c;
1506 static Lisp_Object signal_or_quit (Lisp_Object, Lisp_Object, bool);
1507 static Lisp_Object find_handler_clause (Lisp_Object, Lisp_Object);
1508 static bool maybe_call_debugger (Lisp_Object conditions, Lisp_Object sig,
1509 Lisp_Object data);
1511 static void
1512 process_quit_flag (void)
1514 Lisp_Object flag = Vquit_flag;
1515 Vquit_flag = Qnil;
1516 if (EQ (flag, Qkill_emacs))
1517 Fkill_emacs (Qnil);
1518 if (EQ (Vthrow_on_input, flag))
1519 Fthrow (Vthrow_on_input, Qt);
1520 quit ();
1523 /* Check quit-flag and quit if it is non-nil. Typing C-g does not
1524 directly cause a quit; it only sets Vquit_flag. So the program
1525 needs to call maybe_quit at times when it is safe to quit. Every
1526 loop that might run for a long time or might not exit ought to call
1527 maybe_quit at least once, at a safe place. Unless that is
1528 impossible, of course. But it is very desirable to avoid creating
1529 loops where maybe_quit is impossible.
1531 If quit-flag is set to `kill-emacs' the SIGINT handler has received
1532 a request to exit Emacs when it is safe to do.
1534 When not quitting, process any pending signals.
1536 If you change this function, also adapt module_should_quit in
1537 emacs-module.c. */
1539 void
1540 maybe_quit (void)
1542 if (!NILP (Vquit_flag) && NILP (Vinhibit_quit))
1543 process_quit_flag ();
1544 else if (pending_signals)
1545 process_pending_signals ();
1548 DEFUN ("signal", Fsignal, Ssignal, 2, 2, 0,
1549 doc: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1550 This function does not return.
1552 An error symbol is a symbol with an `error-conditions' property
1553 that is a list of condition names.
1554 A handler for any of those names will get to handle this signal.
1555 The symbol `error' should normally be one of them.
1557 DATA should be a list. Its elements are printed as part of the error message.
1558 See Info anchor `(elisp)Definition of signal' for some details on how this
1559 error message is constructed.
1560 If the signal is handled, DATA is made available to the handler.
1561 See also the function `condition-case'. */
1562 attributes: noreturn)
1563 (Lisp_Object error_symbol, Lisp_Object data)
1565 signal_or_quit (error_symbol, data, false);
1566 eassume (false);
1569 /* Quit, in response to a keyboard quit request. */
1570 Lisp_Object
1571 quit (void)
1573 return signal_or_quit (Qquit, Qnil, true);
1576 /* Signal an error, or quit. ERROR_SYMBOL and DATA are as with Fsignal.
1577 If KEYBOARD_QUIT, this is a quit; ERROR_SYMBOL should be
1578 Qquit and DATA should be Qnil, and this function may return.
1579 Otherwise this function is like Fsignal and does not return. */
1581 static Lisp_Object
1582 signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit)
1584 /* When memory is full, ERROR-SYMBOL is nil,
1585 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1586 That is a special case--don't do this in other situations. */
1587 Lisp_Object conditions;
1588 Lisp_Object string;
1589 Lisp_Object real_error_symbol
1590 = (NILP (error_symbol) ? Fcar (data) : error_symbol);
1591 Lisp_Object clause = Qnil;
1592 struct handler *h;
1594 if (gc_in_progress || waiting_for_input)
1595 emacs_abort ();
1597 #if 0 /* rms: I don't know why this was here,
1598 but it is surely wrong for an error that is handled. */
1599 #ifdef HAVE_WINDOW_SYSTEM
1600 if (display_hourglass_p)
1601 cancel_hourglass ();
1602 #endif
1603 #endif
1605 /* This hook is used by edebug. */
1606 if (! NILP (Vsignal_hook_function)
1607 && ! NILP (error_symbol)
1608 /* Don't try to call a lisp function if we've already overflowed
1609 the specpdl stack. */
1610 && specpdl_ptr < specpdl + specpdl_size)
1612 /* Edebug takes care of restoring these variables when it exits. */
1613 if (lisp_eval_depth + 20 > max_lisp_eval_depth)
1614 max_lisp_eval_depth = lisp_eval_depth + 20;
1616 if (SPECPDL_INDEX () + 40 > max_specpdl_size)
1617 max_specpdl_size = SPECPDL_INDEX () + 40;
1619 call2 (Vsignal_hook_function, error_symbol, data);
1622 conditions = Fget (real_error_symbol, Qerror_conditions);
1624 /* Remember from where signal was called. Skip over the frame for
1625 `signal' itself. If a frame for `error' follows, skip that,
1626 too. Don't do this when ERROR_SYMBOL is nil, because that
1627 is a memory-full error. */
1628 Vsignaling_function = Qnil;
1629 if (!NILP (error_symbol))
1631 union specbinding *pdl = backtrace_next (backtrace_top ());
1632 if (backtrace_p (pdl) && EQ (backtrace_function (pdl), Qerror))
1633 pdl = backtrace_next (pdl);
1634 if (backtrace_p (pdl))
1635 Vsignaling_function = backtrace_function (pdl);
1638 for (h = handlerlist; h; h = h->next)
1640 if (h->type != CONDITION_CASE)
1641 continue;
1642 clause = find_handler_clause (h->tag_or_ch, conditions);
1643 if (!NILP (clause))
1644 break;
1647 if (/* Don't run the debugger for a memory-full error.
1648 (There is no room in memory to do that!) */
1649 !NILP (error_symbol)
1650 && (!NILP (Vdebug_on_signal)
1651 /* If no handler is present now, try to run the debugger. */
1652 || NILP (clause)
1653 /* A `debug' symbol in the handler list disables the normal
1654 suppression of the debugger. */
1655 || (CONSP (clause) && !NILP (Fmemq (Qdebug, clause)))
1656 /* Special handler that means "print a message and run debugger
1657 if requested". */
1658 || EQ (h->tag_or_ch, Qerror)))
1660 bool debugger_called
1661 = maybe_call_debugger (conditions, error_symbol, data);
1662 /* We can't return values to code which signaled an error, but we
1663 can continue code which has signaled a quit. */
1664 if (keyboard_quit && debugger_called && EQ (real_error_symbol, Qquit))
1665 return Qnil;
1668 if (!NILP (clause))
1670 Lisp_Object unwind_data
1671 = (NILP (error_symbol) ? data : Fcons (error_symbol, data));
1673 unwind_to_catch (h, unwind_data);
1675 else
1677 if (handlerlist != handlerlist_sentinel)
1678 /* FIXME: This will come right back here if there's no `top-level'
1679 catcher. A better solution would be to abort here, and instead
1680 add a catch-all condition handler so we never come here. */
1681 Fthrow (Qtop_level, Qt);
1684 if (! NILP (error_symbol))
1685 data = Fcons (error_symbol, data);
1687 string = Ferror_message_string (data);
1688 fatal ("%s", SDATA (string));
1691 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1693 void
1694 xsignal0 (Lisp_Object error_symbol)
1696 xsignal (error_symbol, Qnil);
1699 void
1700 xsignal1 (Lisp_Object error_symbol, Lisp_Object arg)
1702 xsignal (error_symbol, list1 (arg));
1705 void
1706 xsignal2 (Lisp_Object error_symbol, Lisp_Object arg1, Lisp_Object arg2)
1708 xsignal (error_symbol, list2 (arg1, arg2));
1711 void
1712 xsignal3 (Lisp_Object error_symbol, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3)
1714 xsignal (error_symbol, list3 (arg1, arg2, arg3));
1717 /* Signal `error' with message S, and additional arg ARG.
1718 If ARG is not a genuine list, make it a one-element list. */
1720 void
1721 signal_error (const char *s, Lisp_Object arg)
1723 Lisp_Object tortoise, hare;
1725 hare = tortoise = arg;
1726 while (CONSP (hare))
1728 hare = XCDR (hare);
1729 if (!CONSP (hare))
1730 break;
1732 hare = XCDR (hare);
1733 tortoise = XCDR (tortoise);
1735 if (EQ (hare, tortoise))
1736 break;
1739 if (!NILP (hare))
1740 arg = list1 (arg);
1742 xsignal (Qerror, Fcons (build_string (s), arg));
1746 /* Return true if LIST is a non-nil atom or
1747 a list containing one of CONDITIONS. */
1749 static bool
1750 wants_debugger (Lisp_Object list, Lisp_Object conditions)
1752 if (NILP (list))
1753 return 0;
1754 if (! CONSP (list))
1755 return 1;
1757 while (CONSP (conditions))
1759 Lisp_Object this, tail;
1760 this = XCAR (conditions);
1761 for (tail = list; CONSP (tail); tail = XCDR (tail))
1762 if (EQ (XCAR (tail), this))
1763 return 1;
1764 conditions = XCDR (conditions);
1766 return 0;
1769 /* Return true if an error with condition-symbols CONDITIONS,
1770 and described by SIGNAL-DATA, should skip the debugger
1771 according to debugger-ignored-errors. */
1773 static bool
1774 skip_debugger (Lisp_Object conditions, Lisp_Object data)
1776 Lisp_Object tail;
1777 bool first_string = 1;
1778 Lisp_Object error_message;
1780 error_message = Qnil;
1781 for (tail = Vdebug_ignored_errors; CONSP (tail); tail = XCDR (tail))
1783 if (STRINGP (XCAR (tail)))
1785 if (first_string)
1787 error_message = Ferror_message_string (data);
1788 first_string = 0;
1791 if (fast_string_match (XCAR (tail), error_message) >= 0)
1792 return 1;
1794 else
1796 Lisp_Object contail;
1798 for (contail = conditions; CONSP (contail); contail = XCDR (contail))
1799 if (EQ (XCAR (tail), XCAR (contail)))
1800 return 1;
1804 return 0;
1807 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1808 SIG and DATA describe the signal. There are two ways to pass them:
1809 = SIG is the error symbol, and DATA is the rest of the data.
1810 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1811 This is for memory-full errors only. */
1812 static bool
1813 maybe_call_debugger (Lisp_Object conditions, Lisp_Object sig, Lisp_Object data)
1815 Lisp_Object combined_data;
1817 combined_data = Fcons (sig, data);
1819 if (
1820 /* Don't try to run the debugger with interrupts blocked.
1821 The editing loop would return anyway. */
1822 ! input_blocked_p ()
1823 && NILP (Vinhibit_debugger)
1824 /* Does user want to enter debugger for this kind of error? */
1825 && (EQ (sig, Qquit)
1826 ? debug_on_quit
1827 : wants_debugger (Vdebug_on_error, conditions))
1828 && ! skip_debugger (conditions, combined_data)
1829 /* RMS: What's this for? */
1830 && when_entered_debugger < num_nonmacro_input_events)
1832 call_debugger (list2 (Qerror, combined_data));
1833 return 1;
1836 return 0;
1839 static Lisp_Object
1840 find_handler_clause (Lisp_Object handlers, Lisp_Object conditions)
1842 register Lisp_Object h;
1844 /* t is used by handlers for all conditions, set up by C code. */
1845 if (EQ (handlers, Qt))
1846 return Qt;
1848 /* error is used similarly, but means print an error message
1849 and run the debugger if that is enabled. */
1850 if (EQ (handlers, Qerror))
1851 return Qt;
1853 for (h = handlers; CONSP (h); h = XCDR (h))
1855 Lisp_Object handler = XCAR (h);
1856 if (!NILP (Fmemq (handler, conditions)))
1857 return handlers;
1860 return Qnil;
1864 /* Format and return a string; called like vprintf. */
1865 Lisp_Object
1866 vformat_string (const char *m, va_list ap)
1868 char buf[4000];
1869 ptrdiff_t size = sizeof buf;
1870 ptrdiff_t size_max = STRING_BYTES_BOUND + 1;
1871 char *buffer = buf;
1872 ptrdiff_t used;
1873 Lisp_Object string;
1875 used = evxprintf (&buffer, &size, buf, size_max, m, ap);
1876 string = make_string (buffer, used);
1877 if (buffer != buf)
1878 xfree (buffer);
1880 return string;
1883 /* Dump an error message; called like vprintf. */
1884 void
1885 verror (const char *m, va_list ap)
1887 xsignal1 (Qerror, vformat_string (m, ap));
1891 /* Dump an error message; called like printf. */
1893 /* VARARGS 1 */
1894 void
1895 error (const char *m, ...)
1897 va_list ap;
1898 va_start (ap, m);
1899 verror (m, ap);
1902 DEFUN ("commandp", Fcommandp, Scommandp, 1, 2, 0,
1903 doc: /* Non-nil if FUNCTION makes provisions for interactive calling.
1904 This means it contains a description for how to read arguments to give it.
1905 The value is nil for an invalid function or a symbol with no function
1906 definition.
1908 Interactively callable functions include strings and vectors (treated
1909 as keyboard macros), lambda-expressions that contain a top-level call
1910 to `interactive', autoload definitions made by `autoload' with non-nil
1911 fourth argument, and some of the built-in functions of Lisp.
1913 Also, a symbol satisfies `commandp' if its function definition does so.
1915 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
1916 then strings and vectors are not accepted. */)
1917 (Lisp_Object function, Lisp_Object for_call_interactively)
1919 register Lisp_Object fun;
1920 register Lisp_Object funcar;
1921 Lisp_Object if_prop = Qnil;
1923 fun = function;
1925 fun = indirect_function (fun); /* Check cycles. */
1926 if (NILP (fun))
1927 return Qnil;
1929 /* Check an `interactive-form' property if present, analogous to the
1930 function-documentation property. */
1931 fun = function;
1932 while (SYMBOLP (fun))
1934 Lisp_Object tmp = Fget (fun, Qinteractive_form);
1935 if (!NILP (tmp))
1936 if_prop = Qt;
1937 fun = Fsymbol_function (fun);
1940 /* Emacs primitives are interactive if their DEFUN specifies an
1941 interactive spec. */
1942 if (SUBRP (fun))
1943 return XSUBR (fun)->intspec ? Qt : if_prop;
1945 /* Bytecode objects are interactive if they are long enough to
1946 have an element whose index is COMPILED_INTERACTIVE, which is
1947 where the interactive spec is stored. */
1948 else if (COMPILEDP (fun))
1949 return (PVSIZE (fun) > COMPILED_INTERACTIVE ? Qt : if_prop);
1951 /* Strings and vectors are keyboard macros. */
1952 if (STRINGP (fun) || VECTORP (fun))
1953 return (NILP (for_call_interactively) ? Qt : Qnil);
1955 /* Lists may represent commands. */
1956 if (!CONSP (fun))
1957 return Qnil;
1958 funcar = XCAR (fun);
1959 if (EQ (funcar, Qclosure))
1960 return (!NILP (Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun)))))
1961 ? Qt : if_prop);
1962 else if (EQ (funcar, Qlambda))
1963 return !NILP (Fassq (Qinteractive, Fcdr (XCDR (fun)))) ? Qt : if_prop;
1964 else if (EQ (funcar, Qautoload))
1965 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun))))) ? Qt : if_prop;
1966 else
1967 return Qnil;
1970 DEFUN ("autoload", Fautoload, Sautoload, 2, 5, 0,
1971 doc: /* Define FUNCTION to autoload from FILE.
1972 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
1973 Third arg DOCSTRING is documentation for the function.
1974 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
1975 Fifth arg TYPE indicates the type of the object:
1976 nil or omitted says FUNCTION is a function,
1977 `keymap' says FUNCTION is really a keymap, and
1978 `macro' or t says FUNCTION is really a macro.
1979 Third through fifth args give info about the real definition.
1980 They default to nil.
1981 If FUNCTION is already defined other than as an autoload,
1982 this does nothing and returns nil. */)
1983 (Lisp_Object function, Lisp_Object file, Lisp_Object docstring, Lisp_Object interactive, Lisp_Object type)
1985 CHECK_SYMBOL (function);
1986 CHECK_STRING (file);
1988 /* If function is defined and not as an autoload, don't override. */
1989 if (!NILP (XSYMBOL (function)->u.s.function)
1990 && !AUTOLOADP (XSYMBOL (function)->u.s.function))
1991 return Qnil;
1993 if (!NILP (Vpurify_flag) && EQ (docstring, make_number (0)))
1994 /* `read1' in lread.c has found the docstring starting with "\
1995 and assumed the docstring will be provided by Snarf-documentation, so it
1996 passed us 0 instead. But that leads to accidental sharing in purecopy's
1997 hash-consing, so we use a (hopefully) unique integer instead. */
1998 docstring = make_number (XHASH (function));
1999 return Fdefalias (function,
2000 list5 (Qautoload, file, docstring, interactive, type),
2001 Qnil);
2004 void
2005 un_autoload (Lisp_Object oldqueue)
2007 Lisp_Object queue, first, second;
2009 /* Queue to unwind is current value of Vautoload_queue.
2010 oldqueue is the shadowed value to leave in Vautoload_queue. */
2011 queue = Vautoload_queue;
2012 Vautoload_queue = oldqueue;
2013 while (CONSP (queue))
2015 first = XCAR (queue);
2016 second = Fcdr (first);
2017 first = Fcar (first);
2018 if (EQ (first, make_number (0)))
2019 Vfeatures = second;
2020 else
2021 Ffset (first, second);
2022 queue = XCDR (queue);
2026 /* Load an autoloaded function.
2027 FUNNAME is the symbol which is the function's name.
2028 FUNDEF is the autoload definition (a list). */
2030 DEFUN ("autoload-do-load", Fautoload_do_load, Sautoload_do_load, 1, 3, 0,
2031 doc: /* Load FUNDEF which should be an autoload.
2032 If non-nil, FUNNAME should be the symbol whose function value is FUNDEF,
2033 in which case the function returns the new autoloaded function value.
2034 If equal to `macro', MACRO-ONLY specifies that FUNDEF should only be loaded if
2035 it defines a macro. */)
2036 (Lisp_Object fundef, Lisp_Object funname, Lisp_Object macro_only)
2038 ptrdiff_t count = SPECPDL_INDEX ();
2040 if (!CONSP (fundef) || !EQ (Qautoload, XCAR (fundef)))
2041 return fundef;
2043 Lisp_Object kind = Fnth (make_number (4), fundef);
2044 if (EQ (macro_only, Qmacro)
2045 && !(EQ (kind, Qt) || EQ (kind, Qmacro)))
2046 return fundef;
2048 /* This is to make sure that loadup.el gives a clear picture
2049 of what files are preloaded and when. */
2050 if (! NILP (Vpurify_flag))
2051 error ("Attempt to autoload %s while preparing to dump",
2052 SDATA (SYMBOL_NAME (funname)));
2054 CHECK_SYMBOL (funname);
2056 /* Preserve the match data. */
2057 record_unwind_save_match_data ();
2059 /* If autoloading gets an error (which includes the error of failing
2060 to define the function being called), we use Vautoload_queue
2061 to undo function definitions and `provide' calls made by
2062 the function. We do this in the specific case of autoloading
2063 because autoloading is not an explicit request "load this file",
2064 but rather a request to "call this function".
2066 The value saved here is to be restored into Vautoload_queue. */
2067 record_unwind_protect (un_autoload, Vautoload_queue);
2068 Vautoload_queue = Qt;
2069 /* If `macro_only' is set and fundef isn't a macro, assume this autoload to
2070 be a "best-effort" (e.g. to try and find a compiler macro),
2071 so don't signal an error if autoloading fails. */
2072 Lisp_Object ignore_errors
2073 = (EQ (kind, Qt) || EQ (kind, Qmacro)) ? Qnil : macro_only;
2074 Fload (Fcar (Fcdr (fundef)), ignore_errors, Qt, Qnil, Qt);
2076 /* Once loading finishes, don't undo it. */
2077 Vautoload_queue = Qt;
2078 unbind_to (count, Qnil);
2080 if (NILP (funname) || !NILP (ignore_errors))
2081 return Qnil;
2082 else
2084 Lisp_Object fun = Findirect_function (funname, Qnil);
2086 if (!NILP (Fequal (fun, fundef)))
2087 error ("Autoloading file %s failed to define function %s",
2088 SDATA (Fcar (Fcar (Vload_history))),
2089 SDATA (SYMBOL_NAME (funname)));
2090 else
2091 return fun;
2096 DEFUN ("eval", Feval, Seval, 1, 2, 0,
2097 doc: /* Evaluate FORM and return its value.
2098 If LEXICAL is t, evaluate using lexical scoping.
2099 LEXICAL can also be an actual lexical environment, in the form of an
2100 alist mapping symbols to their value. */)
2101 (Lisp_Object form, Lisp_Object lexical)
2103 ptrdiff_t count = SPECPDL_INDEX ();
2104 specbind (Qinternal_interpreter_environment,
2105 CONSP (lexical) || NILP (lexical) ? lexical : list1 (Qt));
2106 return unbind_to (count, eval_sub (form));
2109 /* Grow the specpdl stack by one entry.
2110 The caller should have already initialized the entry.
2111 Signal an error on stack overflow.
2113 Make sure that there is always one unused entry past the top of the
2114 stack, so that the just-initialized entry is safely unwound if
2115 memory exhausted and an error is signaled here. Also, allocate a
2116 never-used entry just before the bottom of the stack; sometimes its
2117 address is taken. */
2119 static void
2120 grow_specpdl (void)
2122 specpdl_ptr++;
2124 if (specpdl_ptr == specpdl + specpdl_size)
2126 ptrdiff_t count = SPECPDL_INDEX ();
2127 ptrdiff_t max_size = min (max_specpdl_size, PTRDIFF_MAX - 1000);
2128 union specbinding *pdlvec = specpdl - 1;
2129 ptrdiff_t pdlvecsize = specpdl_size + 1;
2130 if (max_size <= specpdl_size)
2132 if (max_specpdl_size < 400)
2133 max_size = max_specpdl_size = 400;
2134 if (max_size <= specpdl_size)
2135 signal_error ("Variable binding depth exceeds max-specpdl-size",
2136 Qnil);
2138 pdlvec = xpalloc (pdlvec, &pdlvecsize, 1, max_size + 1, sizeof *specpdl);
2139 specpdl = pdlvec + 1;
2140 specpdl_size = pdlvecsize - 1;
2141 specpdl_ptr = specpdl + count;
2145 ptrdiff_t
2146 record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs)
2148 ptrdiff_t count = SPECPDL_INDEX ();
2150 eassert (nargs >= UNEVALLED);
2151 specpdl_ptr->bt.kind = SPECPDL_BACKTRACE;
2152 specpdl_ptr->bt.debug_on_exit = false;
2153 specpdl_ptr->bt.function = function;
2154 current_thread->stack_top = specpdl_ptr->bt.args = args;
2155 specpdl_ptr->bt.nargs = nargs;
2156 grow_specpdl ();
2158 return count;
2161 /* Eval a sub-expression of the current expression (i.e. in the same
2162 lexical scope). */
2163 Lisp_Object
2164 eval_sub (Lisp_Object form)
2166 Lisp_Object fun, val, original_fun, original_args;
2167 Lisp_Object funcar;
2168 ptrdiff_t count;
2170 /* Declare here, as this array may be accessed by call_debugger near
2171 the end of this function. See Bug#21245. */
2172 Lisp_Object argvals[8];
2174 if (SYMBOLP (form))
2176 /* Look up its binding in the lexical environment.
2177 We do not pay attention to the declared_special flag here, since we
2178 already did that when let-binding the variable. */
2179 Lisp_Object lex_binding
2180 = !NILP (Vinternal_interpreter_environment) /* Mere optimization! */
2181 ? Fassq (form, Vinternal_interpreter_environment)
2182 : Qnil;
2183 if (CONSP (lex_binding))
2184 return XCDR (lex_binding);
2185 else
2186 return Fsymbol_value (form);
2189 if (!CONSP (form))
2190 return form;
2192 maybe_quit ();
2194 maybe_gc ();
2196 if (++lisp_eval_depth > max_lisp_eval_depth)
2198 if (max_lisp_eval_depth < 100)
2199 max_lisp_eval_depth = 100;
2200 if (lisp_eval_depth > max_lisp_eval_depth)
2201 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2204 original_fun = XCAR (form);
2205 original_args = XCDR (form);
2206 CHECK_LIST (original_args);
2208 /* This also protects them from gc. */
2209 count = record_in_backtrace (original_fun, &original_args, UNEVALLED);
2211 if (debug_on_next_call)
2212 do_debug_on_call (Qt, count);
2214 /* At this point, only original_fun and original_args
2215 have values that will be used below. */
2216 retry:
2218 /* Optimize for no indirection. */
2219 fun = original_fun;
2220 if (!SYMBOLP (fun))
2221 fun = Ffunction (Fcons (fun, Qnil));
2222 else if (!NILP (fun) && (fun = XSYMBOL (fun)->u.s.function, SYMBOLP (fun)))
2223 fun = indirect_function (fun);
2225 if (SUBRP (fun))
2227 Lisp_Object args_left = original_args;
2228 Lisp_Object numargs = Flength (args_left);
2230 check_cons_list ();
2232 if (XINT (numargs) < XSUBR (fun)->min_args
2233 || (XSUBR (fun)->max_args >= 0
2234 && XSUBR (fun)->max_args < XINT (numargs)))
2235 xsignal2 (Qwrong_number_of_arguments, original_fun, numargs);
2237 else if (XSUBR (fun)->max_args == UNEVALLED)
2238 val = (XSUBR (fun)->function.aUNEVALLED) (args_left);
2239 else if (XSUBR (fun)->max_args == MANY)
2241 /* Pass a vector of evaluated arguments. */
2242 Lisp_Object *vals;
2243 ptrdiff_t argnum = 0;
2244 USE_SAFE_ALLOCA;
2246 SAFE_ALLOCA_LISP (vals, XINT (numargs));
2248 while (CONSP (args_left) && argnum < XINT (numargs))
2250 Lisp_Object arg = XCAR (args_left);
2251 args_left = XCDR (args_left);
2252 vals[argnum++] = eval_sub (arg);
2255 set_backtrace_args (specpdl + count, vals, argnum);
2257 val = XSUBR (fun)->function.aMANY (argnum, vals);
2259 check_cons_list ();
2260 lisp_eval_depth--;
2261 /* Do the debug-on-exit now, while VALS still exists. */
2262 if (backtrace_debug_on_exit (specpdl + count))
2263 val = call_debugger (list2 (Qexit, val));
2264 SAFE_FREE ();
2265 specpdl_ptr--;
2266 return val;
2268 else
2270 int i, maxargs = XSUBR (fun)->max_args;
2272 for (i = 0; i < maxargs; i++)
2274 argvals[i] = eval_sub (Fcar (args_left));
2275 args_left = Fcdr (args_left);
2278 set_backtrace_args (specpdl + count, argvals, XINT (numargs));
2280 switch (i)
2282 case 0:
2283 val = (XSUBR (fun)->function.a0 ());
2284 break;
2285 case 1:
2286 val = (XSUBR (fun)->function.a1 (argvals[0]));
2287 break;
2288 case 2:
2289 val = (XSUBR (fun)->function.a2 (argvals[0], argvals[1]));
2290 break;
2291 case 3:
2292 val = (XSUBR (fun)->function.a3
2293 (argvals[0], argvals[1], argvals[2]));
2294 break;
2295 case 4:
2296 val = (XSUBR (fun)->function.a4
2297 (argvals[0], argvals[1], argvals[2], argvals[3]));
2298 break;
2299 case 5:
2300 val = (XSUBR (fun)->function.a5
2301 (argvals[0], argvals[1], argvals[2], argvals[3],
2302 argvals[4]));
2303 break;
2304 case 6:
2305 val = (XSUBR (fun)->function.a6
2306 (argvals[0], argvals[1], argvals[2], argvals[3],
2307 argvals[4], argvals[5]));
2308 break;
2309 case 7:
2310 val = (XSUBR (fun)->function.a7
2311 (argvals[0], argvals[1], argvals[2], argvals[3],
2312 argvals[4], argvals[5], argvals[6]));
2313 break;
2315 case 8:
2316 val = (XSUBR (fun)->function.a8
2317 (argvals[0], argvals[1], argvals[2], argvals[3],
2318 argvals[4], argvals[5], argvals[6], argvals[7]));
2319 break;
2321 default:
2322 /* Someone has created a subr that takes more arguments than
2323 is supported by this code. We need to either rewrite the
2324 subr to use a different argument protocol, or add more
2325 cases to this switch. */
2326 emacs_abort ();
2330 else if (COMPILEDP (fun) || MODULE_FUNCTIONP (fun))
2331 return apply_lambda (fun, original_args, count);
2332 else
2334 if (NILP (fun))
2335 xsignal1 (Qvoid_function, original_fun);
2336 if (!CONSP (fun))
2337 xsignal1 (Qinvalid_function, original_fun);
2338 funcar = XCAR (fun);
2339 if (!SYMBOLP (funcar))
2340 xsignal1 (Qinvalid_function, original_fun);
2341 if (EQ (funcar, Qautoload))
2343 Fautoload_do_load (fun, original_fun, Qnil);
2344 goto retry;
2346 if (EQ (funcar, Qmacro))
2348 ptrdiff_t count1 = SPECPDL_INDEX ();
2349 Lisp_Object exp;
2350 /* Bind lexical-binding during expansion of the macro, so the
2351 macro can know reliably if the code it outputs will be
2352 interpreted using lexical-binding or not. */
2353 specbind (Qlexical_binding,
2354 NILP (Vinternal_interpreter_environment) ? Qnil : Qt);
2355 exp = apply1 (Fcdr (fun), original_args);
2356 unbind_to (count1, Qnil);
2357 val = eval_sub (exp);
2359 else if (EQ (funcar, Qlambda)
2360 || EQ (funcar, Qclosure))
2361 return apply_lambda (fun, original_args, count);
2362 else
2363 xsignal1 (Qinvalid_function, original_fun);
2365 check_cons_list ();
2367 lisp_eval_depth--;
2368 if (backtrace_debug_on_exit (specpdl + count))
2369 val = call_debugger (list2 (Qexit, val));
2370 specpdl_ptr--;
2372 return val;
2375 DEFUN ("apply", Fapply, Sapply, 1, MANY, 0,
2376 doc: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2377 Then return the value FUNCTION returns.
2378 Thus, (apply \\='+ 1 2 \\='(3 4)) returns 10.
2379 usage: (apply FUNCTION &rest ARGUMENTS) */)
2380 (ptrdiff_t nargs, Lisp_Object *args)
2382 ptrdiff_t i, numargs, funcall_nargs;
2383 register Lisp_Object *funcall_args = NULL;
2384 register Lisp_Object spread_arg = args[nargs - 1];
2385 Lisp_Object fun = args[0];
2386 Lisp_Object retval;
2387 USE_SAFE_ALLOCA;
2389 CHECK_LIST (spread_arg);
2391 numargs = XINT (Flength (spread_arg));
2393 if (numargs == 0)
2394 return Ffuncall (nargs - 1, args);
2395 else if (numargs == 1)
2397 args [nargs - 1] = XCAR (spread_arg);
2398 return Ffuncall (nargs, args);
2401 numargs += nargs - 2;
2403 /* Optimize for no indirection. */
2404 if (SYMBOLP (fun) && !NILP (fun)
2405 && (fun = XSYMBOL (fun)->u.s.function, SYMBOLP (fun)))
2407 fun = indirect_function (fun);
2408 if (NILP (fun))
2409 /* Let funcall get the error. */
2410 fun = args[0];
2413 if (SUBRP (fun) && XSUBR (fun)->max_args > numargs
2414 /* Don't hide an error by adding missing arguments. */
2415 && numargs >= XSUBR (fun)->min_args)
2417 /* Avoid making funcall cons up a yet another new vector of arguments
2418 by explicitly supplying nil's for optional values. */
2419 SAFE_ALLOCA_LISP (funcall_args, 1 + XSUBR (fun)->max_args);
2420 memclear (funcall_args + numargs + 1,
2421 (XSUBR (fun)->max_args - numargs) * word_size);
2422 funcall_nargs = 1 + XSUBR (fun)->max_args;
2424 else
2425 { /* We add 1 to numargs because funcall_args includes the
2426 function itself as well as its arguments. */
2427 SAFE_ALLOCA_LISP (funcall_args, 1 + numargs);
2428 funcall_nargs = 1 + numargs;
2431 memcpy (funcall_args, args, nargs * word_size);
2432 /* Spread the last arg we got. Its first element goes in
2433 the slot that it used to occupy, hence this value of I. */
2434 i = nargs - 1;
2435 while (!NILP (spread_arg))
2437 funcall_args [i++] = XCAR (spread_arg);
2438 spread_arg = XCDR (spread_arg);
2441 retval = Ffuncall (funcall_nargs, funcall_args);
2443 SAFE_FREE ();
2444 return retval;
2447 /* Run hook variables in various ways. */
2449 static Lisp_Object
2450 funcall_nil (ptrdiff_t nargs, Lisp_Object *args)
2452 Ffuncall (nargs, args);
2453 return Qnil;
2456 DEFUN ("run-hooks", Frun_hooks, Srun_hooks, 0, MANY, 0,
2457 doc: /* Run each hook in HOOKS.
2458 Each argument should be a symbol, a hook variable.
2459 These symbols are processed in the order specified.
2460 If a hook symbol has a non-nil value, that value may be a function
2461 or a list of functions to be called to run the hook.
2462 If the value is a function, it is called with no arguments.
2463 If it is a list, the elements are called, in order, with no arguments.
2465 Major modes should not use this function directly to run their mode
2466 hook; they should use `run-mode-hooks' instead.
2468 Do not use `make-local-variable' to make a hook variable buffer-local.
2469 Instead, use `add-hook' and specify t for the LOCAL argument.
2470 usage: (run-hooks &rest HOOKS) */)
2471 (ptrdiff_t nargs, Lisp_Object *args)
2473 ptrdiff_t i;
2475 for (i = 0; i < nargs; i++)
2476 run_hook (args[i]);
2478 return Qnil;
2481 DEFUN ("run-hook-with-args", Frun_hook_with_args,
2482 Srun_hook_with_args, 1, MANY, 0,
2483 doc: /* Run HOOK with the specified arguments ARGS.
2484 HOOK should be a symbol, a hook variable. The value of HOOK
2485 may be nil, a function, or a list of functions. Call each
2486 function in order with arguments ARGS. The final return value
2487 is unspecified.
2489 Do not use `make-local-variable' to make a hook variable buffer-local.
2490 Instead, use `add-hook' and specify t for the LOCAL argument.
2491 usage: (run-hook-with-args HOOK &rest ARGS) */)
2492 (ptrdiff_t nargs, Lisp_Object *args)
2494 return run_hook_with_args (nargs, args, funcall_nil);
2497 /* NB this one still documents a specific non-nil return value.
2498 (As did run-hook-with-args and run-hook-with-args-until-failure
2499 until they were changed in 24.1.) */
2500 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success,
2501 Srun_hook_with_args_until_success, 1, MANY, 0,
2502 doc: /* Run HOOK with the specified arguments ARGS.
2503 HOOK should be a symbol, a hook variable. The value of HOOK
2504 may be nil, a function, or a list of functions. Call each
2505 function in order with arguments ARGS, stopping at the first
2506 one that returns non-nil, and return that value. Otherwise (if
2507 all functions return nil, or if there are no functions to call),
2508 return nil.
2510 Do not use `make-local-variable' to make a hook variable buffer-local.
2511 Instead, use `add-hook' and specify t for the LOCAL argument.
2512 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2513 (ptrdiff_t nargs, Lisp_Object *args)
2515 return run_hook_with_args (nargs, args, Ffuncall);
2518 static Lisp_Object
2519 funcall_not (ptrdiff_t nargs, Lisp_Object *args)
2521 return NILP (Ffuncall (nargs, args)) ? Qt : Qnil;
2524 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure,
2525 Srun_hook_with_args_until_failure, 1, MANY, 0,
2526 doc: /* Run HOOK with the specified arguments ARGS.
2527 HOOK should be a symbol, a hook variable. The value of HOOK
2528 may be nil, a function, or a list of functions. Call each
2529 function in order with arguments ARGS, stopping at the first
2530 one that returns nil, and return nil. Otherwise (if all functions
2531 return non-nil, or if there are no functions to call), return non-nil
2532 \(do not rely on the precise return value in this case).
2534 Do not use `make-local-variable' to make a hook variable buffer-local.
2535 Instead, use `add-hook' and specify t for the LOCAL argument.
2536 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2537 (ptrdiff_t nargs, Lisp_Object *args)
2539 return NILP (run_hook_with_args (nargs, args, funcall_not)) ? Qt : Qnil;
2542 static Lisp_Object
2543 run_hook_wrapped_funcall (ptrdiff_t nargs, Lisp_Object *args)
2545 Lisp_Object tmp = args[0], ret;
2546 args[0] = args[1];
2547 args[1] = tmp;
2548 ret = Ffuncall (nargs, args);
2549 args[1] = args[0];
2550 args[0] = tmp;
2551 return ret;
2554 DEFUN ("run-hook-wrapped", Frun_hook_wrapped, Srun_hook_wrapped, 2, MANY, 0,
2555 doc: /* Run HOOK, passing each function through WRAP-FUNCTION.
2556 I.e. instead of calling each function FUN directly with arguments ARGS,
2557 it calls WRAP-FUNCTION with arguments FUN and ARGS.
2558 As soon as a call to WRAP-FUNCTION returns non-nil, `run-hook-wrapped'
2559 aborts and returns that value.
2560 usage: (run-hook-wrapped HOOK WRAP-FUNCTION &rest ARGS) */)
2561 (ptrdiff_t nargs, Lisp_Object *args)
2563 return run_hook_with_args (nargs, args, run_hook_wrapped_funcall);
2566 /* ARGS[0] should be a hook symbol.
2567 Call each of the functions in the hook value, passing each of them
2568 as arguments all the rest of ARGS (all NARGS - 1 elements).
2569 FUNCALL specifies how to call each function on the hook. */
2571 Lisp_Object
2572 run_hook_with_args (ptrdiff_t nargs, Lisp_Object *args,
2573 Lisp_Object (*funcall) (ptrdiff_t nargs, Lisp_Object *args))
2575 Lisp_Object sym, val, ret = Qnil;
2577 /* If we are dying or still initializing,
2578 don't do anything--it would probably crash if we tried. */
2579 if (NILP (Vrun_hooks))
2580 return Qnil;
2582 sym = args[0];
2583 val = find_symbol_value (sym);
2585 if (EQ (val, Qunbound) || NILP (val))
2586 return ret;
2587 else if (!CONSP (val) || FUNCTIONP (val))
2589 args[0] = val;
2590 return funcall (nargs, args);
2592 else
2594 Lisp_Object global_vals = Qnil;
2596 for (;
2597 CONSP (val) && NILP (ret);
2598 val = XCDR (val))
2600 if (EQ (XCAR (val), Qt))
2602 /* t indicates this hook has a local binding;
2603 it means to run the global binding too. */
2604 global_vals = Fdefault_value (sym);
2605 if (NILP (global_vals)) continue;
2607 if (!CONSP (global_vals) || EQ (XCAR (global_vals), Qlambda))
2609 args[0] = global_vals;
2610 ret = funcall (nargs, args);
2612 else
2614 for (;
2615 CONSP (global_vals) && NILP (ret);
2616 global_vals = XCDR (global_vals))
2618 args[0] = XCAR (global_vals);
2619 /* In a global value, t should not occur. If it does, we
2620 must ignore it to avoid an endless loop. */
2621 if (!EQ (args[0], Qt))
2622 ret = funcall (nargs, args);
2626 else
2628 args[0] = XCAR (val);
2629 ret = funcall (nargs, args);
2633 return ret;
2637 /* Run the hook HOOK, giving each function no args. */
2639 void
2640 run_hook (Lisp_Object hook)
2642 Frun_hook_with_args (1, &hook);
2645 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2647 void
2648 run_hook_with_args_2 (Lisp_Object hook, Lisp_Object arg1, Lisp_Object arg2)
2650 CALLN (Frun_hook_with_args, hook, arg1, arg2);
2653 /* Apply fn to arg. */
2654 Lisp_Object
2655 apply1 (Lisp_Object fn, Lisp_Object arg)
2657 return NILP (arg) ? Ffuncall (1, &fn) : CALLN (Fapply, fn, arg);
2660 /* Call function fn on no arguments. */
2661 Lisp_Object
2662 call0 (Lisp_Object fn)
2664 return Ffuncall (1, &fn);
2667 /* Call function fn with 1 argument arg1. */
2668 /* ARGSUSED */
2669 Lisp_Object
2670 call1 (Lisp_Object fn, Lisp_Object arg1)
2672 return CALLN (Ffuncall, fn, arg1);
2675 /* Call function fn with 2 arguments arg1, arg2. */
2676 /* ARGSUSED */
2677 Lisp_Object
2678 call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2)
2680 return CALLN (Ffuncall, fn, arg1, arg2);
2683 /* Call function fn with 3 arguments arg1, arg2, arg3. */
2684 /* ARGSUSED */
2685 Lisp_Object
2686 call3 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3)
2688 return CALLN (Ffuncall, fn, arg1, arg2, arg3);
2691 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
2692 /* ARGSUSED */
2693 Lisp_Object
2694 call4 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
2695 Lisp_Object arg4)
2697 return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4);
2700 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
2701 /* ARGSUSED */
2702 Lisp_Object
2703 call5 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
2704 Lisp_Object arg4, Lisp_Object arg5)
2706 return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5);
2709 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
2710 /* ARGSUSED */
2711 Lisp_Object
2712 call6 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
2713 Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6)
2715 return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6);
2718 /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
2719 /* ARGSUSED */
2720 Lisp_Object
2721 call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
2722 Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6, Lisp_Object arg7)
2724 return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6, arg7);
2727 /* Call function fn with 8 arguments arg1, arg2, arg3, arg4, arg5,
2728 arg6, arg7, arg8. */
2729 /* ARGSUSED */
2730 Lisp_Object
2731 call8 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
2732 Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6, Lisp_Object arg7,
2733 Lisp_Object arg8)
2735 return CALLN (Ffuncall, fn, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8);
2738 DEFUN ("functionp", Ffunctionp, Sfunctionp, 1, 1, 0,
2739 doc: /* Return t if OBJECT is a function. */)
2740 (Lisp_Object object)
2742 if (FUNCTIONP (object))
2743 return Qt;
2744 return Qnil;
2747 bool
2748 FUNCTIONP (Lisp_Object object)
2750 if (SYMBOLP (object) && !NILP (Ffboundp (object)))
2752 object = Findirect_function (object, Qt);
2754 if (CONSP (object) && EQ (XCAR (object), Qautoload))
2756 /* Autoloaded symbols are functions, except if they load
2757 macros or keymaps. */
2758 for (int i = 0; i < 4 && CONSP (object); i++)
2759 object = XCDR (object);
2761 return ! (CONSP (object) && !NILP (XCAR (object)));
2765 if (SUBRP (object))
2766 return XSUBR (object)->max_args != UNEVALLED;
2767 else if (COMPILEDP (object) || MODULE_FUNCTIONP (object))
2768 return true;
2769 else if (CONSP (object))
2771 Lisp_Object car = XCAR (object);
2772 return EQ (car, Qlambda) || EQ (car, Qclosure);
2774 else
2775 return false;
2778 DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0,
2779 doc: /* Call first argument as a function, passing remaining arguments to it.
2780 Return the value that function returns.
2781 Thus, (funcall \\='cons \\='x \\='y) returns (x . y).
2782 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2783 (ptrdiff_t nargs, Lisp_Object *args)
2785 Lisp_Object fun, original_fun;
2786 Lisp_Object funcar;
2787 ptrdiff_t numargs = nargs - 1;
2788 Lisp_Object val;
2789 ptrdiff_t count;
2791 maybe_quit ();
2793 if (++lisp_eval_depth > max_lisp_eval_depth)
2795 if (max_lisp_eval_depth < 100)
2796 max_lisp_eval_depth = 100;
2797 if (lisp_eval_depth > max_lisp_eval_depth)
2798 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2801 count = record_in_backtrace (args[0], &args[1], nargs - 1);
2803 maybe_gc ();
2805 if (debug_on_next_call)
2806 do_debug_on_call (Qlambda, count);
2808 check_cons_list ();
2810 original_fun = args[0];
2812 retry:
2814 /* Optimize for no indirection. */
2815 fun = original_fun;
2816 if (SYMBOLP (fun) && !NILP (fun)
2817 && (fun = XSYMBOL (fun)->u.s.function, SYMBOLP (fun)))
2818 fun = indirect_function (fun);
2820 if (SUBRP (fun))
2821 val = funcall_subr (XSUBR (fun), numargs, args + 1);
2822 else if (COMPILEDP (fun) || MODULE_FUNCTIONP (fun))
2823 val = funcall_lambda (fun, numargs, args + 1);
2824 else
2826 if (NILP (fun))
2827 xsignal1 (Qvoid_function, original_fun);
2828 if (!CONSP (fun))
2829 xsignal1 (Qinvalid_function, original_fun);
2830 funcar = XCAR (fun);
2831 if (!SYMBOLP (funcar))
2832 xsignal1 (Qinvalid_function, original_fun);
2833 if (EQ (funcar, Qlambda)
2834 || EQ (funcar, Qclosure))
2835 val = funcall_lambda (fun, numargs, args + 1);
2836 else if (EQ (funcar, Qautoload))
2838 Fautoload_do_load (fun, original_fun, Qnil);
2839 check_cons_list ();
2840 goto retry;
2842 else
2843 xsignal1 (Qinvalid_function, original_fun);
2845 check_cons_list ();
2846 lisp_eval_depth--;
2847 if (backtrace_debug_on_exit (specpdl + count))
2848 val = call_debugger (list2 (Qexit, val));
2849 specpdl_ptr--;
2850 return val;
2854 /* Apply a C subroutine SUBR to the NUMARGS evaluated arguments in ARG_VECTOR
2855 and return the result of evaluation. */
2857 Lisp_Object
2858 funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *args)
2860 if (numargs < subr->min_args
2861 || (subr->max_args >= 0 && subr->max_args < numargs))
2863 Lisp_Object fun;
2864 XSETSUBR (fun, subr);
2865 xsignal2 (Qwrong_number_of_arguments, fun, make_number (numargs));
2868 else if (subr->max_args == UNEVALLED)
2870 Lisp_Object fun;
2871 XSETSUBR (fun, subr);
2872 xsignal1 (Qinvalid_function, fun);
2875 else if (subr->max_args == MANY)
2876 return (subr->function.aMANY) (numargs, args);
2877 else
2879 Lisp_Object internal_argbuf[8];
2880 Lisp_Object *internal_args;
2881 if (subr->max_args > numargs)
2883 eassert (subr->max_args <= ARRAYELTS (internal_argbuf));
2884 internal_args = internal_argbuf;
2885 memcpy (internal_args, args, numargs * word_size);
2886 memclear (internal_args + numargs,
2887 (subr->max_args - numargs) * word_size);
2889 else
2890 internal_args = args;
2891 switch (subr->max_args)
2893 case 0:
2894 return (subr->function.a0 ());
2895 case 1:
2896 return (subr->function.a1 (internal_args[0]));
2897 case 2:
2898 return (subr->function.a2
2899 (internal_args[0], internal_args[1]));
2900 case 3:
2901 return (subr->function.a3
2902 (internal_args[0], internal_args[1], internal_args[2]));
2903 case 4:
2904 return (subr->function.a4
2905 (internal_args[0], internal_args[1], internal_args[2],
2906 internal_args[3]));
2907 case 5:
2908 return (subr->function.a5
2909 (internal_args[0], internal_args[1], internal_args[2],
2910 internal_args[3], internal_args[4]));
2911 case 6:
2912 return (subr->function.a6
2913 (internal_args[0], internal_args[1], internal_args[2],
2914 internal_args[3], internal_args[4], internal_args[5]));
2915 case 7:
2916 return (subr->function.a7
2917 (internal_args[0], internal_args[1], internal_args[2],
2918 internal_args[3], internal_args[4], internal_args[5],
2919 internal_args[6]));
2920 case 8:
2921 return (subr->function.a8
2922 (internal_args[0], internal_args[1], internal_args[2],
2923 internal_args[3], internal_args[4], internal_args[5],
2924 internal_args[6], internal_args[7]));
2926 default:
2928 /* If a subr takes more than 8 arguments without using MANY
2929 or UNEVALLED, we need to extend this function to support it.
2930 Until this is done, there is no way to call the function. */
2931 emacs_abort ();
2936 static Lisp_Object
2937 apply_lambda (Lisp_Object fun, Lisp_Object args, ptrdiff_t count)
2939 Lisp_Object args_left;
2940 ptrdiff_t i;
2941 EMACS_INT numargs;
2942 Lisp_Object *arg_vector;
2943 Lisp_Object tem;
2944 USE_SAFE_ALLOCA;
2946 numargs = XFASTINT (Flength (args));
2947 SAFE_ALLOCA_LISP (arg_vector, numargs);
2948 args_left = args;
2950 for (i = 0; i < numargs; )
2952 tem = Fcar (args_left), args_left = Fcdr (args_left);
2953 tem = eval_sub (tem);
2954 arg_vector[i++] = tem;
2957 set_backtrace_args (specpdl + count, arg_vector, i);
2958 tem = funcall_lambda (fun, numargs, arg_vector);
2960 check_cons_list ();
2961 lisp_eval_depth--;
2962 /* Do the debug-on-exit now, while arg_vector still exists. */
2963 if (backtrace_debug_on_exit (specpdl + count))
2964 tem = call_debugger (list2 (Qexit, tem));
2965 SAFE_FREE ();
2966 specpdl_ptr--;
2967 return tem;
2970 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2971 and return the result of evaluation.
2972 FUN must be either a lambda-expression, a compiled-code object,
2973 or a module function. */
2975 static Lisp_Object
2976 funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
2977 register Lisp_Object *arg_vector)
2979 Lisp_Object val, syms_left, next, lexenv;
2980 ptrdiff_t count = SPECPDL_INDEX ();
2981 ptrdiff_t i;
2982 bool optional, rest;
2984 if (CONSP (fun))
2986 if (EQ (XCAR (fun), Qclosure))
2988 Lisp_Object cdr = XCDR (fun); /* Drop `closure'. */
2989 if (! CONSP (cdr))
2990 xsignal1 (Qinvalid_function, fun);
2991 fun = cdr;
2992 lexenv = XCAR (fun);
2994 else
2995 lexenv = Qnil;
2996 syms_left = XCDR (fun);
2997 if (CONSP (syms_left))
2998 syms_left = XCAR (syms_left);
2999 else
3000 xsignal1 (Qinvalid_function, fun);
3002 else if (COMPILEDP (fun))
3004 ptrdiff_t size = PVSIZE (fun);
3005 if (size <= COMPILED_STACK_DEPTH)
3006 xsignal1 (Qinvalid_function, fun);
3007 syms_left = AREF (fun, COMPILED_ARGLIST);
3008 if (INTEGERP (syms_left))
3009 /* A byte-code object with an integer args template means we
3010 shouldn't bind any arguments, instead just call the byte-code
3011 interpreter directly; it will push arguments as necessary.
3013 Byte-code objects with a nil args template (the default)
3014 have dynamically-bound arguments, and use the
3015 argument-binding code below instead (as do all interpreted
3016 functions, even lexically bound ones). */
3018 /* If we have not actually read the bytecode string
3019 and constants vector yet, fetch them from the file. */
3020 if (CONSP (AREF (fun, COMPILED_BYTECODE)))
3021 Ffetch_bytecode (fun);
3022 return exec_byte_code (AREF (fun, COMPILED_BYTECODE),
3023 AREF (fun, COMPILED_CONSTANTS),
3024 AREF (fun, COMPILED_STACK_DEPTH),
3025 syms_left,
3026 nargs, arg_vector);
3028 lexenv = Qnil;
3030 #ifdef HAVE_MODULES
3031 else if (MODULE_FUNCTIONP (fun))
3032 return funcall_module (fun, nargs, arg_vector);
3033 #endif
3034 else
3035 emacs_abort ();
3037 i = optional = rest = 0;
3038 bool previous_optional_or_rest = false;
3039 for (; CONSP (syms_left); syms_left = XCDR (syms_left))
3041 maybe_quit ();
3043 next = XCAR (syms_left);
3044 if (!SYMBOLP (next))
3045 xsignal1 (Qinvalid_function, fun);
3047 if (EQ (next, Qand_rest))
3049 if (rest || previous_optional_or_rest)
3050 xsignal1 (Qinvalid_function, fun);
3051 rest = 1;
3052 previous_optional_or_rest = true;
3054 else if (EQ (next, Qand_optional))
3056 if (optional || rest || previous_optional_or_rest)
3057 xsignal1 (Qinvalid_function, fun);
3058 optional = 1;
3059 previous_optional_or_rest = true;
3061 else
3063 Lisp_Object arg;
3064 if (rest)
3066 arg = Flist (nargs - i, &arg_vector[i]);
3067 i = nargs;
3069 else if (i < nargs)
3070 arg = arg_vector[i++];
3071 else if (!optional)
3072 xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs));
3073 else
3074 arg = Qnil;
3076 /* Bind the argument. */
3077 if (!NILP (lexenv) && SYMBOLP (next))
3078 /* Lexically bind NEXT by adding it to the lexenv alist. */
3079 lexenv = Fcons (Fcons (next, arg), lexenv);
3080 else
3081 /* Dynamically bind NEXT. */
3082 specbind (next, arg);
3083 previous_optional_or_rest = false;
3087 if (!NILP (syms_left) || previous_optional_or_rest)
3088 xsignal1 (Qinvalid_function, fun);
3089 else if (i < nargs)
3090 xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs));
3092 if (!EQ (lexenv, Vinternal_interpreter_environment))
3093 /* Instantiate a new lexical environment. */
3094 specbind (Qinternal_interpreter_environment, lexenv);
3096 if (CONSP (fun))
3097 val = Fprogn (XCDR (XCDR (fun)));
3098 else
3100 /* If we have not actually read the bytecode string
3101 and constants vector yet, fetch them from the file. */
3102 if (CONSP (AREF (fun, COMPILED_BYTECODE)))
3103 Ffetch_bytecode (fun);
3104 val = exec_byte_code (AREF (fun, COMPILED_BYTECODE),
3105 AREF (fun, COMPILED_CONSTANTS),
3106 AREF (fun, COMPILED_STACK_DEPTH),
3107 Qnil, 0, 0);
3110 return unbind_to (count, val);
3113 DEFUN ("func-arity", Ffunc_arity, Sfunc_arity, 1, 1, 0,
3114 doc: /* Return minimum and maximum number of args allowed for FUNCTION.
3115 FUNCTION must be a function of some kind.
3116 The returned value is a cons cell (MIN . MAX). MIN is the minimum number
3117 of args. MAX is the maximum number, or the symbol `many', for a
3118 function with `&rest' args, or `unevalled' for a special form. */)
3119 (Lisp_Object function)
3121 Lisp_Object original;
3122 Lisp_Object funcar;
3123 Lisp_Object result;
3125 original = function;
3127 retry:
3129 /* Optimize for no indirection. */
3130 function = original;
3131 if (SYMBOLP (function) && !NILP (function))
3133 function = XSYMBOL (function)->u.s.function;
3134 if (SYMBOLP (function))
3135 function = indirect_function (function);
3138 if (CONSP (function) && EQ (XCAR (function), Qmacro))
3139 function = XCDR (function);
3141 if (SUBRP (function))
3142 result = Fsubr_arity (function);
3143 else if (COMPILEDP (function))
3144 result = lambda_arity (function);
3145 #ifdef HAVE_MODULES
3146 else if (MODULE_FUNCTIONP (function))
3147 result = module_function_arity (XMODULE_FUNCTION (function));
3148 #endif
3149 else
3151 if (NILP (function))
3152 xsignal1 (Qvoid_function, original);
3153 if (!CONSP (function))
3154 xsignal1 (Qinvalid_function, original);
3155 funcar = XCAR (function);
3156 if (!SYMBOLP (funcar))
3157 xsignal1 (Qinvalid_function, original);
3158 if (EQ (funcar, Qlambda)
3159 || EQ (funcar, Qclosure))
3160 result = lambda_arity (function);
3161 else if (EQ (funcar, Qautoload))
3163 Fautoload_do_load (function, original, Qnil);
3164 goto retry;
3166 else
3167 xsignal1 (Qinvalid_function, original);
3169 return result;
3172 /* FUN must be either a lambda-expression or a compiled-code object. */
3173 static Lisp_Object
3174 lambda_arity (Lisp_Object fun)
3176 Lisp_Object syms_left;
3178 if (CONSP (fun))
3180 if (EQ (XCAR (fun), Qclosure))
3182 fun = XCDR (fun); /* Drop `closure'. */
3183 CHECK_CONS (fun);
3185 syms_left = XCDR (fun);
3186 if (CONSP (syms_left))
3187 syms_left = XCAR (syms_left);
3188 else
3189 xsignal1 (Qinvalid_function, fun);
3191 else if (COMPILEDP (fun))
3193 ptrdiff_t size = PVSIZE (fun);
3194 if (size <= COMPILED_STACK_DEPTH)
3195 xsignal1 (Qinvalid_function, fun);
3196 syms_left = AREF (fun, COMPILED_ARGLIST);
3197 if (INTEGERP (syms_left))
3198 return get_byte_code_arity (syms_left);
3200 else
3201 emacs_abort ();
3203 EMACS_INT minargs = 0, maxargs = 0;
3204 bool optional = false;
3205 for (; CONSP (syms_left); syms_left = XCDR (syms_left))
3207 Lisp_Object next = XCAR (syms_left);
3208 if (!SYMBOLP (next))
3209 xsignal1 (Qinvalid_function, fun);
3211 if (EQ (next, Qand_rest))
3212 return Fcons (make_number (minargs), Qmany);
3213 else if (EQ (next, Qand_optional))
3214 optional = true;
3215 else
3217 if (!optional)
3218 minargs++;
3219 maxargs++;
3223 if (!NILP (syms_left))
3224 xsignal1 (Qinvalid_function, fun);
3226 return Fcons (make_number (minargs), make_number (maxargs));
3229 DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode,
3230 1, 1, 0,
3231 doc: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3232 (Lisp_Object object)
3234 Lisp_Object tem;
3236 if (COMPILEDP (object))
3238 ptrdiff_t size = PVSIZE (object);
3239 if (size <= COMPILED_STACK_DEPTH)
3240 xsignal1 (Qinvalid_function, object);
3241 if (CONSP (AREF (object, COMPILED_BYTECODE)))
3243 tem = read_doc_string (AREF (object, COMPILED_BYTECODE));
3244 if (!CONSP (tem))
3246 tem = AREF (object, COMPILED_BYTECODE);
3247 if (CONSP (tem) && STRINGP (XCAR (tem)))
3248 error ("Invalid byte code in %s", SDATA (XCAR (tem)));
3249 else
3250 error ("Invalid byte code");
3252 ASET (object, COMPILED_BYTECODE, XCAR (tem));
3253 ASET (object, COMPILED_CONSTANTS, XCDR (tem));
3256 return object;
3259 /* Return true if SYMBOL currently has a let-binding
3260 which was made in the buffer that is now current. */
3262 bool
3263 let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol)
3265 union specbinding *p;
3266 Lisp_Object buf = Fcurrent_buffer ();
3268 for (p = specpdl_ptr; p > specpdl; )
3269 if ((--p)->kind > SPECPDL_LET)
3271 struct Lisp_Symbol *let_bound_symbol = XSYMBOL (specpdl_symbol (p));
3272 eassert (let_bound_symbol->u.s.redirect != SYMBOL_VARALIAS);
3273 if (symbol == let_bound_symbol
3274 && EQ (specpdl_where (p), buf))
3275 return 1;
3278 return 0;
3281 static void
3282 do_specbind (struct Lisp_Symbol *sym, union specbinding *bind,
3283 Lisp_Object value, enum Set_Internal_Bind bindflag)
3285 switch (sym->u.s.redirect)
3287 case SYMBOL_PLAINVAL:
3288 if (!sym->u.s.trapped_write)
3289 SET_SYMBOL_VAL (sym, value);
3290 else
3291 set_internal (specpdl_symbol (bind), value, Qnil, bindflag);
3292 break;
3294 case SYMBOL_FORWARDED:
3295 if (BUFFER_OBJFWDP (SYMBOL_FWD (sym))
3296 && specpdl_kind (bind) == SPECPDL_LET_DEFAULT)
3298 set_default_internal (specpdl_symbol (bind), value, bindflag);
3299 return;
3301 FALLTHROUGH;
3302 case SYMBOL_LOCALIZED:
3303 set_internal (specpdl_symbol (bind), value, Qnil, bindflag);
3304 break;
3306 default:
3307 emacs_abort ();
3311 /* `specpdl_ptr' describes which variable is
3312 let-bound, so it can be properly undone when we unbind_to.
3313 It can be either a plain SPECPDL_LET or a SPECPDL_LET_LOCAL/DEFAULT.
3314 - SYMBOL is the variable being bound. Note that it should not be
3315 aliased (i.e. when let-binding V1 that's aliased to V2, we want
3316 to record V2 here).
3317 - WHERE tells us in which buffer the binding took place.
3318 This is used for SPECPDL_LET_LOCAL bindings (i.e. bindings to a
3319 buffer-local variable) as well as for SPECPDL_LET_DEFAULT bindings,
3320 i.e. bindings to the default value of a variable which can be
3321 buffer-local. */
3323 void
3324 specbind (Lisp_Object symbol, Lisp_Object value)
3326 struct Lisp_Symbol *sym;
3328 CHECK_SYMBOL (symbol);
3329 sym = XSYMBOL (symbol);
3331 start:
3332 switch (sym->u.s.redirect)
3334 case SYMBOL_VARALIAS:
3335 sym = indirect_variable (sym); XSETSYMBOL (symbol, sym); goto start;
3336 case SYMBOL_PLAINVAL:
3337 /* The most common case is that of a non-constant symbol with a
3338 trivial value. Make that as fast as we can. */
3339 specpdl_ptr->let.kind = SPECPDL_LET;
3340 specpdl_ptr->let.symbol = symbol;
3341 specpdl_ptr->let.old_value = SYMBOL_VAL (sym);
3342 specpdl_ptr->let.saved_value = Qnil;
3343 grow_specpdl ();
3344 do_specbind (sym, specpdl_ptr - 1, value, SET_INTERNAL_BIND);
3345 break;
3346 case SYMBOL_LOCALIZED:
3347 case SYMBOL_FORWARDED:
3349 Lisp_Object ovalue = find_symbol_value (symbol);
3350 specpdl_ptr->let.kind = SPECPDL_LET_LOCAL;
3351 specpdl_ptr->let.symbol = symbol;
3352 specpdl_ptr->let.old_value = ovalue;
3353 specpdl_ptr->let.where = Fcurrent_buffer ();
3354 specpdl_ptr->let.saved_value = Qnil;
3356 eassert (sym->u.s.redirect != SYMBOL_LOCALIZED
3357 || (EQ (SYMBOL_BLV (sym)->where, Fcurrent_buffer ())));
3359 if (sym->u.s.redirect == SYMBOL_LOCALIZED)
3361 if (!blv_found (SYMBOL_BLV (sym)))
3362 specpdl_ptr->let.kind = SPECPDL_LET_DEFAULT;
3364 else if (BUFFER_OBJFWDP (SYMBOL_FWD (sym)))
3366 /* If SYMBOL is a per-buffer variable which doesn't have a
3367 buffer-local value here, make the `let' change the global
3368 value by changing the value of SYMBOL in all buffers not
3369 having their own value. This is consistent with what
3370 happens with other buffer-local variables. */
3371 if (NILP (Flocal_variable_p (symbol, Qnil)))
3373 specpdl_ptr->let.kind = SPECPDL_LET_DEFAULT;
3374 grow_specpdl ();
3375 do_specbind (sym, specpdl_ptr - 1, value, SET_INTERNAL_BIND);
3376 return;
3379 else
3380 specpdl_ptr->let.kind = SPECPDL_LET;
3382 grow_specpdl ();
3383 do_specbind (sym, specpdl_ptr - 1, value, SET_INTERNAL_BIND);
3384 break;
3386 default: emacs_abort ();
3390 /* Push unwind-protect entries of various types. */
3392 void
3393 record_unwind_protect (void (*function) (Lisp_Object), Lisp_Object arg)
3395 specpdl_ptr->unwind.kind = SPECPDL_UNWIND;
3396 specpdl_ptr->unwind.func = function;
3397 specpdl_ptr->unwind.arg = arg;
3398 grow_specpdl ();
3401 void
3402 record_unwind_protect_ptr (void (*function) (void *), void *arg)
3404 specpdl_ptr->unwind_ptr.kind = SPECPDL_UNWIND_PTR;
3405 specpdl_ptr->unwind_ptr.func = function;
3406 specpdl_ptr->unwind_ptr.arg = arg;
3407 grow_specpdl ();
3410 void
3411 record_unwind_protect_int (void (*function) (int), int arg)
3413 specpdl_ptr->unwind_int.kind = SPECPDL_UNWIND_INT;
3414 specpdl_ptr->unwind_int.func = function;
3415 specpdl_ptr->unwind_int.arg = arg;
3416 grow_specpdl ();
3419 void
3420 record_unwind_protect_void (void (*function) (void))
3422 specpdl_ptr->unwind_void.kind = SPECPDL_UNWIND_VOID;
3423 specpdl_ptr->unwind_void.func = function;
3424 grow_specpdl ();
3427 void
3428 rebind_for_thread_switch (void)
3430 union specbinding *bind;
3432 for (bind = specpdl; bind != specpdl_ptr; ++bind)
3434 if (bind->kind >= SPECPDL_LET)
3436 Lisp_Object value = specpdl_saved_value (bind);
3437 Lisp_Object sym = specpdl_symbol (bind);
3438 bind->let.saved_value = Qnil;
3439 do_specbind (XSYMBOL (sym), bind, value,
3440 SET_INTERNAL_THREAD_SWITCH);
3445 static void
3446 do_one_unbind (union specbinding *this_binding, bool unwinding,
3447 enum Set_Internal_Bind bindflag)
3449 eassert (unwinding || this_binding->kind >= SPECPDL_LET);
3450 switch (this_binding->kind)
3452 case SPECPDL_UNWIND:
3453 this_binding->unwind.func (this_binding->unwind.arg);
3454 break;
3455 case SPECPDL_UNWIND_PTR:
3456 this_binding->unwind_ptr.func (this_binding->unwind_ptr.arg);
3457 break;
3458 case SPECPDL_UNWIND_INT:
3459 this_binding->unwind_int.func (this_binding->unwind_int.arg);
3460 break;
3461 case SPECPDL_UNWIND_VOID:
3462 this_binding->unwind_void.func ();
3463 break;
3464 case SPECPDL_BACKTRACE:
3465 break;
3466 case SPECPDL_LET:
3467 { /* If variable has a trivial value (no forwarding), and isn't
3468 trapped, we can just set it. */
3469 Lisp_Object sym = specpdl_symbol (this_binding);
3470 if (SYMBOLP (sym) && XSYMBOL (sym)->u.s.redirect == SYMBOL_PLAINVAL)
3472 if (XSYMBOL (sym)->u.s.trapped_write == SYMBOL_UNTRAPPED_WRITE)
3473 SET_SYMBOL_VAL (XSYMBOL (sym), specpdl_old_value (this_binding));
3474 else
3475 set_internal (sym, specpdl_old_value (this_binding),
3476 Qnil, bindflag);
3477 break;
3480 /* Come here only if make_local_foo was used for the first time
3481 on this var within this let. */
3482 FALLTHROUGH;
3483 case SPECPDL_LET_DEFAULT:
3484 set_default_internal (specpdl_symbol (this_binding),
3485 specpdl_old_value (this_binding),
3486 bindflag);
3487 break;
3488 case SPECPDL_LET_LOCAL:
3490 Lisp_Object symbol = specpdl_symbol (this_binding);
3491 Lisp_Object where = specpdl_where (this_binding);
3492 Lisp_Object old_value = specpdl_old_value (this_binding);
3493 eassert (BUFFERP (where));
3495 /* If this was a local binding, reset the value in the appropriate
3496 buffer, but only if that buffer's binding still exists. */
3497 if (!NILP (Flocal_variable_p (symbol, where)))
3498 set_internal (symbol, old_value, where, bindflag);
3500 break;
3504 static void
3505 do_nothing (void)
3508 /* Push an unwind-protect entry that does nothing, so that
3509 set_unwind_protect_ptr can overwrite it later. */
3511 void
3512 record_unwind_protect_nothing (void)
3514 record_unwind_protect_void (do_nothing);
3517 /* Clear the unwind-protect entry COUNT, so that it does nothing.
3518 It need not be at the top of the stack. */
3520 void
3521 clear_unwind_protect (ptrdiff_t count)
3523 union specbinding *p = specpdl + count;
3524 p->unwind_void.kind = SPECPDL_UNWIND_VOID;
3525 p->unwind_void.func = do_nothing;
3528 /* Set the unwind-protect entry COUNT so that it invokes FUNC (ARG).
3529 It need not be at the top of the stack. Discard the entry's
3530 previous value without invoking it. */
3532 void
3533 set_unwind_protect (ptrdiff_t count, void (*func) (Lisp_Object),
3534 Lisp_Object arg)
3536 union specbinding *p = specpdl + count;
3537 p->unwind.kind = SPECPDL_UNWIND;
3538 p->unwind.func = func;
3539 p->unwind.arg = arg;
3542 void
3543 set_unwind_protect_ptr (ptrdiff_t count, void (*func) (void *), void *arg)
3545 union specbinding *p = specpdl + count;
3546 p->unwind_ptr.kind = SPECPDL_UNWIND_PTR;
3547 p->unwind_ptr.func = func;
3548 p->unwind_ptr.arg = arg;
3551 /* Pop and execute entries from the unwind-protect stack until the
3552 depth COUNT is reached. Return VALUE. */
3554 Lisp_Object
3555 unbind_to (ptrdiff_t count, Lisp_Object value)
3557 Lisp_Object quitf = Vquit_flag;
3559 Vquit_flag = Qnil;
3561 while (specpdl_ptr != specpdl + count)
3563 /* Copy the binding, and decrement specpdl_ptr, before we do
3564 the work to unbind it. We decrement first
3565 so that an error in unbinding won't try to unbind
3566 the same entry again, and we copy the binding first
3567 in case more bindings are made during some of the code we run. */
3569 union specbinding this_binding;
3570 this_binding = *--specpdl_ptr;
3572 do_one_unbind (&this_binding, true, SET_INTERNAL_UNBIND);
3575 if (NILP (Vquit_flag) && !NILP (quitf))
3576 Vquit_flag = quitf;
3578 return value;
3581 void
3582 unbind_for_thread_switch (struct thread_state *thr)
3584 union specbinding *bind;
3586 for (bind = thr->m_specpdl_ptr; bind > thr->m_specpdl;)
3588 if ((--bind)->kind >= SPECPDL_LET)
3590 Lisp_Object sym = specpdl_symbol (bind);
3591 bind->let.saved_value = find_symbol_value (sym);
3592 do_one_unbind (bind, false, SET_INTERNAL_THREAD_SWITCH);
3597 DEFUN ("special-variable-p", Fspecial_variable_p, Sspecial_variable_p, 1, 1, 0,
3598 doc: /* Return non-nil if SYMBOL's global binding has been declared special.
3599 A special variable is one that will be bound dynamically, even in a
3600 context where binding is lexical by default. */)
3601 (Lisp_Object symbol)
3603 CHECK_SYMBOL (symbol);
3604 return XSYMBOL (symbol)->u.s.declared_special ? Qt : Qnil;
3608 static union specbinding *
3609 get_backtrace_starting_at (Lisp_Object base)
3611 union specbinding *pdl = backtrace_top ();
3613 if (!NILP (base))
3614 { /* Skip up to `base'. */
3615 base = Findirect_function (base, Qt);
3616 while (backtrace_p (pdl)
3617 && !EQ (base, Findirect_function (backtrace_function (pdl), Qt)))
3618 pdl = backtrace_next (pdl);
3621 return pdl;
3624 static union specbinding *
3625 get_backtrace_frame (Lisp_Object nframes, Lisp_Object base)
3627 register EMACS_INT i;
3629 CHECK_NATNUM (nframes);
3630 union specbinding *pdl = get_backtrace_starting_at (base);
3632 /* Find the frame requested. */
3633 for (i = XFASTINT (nframes); i > 0 && backtrace_p (pdl); i--)
3634 pdl = backtrace_next (pdl);
3636 return pdl;
3639 static Lisp_Object
3640 backtrace_frame_apply (Lisp_Object function, union specbinding *pdl)
3642 if (!backtrace_p (pdl))
3643 return Qnil;
3645 Lisp_Object flags = Qnil;
3646 if (backtrace_debug_on_exit (pdl))
3647 flags = Fcons (QCdebug_on_exit, Fcons (Qt, Qnil));
3649 if (backtrace_nargs (pdl) == UNEVALLED)
3650 return call4 (function, Qnil, backtrace_function (pdl), *backtrace_args (pdl), flags);
3651 else
3653 Lisp_Object tem = Flist (backtrace_nargs (pdl), backtrace_args (pdl));
3654 return call4 (function, Qt, backtrace_function (pdl), tem, flags);
3658 DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
3659 doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3660 The debugger is entered when that frame exits, if the flag is non-nil. */)
3661 (Lisp_Object level, Lisp_Object flag)
3663 CHECK_NUMBER (level);
3664 union specbinding *pdl = get_backtrace_frame(level, Qnil);
3666 if (backtrace_p (pdl))
3667 set_backtrace_debug_on_exit (pdl, !NILP (flag));
3669 return flag;
3672 DEFUN ("mapbacktrace", Fmapbacktrace, Smapbacktrace, 1, 2, 0,
3673 doc: /* Call FUNCTION for each frame in backtrace.
3674 If BASE is non-nil, it should be a function and iteration will start
3675 from its nearest activation frame.
3676 FUNCTION is called with 4 arguments: EVALD, FUNC, ARGS, and FLAGS. If
3677 a frame has not evaluated its arguments yet or is a special form,
3678 EVALD is nil and ARGS is a list of forms. If a frame has evaluated
3679 its arguments and called its function already, EVALD is t and ARGS is
3680 a list of values.
3681 FLAGS is a plist of properties of the current frame: currently, the
3682 only supported property is :debug-on-exit. `mapbacktrace' always
3683 returns nil. */)
3684 (Lisp_Object function, Lisp_Object base)
3686 union specbinding *pdl = get_backtrace_starting_at (base);
3688 while (backtrace_p (pdl))
3690 ptrdiff_t i = pdl - specpdl;
3691 backtrace_frame_apply (function, pdl);
3692 /* Beware! PDL is no longer valid here because FUNCTION might
3693 have caused grow_specpdl to reallocate pdlvec. We must use
3694 the saved index, cf. Bug#27258. */
3695 pdl = backtrace_next (&specpdl[i]);
3698 return Qnil;
3701 DEFUN ("backtrace-frame--internal", Fbacktrace_frame_internal,
3702 Sbacktrace_frame_internal, 3, 3, NULL,
3703 doc: /* Call FUNCTION on stack frame NFRAMES away from BASE.
3704 Return the result of FUNCTION, or nil if no matching frame could be found. */)
3705 (Lisp_Object function, Lisp_Object nframes, Lisp_Object base)
3707 return backtrace_frame_apply (function, get_backtrace_frame (nframes, base));
3710 /* For backtrace-eval, we want to temporarily unwind the last few elements of
3711 the specpdl stack, and then rewind them. We store the pre-unwind values
3712 directly in the pre-existing specpdl elements (i.e. we swap the current
3713 value and the old value stored in the specpdl), kind of like the inplace
3714 pointer-reversal trick. As it turns out, the rewind does the same as the
3715 unwind, except it starts from the other end of the specpdl stack, so we use
3716 the same function for both unwind and rewind. */
3717 static void
3718 backtrace_eval_unrewind (int distance)
3720 union specbinding *tmp = specpdl_ptr;
3721 int step = -1;
3722 if (distance < 0)
3723 { /* It's a rewind rather than unwind. */
3724 tmp += distance - 1;
3725 step = 1;
3726 distance = -distance;
3729 for (; distance > 0; distance--)
3731 tmp += step;
3732 switch (tmp->kind)
3734 /* FIXME: Ideally we'd like to "temporarily unwind" (some of) those
3735 unwind_protect, but the problem is that we don't know how to
3736 rewind them afterwards. */
3737 case SPECPDL_UNWIND:
3739 Lisp_Object oldarg = tmp->unwind.arg;
3740 if (tmp->unwind.func == set_buffer_if_live)
3741 tmp->unwind.arg = Fcurrent_buffer ();
3742 else if (tmp->unwind.func == save_excursion_restore)
3743 tmp->unwind.arg = save_excursion_save ();
3744 else
3745 break;
3746 tmp->unwind.func (oldarg);
3747 break;
3750 case SPECPDL_UNWIND_PTR:
3751 case SPECPDL_UNWIND_INT:
3752 case SPECPDL_UNWIND_VOID:
3753 case SPECPDL_BACKTRACE:
3754 break;
3755 case SPECPDL_LET:
3756 { /* If variable has a trivial value (no forwarding), we can
3757 just set it. No need to check for constant symbols here,
3758 since that was already done by specbind. */
3759 Lisp_Object sym = specpdl_symbol (tmp);
3760 if (SYMBOLP (sym)
3761 && XSYMBOL (sym)->u.s.redirect == SYMBOL_PLAINVAL)
3763 Lisp_Object old_value = specpdl_old_value (tmp);
3764 set_specpdl_old_value (tmp, SYMBOL_VAL (XSYMBOL (sym)));
3765 SET_SYMBOL_VAL (XSYMBOL (sym), old_value);
3766 break;
3769 /* Come here only if make_local_foo was used for the first
3770 time on this var within this let. */
3771 FALLTHROUGH;
3772 case SPECPDL_LET_DEFAULT:
3774 Lisp_Object sym = specpdl_symbol (tmp);
3775 Lisp_Object old_value = specpdl_old_value (tmp);
3776 set_specpdl_old_value (tmp, Fdefault_value (sym));
3777 Fset_default (sym, old_value);
3779 break;
3780 case SPECPDL_LET_LOCAL:
3782 Lisp_Object symbol = specpdl_symbol (tmp);
3783 Lisp_Object where = specpdl_where (tmp);
3784 Lisp_Object old_value = specpdl_old_value (tmp);
3785 eassert (BUFFERP (where));
3787 /* If this was a local binding, reset the value in the appropriate
3788 buffer, but only if that buffer's binding still exists. */
3789 if (!NILP (Flocal_variable_p (symbol, where)))
3791 set_specpdl_old_value
3792 (tmp, Fbuffer_local_value (symbol, where));
3793 set_internal (symbol, old_value, where, SET_INTERNAL_UNBIND);
3796 break;
3801 DEFUN ("backtrace-eval", Fbacktrace_eval, Sbacktrace_eval, 2, 3, NULL,
3802 doc: /* Evaluate EXP in the context of some activation frame.
3803 NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */)
3804 (Lisp_Object exp, Lisp_Object nframes, Lisp_Object base)
3806 union specbinding *pdl = get_backtrace_frame (nframes, base);
3807 ptrdiff_t count = SPECPDL_INDEX ();
3808 ptrdiff_t distance = specpdl_ptr - pdl;
3809 eassert (distance >= 0);
3811 if (!backtrace_p (pdl))
3812 error ("Activation frame not found!");
3814 backtrace_eval_unrewind (distance);
3815 record_unwind_protect_int (backtrace_eval_unrewind, -distance);
3817 /* Use eval_sub rather than Feval since the main motivation behind
3818 backtrace-eval is to be able to get/set the value of lexical variables
3819 from the debugger. */
3820 return unbind_to (count, eval_sub (exp));
3823 DEFUN ("backtrace--locals", Fbacktrace__locals, Sbacktrace__locals, 1, 2, NULL,
3824 doc: /* Return names and values of local variables of a stack frame.
3825 NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'. */)
3826 (Lisp_Object nframes, Lisp_Object base)
3828 union specbinding *frame = get_backtrace_frame (nframes, base);
3829 union specbinding *prevframe
3830 = get_backtrace_frame (make_number (XFASTINT (nframes) - 1), base);
3831 ptrdiff_t distance = specpdl_ptr - frame;
3832 Lisp_Object result = Qnil;
3833 eassert (distance >= 0);
3835 if (!backtrace_p (prevframe))
3836 error ("Activation frame not found!");
3837 if (!backtrace_p (frame))
3838 error ("Activation frame not found!");
3840 /* The specpdl entries normally contain the symbol being bound along with its
3841 `old_value', so it can be restored. The new value to which it is bound is
3842 available in one of two places: either in the current value of the
3843 variable (if it hasn't been rebound yet) or in the `old_value' slot of the
3844 next specpdl entry for it.
3845 `backtrace_eval_unrewind' happens to swap the role of `old_value'
3846 and "new value", so we abuse it here, to fetch the new value.
3847 It's ugly (we'd rather not modify global data) and a bit inefficient,
3848 but it does the job for now. */
3849 backtrace_eval_unrewind (distance);
3851 /* Grab values. */
3853 union specbinding *tmp = prevframe;
3854 for (; tmp > frame; tmp--)
3856 switch (tmp->kind)
3858 case SPECPDL_LET:
3859 case SPECPDL_LET_DEFAULT:
3860 case SPECPDL_LET_LOCAL:
3862 Lisp_Object sym = specpdl_symbol (tmp);
3863 Lisp_Object val = specpdl_old_value (tmp);
3864 if (EQ (sym, Qinternal_interpreter_environment))
3866 Lisp_Object env = val;
3867 for (; CONSP (env); env = XCDR (env))
3869 Lisp_Object binding = XCAR (env);
3870 if (CONSP (binding))
3871 result = Fcons (Fcons (XCAR (binding),
3872 XCDR (binding)),
3873 result);
3876 else
3877 result = Fcons (Fcons (sym, val), result);
3879 break;
3881 case SPECPDL_UNWIND:
3882 case SPECPDL_UNWIND_PTR:
3883 case SPECPDL_UNWIND_INT:
3884 case SPECPDL_UNWIND_VOID:
3885 case SPECPDL_BACKTRACE:
3886 break;
3888 default:
3889 emacs_abort ();
3894 /* Restore values from specpdl to original place. */
3895 backtrace_eval_unrewind (-distance);
3897 return result;
3901 void
3902 mark_specpdl (union specbinding *first, union specbinding *ptr)
3904 union specbinding *pdl;
3905 for (pdl = first; pdl != ptr; pdl++)
3907 switch (pdl->kind)
3909 case SPECPDL_UNWIND:
3910 mark_object (specpdl_arg (pdl));
3911 break;
3913 case SPECPDL_BACKTRACE:
3915 ptrdiff_t nargs = backtrace_nargs (pdl);
3916 mark_object (backtrace_function (pdl));
3917 if (nargs == UNEVALLED)
3918 nargs = 1;
3919 while (nargs--)
3920 mark_object (backtrace_args (pdl)[nargs]);
3922 break;
3924 case SPECPDL_LET_DEFAULT:
3925 case SPECPDL_LET_LOCAL:
3926 mark_object (specpdl_where (pdl));
3927 FALLTHROUGH;
3928 case SPECPDL_LET:
3929 mark_object (specpdl_symbol (pdl));
3930 mark_object (specpdl_old_value (pdl));
3931 mark_object (specpdl_saved_value (pdl));
3932 break;
3934 case SPECPDL_UNWIND_PTR:
3935 case SPECPDL_UNWIND_INT:
3936 case SPECPDL_UNWIND_VOID:
3937 break;
3939 default:
3940 emacs_abort ();
3945 void
3946 get_backtrace (Lisp_Object array)
3948 union specbinding *pdl = backtrace_next (backtrace_top ());
3949 ptrdiff_t i = 0, asize = ASIZE (array);
3951 /* Copy the backtrace contents into working memory. */
3952 for (; i < asize; i++)
3954 if (backtrace_p (pdl))
3956 ASET (array, i, backtrace_function (pdl));
3957 pdl = backtrace_next (pdl);
3959 else
3960 ASET (array, i, Qnil);
3964 Lisp_Object backtrace_top_function (void)
3966 union specbinding *pdl = backtrace_top ();
3967 return (backtrace_p (pdl) ? backtrace_function (pdl) : Qnil);
3970 void
3971 syms_of_eval (void)
3973 DEFVAR_INT ("max-specpdl-size", max_specpdl_size,
3974 doc: /* Limit on number of Lisp variable bindings and `unwind-protect's.
3975 If Lisp code tries to increase the total number past this amount,
3976 an error is signaled.
3977 You can safely use a value considerably larger than the default value,
3978 if that proves inconveniently small. However, if you increase it too far,
3979 Emacs could run out of memory trying to make the stack bigger.
3980 Note that this limit may be silently increased by the debugger
3981 if `debug-on-error' or `debug-on-quit' is set. */);
3983 DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth,
3984 doc: /* Limit on depth in `eval', `apply' and `funcall' before error.
3986 This limit serves to catch infinite recursions for you before they cause
3987 actual stack overflow in C, which would be fatal for Emacs.
3988 You can safely make it considerably larger than its default value,
3989 if that proves inconveniently small. However, if you increase it too far,
3990 Emacs could overflow the real C stack, and crash. */);
3992 DEFVAR_LISP ("quit-flag", Vquit_flag,
3993 doc: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3994 If the value is t, that means do an ordinary quit.
3995 If the value equals `throw-on-input', that means quit by throwing
3996 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3997 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3998 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3999 Vquit_flag = Qnil;
4001 DEFVAR_LISP ("inhibit-quit", Vinhibit_quit,
4002 doc: /* Non-nil inhibits C-g quitting from happening immediately.
4003 Note that `quit-flag' will still be set by typing C-g,
4004 so a quit will be signaled as soon as `inhibit-quit' is nil.
4005 To prevent this happening, set `quit-flag' to nil
4006 before making `inhibit-quit' nil. */);
4007 Vinhibit_quit = Qnil;
4009 DEFSYM (Qsetq, "setq");
4010 DEFSYM (Qinhibit_quit, "inhibit-quit");
4011 DEFSYM (Qautoload, "autoload");
4012 DEFSYM (Qinhibit_debugger, "inhibit-debugger");
4013 DEFSYM (Qmacro, "macro");
4015 /* Note that the process handling also uses Qexit, but we don't want
4016 to staticpro it twice, so we just do it here. */
4017 DEFSYM (Qexit, "exit");
4019 DEFSYM (Qinteractive, "interactive");
4020 DEFSYM (Qcommandp, "commandp");
4021 DEFSYM (Qand_rest, "&rest");
4022 DEFSYM (Qand_optional, "&optional");
4023 DEFSYM (Qclosure, "closure");
4024 DEFSYM (QCdocumentation, ":documentation");
4025 DEFSYM (Qdebug, "debug");
4027 DEFVAR_LISP ("inhibit-debugger", Vinhibit_debugger,
4028 doc: /* Non-nil means never enter the debugger.
4029 Normally set while the debugger is already active, to avoid recursive
4030 invocations. */);
4031 Vinhibit_debugger = Qnil;
4033 DEFVAR_LISP ("debug-on-error", Vdebug_on_error,
4034 doc: /* Non-nil means enter debugger if an error is signaled.
4035 Does not apply to errors handled by `condition-case' or those
4036 matched by `debug-ignored-errors'.
4037 If the value is a list, an error only means to enter the debugger
4038 if one of its condition symbols appears in the list.
4039 When you evaluate an expression interactively, this variable
4040 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
4041 The command `toggle-debug-on-error' toggles this.
4042 See also the variable `debug-on-quit' and `inhibit-debugger'. */);
4043 Vdebug_on_error = Qnil;
4045 DEFVAR_LISP ("debug-ignored-errors", Vdebug_ignored_errors,
4046 doc: /* List of errors for which the debugger should not be called.
4047 Each element may be a condition-name or a regexp that matches error messages.
4048 If any element applies to a given error, that error skips the debugger
4049 and just returns to top level.
4050 This overrides the variable `debug-on-error'.
4051 It does not apply to errors handled by `condition-case'. */);
4052 Vdebug_ignored_errors = Qnil;
4054 DEFVAR_BOOL ("debug-on-quit", debug_on_quit,
4055 doc: /* Non-nil means enter debugger if quit is signaled (C-g, for example).
4056 Does not apply if quit is handled by a `condition-case'. */);
4057 debug_on_quit = 0;
4059 DEFVAR_BOOL ("debug-on-next-call", debug_on_next_call,
4060 doc: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
4062 DEFVAR_BOOL ("debugger-may-continue", debugger_may_continue,
4063 doc: /* Non-nil means debugger may continue execution.
4064 This is nil when the debugger is called under circumstances where it
4065 might not be safe to continue. */);
4066 debugger_may_continue = 1;
4068 DEFVAR_BOOL ("debugger-stack-frame-as-list", debugger_stack_frame_as_list,
4069 doc: /* Non-nil means display call stack frames as lists. */);
4070 debugger_stack_frame_as_list = 0;
4072 DEFVAR_LISP ("debugger", Vdebugger,
4073 doc: /* Function to call to invoke debugger.
4074 If due to frame exit, args are `exit' and the value being returned;
4075 this function's value will be returned instead of that.
4076 If due to error, args are `error' and a list of the args to `signal'.
4077 If due to `apply' or `funcall' entry, one arg, `lambda'.
4078 If due to `eval' entry, one arg, t. */);
4079 Vdebugger = Qnil;
4081 DEFVAR_LISP ("signal-hook-function", Vsignal_hook_function,
4082 doc: /* If non-nil, this is a function for `signal' to call.
4083 It receives the same arguments that `signal' was given.
4084 The Edebug package uses this to regain control. */);
4085 Vsignal_hook_function = Qnil;
4087 DEFVAR_LISP ("debug-on-signal", Vdebug_on_signal,
4088 doc: /* Non-nil means call the debugger regardless of condition handlers.
4089 Note that `debug-on-error', `debug-on-quit' and friends
4090 still determine whether to handle the particular condition. */);
4091 Vdebug_on_signal = Qnil;
4093 /* When lexical binding is being used,
4094 Vinternal_interpreter_environment is non-nil, and contains an alist
4095 of lexically-bound variable, or (t), indicating an empty
4096 environment. The lisp name of this variable would be
4097 `internal-interpreter-environment' if it weren't hidden.
4098 Every element of this list can be either a cons (VAR . VAL)
4099 specifying a lexical binding, or a single symbol VAR indicating
4100 that this variable should use dynamic scoping. */
4101 DEFSYM (Qinternal_interpreter_environment,
4102 "internal-interpreter-environment");
4103 DEFVAR_LISP ("internal-interpreter-environment",
4104 Vinternal_interpreter_environment,
4105 doc: /* If non-nil, the current lexical environment of the lisp interpreter.
4106 When lexical binding is not being used, this variable is nil.
4107 A value of `(t)' indicates an empty environment, otherwise it is an
4108 alist of active lexical bindings. */);
4109 Vinternal_interpreter_environment = Qnil;
4110 /* Don't export this variable to Elisp, so no one can mess with it
4111 (Just imagine if someone makes it buffer-local). */
4112 Funintern (Qinternal_interpreter_environment, Qnil);
4114 Vrun_hooks = intern_c_string ("run-hooks");
4115 staticpro (&Vrun_hooks);
4117 staticpro (&Vautoload_queue);
4118 Vautoload_queue = Qnil;
4119 staticpro (&Vsignaling_function);
4120 Vsignaling_function = Qnil;
4122 inhibit_lisp_code = Qnil;
4124 DEFSYM (Qcatch_all_memory_full, "catch-all-memory-full");
4125 Funintern (Qcatch_all_memory_full, Qnil);
4127 defsubr (&Sor);
4128 defsubr (&Sand);
4129 defsubr (&Sif);
4130 defsubr (&Scond);
4131 defsubr (&Sprogn);
4132 defsubr (&Sprog1);
4133 defsubr (&Sprog2);
4134 defsubr (&Ssetq);
4135 defsubr (&Squote);
4136 defsubr (&Sfunction);
4137 defsubr (&Sdefault_toplevel_value);
4138 defsubr (&Sset_default_toplevel_value);
4139 defsubr (&Sdefvar);
4140 defsubr (&Sdefvaralias);
4141 DEFSYM (Qdefvaralias, "defvaralias");
4142 defsubr (&Sdefconst);
4143 defsubr (&Smake_var_non_special);
4144 defsubr (&Slet);
4145 defsubr (&SletX);
4146 defsubr (&Swhile);
4147 defsubr (&Smacroexpand);
4148 defsubr (&Scatch);
4149 defsubr (&Sthrow);
4150 defsubr (&Sunwind_protect);
4151 defsubr (&Scondition_case);
4152 defsubr (&Ssignal);
4153 defsubr (&Scommandp);
4154 defsubr (&Sautoload);
4155 defsubr (&Sautoload_do_load);
4156 defsubr (&Seval);
4157 defsubr (&Sapply);
4158 defsubr (&Sfuncall);
4159 defsubr (&Sfunc_arity);
4160 defsubr (&Srun_hooks);
4161 defsubr (&Srun_hook_with_args);
4162 defsubr (&Srun_hook_with_args_until_success);
4163 defsubr (&Srun_hook_with_args_until_failure);
4164 defsubr (&Srun_hook_wrapped);
4165 defsubr (&Sfetch_bytecode);
4166 defsubr (&Sbacktrace_debug);
4167 DEFSYM (QCdebug_on_exit, ":debug-on-exit");
4168 defsubr (&Smapbacktrace);
4169 defsubr (&Sbacktrace_frame_internal);
4170 defsubr (&Sbacktrace_eval);
4171 defsubr (&Sbacktrace__locals);
4172 defsubr (&Sspecial_variable_p);
4173 defsubr (&Sfunctionp);