1 /* Evaluator for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1987, 1993-1995, 1999-2013 Free Software
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
25 #include "blockinput.h"
28 #include "dispextern.h"
29 #include "frame.h" /* For XFRAME. */
35 /* static struct backtrace *backtrace_list; */
37 /* #if !BYTE_MARK_STACK */
40 /* struct catchtag *catchlist; */
42 /* Chain of condition handlers currently in effect.
43 The elements of this chain are contained in the stack frames
44 of Fcondition_case and internal_condition_case.
45 When an error is signaled (by calling Fsignal, below),
46 this chain is searched for an element that applies. */
48 /* #if !BYTE_MARK_STACK */
51 /* struct handler *handlerlist; */
54 /* Count levels of GCPRO to detect failure to UNGCPRO. */
58 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
;
59 Lisp_Object Qinhibit_quit
;
60 Lisp_Object Qand_rest
;
61 static Lisp_Object Qand_optional
;
62 static Lisp_Object Qinhibit_debugger
;
63 static Lisp_Object Qdeclare
;
64 Lisp_Object Qinternal_interpreter_environment
, Qclosure
;
66 static Lisp_Object Qdebug
;
68 /* This holds either the symbol `run-hooks' or nil.
69 It is nil at an early stage of startup, and when Emacs
72 Lisp_Object Vrun_hooks
;
74 /* Non-nil means record all fset's and provide's, to be undone
75 if the file being autoloaded is not fully loaded.
76 They are recorded by being consed onto the front of Vautoload_queue:
77 (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide. */
79 Lisp_Object Vautoload_queue
;
81 /* Current number of specbindings allocated in specpdl. */
83 /* ptrdiff_t specpdl_size; */
85 /* Pointer to beginning of specpdl. */
87 /* struct specbinding *specpdl; */
89 /* Pointer to first unused element in specpdl. */
91 /* struct specbinding *specpdl_ptr; */
93 /* Depth in Lisp evaluations and function calls. */
95 /* static EMACS_INT lisp_eval_depth; */
97 /* The value of num_nonmacro_input_events as of the last time we
98 started to enter the debugger. If we decide to enter the debugger
99 again when this is still equal to num_nonmacro_input_events, then we
100 know that the debugger itself has an error, and we should just
101 signal the error instead of entering an infinite loop of debugger
104 static EMACS_INT when_entered_debugger
;
106 /* The function from which the last `signal' was called. Set in
109 Lisp_Object Vsignaling_function
;
111 /* If non-nil, Lisp code must not be run since some part of Emacs is
112 in an inconsistent state. Currently, x-create-frame uses this to
113 avoid triggering window-configuration-change-hook while the new
114 frame is half-initialized. */
115 Lisp_Object inhibit_lisp_code
;
117 static Lisp_Object
funcall_lambda (Lisp_Object
, ptrdiff_t, Lisp_Object
*);
118 static Lisp_Object
apply_lambda (Lisp_Object fun
, Lisp_Object args
);
120 /* Functions to set Lisp_Object slots of struct specbinding. */
123 set_specpdl_symbol (Lisp_Object symbol
)
125 specpdl_ptr
->symbol
= symbol
;
129 set_specpdl_old_value (Lisp_Object oldval
)
131 specpdl_ptr
->old_value
= oldval
;
135 set_specpdl_saved_value (Lisp_Object savedval
)
137 specpdl_ptr
->saved_value
= savedval
;
141 init_eval_once (void)
144 specpdl
= xmalloc (size
* sizeof *specpdl
);
146 specpdl_ptr
= specpdl
;
147 /* Don't forget to update docs (lispref node "Local Variables"). */
148 max_specpdl_size
= 1300; /* 1000 is not enough for CEDET's c-by.el. */
149 max_lisp_eval_depth
= 600;
157 specpdl_ptr
= specpdl
;
162 debug_on_next_call
= 0;
167 /* This is less than the initial value of num_nonmacro_input_events. */
168 when_entered_debugger
= -1;
171 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
172 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
174 mark_catchlist (struct catchtag
*catch)
176 for (; catch; catch = catch->next
)
178 mark_object (catch->tag
);
179 mark_object (catch->val
);
184 /* Unwind-protect function used by call_debugger. */
187 restore_stack_limits (Lisp_Object data
)
189 max_specpdl_size
= XINT (XCAR (data
));
190 max_lisp_eval_depth
= XINT (XCDR (data
));
194 /* Call the Lisp debugger, giving it argument ARG. */
197 call_debugger (Lisp_Object arg
)
199 bool debug_while_redisplaying
;
200 ptrdiff_t count
= SPECPDL_INDEX ();
202 EMACS_INT old_max
= max_specpdl_size
;
204 /* Temporarily bump up the stack limits,
205 so the debugger won't run out of stack. */
207 max_specpdl_size
+= 1;
208 record_unwind_protect (restore_stack_limits
,
209 Fcons (make_number (old_max
),
210 make_number (max_lisp_eval_depth
)));
211 max_specpdl_size
= old_max
;
213 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
214 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
216 if (max_specpdl_size
- 100 < SPECPDL_INDEX ())
217 max_specpdl_size
= SPECPDL_INDEX () + 100;
219 #ifdef HAVE_WINDOW_SYSTEM
220 if (display_hourglass_p
)
224 debug_on_next_call
= 0;
225 when_entered_debugger
= num_nonmacro_input_events
;
227 /* Resetting redisplaying_p to 0 makes sure that debug output is
228 displayed if the debugger is invoked during redisplay. */
229 debug_while_redisplaying
= redisplaying_p
;
231 specbind (intern ("debugger-may-continue"),
232 debug_while_redisplaying
? Qnil
: Qt
);
233 specbind (Qinhibit_redisplay
, Qnil
);
234 specbind (Qinhibit_debugger
, Qt
);
236 #if 0 /* Binding this prevents execution of Lisp code during
237 redisplay, which necessarily leads to display problems. */
238 specbind (Qinhibit_eval_during_redisplay
, Qt
);
241 val
= apply1 (Vdebugger
, arg
);
243 /* Interrupting redisplay and resuming it later is not safe under
244 all circumstances. So, when the debugger returns, abort the
245 interrupted redisplay by going back to the top-level. */
246 if (debug_while_redisplaying
)
249 return unbind_to (count
, val
);
253 do_debug_on_call (Lisp_Object code
)
255 debug_on_next_call
= 0;
256 backtrace_list
->debug_on_exit
= 1;
257 call_debugger (Fcons (code
, Qnil
));
260 /* NOTE!!! Every function that can call EVAL must protect its args
261 and temporaries from garbage collection while it needs them.
262 The definition of `For' shows what you have to do. */
264 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
265 doc
: /* Eval args until one of them yields non-nil, then return that value.
266 The remaining args are not evalled at all.
267 If all args return nil, return nil.
268 usage: (or CONDITIONS...) */)
271 register Lisp_Object val
= Qnil
;
278 val
= eval_sub (XCAR (args
));
288 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
289 doc
: /* Eval args until one of them yields nil, then return nil.
290 The remaining args are not evalled at all.
291 If no arg yields nil, return the last arg's value.
292 usage: (and CONDITIONS...) */)
295 register Lisp_Object val
= Qt
;
302 val
= eval_sub (XCAR (args
));
312 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
313 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
314 Returns the value of THEN or the value of the last of the ELSE's.
315 THEN must be one expression, but ELSE... can be zero or more expressions.
316 If COND yields nil, and there are no ELSE's, the value is nil.
317 usage: (if COND THEN ELSE...) */)
320 register Lisp_Object cond
;
324 cond
= eval_sub (Fcar (args
));
328 return eval_sub (Fcar (Fcdr (args
)));
329 return Fprogn (Fcdr (Fcdr (args
)));
332 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
333 doc
: /* Try each clause until one succeeds.
334 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
335 and, if the value is non-nil, this clause succeeds:
336 then the expressions in BODY are evaluated and the last one's
337 value is the value of the cond-form.
338 If no clause succeeds, cond returns nil.
339 If a clause has one element, as in (CONDITION),
340 CONDITION's value if non-nil is returned from the cond-form.
341 usage: (cond CLAUSES...) */)
344 register Lisp_Object clause
, val
;
351 clause
= Fcar (args
);
352 val
= eval_sub (Fcar (clause
));
355 if (!EQ (XCDR (clause
), Qnil
))
356 val
= Fprogn (XCDR (clause
));
366 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
367 doc
: /* Eval BODY forms sequentially and return value of last one.
368 usage: (progn BODY...) */)
371 register Lisp_Object val
= Qnil
;
378 val
= eval_sub (XCAR (args
));
386 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
387 doc
: /* Eval FIRST and BODY sequentially; return value from FIRST.
388 The value of FIRST is saved during the evaluation of the remaining args,
389 whose values are discarded.
390 usage: (prog1 FIRST BODY...) */)
394 register Lisp_Object args_left
;
395 struct gcpro gcpro1
, gcpro2
;
401 val
= eval_sub (XCAR (args_left
));
402 while (CONSP (args_left
= XCDR (args_left
)))
403 eval_sub (XCAR (args_left
));
409 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
410 doc
: /* Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
411 The value of FORM2 is saved during the evaluation of the
412 remaining args, whose values are discarded.
413 usage: (prog2 FORM1 FORM2 BODY...) */)
419 eval_sub (XCAR (args
));
421 return Fprog1 (XCDR (args
));
424 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
425 doc
: /* Set each SYM to the value of its VAL.
426 The symbols SYM are variables; they are literal (not evaluated).
427 The values VAL are expressions; they are evaluated.
428 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
429 The second VAL is not computed until after the first SYM is set, and so on;
430 each VAL can use the new value of variables set earlier in the `setq'.
431 The return value of the `setq' form is the value of the last VAL.
432 usage: (setq [SYM VAL]...) */)
435 register Lisp_Object args_left
;
436 register Lisp_Object val
, sym
, lex_binding
;
447 val
= eval_sub (Fcar (Fcdr (args_left
)));
448 sym
= Fcar (args_left
);
450 /* Like for eval_sub, we do not check declared_special here since
451 it's been done when let-binding. */
452 if (!NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
454 && !NILP (lex_binding
455 = Fassq (sym
, Vinternal_interpreter_environment
)))
456 XSETCDR (lex_binding
, val
); /* SYM is lexically bound. */
458 Fset (sym
, val
); /* SYM is dynamically bound. */
460 args_left
= Fcdr (Fcdr (args_left
));
462 while (!NILP (args_left
));
468 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
469 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
470 Warning: `quote' does not construct its return value, but just returns
471 the value that was pre-constructed by the Lisp reader (see info node
472 `(elisp)Printed Representation').
473 This means that '(a . b) is not identical to (cons 'a 'b): the former
474 does not cons. Quoting should be reserved for constants that will
475 never be modified by side-effects, unless you like self-modifying code.
476 See the common pitfall in info node `(elisp)Rearrangement' for an example
477 of unexpected results when a quoted object is modified.
478 usage: (quote ARG) */)
481 if (!NILP (Fcdr (args
)))
482 xsignal2 (Qwrong_number_of_arguments
, Qquote
, Flength (args
));
486 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
487 doc
: /* Like `quote', but preferred for objects which are functions.
488 In byte compilation, `function' causes its argument to be compiled.
489 `quote' cannot do that.
490 usage: (function ARG) */)
493 Lisp_Object quoted
= XCAR (args
);
495 if (!NILP (Fcdr (args
)))
496 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
498 if (!NILP (Vinternal_interpreter_environment
)
500 && EQ (XCAR (quoted
), Qlambda
))
501 /* This is a lambda expression within a lexical environment;
502 return an interpreted closure instead of a simple lambda. */
503 return Fcons (Qclosure
, Fcons (Vinternal_interpreter_environment
,
506 /* Simply quote the argument. */
511 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
512 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
513 Aliased variables always have the same value; setting one sets the other.
514 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
515 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
516 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
517 itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
518 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
519 The return value is BASE-VARIABLE. */)
520 (Lisp_Object new_alias
, Lisp_Object base_variable
, Lisp_Object docstring
)
522 struct Lisp_Symbol
*sym
;
524 CHECK_SYMBOL (new_alias
);
525 CHECK_SYMBOL (base_variable
);
527 sym
= XSYMBOL (new_alias
);
530 /* Not sure why, but why not? */
531 error ("Cannot make a constant an alias");
533 switch (sym
->redirect
)
535 case SYMBOL_FORWARDED
:
536 error ("Cannot make an internal variable an alias");
537 case SYMBOL_LOCALIZED
:
538 error ("Don't know how to make a localized variable an alias");
541 /* http://lists.gnu.org/archive/html/emacs-devel/2008-04/msg00834.html
542 If n_a is bound, but b_v is not, set the value of b_v to n_a,
543 so that old-code that affects n_a before the aliasing is setup
545 if (NILP (Fboundp (base_variable
)))
546 set_internal (base_variable
, find_symbol_value (new_alias
), Qnil
, 1);
549 struct specbinding
*p
;
551 for (p
= specpdl_ptr
; p
> specpdl
; )
552 if ((--p
)->func
== NULL
554 CONSP (p
->symbol
) ? XCAR (p
->symbol
) : p
->symbol
)))
555 error ("Don't know how to make a let-bound variable an alias");
558 sym
->declared_special
= 1;
559 XSYMBOL (base_variable
)->declared_special
= 1;
560 sym
->redirect
= SYMBOL_VARALIAS
;
561 SET_SYMBOL_ALIAS (sym
, XSYMBOL (base_variable
));
562 sym
->constant
= SYMBOL_CONSTANT_P (base_variable
);
563 LOADHIST_ATTACH (new_alias
);
564 /* Even if docstring is nil: remove old docstring. */
565 Fput (new_alias
, Qvariable_documentation
, docstring
);
567 return base_variable
;
571 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
572 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
573 You are not required to define a variable in order to use it, but
574 defining it lets you supply an initial value and documentation, which
575 can be referred to by the Emacs help facilities and other programming
576 tools. The `defvar' form also declares the variable as \"special\",
577 so that it is always dynamically bound even if `lexical-binding' is t.
579 The optional argument INITVALUE is evaluated, and used to set SYMBOL,
580 only if SYMBOL's value is void. If SYMBOL is buffer-local, its
581 default value is what is set; buffer-local values are not affected.
582 If INITVALUE is missing, SYMBOL's value is not set.
584 If SYMBOL has a local binding, then this form affects the local
585 binding. This is usually not what you want. Thus, if you need to
586 load a file defining variables, with this form or with `defconst' or
587 `defcustom', you should always load that file _outside_ any bindings
588 for these variables. \(`defconst' and `defcustom' behave similarly in
591 The optional argument DOCSTRING is a documentation string for the
594 To define a user option, use `defcustom' instead of `defvar'.
595 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
598 register Lisp_Object sym
, tem
, tail
;
602 if (!NILP (Fcdr (Fcdr (tail
))))
603 error ("Too many arguments");
605 tem
= Fdefault_boundp (sym
);
608 /* Do it before evaluating the initial value, for self-references. */
609 XSYMBOL (sym
)->declared_special
= 1;
612 Fset_default (sym
, eval_sub (Fcar (tail
)));
614 { /* Check if there is really a global binding rather than just a let
615 binding that shadows the global unboundness of the var. */
616 struct specbinding
*pdl
= specpdl_ptr
;
617 while (pdl
> specpdl
)
619 if (EQ ((--pdl
)->symbol
, sym
) && !pdl
->func
620 && EQ (pdl
->old_value
, Qunbound
))
623 ("Warning: defvar ignored because %s is let-bound",
624 SYMBOL_NAME (sym
), 1);
633 if (!NILP (Vpurify_flag
))
634 tem
= Fpurecopy (tem
);
635 Fput (sym
, Qvariable_documentation
, tem
);
637 LOADHIST_ATTACH (sym
);
639 else if (!NILP (Vinternal_interpreter_environment
)
640 && !XSYMBOL (sym
)->declared_special
)
641 /* A simple (defvar foo) with lexical scoping does "nothing" except
642 declare that var to be dynamically scoped *locally* (i.e. within
643 the current file or let-block). */
644 Vinternal_interpreter_environment
645 = Fcons (sym
, Vinternal_interpreter_environment
);
648 /* Simple (defvar <var>) should not count as a definition at all.
649 It could get in the way of other definitions, and unloading this
650 package could try to make the variable unbound. */
656 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
657 doc
: /* Define SYMBOL as a constant variable.
658 This declares that neither programs nor users should ever change the
659 value. This constancy is not actually enforced by Emacs Lisp, but
660 SYMBOL is marked as a special variable so that it is never lexically
663 The `defconst' form always sets the value of SYMBOL to the result of
664 evalling INITVALUE. If SYMBOL is buffer-local, its default value is
665 what is set; buffer-local values are not affected. If SYMBOL has a
666 local binding, then this form sets the local binding's value.
667 However, you should normally not make local bindings for variables
668 defined with this form.
670 The optional DOCSTRING specifies the variable's documentation string.
671 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
674 register Lisp_Object sym
, tem
;
677 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
678 error ("Too many arguments");
680 tem
= eval_sub (Fcar (Fcdr (args
)));
681 if (!NILP (Vpurify_flag
))
682 tem
= Fpurecopy (tem
);
683 Fset_default (sym
, tem
);
684 XSYMBOL (sym
)->declared_special
= 1;
685 tem
= Fcar (Fcdr (Fcdr (args
)));
688 if (!NILP (Vpurify_flag
))
689 tem
= Fpurecopy (tem
);
690 Fput (sym
, Qvariable_documentation
, tem
);
692 Fput (sym
, Qrisky_local_variable
, Qt
);
693 LOADHIST_ATTACH (sym
);
697 /* Make SYMBOL lexically scoped. */
698 DEFUN ("internal-make-var-non-special", Fmake_var_non_special
,
699 Smake_var_non_special
, 1, 1, 0,
700 doc
: /* Internal function. */)
703 CHECK_SYMBOL (symbol
);
704 XSYMBOL (symbol
)->declared_special
= 0;
709 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
710 doc
: /* Bind variables according to VARLIST then eval BODY.
711 The value of the last form in BODY is returned.
712 Each element of VARLIST is a symbol (which is bound to nil)
713 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
714 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
715 usage: (let* VARLIST BODY...) */)
718 Lisp_Object varlist
, var
, val
, elt
, lexenv
;
719 ptrdiff_t count
= SPECPDL_INDEX ();
720 struct gcpro gcpro1
, gcpro2
, gcpro3
;
722 GCPRO3 (args
, elt
, varlist
);
724 lexenv
= Vinternal_interpreter_environment
;
726 varlist
= Fcar (args
);
727 while (CONSP (varlist
))
731 elt
= XCAR (varlist
);
737 else if (! NILP (Fcdr (Fcdr (elt
))))
738 signal_error ("`let' bindings can have only one value-form", elt
);
742 val
= eval_sub (Fcar (Fcdr (elt
)));
745 if (!NILP (lexenv
) && SYMBOLP (var
)
746 && !XSYMBOL (var
)->declared_special
747 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
748 /* Lexically bind VAR by adding it to the interpreter's binding
752 = Fcons (Fcons (var
, val
), Vinternal_interpreter_environment
);
753 if (EQ (Vinternal_interpreter_environment
, lexenv
))
754 /* Save the old lexical environment on the specpdl stack,
755 but only for the first lexical binding, since we'll never
756 need to revert to one of the intermediate ones. */
757 specbind (Qinternal_interpreter_environment
, newenv
);
759 Vinternal_interpreter_environment
= newenv
;
764 varlist
= XCDR (varlist
);
767 val
= Fprogn (Fcdr (args
));
768 return unbind_to (count
, val
);
771 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
772 doc
: /* Bind variables according to VARLIST then eval BODY.
773 The value of the last form in BODY is returned.
774 Each element of VARLIST is a symbol (which is bound to nil)
775 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
776 All the VALUEFORMs are evalled before any symbols are bound.
777 usage: (let VARLIST BODY...) */)
780 Lisp_Object
*temps
, tem
, lexenv
;
781 register Lisp_Object elt
, varlist
;
782 ptrdiff_t count
= SPECPDL_INDEX ();
784 struct gcpro gcpro1
, gcpro2
;
787 varlist
= Fcar (args
);
789 /* Make space to hold the values to give the bound variables. */
790 elt
= Flength (varlist
);
791 SAFE_ALLOCA_LISP (temps
, XFASTINT (elt
));
793 /* Compute the values and store them in `temps'. */
795 GCPRO2 (args
, *temps
);
798 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
801 elt
= XCAR (varlist
);
803 temps
[argnum
++] = Qnil
;
804 else if (! NILP (Fcdr (Fcdr (elt
))))
805 signal_error ("`let' bindings can have only one value-form", elt
);
807 temps
[argnum
++] = eval_sub (Fcar (Fcdr (elt
)));
808 gcpro2
.nvars
= argnum
;
812 lexenv
= Vinternal_interpreter_environment
;
814 varlist
= Fcar (args
);
815 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
819 elt
= XCAR (varlist
);
820 var
= SYMBOLP (elt
) ? elt
: Fcar (elt
);
821 tem
= temps
[argnum
++];
823 if (!NILP (lexenv
) && SYMBOLP (var
)
824 && !XSYMBOL (var
)->declared_special
825 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
826 /* Lexically bind VAR by adding it to the lexenv alist. */
827 lexenv
= Fcons (Fcons (var
, tem
), lexenv
);
829 /* Dynamically bind VAR. */
833 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
834 /* Instantiate a new lexical environment. */
835 specbind (Qinternal_interpreter_environment
, lexenv
);
837 elt
= Fprogn (Fcdr (args
));
839 return unbind_to (count
, elt
);
842 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
843 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
844 The order of execution is thus TEST, BODY, TEST, BODY and so on
845 until TEST returns nil.
846 usage: (while TEST BODY...) */)
849 Lisp_Object test
, body
;
850 struct gcpro gcpro1
, gcpro2
;
856 while (!NILP (eval_sub (test
)))
866 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
867 doc
: /* Return result of expanding macros at top level of FORM.
868 If FORM is not a macro call, it is returned unchanged.
869 Otherwise, the macro is expanded and the expansion is considered
870 in place of FORM. When a non-macro-call results, it is returned.
872 The second optional arg ENVIRONMENT specifies an environment of macro
873 definitions to shadow the loaded ones for use in file byte-compilation. */)
874 (Lisp_Object form
, Lisp_Object environment
)
876 /* With cleanups from Hallvard Furuseth. */
877 register Lisp_Object expander
, sym
, def
, tem
;
881 /* Come back here each time we expand a macro call,
882 in case it expands into another macro call. */
885 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
886 def
= sym
= XCAR (form
);
888 /* Trace symbols aliases to other symbols
889 until we get a symbol that is not an alias. */
890 while (SYMBOLP (def
))
894 tem
= Fassq (sym
, environment
);
897 def
= XSYMBOL (sym
)->function
;
903 /* Right now TEM is the result from SYM in ENVIRONMENT,
904 and if TEM is nil then DEF is SYM's function definition. */
907 /* SYM is not mentioned in ENVIRONMENT.
908 Look at its function definition. */
911 def
= Fautoload_do_load (def
, sym
, Qmacro
);
914 /* Not defined or definition not suitable. */
916 if (!EQ (XCAR (def
), Qmacro
))
918 else expander
= XCDR (def
);
922 expander
= XCDR (tem
);
927 Lisp_Object newform
= apply1 (expander
, XCDR (form
));
928 if (EQ (form
, newform
))
937 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
938 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
939 TAG is evalled to get the tag to use; it must not be nil.
941 Then the BODY is executed.
942 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
943 If no throw happens, `catch' returns the value of the last BODY form.
944 If a throw happens, it specifies the value to return from `catch'.
945 usage: (catch TAG BODY...) */)
948 register Lisp_Object tag
;
952 tag
= eval_sub (Fcar (args
));
954 return internal_catch (tag
, Fprogn
, Fcdr (args
));
957 /* Set up a catch, then call C function FUNC on argument ARG.
958 FUNC should return a Lisp_Object.
959 This is how catches are done from within C code. */
962 internal_catch (Lisp_Object tag
, Lisp_Object (*func
) (Lisp_Object
), Lisp_Object arg
)
964 /* This structure is made part of the chain `catchlist'. */
967 /* Fill in the components of c, and put it on the list. */
971 c
.backlist
= backtrace_list
;
972 c
.f_handlerlist
= handlerlist
;
973 c
.f_lisp_eval_depth
= lisp_eval_depth
;
974 c
.pdlcount
= SPECPDL_INDEX ();
975 c
.poll_suppress_count
= poll_suppress_count
;
976 c
.interrupt_input_blocked
= interrupt_input_blocked
;
978 c
.byte_stack
= byte_stack_list
;
982 if (! sys_setjmp (c
.jmp
))
983 c
.val
= (*func
) (arg
);
985 /* Throw works by a longjmp that comes right here. */
990 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
991 jump to that CATCH, returning VALUE as the value of that catch.
993 This is the guts of Fthrow and Fsignal; they differ only in the way
994 they choose the catch tag to throw to. A catch tag for a
995 condition-case form has a TAG of Qnil.
997 Before each catch is discarded, unbind all special bindings and
998 execute all unwind-protect clauses made above that catch. Unwind
999 the handler stack as we go, so that the proper handlers are in
1000 effect for each unwind-protect clause we run. At the end, restore
1001 some static info saved in CATCH, and longjmp to the location
1004 This is used for correct unwinding in Fthrow and Fsignal. */
1006 static _Noreturn
void
1007 unwind_to_catch (struct catchtag
*catch, Lisp_Object value
)
1011 /* Save the value in the tag. */
1014 /* Restore certain special C variables. */
1015 set_poll_suppress_count (catch->poll_suppress_count
);
1016 unblock_input_to (catch->interrupt_input_blocked
);
1021 last_time
= catchlist
== catch;
1023 /* Unwind the specpdl stack, and then restore the proper set of
1025 unbind_to (catchlist
->pdlcount
, Qnil
);
1026 handlerlist
= catchlist
->f_handlerlist
;
1027 catchlist
= catchlist
->next
;
1029 while (! last_time
);
1031 byte_stack_list
= catch->byte_stack
;
1032 gcprolist
= catch->gcpro
;
1034 gcpro_level
= gcprolist
? gcprolist
->level
+ 1 : 0;
1036 backtrace_list
= catch->backlist
;
1037 lisp_eval_depth
= catch->f_lisp_eval_depth
;
1039 sys_longjmp (catch->jmp
, 1);
1042 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1043 doc
: /* Throw to the catch for TAG and return VALUE from it.
1044 Both TAG and VALUE are evalled. */)
1045 (register Lisp_Object tag
, Lisp_Object value
)
1047 register struct catchtag
*c
;
1050 for (c
= catchlist
; c
; c
= c
->next
)
1052 if (EQ (c
->tag
, tag
))
1053 unwind_to_catch (c
, value
);
1055 xsignal2 (Qno_catch
, tag
, value
);
1059 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1060 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1061 If BODYFORM completes normally, its value is returned
1062 after executing the UNWINDFORMS.
1063 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1064 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1068 ptrdiff_t count
= SPECPDL_INDEX ();
1070 record_unwind_protect (Fprogn
, Fcdr (args
));
1071 val
= eval_sub (Fcar (args
));
1072 return unbind_to (count
, val
);
1075 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1076 doc
: /* Regain control when an error is signaled.
1077 Executes BODYFORM and returns its value if no error happens.
1078 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1079 where the BODY is made of Lisp expressions.
1081 A handler is applicable to an error
1082 if CONDITION-NAME is one of the error's condition names.
1083 If an error happens, the first applicable handler is run.
1085 The car of a handler may be a list of condition names instead of a
1086 single condition name; then it handles all of them. If the special
1087 condition name `debug' is present in this list, it allows another
1088 condition in the list to run the debugger if `debug-on-error' and the
1089 other usual mechanisms says it should (otherwise, `condition-case'
1090 suppresses the debugger).
1092 When a handler handles an error, control returns to the `condition-case'
1093 and it executes the handler's BODY...
1094 with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
1095 \(If VAR is nil, the handler can't access that information.)
1096 Then the value of the last BODY form is returned from the `condition-case'
1099 See also the function `signal' for more info.
1100 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1103 Lisp_Object var
= Fcar (args
);
1104 Lisp_Object bodyform
= Fcar (Fcdr (args
));
1105 Lisp_Object handlers
= Fcdr (Fcdr (args
));
1107 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1110 /* Like Fcondition_case, but the args are separate
1111 rather than passed in a list. Used by Fbyte_code. */
1114 internal_lisp_condition_case (volatile Lisp_Object var
, Lisp_Object bodyform
,
1115 Lisp_Object handlers
)
1123 for (val
= handlers
; CONSP (val
); val
= XCDR (val
))
1129 && (SYMBOLP (XCAR (tem
))
1130 || CONSP (XCAR (tem
))))))
1131 error ("Invalid condition handler: %s",
1132 SDATA (Fprin1_to_string (tem
, Qt
)));
1137 c
.backlist
= backtrace_list
;
1138 c
.f_handlerlist
= handlerlist
;
1139 c
.f_lisp_eval_depth
= lisp_eval_depth
;
1140 c
.pdlcount
= SPECPDL_INDEX ();
1141 c
.poll_suppress_count
= poll_suppress_count
;
1142 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1143 c
.gcpro
= gcprolist
;
1144 c
.byte_stack
= byte_stack_list
;
1145 if (sys_setjmp (c
.jmp
))
1148 specbind (h
.var
, c
.val
);
1149 val
= Fprogn (Fcdr (h
.chosen_clause
));
1151 /* Note that this just undoes the binding of h.var; whoever
1152 longjumped to us unwound the stack to c.pdlcount before
1154 unbind_to (c
.pdlcount
, Qnil
);
1161 h
.handler
= handlers
;
1162 h
.next
= handlerlist
;
1166 val
= eval_sub (bodyform
);
1168 handlerlist
= h
.next
;
1172 /* Call the function BFUN with no arguments, catching errors within it
1173 according to HANDLERS. If there is an error, call HFUN with
1174 one argument which is the data that describes the error:
1177 HANDLERS can be a list of conditions to catch.
1178 If HANDLERS is Qt, catch all errors.
1179 If HANDLERS is Qerror, catch all errors
1180 but allow the debugger to run if that is enabled. */
1183 internal_condition_case (Lisp_Object (*bfun
) (void), Lisp_Object handlers
,
1184 Lisp_Object (*hfun
) (Lisp_Object
))
1192 c
.backlist
= backtrace_list
;
1193 c
.f_handlerlist
= handlerlist
;
1194 c
.f_lisp_eval_depth
= lisp_eval_depth
;
1195 c
.pdlcount
= SPECPDL_INDEX ();
1196 c
.poll_suppress_count
= poll_suppress_count
;
1197 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1198 c
.gcpro
= gcprolist
;
1199 c
.byte_stack
= byte_stack_list
;
1200 if (sys_setjmp (c
.jmp
))
1202 return (*hfun
) (c
.val
);
1206 h
.handler
= handlers
;
1208 h
.next
= handlerlist
;
1214 handlerlist
= h
.next
;
1218 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1221 internal_condition_case_1 (Lisp_Object (*bfun
) (Lisp_Object
), Lisp_Object arg
,
1222 Lisp_Object handlers
, Lisp_Object (*hfun
) (Lisp_Object
))
1230 c
.backlist
= backtrace_list
;
1231 c
.f_handlerlist
= handlerlist
;
1232 c
.f_lisp_eval_depth
= lisp_eval_depth
;
1233 c
.pdlcount
= SPECPDL_INDEX ();
1234 c
.poll_suppress_count
= poll_suppress_count
;
1235 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1236 c
.gcpro
= gcprolist
;
1237 c
.byte_stack
= byte_stack_list
;
1238 if (sys_setjmp (c
.jmp
))
1240 return (*hfun
) (c
.val
);
1244 h
.handler
= handlers
;
1246 h
.next
= handlerlist
;
1250 val
= (*bfun
) (arg
);
1252 handlerlist
= h
.next
;
1256 /* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as
1260 internal_condition_case_2 (Lisp_Object (*bfun
) (Lisp_Object
, Lisp_Object
),
1263 Lisp_Object handlers
,
1264 Lisp_Object (*hfun
) (Lisp_Object
))
1272 c
.backlist
= backtrace_list
;
1273 c
.f_handlerlist
= handlerlist
;
1274 c
.f_lisp_eval_depth
= lisp_eval_depth
;
1275 c
.pdlcount
= SPECPDL_INDEX ();
1276 c
.poll_suppress_count
= poll_suppress_count
;
1277 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1278 c
.gcpro
= gcprolist
;
1279 c
.byte_stack
= byte_stack_list
;
1280 if (sys_setjmp (c
.jmp
))
1282 return (*hfun
) (c
.val
);
1286 h
.handler
= handlers
;
1288 h
.next
= handlerlist
;
1292 val
= (*bfun
) (arg1
, arg2
);
1294 handlerlist
= h
.next
;
1298 /* Like internal_condition_case but call BFUN with NARGS as first,
1299 and ARGS as second argument. */
1302 internal_condition_case_n (Lisp_Object (*bfun
) (ptrdiff_t, Lisp_Object
*),
1305 Lisp_Object handlers
,
1306 Lisp_Object (*hfun
) (Lisp_Object err
,
1316 c
.backlist
= backtrace_list
;
1317 c
.f_handlerlist
= handlerlist
;
1318 c
.f_lisp_eval_depth
= lisp_eval_depth
;
1319 c
.pdlcount
= SPECPDL_INDEX ();
1320 c
.poll_suppress_count
= poll_suppress_count
;
1321 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1322 c
.gcpro
= gcprolist
;
1323 c
.byte_stack
= byte_stack_list
;
1324 if (sys_setjmp (c
.jmp
))
1326 return (*hfun
) (c
.val
, nargs
, args
);
1330 h
.handler
= handlers
;
1332 h
.next
= handlerlist
;
1336 val
= (*bfun
) (nargs
, args
);
1338 handlerlist
= h
.next
;
1343 static Lisp_Object
find_handler_clause (Lisp_Object
, Lisp_Object
);
1344 static bool maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
,
1348 process_quit_flag (void)
1350 Lisp_Object flag
= Vquit_flag
;
1352 if (EQ (flag
, Qkill_emacs
))
1354 if (EQ (Vthrow_on_input
, flag
))
1355 Fthrow (Vthrow_on_input
, Qt
);
1356 Fsignal (Qquit
, Qnil
);
1359 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1360 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1361 This function does not return.
1363 An error symbol is a symbol with an `error-conditions' property
1364 that is a list of condition names.
1365 A handler for any of those names will get to handle this signal.
1366 The symbol `error' should normally be one of them.
1368 DATA should be a list. Its elements are printed as part of the error message.
1369 See Info anchor `(elisp)Definition of signal' for some details on how this
1370 error message is constructed.
1371 If the signal is handled, DATA is made available to the handler.
1372 See also the function `condition-case'. */)
1373 (Lisp_Object error_symbol
, Lisp_Object data
)
1375 /* When memory is full, ERROR-SYMBOL is nil,
1376 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1377 That is a special case--don't do this in other situations. */
1378 Lisp_Object conditions
;
1380 Lisp_Object real_error_symbol
1381 = (NILP (error_symbol
) ? Fcar (data
) : error_symbol
);
1382 register Lisp_Object clause
= Qnil
;
1384 struct backtrace
*bp
;
1388 if (gc_in_progress
|| waiting_for_input
)
1391 #if 0 /* rms: I don't know why this was here,
1392 but it is surely wrong for an error that is handled. */
1393 #ifdef HAVE_WINDOW_SYSTEM
1394 if (display_hourglass_p
)
1395 cancel_hourglass ();
1399 /* This hook is used by edebug. */
1400 if (! NILP (Vsignal_hook_function
)
1401 && ! NILP (error_symbol
))
1403 /* Edebug takes care of restoring these variables when it exits. */
1404 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1405 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1407 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1408 max_specpdl_size
= SPECPDL_INDEX () + 40;
1410 call2 (Vsignal_hook_function
, error_symbol
, data
);
1413 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1415 /* Remember from where signal was called. Skip over the frame for
1416 `signal' itself. If a frame for `error' follows, skip that,
1417 too. Don't do this when ERROR_SYMBOL is nil, because that
1418 is a memory-full error. */
1419 Vsignaling_function
= Qnil
;
1420 if (backtrace_list
&& !NILP (error_symbol
))
1422 bp
= backtrace_list
->next
;
1423 if (bp
&& EQ (bp
->function
, Qerror
))
1426 Vsignaling_function
= bp
->function
;
1429 for (h
= handlerlist
; h
; h
= h
->next
)
1431 clause
= find_handler_clause (h
->handler
, conditions
);
1436 if (/* Don't run the debugger for a memory-full error.
1437 (There is no room in memory to do that!) */
1438 !NILP (error_symbol
)
1439 && (!NILP (Vdebug_on_signal
)
1440 /* If no handler is present now, try to run the debugger. */
1442 /* A `debug' symbol in the handler list disables the normal
1443 suppression of the debugger. */
1444 || (CONSP (clause
) && CONSP (XCAR (clause
))
1445 && !NILP (Fmemq (Qdebug
, XCAR (clause
))))
1446 /* Special handler that means "print a message and run debugger
1448 || EQ (h
->handler
, Qerror
)))
1450 bool debugger_called
1451 = maybe_call_debugger (conditions
, error_symbol
, data
);
1452 /* We can't return values to code which signaled an error, but we
1453 can continue code which has signaled a quit. */
1454 if (debugger_called
&& EQ (real_error_symbol
, Qquit
))
1460 Lisp_Object unwind_data
1461 = (NILP (error_symbol
) ? data
: Fcons (error_symbol
, data
));
1463 h
->chosen_clause
= clause
;
1464 unwind_to_catch (h
->tag
, unwind_data
);
1469 Fthrow (Qtop_level
, Qt
);
1472 if (! NILP (error_symbol
))
1473 data
= Fcons (error_symbol
, data
);
1475 string
= Ferror_message_string (data
);
1476 fatal ("%s", SDATA (string
));
1479 /* Internal version of Fsignal that never returns.
1480 Used for anything but Qquit (which can return from Fsignal). */
1483 xsignal (Lisp_Object error_symbol
, Lisp_Object data
)
1485 Fsignal (error_symbol
, data
);
1489 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1492 xsignal0 (Lisp_Object error_symbol
)
1494 xsignal (error_symbol
, Qnil
);
1498 xsignal1 (Lisp_Object error_symbol
, Lisp_Object arg
)
1500 xsignal (error_symbol
, list1 (arg
));
1504 xsignal2 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
)
1506 xsignal (error_symbol
, list2 (arg1
, arg2
));
1510 xsignal3 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
1512 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1515 /* Signal `error' with message S, and additional arg ARG.
1516 If ARG is not a genuine list, make it a one-element list. */
1519 signal_error (const char *s
, Lisp_Object arg
)
1521 Lisp_Object tortoise
, hare
;
1523 hare
= tortoise
= arg
;
1524 while (CONSP (hare
))
1531 tortoise
= XCDR (tortoise
);
1533 if (EQ (hare
, tortoise
))
1538 arg
= Fcons (arg
, Qnil
); /* Make it a list. */
1540 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1544 /* Return true if LIST is a non-nil atom or
1545 a list containing one of CONDITIONS. */
1548 wants_debugger (Lisp_Object list
, Lisp_Object conditions
)
1555 while (CONSP (conditions
))
1557 Lisp_Object
this, tail
;
1558 this = XCAR (conditions
);
1559 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1560 if (EQ (XCAR (tail
), this))
1562 conditions
= XCDR (conditions
);
1567 /* Return true if an error with condition-symbols CONDITIONS,
1568 and described by SIGNAL-DATA, should skip the debugger
1569 according to debugger-ignored-errors. */
1572 skip_debugger (Lisp_Object conditions
, Lisp_Object data
)
1575 bool first_string
= 1;
1576 Lisp_Object error_message
;
1578 error_message
= Qnil
;
1579 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1581 if (STRINGP (XCAR (tail
)))
1585 error_message
= Ferror_message_string (data
);
1589 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1594 Lisp_Object contail
;
1596 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1597 if (EQ (XCAR (tail
), XCAR (contail
)))
1605 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1606 SIG and DATA describe the signal. There are two ways to pass them:
1607 = SIG is the error symbol, and DATA is the rest of the data.
1608 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1609 This is for memory-full errors only. */
1611 maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
, Lisp_Object data
)
1613 Lisp_Object combined_data
;
1615 combined_data
= Fcons (sig
, data
);
1618 /* Don't try to run the debugger with interrupts blocked.
1619 The editing loop would return anyway. */
1620 ! input_blocked_p ()
1621 && NILP (Vinhibit_debugger
)
1622 /* Does user want to enter debugger for this kind of error? */
1625 : wants_debugger (Vdebug_on_error
, conditions
))
1626 && ! skip_debugger (conditions
, combined_data
)
1627 /* RMS: What's this for? */
1628 && when_entered_debugger
< num_nonmacro_input_events
)
1630 call_debugger (Fcons (Qerror
, Fcons (combined_data
, Qnil
)));
1638 find_handler_clause (Lisp_Object handlers
, Lisp_Object conditions
)
1640 register Lisp_Object h
;
1642 /* t is used by handlers for all conditions, set up by C code. */
1643 if (EQ (handlers
, Qt
))
1646 /* error is used similarly, but means print an error message
1647 and run the debugger if that is enabled. */
1648 if (EQ (handlers
, Qerror
))
1651 for (h
= handlers
; CONSP (h
); h
= XCDR (h
))
1653 Lisp_Object handler
= XCAR (h
);
1654 Lisp_Object condit
, tem
;
1656 if (!CONSP (handler
))
1658 condit
= XCAR (handler
);
1659 /* Handle a single condition name in handler HANDLER. */
1660 if (SYMBOLP (condit
))
1662 tem
= Fmemq (Fcar (handler
), conditions
);
1666 /* Handle a list of condition names in handler HANDLER. */
1667 else if (CONSP (condit
))
1670 for (tail
= condit
; CONSP (tail
); tail
= XCDR (tail
))
1672 tem
= Fmemq (XCAR (tail
), conditions
);
1683 /* Dump an error message; called like vprintf. */
1685 verror (const char *m
, va_list ap
)
1688 ptrdiff_t size
= sizeof buf
;
1689 ptrdiff_t size_max
= STRING_BYTES_BOUND
+ 1;
1694 used
= evxprintf (&buffer
, &size
, buf
, size_max
, m
, ap
);
1695 string
= make_string (buffer
, used
);
1699 xsignal1 (Qerror
, string
);
1703 /* Dump an error message; called like printf. */
1707 error (const char *m
, ...)
1714 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
1715 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
1716 This means it contains a description for how to read arguments to give it.
1717 The value is nil for an invalid function or a symbol with no function
1720 Interactively callable functions include strings and vectors (treated
1721 as keyboard macros), lambda-expressions that contain a top-level call
1722 to `interactive', autoload definitions made by `autoload' with non-nil
1723 fourth argument, and some of the built-in functions of Lisp.
1725 Also, a symbol satisfies `commandp' if its function definition does so.
1727 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
1728 then strings and vectors are not accepted. */)
1729 (Lisp_Object function
, Lisp_Object for_call_interactively
)
1731 register Lisp_Object fun
;
1732 register Lisp_Object funcar
;
1733 Lisp_Object if_prop
= Qnil
;
1737 fun
= indirect_function (fun
); /* Check cycles. */
1741 /* Check an `interactive-form' property if present, analogous to the
1742 function-documentation property. */
1744 while (SYMBOLP (fun
))
1746 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
1749 fun
= Fsymbol_function (fun
);
1752 /* Emacs primitives are interactive if their DEFUN specifies an
1753 interactive spec. */
1755 return XSUBR (fun
)->intspec
? Qt
: if_prop
;
1757 /* Bytecode objects are interactive if they are long enough to
1758 have an element whose index is COMPILED_INTERACTIVE, which is
1759 where the interactive spec is stored. */
1760 else if (COMPILEDP (fun
))
1761 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
1764 /* Strings and vectors are keyboard macros. */
1765 if (STRINGP (fun
) || VECTORP (fun
))
1766 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
1768 /* Lists may represent commands. */
1771 funcar
= XCAR (fun
);
1772 if (EQ (funcar
, Qclosure
))
1773 return (!NILP (Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
)))))
1775 else if (EQ (funcar
, Qlambda
))
1776 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
1777 else if (EQ (funcar
, Qautoload
))
1778 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
1783 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1784 doc
: /* Define FUNCTION to autoload from FILE.
1785 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
1786 Third arg DOCSTRING is documentation for the function.
1787 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
1788 Fifth arg TYPE indicates the type of the object:
1789 nil or omitted says FUNCTION is a function,
1790 `keymap' says FUNCTION is really a keymap, and
1791 `macro' or t says FUNCTION is really a macro.
1792 Third through fifth args give info about the real definition.
1793 They default to nil.
1794 If FUNCTION is already defined other than as an autoload,
1795 this does nothing and returns nil. */)
1796 (Lisp_Object function
, Lisp_Object file
, Lisp_Object docstring
, Lisp_Object interactive
, Lisp_Object type
)
1798 CHECK_SYMBOL (function
);
1799 CHECK_STRING (file
);
1801 /* If function is defined and not as an autoload, don't override. */
1802 if (!NILP (XSYMBOL (function
)->function
)
1803 && !AUTOLOADP (XSYMBOL (function
)->function
))
1806 if (!NILP (Vpurify_flag
) && EQ (docstring
, make_number (0)))
1807 /* `read1' in lread.c has found the docstring starting with "\
1808 and assumed the docstring will be provided by Snarf-documentation, so it
1809 passed us 0 instead. But that leads to accidental sharing in purecopy's
1810 hash-consing, so we use a (hopefully) unique integer instead. */
1811 docstring
= make_number (XHASH (function
));
1812 return Fdefalias (function
,
1813 list5 (Qautoload
, file
, docstring
, interactive
, type
),
1818 un_autoload (Lisp_Object oldqueue
)
1820 register Lisp_Object queue
, first
, second
;
1822 /* Queue to unwind is current value of Vautoload_queue.
1823 oldqueue is the shadowed value to leave in Vautoload_queue. */
1824 queue
= Vautoload_queue
;
1825 Vautoload_queue
= oldqueue
;
1826 while (CONSP (queue
))
1828 first
= XCAR (queue
);
1829 second
= Fcdr (first
);
1830 first
= Fcar (first
);
1831 if (EQ (first
, make_number (0)))
1834 Ffset (first
, second
);
1835 queue
= XCDR (queue
);
1840 /* Load an autoloaded function.
1841 FUNNAME is the symbol which is the function's name.
1842 FUNDEF is the autoload definition (a list). */
1844 DEFUN ("autoload-do-load", Fautoload_do_load
, Sautoload_do_load
, 1, 3, 0,
1845 doc
: /* Load FUNDEF which should be an autoload.
1846 If non-nil, FUNNAME should be the symbol whose function value is FUNDEF,
1847 in which case the function returns the new autoloaded function value.
1848 If equal to `macro', MACRO-ONLY specifies that FUNDEF should only be loaded if
1849 it is defines a macro. */)
1850 (Lisp_Object fundef
, Lisp_Object funname
, Lisp_Object macro_only
)
1852 ptrdiff_t count
= SPECPDL_INDEX ();
1853 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1855 if (!CONSP (fundef
) || !EQ (Qautoload
, XCAR (fundef
)))
1858 if (EQ (macro_only
, Qmacro
))
1860 Lisp_Object kind
= Fnth (make_number (4), fundef
);
1861 if (! (EQ (kind
, Qt
) || EQ (kind
, Qmacro
)))
1865 /* This is to make sure that loadup.el gives a clear picture
1866 of what files are preloaded and when. */
1867 if (! NILP (Vpurify_flag
))
1868 error ("Attempt to autoload %s while preparing to dump",
1869 SDATA (SYMBOL_NAME (funname
)));
1871 CHECK_SYMBOL (funname
);
1872 GCPRO3 (funname
, fundef
, macro_only
);
1874 /* Preserve the match data. */
1875 record_unwind_save_match_data ();
1877 /* If autoloading gets an error (which includes the error of failing
1878 to define the function being called), we use Vautoload_queue
1879 to undo function definitions and `provide' calls made by
1880 the function. We do this in the specific case of autoloading
1881 because autoloading is not an explicit request "load this file",
1882 but rather a request to "call this function".
1884 The value saved here is to be restored into Vautoload_queue. */
1885 record_unwind_protect (un_autoload
, Vautoload_queue
);
1886 Vautoload_queue
= Qt
;
1887 /* If `macro_only', assume this autoload to be a "best-effort",
1888 so don't signal an error if autoloading fails. */
1889 Fload (Fcar (Fcdr (fundef
)), macro_only
, Qt
, Qnil
, Qt
);
1891 /* Once loading finishes, don't undo it. */
1892 Vautoload_queue
= Qt
;
1893 unbind_to (count
, Qnil
);
1901 Lisp_Object fun
= Findirect_function (funname
, Qnil
);
1903 if (!NILP (Fequal (fun
, fundef
)))
1904 error ("Autoloading failed to define function %s",
1905 SDATA (SYMBOL_NAME (funname
)));
1912 DEFUN ("eval", Feval
, Seval
, 1, 2, 0,
1913 doc
: /* Evaluate FORM and return its value.
1914 If LEXICAL is t, evaluate using lexical scoping. */)
1915 (Lisp_Object form
, Lisp_Object lexical
)
1917 ptrdiff_t count
= SPECPDL_INDEX ();
1918 specbind (Qinternal_interpreter_environment
,
1919 CONSP (lexical
) || NILP (lexical
) ? lexical
: Fcons (Qt
, Qnil
));
1920 return unbind_to (count
, eval_sub (form
));
1923 /* Eval a sub-expression of the current expression (i.e. in the same
1926 eval_sub (Lisp_Object form
)
1928 Lisp_Object fun
, val
, original_fun
, original_args
;
1930 struct backtrace backtrace
;
1931 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1935 /* Look up its binding in the lexical environment.
1936 We do not pay attention to the declared_special flag here, since we
1937 already did that when let-binding the variable. */
1938 Lisp_Object lex_binding
1939 = !NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
1940 ? Fassq (form
, Vinternal_interpreter_environment
)
1942 if (CONSP (lex_binding
))
1943 return XCDR (lex_binding
);
1945 return Fsymbol_value (form
);
1957 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1959 if (max_lisp_eval_depth
< 100)
1960 max_lisp_eval_depth
= 100;
1961 if (lisp_eval_depth
> max_lisp_eval_depth
)
1962 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
1965 original_fun
= XCAR (form
);
1966 original_args
= XCDR (form
);
1968 backtrace
.next
= backtrace_list
;
1969 backtrace
.function
= original_fun
; /* This also protects them from gc. */
1970 backtrace
.args
= &original_args
;
1971 backtrace
.nargs
= UNEVALLED
;
1972 backtrace
.debug_on_exit
= 0;
1973 backtrace_list
= &backtrace
;
1975 if (debug_on_next_call
)
1976 do_debug_on_call (Qt
);
1978 /* At this point, only original_fun and original_args
1979 have values that will be used below. */
1982 /* Optimize for no indirection. */
1984 if (SYMBOLP (fun
) && !NILP (fun
)
1985 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
1986 fun
= indirect_function (fun
);
1990 Lisp_Object numargs
;
1991 Lisp_Object argvals
[8];
1992 Lisp_Object args_left
;
1993 register int i
, maxargs
;
1995 args_left
= original_args
;
1996 numargs
= Flength (args_left
);
2000 if (XINT (numargs
) < XSUBR (fun
)->min_args
2001 || (XSUBR (fun
)->max_args
>= 0
2002 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2003 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2005 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2006 val
= (XSUBR (fun
)->function
.aUNEVALLED
) (args_left
);
2007 else if (XSUBR (fun
)->max_args
== MANY
)
2009 /* Pass a vector of evaluated arguments. */
2011 ptrdiff_t argnum
= 0;
2014 SAFE_ALLOCA_LISP (vals
, XINT (numargs
));
2016 GCPRO3 (args_left
, fun
, fun
);
2020 while (!NILP (args_left
))
2022 vals
[argnum
++] = eval_sub (Fcar (args_left
));
2023 args_left
= Fcdr (args_left
);
2024 gcpro3
.nvars
= argnum
;
2027 backtrace
.args
= vals
;
2028 backtrace
.nargs
= XINT (numargs
);
2030 val
= (XSUBR (fun
)->function
.aMANY
) (XINT (numargs
), vals
);
2036 GCPRO3 (args_left
, fun
, fun
);
2037 gcpro3
.var
= argvals
;
2040 maxargs
= XSUBR (fun
)->max_args
;
2041 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
2043 argvals
[i
] = eval_sub (Fcar (args_left
));
2049 backtrace
.args
= argvals
;
2050 backtrace
.nargs
= XINT (numargs
);
2055 val
= (XSUBR (fun
)->function
.a0 ());
2058 val
= (XSUBR (fun
)->function
.a1 (argvals
[0]));
2061 val
= (XSUBR (fun
)->function
.a2 (argvals
[0], argvals
[1]));
2064 val
= (XSUBR (fun
)->function
.a3
2065 (argvals
[0], argvals
[1], argvals
[2]));
2068 val
= (XSUBR (fun
)->function
.a4
2069 (argvals
[0], argvals
[1], argvals
[2], argvals
[3]));
2072 val
= (XSUBR (fun
)->function
.a5
2073 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2077 val
= (XSUBR (fun
)->function
.a6
2078 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2079 argvals
[4], argvals
[5]));
2082 val
= (XSUBR (fun
)->function
.a7
2083 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2084 argvals
[4], argvals
[5], argvals
[6]));
2088 val
= (XSUBR (fun
)->function
.a8
2089 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2090 argvals
[4], argvals
[5], argvals
[6], argvals
[7]));
2094 /* Someone has created a subr that takes more arguments than
2095 is supported by this code. We need to either rewrite the
2096 subr to use a different argument protocol, or add more
2097 cases to this switch. */
2102 else if (COMPILEDP (fun
))
2103 val
= apply_lambda (fun
, original_args
);
2107 xsignal1 (Qvoid_function
, original_fun
);
2109 xsignal1 (Qinvalid_function
, original_fun
);
2110 funcar
= XCAR (fun
);
2111 if (!SYMBOLP (funcar
))
2112 xsignal1 (Qinvalid_function
, original_fun
);
2113 if (EQ (funcar
, Qautoload
))
2115 Fautoload_do_load (fun
, original_fun
, Qnil
);
2118 if (EQ (funcar
, Qmacro
))
2120 ptrdiff_t count
= SPECPDL_INDEX ();
2122 /* Bind lexical-binding during expansion of the macro, so the
2123 macro can know reliably if the code it outputs will be
2124 interpreted using lexical-binding or not. */
2125 specbind (Qlexical_binding
,
2126 NILP (Vinternal_interpreter_environment
) ? Qnil
: Qt
);
2127 exp
= apply1 (Fcdr (fun
), original_args
);
2128 unbind_to (count
, Qnil
);
2129 val
= eval_sub (exp
);
2131 else if (EQ (funcar
, Qlambda
)
2132 || EQ (funcar
, Qclosure
))
2133 val
= apply_lambda (fun
, original_args
);
2135 xsignal1 (Qinvalid_function
, original_fun
);
2140 if (backtrace
.debug_on_exit
)
2141 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2142 backtrace_list
= backtrace
.next
;
2147 DEFUN ("apply", Fapply
, Sapply
, 1, MANY
, 0,
2148 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2149 Then return the value FUNCTION returns.
2150 Thus, (apply '+ 1 2 '(3 4)) returns 10.
2151 usage: (apply FUNCTION &rest ARGUMENTS) */)
2152 (ptrdiff_t nargs
, Lisp_Object
*args
)
2156 register Lisp_Object spread_arg
;
2157 register Lisp_Object
*funcall_args
;
2158 Lisp_Object fun
, retval
;
2159 struct gcpro gcpro1
;
2164 spread_arg
= args
[nargs
- 1];
2165 CHECK_LIST (spread_arg
);
2167 numargs
= XINT (Flength (spread_arg
));
2170 return Ffuncall (nargs
- 1, args
);
2171 else if (numargs
== 1)
2173 args
[nargs
- 1] = XCAR (spread_arg
);
2174 return Ffuncall (nargs
, args
);
2177 numargs
+= nargs
- 2;
2179 /* Optimize for no indirection. */
2180 if (SYMBOLP (fun
) && !NILP (fun
)
2181 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2182 fun
= indirect_function (fun
);
2185 /* Let funcall get the error. */
2192 if (numargs
< XSUBR (fun
)->min_args
2193 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2194 goto funcall
; /* Let funcall get the error. */
2195 else if (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
> numargs
)
2197 /* Avoid making funcall cons up a yet another new vector of arguments
2198 by explicitly supplying nil's for optional values. */
2199 SAFE_ALLOCA_LISP (funcall_args
, 1 + XSUBR (fun
)->max_args
);
2200 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2201 funcall_args
[++i
] = Qnil
;
2202 GCPRO1 (*funcall_args
);
2203 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2207 /* We add 1 to numargs because funcall_args includes the
2208 function itself as well as its arguments. */
2211 SAFE_ALLOCA_LISP (funcall_args
, 1 + numargs
);
2212 GCPRO1 (*funcall_args
);
2213 gcpro1
.nvars
= 1 + numargs
;
2216 memcpy (funcall_args
, args
, nargs
* word_size
);
2217 /* Spread the last arg we got. Its first element goes in
2218 the slot that it used to occupy, hence this value of I. */
2220 while (!NILP (spread_arg
))
2222 funcall_args
[i
++] = XCAR (spread_arg
);
2223 spread_arg
= XCDR (spread_arg
);
2226 /* By convention, the caller needs to gcpro Ffuncall's args. */
2227 retval
= Ffuncall (gcpro1
.nvars
, funcall_args
);
2234 /* Run hook variables in various ways. */
2237 funcall_nil (ptrdiff_t nargs
, Lisp_Object
*args
)
2239 Ffuncall (nargs
, args
);
2243 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2244 doc
: /* Run each hook in HOOKS.
2245 Each argument should be a symbol, a hook variable.
2246 These symbols are processed in the order specified.
2247 If a hook symbol has a non-nil value, that value may be a function
2248 or a list of functions to be called to run the hook.
2249 If the value is a function, it is called with no arguments.
2250 If it is a list, the elements are called, in order, with no arguments.
2252 Major modes should not use this function directly to run their mode
2253 hook; they should use `run-mode-hooks' instead.
2255 Do not use `make-local-variable' to make a hook variable buffer-local.
2256 Instead, use `add-hook' and specify t for the LOCAL argument.
2257 usage: (run-hooks &rest HOOKS) */)
2258 (ptrdiff_t nargs
, Lisp_Object
*args
)
2260 Lisp_Object hook
[1];
2263 for (i
= 0; i
< nargs
; i
++)
2266 run_hook_with_args (1, hook
, funcall_nil
);
2272 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2273 Srun_hook_with_args
, 1, MANY
, 0,
2274 doc
: /* Run HOOK with the specified arguments ARGS.
2275 HOOK should be a symbol, a hook variable. The value of HOOK
2276 may be nil, a function, or a list of functions. Call each
2277 function in order with arguments ARGS. The final return value
2280 Do not use `make-local-variable' to make a hook variable buffer-local.
2281 Instead, use `add-hook' and specify t for the LOCAL argument.
2282 usage: (run-hook-with-args HOOK &rest ARGS) */)
2283 (ptrdiff_t nargs
, Lisp_Object
*args
)
2285 return run_hook_with_args (nargs
, args
, funcall_nil
);
2288 /* NB this one still documents a specific non-nil return value.
2289 (As did run-hook-with-args and run-hook-with-args-until-failure
2290 until they were changed in 24.1.) */
2291 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2292 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2293 doc
: /* Run HOOK with the specified arguments ARGS.
2294 HOOK should be a symbol, a hook variable. The value of HOOK
2295 may be nil, a function, or a list of functions. Call each
2296 function in order with arguments ARGS, stopping at the first
2297 one that returns non-nil, and return that value. Otherwise (if
2298 all functions return nil, or if there are no functions to call),
2301 Do not use `make-local-variable' to make a hook variable buffer-local.
2302 Instead, use `add-hook' and specify t for the LOCAL argument.
2303 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2304 (ptrdiff_t nargs
, Lisp_Object
*args
)
2306 return run_hook_with_args (nargs
, args
, Ffuncall
);
2310 funcall_not (ptrdiff_t nargs
, Lisp_Object
*args
)
2312 return NILP (Ffuncall (nargs
, args
)) ? Qt
: Qnil
;
2315 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2316 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2317 doc
: /* Run HOOK with the specified arguments ARGS.
2318 HOOK should be a symbol, a hook variable. The value of HOOK
2319 may be nil, a function, or a list of functions. Call each
2320 function in order with arguments ARGS, stopping at the first
2321 one that returns nil, and return nil. Otherwise (if all functions
2322 return non-nil, or if there are no functions to call), return non-nil
2323 \(do not rely on the precise return value in this case).
2325 Do not use `make-local-variable' to make a hook variable buffer-local.
2326 Instead, use `add-hook' and specify t for the LOCAL argument.
2327 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2328 (ptrdiff_t nargs
, Lisp_Object
*args
)
2330 return NILP (run_hook_with_args (nargs
, args
, funcall_not
)) ? Qt
: Qnil
;
2334 run_hook_wrapped_funcall (ptrdiff_t nargs
, Lisp_Object
*args
)
2336 Lisp_Object tmp
= args
[0], ret
;
2339 ret
= Ffuncall (nargs
, args
);
2345 DEFUN ("run-hook-wrapped", Frun_hook_wrapped
, Srun_hook_wrapped
, 2, MANY
, 0,
2346 doc
: /* Run HOOK, passing each function through WRAP-FUNCTION.
2347 I.e. instead of calling each function FUN directly with arguments ARGS,
2348 it calls WRAP-FUNCTION with arguments FUN and ARGS.
2349 As soon as a call to WRAP-FUNCTION returns non-nil, `run-hook-wrapped'
2350 aborts and returns that value.
2351 usage: (run-hook-wrapped HOOK WRAP-FUNCTION &rest ARGS) */)
2352 (ptrdiff_t nargs
, Lisp_Object
*args
)
2354 return run_hook_with_args (nargs
, args
, run_hook_wrapped_funcall
);
2357 /* ARGS[0] should be a hook symbol.
2358 Call each of the functions in the hook value, passing each of them
2359 as arguments all the rest of ARGS (all NARGS - 1 elements).
2360 FUNCALL specifies how to call each function on the hook.
2361 The caller (or its caller, etc) must gcpro all of ARGS,
2362 except that it isn't necessary to gcpro ARGS[0]. */
2365 run_hook_with_args (ptrdiff_t nargs
, Lisp_Object
*args
,
2366 Lisp_Object (*funcall
) (ptrdiff_t nargs
, Lisp_Object
*args
))
2368 Lisp_Object sym
, val
, ret
= Qnil
;
2369 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2371 /* If we are dying or still initializing,
2372 don't do anything--it would probably crash if we tried. */
2373 if (NILP (Vrun_hooks
))
2377 val
= find_symbol_value (sym
);
2379 if (EQ (val
, Qunbound
) || NILP (val
))
2381 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2384 return funcall (nargs
, args
);
2388 Lisp_Object global_vals
= Qnil
;
2389 GCPRO3 (sym
, val
, global_vals
);
2392 CONSP (val
) && NILP (ret
);
2395 if (EQ (XCAR (val
), Qt
))
2397 /* t indicates this hook has a local binding;
2398 it means to run the global binding too. */
2399 global_vals
= Fdefault_value (sym
);
2400 if (NILP (global_vals
)) continue;
2402 if (!CONSP (global_vals
) || EQ (XCAR (global_vals
), Qlambda
))
2404 args
[0] = global_vals
;
2405 ret
= funcall (nargs
, args
);
2410 CONSP (global_vals
) && NILP (ret
);
2411 global_vals
= XCDR (global_vals
))
2413 args
[0] = XCAR (global_vals
);
2414 /* In a global value, t should not occur. If it does, we
2415 must ignore it to avoid an endless loop. */
2416 if (!EQ (args
[0], Qt
))
2417 ret
= funcall (nargs
, args
);
2423 args
[0] = XCAR (val
);
2424 ret
= funcall (nargs
, args
);
2433 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2436 run_hook_with_args_2 (Lisp_Object hook
, Lisp_Object arg1
, Lisp_Object arg2
)
2438 Lisp_Object temp
[3];
2443 Frun_hook_with_args (3, temp
);
2446 /* Apply fn to arg. */
2448 apply1 (Lisp_Object fn
, Lisp_Object arg
)
2450 struct gcpro gcpro1
;
2454 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2457 Lisp_Object args
[2];
2461 RETURN_UNGCPRO (Fapply (2, args
));
2465 /* Call function fn on no arguments. */
2467 call0 (Lisp_Object fn
)
2469 struct gcpro gcpro1
;
2472 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2475 /* Call function fn with 1 argument arg1. */
2478 call1 (Lisp_Object fn
, Lisp_Object arg1
)
2480 struct gcpro gcpro1
;
2481 Lisp_Object args
[2];
2487 RETURN_UNGCPRO (Ffuncall (2, args
));
2490 /* Call function fn with 2 arguments arg1, arg2. */
2493 call2 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
)
2495 struct gcpro gcpro1
;
2496 Lisp_Object args
[3];
2502 RETURN_UNGCPRO (Ffuncall (3, args
));
2505 /* Call function fn with 3 arguments arg1, arg2, arg3. */
2508 call3 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2510 struct gcpro gcpro1
;
2511 Lisp_Object args
[4];
2518 RETURN_UNGCPRO (Ffuncall (4, args
));
2521 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
2524 call4 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2527 struct gcpro gcpro1
;
2528 Lisp_Object args
[5];
2536 RETURN_UNGCPRO (Ffuncall (5, args
));
2539 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
2542 call5 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2543 Lisp_Object arg4
, Lisp_Object arg5
)
2545 struct gcpro gcpro1
;
2546 Lisp_Object args
[6];
2555 RETURN_UNGCPRO (Ffuncall (6, args
));
2558 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
2561 call6 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2562 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
)
2564 struct gcpro gcpro1
;
2565 Lisp_Object args
[7];
2575 RETURN_UNGCPRO (Ffuncall (7, args
));
2578 /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
2581 call7 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2582 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
)
2584 struct gcpro gcpro1
;
2585 Lisp_Object args
[8];
2596 RETURN_UNGCPRO (Ffuncall (8, args
));
2599 /* The caller should GCPRO all the elements of ARGS. */
2601 DEFUN ("functionp", Ffunctionp
, Sfunctionp
, 1, 1, 0,
2602 doc
: /* Non-nil if OBJECT is a function. */)
2603 (Lisp_Object object
)
2605 if (FUNCTIONP (object
))
2610 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2611 doc
: /* Call first argument as a function, passing remaining arguments to it.
2612 Return the value that function returns.
2613 Thus, (funcall 'cons 'x 'y) returns (x . y).
2614 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2615 (ptrdiff_t nargs
, Lisp_Object
*args
)
2617 Lisp_Object fun
, original_fun
;
2619 ptrdiff_t numargs
= nargs
- 1;
2620 Lisp_Object lisp_numargs
;
2622 struct backtrace backtrace
;
2623 register Lisp_Object
*internal_args
;
2628 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2630 if (max_lisp_eval_depth
< 100)
2631 max_lisp_eval_depth
= 100;
2632 if (lisp_eval_depth
> max_lisp_eval_depth
)
2633 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2636 backtrace
.next
= backtrace_list
;
2637 backtrace
.function
= args
[0];
2638 backtrace
.args
= &args
[1]; /* This also GCPROs them. */
2639 backtrace
.nargs
= nargs
- 1;
2640 backtrace
.debug_on_exit
= 0;
2641 backtrace_list
= &backtrace
;
2643 /* Call GC after setting up the backtrace, so the latter GCPROs the args. */
2646 if (debug_on_next_call
)
2647 do_debug_on_call (Qlambda
);
2651 original_fun
= args
[0];
2655 /* Optimize for no indirection. */
2657 if (SYMBOLP (fun
) && !NILP (fun
)
2658 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2659 fun
= indirect_function (fun
);
2663 if (numargs
< XSUBR (fun
)->min_args
2664 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2666 XSETFASTINT (lisp_numargs
, numargs
);
2667 xsignal2 (Qwrong_number_of_arguments
, original_fun
, lisp_numargs
);
2670 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2671 xsignal1 (Qinvalid_function
, original_fun
);
2673 else if (XSUBR (fun
)->max_args
== MANY
)
2674 val
= (XSUBR (fun
)->function
.aMANY
) (numargs
, args
+ 1);
2677 if (XSUBR (fun
)->max_args
> numargs
)
2679 internal_args
= alloca (XSUBR (fun
)->max_args
2680 * sizeof *internal_args
);
2681 memcpy (internal_args
, args
+ 1, numargs
* word_size
);
2682 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2683 internal_args
[i
] = Qnil
;
2686 internal_args
= args
+ 1;
2687 switch (XSUBR (fun
)->max_args
)
2690 val
= (XSUBR (fun
)->function
.a0 ());
2693 val
= (XSUBR (fun
)->function
.a1 (internal_args
[0]));
2696 val
= (XSUBR (fun
)->function
.a2
2697 (internal_args
[0], internal_args
[1]));
2700 val
= (XSUBR (fun
)->function
.a3
2701 (internal_args
[0], internal_args
[1], internal_args
[2]));
2704 val
= (XSUBR (fun
)->function
.a4
2705 (internal_args
[0], internal_args
[1], internal_args
[2],
2709 val
= (XSUBR (fun
)->function
.a5
2710 (internal_args
[0], internal_args
[1], internal_args
[2],
2711 internal_args
[3], internal_args
[4]));
2714 val
= (XSUBR (fun
)->function
.a6
2715 (internal_args
[0], internal_args
[1], internal_args
[2],
2716 internal_args
[3], internal_args
[4], internal_args
[5]));
2719 val
= (XSUBR (fun
)->function
.a7
2720 (internal_args
[0], internal_args
[1], internal_args
[2],
2721 internal_args
[3], internal_args
[4], internal_args
[5],
2726 val
= (XSUBR (fun
)->function
.a8
2727 (internal_args
[0], internal_args
[1], internal_args
[2],
2728 internal_args
[3], internal_args
[4], internal_args
[5],
2729 internal_args
[6], internal_args
[7]));
2734 /* If a subr takes more than 8 arguments without using MANY
2735 or UNEVALLED, we need to extend this function to support it.
2736 Until this is done, there is no way to call the function. */
2741 else if (COMPILEDP (fun
))
2742 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2746 xsignal1 (Qvoid_function
, original_fun
);
2748 xsignal1 (Qinvalid_function
, original_fun
);
2749 funcar
= XCAR (fun
);
2750 if (!SYMBOLP (funcar
))
2751 xsignal1 (Qinvalid_function
, original_fun
);
2752 if (EQ (funcar
, Qlambda
)
2753 || EQ (funcar
, Qclosure
))
2754 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2755 else if (EQ (funcar
, Qautoload
))
2757 Fautoload_do_load (fun
, original_fun
, Qnil
);
2762 xsignal1 (Qinvalid_function
, original_fun
);
2766 if (backtrace
.debug_on_exit
)
2767 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2768 backtrace_list
= backtrace
.next
;
2773 apply_lambda (Lisp_Object fun
, Lisp_Object args
)
2775 Lisp_Object args_left
;
2778 register Lisp_Object
*arg_vector
;
2779 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2780 register Lisp_Object tem
;
2783 numargs
= XFASTINT (Flength (args
));
2784 SAFE_ALLOCA_LISP (arg_vector
, numargs
);
2787 GCPRO3 (*arg_vector
, args_left
, fun
);
2790 for (i
= 0; i
< numargs
; )
2792 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2793 tem
= eval_sub (tem
);
2794 arg_vector
[i
++] = tem
;
2800 backtrace_list
->args
= arg_vector
;
2801 backtrace_list
->nargs
= i
;
2802 tem
= funcall_lambda (fun
, numargs
, arg_vector
);
2804 /* Do the debug-on-exit now, while arg_vector still exists. */
2805 if (backtrace_list
->debug_on_exit
)
2806 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
2807 /* Don't do it again when we return to eval. */
2808 backtrace_list
->debug_on_exit
= 0;
2813 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2814 and return the result of evaluation.
2815 FUN must be either a lambda-expression or a compiled-code object. */
2818 funcall_lambda (Lisp_Object fun
, ptrdiff_t nargs
,
2819 register Lisp_Object
*arg_vector
)
2821 Lisp_Object val
, syms_left
, next
, lexenv
;
2822 ptrdiff_t count
= SPECPDL_INDEX ();
2824 bool optional
, rest
;
2828 if (EQ (XCAR (fun
), Qclosure
))
2830 fun
= XCDR (fun
); /* Drop `closure'. */
2831 lexenv
= XCAR (fun
);
2832 CHECK_LIST_CONS (fun
, fun
);
2836 syms_left
= XCDR (fun
);
2837 if (CONSP (syms_left
))
2838 syms_left
= XCAR (syms_left
);
2840 xsignal1 (Qinvalid_function
, fun
);
2842 else if (COMPILEDP (fun
))
2844 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
2845 if (INTEGERP (syms_left
))
2846 /* A byte-code object with a non-nil `push args' slot means we
2847 shouldn't bind any arguments, instead just call the byte-code
2848 interpreter directly; it will push arguments as necessary.
2850 Byte-code objects with either a non-existent, or a nil value for
2851 the `push args' slot (the default), have dynamically-bound
2852 arguments, and use the argument-binding code below instead (as do
2853 all interpreted functions, even lexically bound ones). */
2855 /* If we have not actually read the bytecode string
2856 and constants vector yet, fetch them from the file. */
2857 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
2858 Ffetch_bytecode (fun
);
2859 return exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
2860 AREF (fun
, COMPILED_CONSTANTS
),
2861 AREF (fun
, COMPILED_STACK_DEPTH
),
2870 i
= optional
= rest
= 0;
2871 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
2875 next
= XCAR (syms_left
);
2876 if (!SYMBOLP (next
))
2877 xsignal1 (Qinvalid_function
, fun
);
2879 if (EQ (next
, Qand_rest
))
2881 else if (EQ (next
, Qand_optional
))
2888 arg
= Flist (nargs
- i
, &arg_vector
[i
]);
2892 arg
= arg_vector
[i
++];
2894 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
2898 /* Bind the argument. */
2899 if (!NILP (lexenv
) && SYMBOLP (next
))
2900 /* Lexically bind NEXT by adding it to the lexenv alist. */
2901 lexenv
= Fcons (Fcons (next
, arg
), lexenv
);
2903 /* Dynamically bind NEXT. */
2904 specbind (next
, arg
);
2908 if (!NILP (syms_left
))
2909 xsignal1 (Qinvalid_function
, fun
);
2911 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
2913 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
2914 /* Instantiate a new lexical environment. */
2915 specbind (Qinternal_interpreter_environment
, lexenv
);
2918 val
= Fprogn (XCDR (XCDR (fun
)));
2921 /* If we have not actually read the bytecode string
2922 and constants vector yet, fetch them from the file. */
2923 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
2924 Ffetch_bytecode (fun
);
2925 val
= exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
2926 AREF (fun
, COMPILED_CONSTANTS
),
2927 AREF (fun
, COMPILED_STACK_DEPTH
),
2931 return unbind_to (count
, val
);
2934 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
2936 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
2937 (Lisp_Object object
)
2941 if (COMPILEDP (object
) && CONSP (AREF (object
, COMPILED_BYTECODE
)))
2943 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
2946 tem
= AREF (object
, COMPILED_BYTECODE
);
2947 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
2948 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
2950 error ("Invalid byte code");
2952 ASET (object
, COMPILED_BYTECODE
, XCAR (tem
));
2953 ASET (object
, COMPILED_CONSTANTS
, XCDR (tem
));
2961 register ptrdiff_t count
= SPECPDL_INDEX ();
2962 ptrdiff_t max_size
= min (max_specpdl_size
, PTRDIFF_MAX
);
2963 if (max_size
<= specpdl_size
)
2965 if (max_specpdl_size
< 400)
2966 max_size
= max_specpdl_size
= 400;
2967 if (max_size
<= specpdl_size
)
2968 signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil
);
2970 specpdl
= xpalloc (specpdl
, &specpdl_size
, 1, max_size
, sizeof *specpdl
);
2971 specpdl_ptr
= specpdl
+ count
;
2975 binding_symbol (const struct specbinding
*bind
)
2977 if (!CONSP (bind
->symbol
))
2978 return bind
->symbol
;
2979 return XCAR (bind
->symbol
);
2983 do_specbind (struct Lisp_Symbol
*sym
, struct specbinding
*bind
,
2986 switch (sym
->redirect
)
2988 case SYMBOL_PLAINVAL
:
2990 SET_SYMBOL_VAL (sym
, value
);
2992 set_internal (bind
->symbol
, value
, Qnil
, 1);
2995 case SYMBOL_LOCALIZED
:
2996 case SYMBOL_FORWARDED
:
2997 if ((sym
->redirect
== SYMBOL_LOCALIZED
2998 || BUFFER_OBJFWDP (SYMBOL_FWD (sym
)))
2999 && CONSP (bind
->symbol
))
3003 where
= XCAR (XCDR (bind
->symbol
));
3005 && sym
->redirect
== SYMBOL_FORWARDED
)
3007 Fset_default (XCAR (bind
->symbol
), value
);
3012 set_internal (binding_symbol (bind
), value
, Qnil
, 1);
3020 /* `specpdl_ptr->symbol' is a field which describes which variable is
3021 let-bound, so it can be properly undone when we unbind_to.
3022 It can have the following two shapes:
3023 - SYMBOL : if it's a plain symbol, it means that we have let-bound
3024 a symbol that is not buffer-local (at least at the time
3025 the let binding started). Note also that it should not be
3026 aliased (i.e. when let-binding V1 that's aliased to V2, we want
3028 - (SYMBOL WHERE . BUFFER) : this means that it is a let-binding for
3029 variable SYMBOL which can be buffer-local. WHERE tells us
3030 which buffer is affected (or nil if the let-binding affects the
3031 global value of the variable) and BUFFER tells us which buffer was
3032 current (i.e. if WHERE is non-nil, then BUFFER==WHERE, otherwise
3033 BUFFER did not yet have a buffer-local value). */
3036 specbind (Lisp_Object symbol
, Lisp_Object value
)
3038 struct Lisp_Symbol
*sym
;
3040 CHECK_SYMBOL (symbol
);
3041 sym
= XSYMBOL (symbol
);
3042 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3046 switch (sym
->redirect
)
3048 case SYMBOL_VARALIAS
:
3049 sym
= indirect_variable (sym
); XSETSYMBOL (symbol
, sym
); goto start
;
3050 case SYMBOL_PLAINVAL
:
3051 /* The most common case is that of a non-constant symbol with a
3052 trivial value. Make that as fast as we can. */
3053 set_specpdl_symbol (symbol
);
3054 set_specpdl_old_value (SYMBOL_VAL (sym
));
3055 specpdl_ptr
->func
= NULL
;
3056 specpdl_ptr
->saved_value
= Qnil
;
3058 do_specbind (sym
, specpdl_ptr
- 1, value
);
3060 case SYMBOL_LOCALIZED
:
3061 if (SYMBOL_BLV (sym
)->frame_local
)
3062 error ("Frame-local vars cannot be let-bound");
3063 case SYMBOL_FORWARDED
:
3065 Lisp_Object ovalue
= find_symbol_value (symbol
);
3066 specpdl_ptr
->func
= 0;
3067 set_specpdl_old_value (ovalue
);
3069 eassert (sym
->redirect
!= SYMBOL_LOCALIZED
3070 || (EQ (SYMBOL_BLV (sym
)->where
,
3071 SYMBOL_BLV (sym
)->frame_local
?
3072 Fselected_frame () : Fcurrent_buffer ())));
3074 if (sym
->redirect
== SYMBOL_LOCALIZED
3075 || BUFFER_OBJFWDP (SYMBOL_FWD (sym
)))
3077 Lisp_Object where
, cur_buf
= Fcurrent_buffer ();
3079 /* For a local variable, record both the symbol and which
3080 buffer's or frame's value we are saving. */
3081 if (!NILP (Flocal_variable_p (symbol
, Qnil
)))
3083 eassert (sym
->redirect
!= SYMBOL_LOCALIZED
3084 || (blv_found (SYMBOL_BLV (sym
))
3085 && EQ (cur_buf
, SYMBOL_BLV (sym
)->where
)));
3088 else if (sym
->redirect
== SYMBOL_LOCALIZED
3089 && blv_found (SYMBOL_BLV (sym
)))
3090 where
= SYMBOL_BLV (sym
)->where
;
3094 /* We're not using the `unused' slot in the specbinding
3095 structure because this would mean we have to do more
3096 work for simple variables. */
3097 /* FIXME: The third value `current_buffer' is only used in
3098 let_shadows_buffer_binding_p which is itself only used
3099 in set_internal for local_if_set. */
3100 eassert (NILP (where
) || EQ (where
, cur_buf
));
3101 set_specpdl_symbol (Fcons (symbol
, Fcons (where
, cur_buf
)));
3103 /* If SYMBOL is a per-buffer variable which doesn't have a
3104 buffer-local value here, make the `let' change the global
3105 value by changing the value of SYMBOL in all buffers not
3106 having their own value. This is consistent with what
3107 happens with other buffer-local variables. */
3109 && sym
->redirect
== SYMBOL_FORWARDED
)
3111 eassert (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)));
3113 do_specbind (sym
, specpdl_ptr
- 1, value
);
3118 set_specpdl_symbol (symbol
);
3121 do_specbind (sym
, specpdl_ptr
- 1, value
);
3124 default: emacs_abort ();
3129 record_unwind_protect (Lisp_Object (*function
) (Lisp_Object
), Lisp_Object arg
)
3131 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3133 specpdl_ptr
->func
= function
;
3134 set_specpdl_symbol (Qnil
);
3135 set_specpdl_old_value (arg
);
3136 set_specpdl_saved_value (Qnil
);
3141 rebind_for_thread_switch (void)
3143 struct specbinding
*bind
;
3145 for (bind
= specpdl
; bind
!= specpdl_ptr
; ++bind
)
3147 if (bind
->func
== NULL
)
3149 Lisp_Object value
= bind
->saved_value
;
3151 bind
->saved_value
= Qnil
;
3152 do_specbind (XSYMBOL (binding_symbol (bind
)), bind
, value
);
3158 do_one_unbind (const struct specbinding
*this_binding
, int unwinding
)
3160 if (this_binding
->func
!= 0)
3161 (*this_binding
->func
) (this_binding
->old_value
);
3162 /* If the symbol is a list, it is really (SYMBOL WHERE
3163 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3164 frame. If WHERE is a buffer or frame, this indicates we
3165 bound a variable that had a buffer-local or frame-local
3166 binding. WHERE nil means that the variable had the default
3167 value when it was bound. CURRENT-BUFFER is the buffer that
3168 was current when the variable was bound. */
3169 else if (CONSP (this_binding
->symbol
))
3171 Lisp_Object symbol
, where
;
3173 symbol
= XCAR (this_binding
->symbol
);
3174 where
= XCAR (XCDR (this_binding
->symbol
));
3177 Fset_default (symbol
, this_binding
->old_value
);
3178 /* If `where' is non-nil, reset the value in the appropriate
3179 local binding, but only if that binding still exists. */
3180 else if (BUFFERP (where
)
3181 ? !NILP (Flocal_variable_p (symbol
, where
))
3182 : !NILP (Fassq (symbol
, XFRAME (where
)->param_alist
)))
3183 set_internal (symbol
, this_binding
->old_value
, where
, 1);
3185 /* If variable has a trivial value (no forwarding), we can
3186 just set it. No need to check for constant symbols here,
3187 since that was already done by specbind. */
3188 else if (XSYMBOL (this_binding
->symbol
)->redirect
== SYMBOL_PLAINVAL
)
3189 SET_SYMBOL_VAL (XSYMBOL (this_binding
->symbol
),
3190 this_binding
->old_value
);
3192 /* NOTE: we only ever come here if make_local_foo was used for
3193 the first time on this var within this let. */
3194 Fset_default (this_binding
->symbol
, this_binding
->old_value
);
3198 unbind_to (ptrdiff_t count
, Lisp_Object value
)
3200 Lisp_Object quitf
= Vquit_flag
;
3201 struct gcpro gcpro1
, gcpro2
;
3203 GCPRO2 (value
, quitf
);
3206 while (specpdl_ptr
!= specpdl
+ count
)
3208 /* Copy the binding, and decrement specpdl_ptr, before we do
3209 the work to unbind it. We decrement first
3210 so that an error in unbinding won't try to unbind
3211 the same entry again, and we copy the binding first
3212 in case more bindings are made during some of the code we run. */
3214 struct specbinding this_binding
;
3215 this_binding
= *--specpdl_ptr
;
3217 do_one_unbind (&this_binding
, 1);
3220 if (NILP (Vquit_flag
) && !NILP (quitf
))
3228 unbind_for_thread_switch (void)
3230 struct specbinding
*bind
;
3232 for (bind
= specpdl_ptr
; bind
!= specpdl
; --bind
)
3234 if (bind
->func
== NULL
)
3236 bind
->saved_value
= find_symbol_value (binding_symbol (bind
));
3237 do_one_unbind (bind
, 0);
3242 DEFUN ("special-variable-p", Fspecial_variable_p
, Sspecial_variable_p
, 1, 1, 0,
3243 doc
: /* Return non-nil if SYMBOL's global binding has been declared special.
3244 A special variable is one that will be bound dynamically, even in a
3245 context where binding is lexical by default. */)
3246 (Lisp_Object symbol
)
3248 CHECK_SYMBOL (symbol
);
3249 return XSYMBOL (symbol
)->declared_special
? Qt
: Qnil
;
3253 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3254 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3255 The debugger is entered when that frame exits, if the flag is non-nil. */)
3256 (Lisp_Object level
, Lisp_Object flag
)
3258 register struct backtrace
*backlist
= backtrace_list
;
3259 register EMACS_INT i
;
3261 CHECK_NUMBER (level
);
3263 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
3265 backlist
= backlist
->next
;
3269 backlist
->debug_on_exit
= !NILP (flag
);
3274 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3275 doc
: /* Print a trace of Lisp function calls currently active.
3276 Output stream used is value of `standard-output'. */)
3279 register struct backtrace
*backlist
= backtrace_list
;
3282 struct gcpro gcpro1
;
3283 Lisp_Object old_print_level
= Vprint_level
;
3285 if (NILP (Vprint_level
))
3286 XSETFASTINT (Vprint_level
, 8);
3293 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
3294 if (backlist
->nargs
== UNEVALLED
)
3296 Fprin1 (Fcons (backlist
->function
, *backlist
->args
), Qnil
);
3297 write_string ("\n", -1);
3301 tem
= backlist
->function
;
3302 Fprin1 (tem
, Qnil
); /* This can QUIT. */
3303 write_string ("(", -1);
3304 if (backlist
->nargs
== MANY
)
3305 { /* FIXME: Can this happen? */
3307 for (tail
= *backlist
->args
; !NILP (tail
); tail
= Fcdr (tail
))
3310 write_string (" ", -1);
3311 Fprin1 (Fcar (tail
), Qnil
);
3318 for (i
= 0; i
< backlist
->nargs
; i
++)
3320 if (i
) write_string (" ", -1);
3321 Fprin1 (backlist
->args
[i
], Qnil
);
3324 write_string (")\n", -1);
3326 backlist
= backlist
->next
;
3329 Vprint_level
= old_print_level
;
3334 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, NULL
,
3335 doc
: /* Return the function and arguments NFRAMES up from current execution point.
3336 If that frame has not evaluated the arguments yet (or is a special form),
3337 the value is (nil FUNCTION ARG-FORMS...).
3338 If that frame has evaluated its arguments and called its function already,
3339 the value is (t FUNCTION ARG-VALUES...).
3340 A &rest arg is represented as the tail of the list ARG-VALUES.
3341 FUNCTION is whatever was supplied as car of evaluated list,
3342 or a lambda expression for macro calls.
3343 If NFRAMES is more than the number of frames, the value is nil. */)
3344 (Lisp_Object nframes
)
3346 register struct backtrace
*backlist
= backtrace_list
;
3347 register EMACS_INT i
;
3350 CHECK_NATNUM (nframes
);
3352 /* Find the frame requested. */
3353 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3354 backlist
= backlist
->next
;
3358 if (backlist
->nargs
== UNEVALLED
)
3359 return Fcons (Qnil
, Fcons (backlist
->function
, *backlist
->args
));
3362 if (backlist
->nargs
== MANY
) /* FIXME: Can this happen? */
3363 tem
= *backlist
->args
;
3365 tem
= Flist (backlist
->nargs
, backlist
->args
);
3367 return Fcons (Qt
, Fcons (backlist
->function
, tem
));
3374 mark_backtrace (void)
3376 register struct backtrace
*backlist
;
3379 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3381 mark_object (backlist
->function
);
3383 if (backlist
->nargs
== UNEVALLED
3384 || backlist
->nargs
== MANY
) /* FIXME: Can this happen? */
3387 i
= backlist
->nargs
;
3389 mark_object (backlist
->args
[i
]);
3397 DEFVAR_INT ("max-specpdl-size", max_specpdl_size
,
3398 doc
: /* Limit on number of Lisp variable bindings and `unwind-protect's.
3399 If Lisp code tries to increase the total number past this amount,
3400 an error is signaled.
3401 You can safely use a value considerably larger than the default value,
3402 if that proves inconveniently small. However, if you increase it too far,
3403 Emacs could run out of memory trying to make the stack bigger. */);
3405 DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth
,
3406 doc
: /* Limit on depth in `eval', `apply' and `funcall' before error.
3408 This limit serves to catch infinite recursions for you before they cause
3409 actual stack overflow in C, which would be fatal for Emacs.
3410 You can safely make it considerably larger than its default value,
3411 if that proves inconveniently small. However, if you increase it too far,
3412 Emacs could overflow the real C stack, and crash. */);
3414 DEFVAR_LISP ("quit-flag", Vquit_flag
,
3415 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3416 If the value is t, that means do an ordinary quit.
3417 If the value equals `throw-on-input', that means quit by throwing
3418 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3419 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3420 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3423 DEFVAR_LISP ("inhibit-quit", Vinhibit_quit
,
3424 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3425 Note that `quit-flag' will still be set by typing C-g,
3426 so a quit will be signaled as soon as `inhibit-quit' is nil.
3427 To prevent this happening, set `quit-flag' to nil
3428 before making `inhibit-quit' nil. */);
3429 Vinhibit_quit
= Qnil
;
3431 DEFSYM (Qinhibit_quit
, "inhibit-quit");
3432 DEFSYM (Qautoload
, "autoload");
3433 DEFSYM (Qinhibit_debugger
, "inhibit-debugger");
3434 DEFSYM (Qmacro
, "macro");
3435 DEFSYM (Qdeclare
, "declare");
3437 /* Note that the process handling also uses Qexit, but we don't want
3438 to staticpro it twice, so we just do it here. */
3439 DEFSYM (Qexit
, "exit");
3441 DEFSYM (Qinteractive
, "interactive");
3442 DEFSYM (Qcommandp
, "commandp");
3443 DEFSYM (Qand_rest
, "&rest");
3444 DEFSYM (Qand_optional
, "&optional");
3445 DEFSYM (Qclosure
, "closure");
3446 DEFSYM (Qdebug
, "debug");
3448 DEFVAR_LISP ("inhibit-debugger", Vinhibit_debugger
,
3449 doc
: /* Non-nil means never enter the debugger.
3450 Normally set while the debugger is already active, to avoid recursive
3452 Vinhibit_debugger
= Qnil
;
3454 DEFVAR_LISP ("debug-on-error", Vdebug_on_error
,
3455 doc
: /* Non-nil means enter debugger if an error is signaled.
3456 Does not apply to errors handled by `condition-case' or those
3457 matched by `debug-ignored-errors'.
3458 If the value is a list, an error only means to enter the debugger
3459 if one of its condition symbols appears in the list.
3460 When you evaluate an expression interactively, this variable
3461 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3462 The command `toggle-debug-on-error' toggles this.
3463 See also the variable `debug-on-quit' and `inhibit-debugger'. */);
3464 Vdebug_on_error
= Qnil
;
3466 DEFVAR_LISP ("debug-ignored-errors", Vdebug_ignored_errors
,
3467 doc
: /* List of errors for which the debugger should not be called.
3468 Each element may be a condition-name or a regexp that matches error messages.
3469 If any element applies to a given error, that error skips the debugger
3470 and just returns to top level.
3471 This overrides the variable `debug-on-error'.
3472 It does not apply to errors handled by `condition-case'. */);
3473 Vdebug_ignored_errors
= Qnil
;
3475 DEFVAR_BOOL ("debug-on-quit", debug_on_quit
,
3476 doc
: /* Non-nil means enter debugger if quit is signaled (C-g, for example).
3477 Does not apply if quit is handled by a `condition-case'. */);
3480 DEFVAR_BOOL ("debug-on-next-call", debug_on_next_call
,
3481 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3483 DEFVAR_BOOL ("debugger-may-continue", debugger_may_continue
,
3484 doc
: /* Non-nil means debugger may continue execution.
3485 This is nil when the debugger is called under circumstances where it
3486 might not be safe to continue. */);
3487 debugger_may_continue
= 1;
3489 DEFVAR_LISP ("debugger", Vdebugger
,
3490 doc
: /* Function to call to invoke debugger.
3491 If due to frame exit, args are `exit' and the value being returned;
3492 this function's value will be returned instead of that.
3493 If due to error, args are `error' and a list of the args to `signal'.
3494 If due to `apply' or `funcall' entry, one arg, `lambda'.
3495 If due to `eval' entry, one arg, t. */);
3498 DEFVAR_LISP ("signal-hook-function", Vsignal_hook_function
,
3499 doc
: /* If non-nil, this is a function for `signal' to call.
3500 It receives the same arguments that `signal' was given.
3501 The Edebug package uses this to regain control. */);
3502 Vsignal_hook_function
= Qnil
;
3504 DEFVAR_LISP ("debug-on-signal", Vdebug_on_signal
,
3505 doc
: /* Non-nil means call the debugger regardless of condition handlers.
3506 Note that `debug-on-error', `debug-on-quit' and friends
3507 still determine whether to handle the particular condition. */);
3508 Vdebug_on_signal
= Qnil
;
3510 /* When lexical binding is being used,
3511 Vinternal_interpreter_environment is non-nil, and contains an alist
3512 of lexically-bound variable, or (t), indicating an empty
3513 environment. The lisp name of this variable would be
3514 `internal-interpreter-environment' if it weren't hidden.
3515 Every element of this list can be either a cons (VAR . VAL)
3516 specifying a lexical binding, or a single symbol VAR indicating
3517 that this variable should use dynamic scoping. */
3518 DEFSYM (Qinternal_interpreter_environment
,
3519 "internal-interpreter-environment");
3520 DEFVAR_LISP ("internal-interpreter-environment",
3521 Vinternal_interpreter_environment
,
3522 doc
: /* If non-nil, the current lexical environment of the lisp interpreter.
3523 When lexical binding is not being used, this variable is nil.
3524 A value of `(t)' indicates an empty environment, otherwise it is an
3525 alist of active lexical bindings. */);
3526 Vinternal_interpreter_environment
= Qnil
;
3527 /* Don't export this variable to Elisp, so no one can mess with it
3528 (Just imagine if someone makes it buffer-local). */
3529 Funintern (Qinternal_interpreter_environment
, Qnil
);
3531 DEFSYM (Vrun_hooks
, "run-hooks");
3533 staticpro (&Vautoload_queue
);
3534 Vautoload_queue
= Qnil
;
3535 staticpro (&Vsignaling_function
);
3536 Vsignaling_function
= Qnil
;
3538 inhibit_lisp_code
= Qnil
;
3549 defsubr (&Sfunction
);
3551 defsubr (&Sdefvaralias
);
3552 defsubr (&Sdefconst
);
3553 defsubr (&Smake_var_non_special
);
3557 defsubr (&Smacroexpand
);
3560 defsubr (&Sunwind_protect
);
3561 defsubr (&Scondition_case
);
3563 defsubr (&Scommandp
);
3564 defsubr (&Sautoload
);
3565 defsubr (&Sautoload_do_load
);
3568 defsubr (&Sfuncall
);
3569 defsubr (&Srun_hooks
);
3570 defsubr (&Srun_hook_with_args
);
3571 defsubr (&Srun_hook_with_args_until_success
);
3572 defsubr (&Srun_hook_with_args_until_failure
);
3573 defsubr (&Srun_hook_wrapped
);
3574 defsubr (&Sfetch_bytecode
);
3575 defsubr (&Sbacktrace_debug
);
3576 defsubr (&Sbacktrace
);
3577 defsubr (&Sbacktrace_frame
);
3578 defsubr (&Sspecial_variable_p
);
3579 defsubr (&Sfunctionp
);