1 /* Evaluator for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1987, 1993-1995, 1999-2012 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software: you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation, either version 3 of the License, or
9 (at your option) any later version.
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 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. */
37 struct backtrace
*next
;
38 Lisp_Object
*function
;
39 Lisp_Object
*args
; /* Points to vector of args. */
40 ptrdiff_t nargs
; /* Length of vector. */
41 /* Nonzero means call value of debugger when done with this operation. */
42 unsigned int debug_on_exit
: 1;
45 static struct backtrace
*backtrace_list
;
50 struct catchtag
*catchlist
;
52 /* Chain of condition handlers currently in effect.
53 The elements of this chain are contained in the stack frames
54 of Fcondition_case and internal_condition_case.
55 When an error is signaled (by calling Fsignal, below),
56 this chain is searched for an element that applies. */
61 struct handler
*handlerlist
;
64 /* Count levels of GCPRO to detect failure to UNGCPRO. */
68 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
;
69 Lisp_Object Qinhibit_quit
;
70 Lisp_Object Qand_rest
;
71 static Lisp_Object Qand_optional
;
72 static Lisp_Object Qdebug_on_error
;
73 static Lisp_Object Qdeclare
;
74 Lisp_Object Qinternal_interpreter_environment
, Qclosure
;
76 static Lisp_Object Qdebug
;
78 /* This holds either the symbol `run-hooks' or nil.
79 It is nil at an early stage of startup, and when Emacs
82 Lisp_Object Vrun_hooks
;
84 /* Non-nil means record all fset's and provide's, to be undone
85 if the file being autoloaded is not fully loaded.
86 They are recorded by being consed onto the front of Vautoload_queue:
87 (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide. */
89 Lisp_Object Vautoload_queue
;
91 /* Current number of specbindings allocated in specpdl. */
93 ptrdiff_t specpdl_size
;
95 /* Pointer to beginning of specpdl. */
97 struct specbinding
*specpdl
;
99 /* Pointer to first unused element in specpdl. */
101 struct specbinding
*specpdl_ptr
;
103 /* Depth in Lisp evaluations and function calls. */
105 static EMACS_INT lisp_eval_depth
;
107 /* The value of num_nonmacro_input_events as of the last time we
108 started to enter the debugger. If we decide to enter the debugger
109 again when this is still equal to num_nonmacro_input_events, then we
110 know that the debugger itself has an error, and we should just
111 signal the error instead of entering an infinite loop of debugger
114 static EMACS_INT when_entered_debugger
;
116 /* The function from which the last `signal' was called. Set in
119 Lisp_Object Vsignaling_function
;
121 /* Set to non-zero while processing X events. Checked in Feval to
122 make sure the Lisp interpreter isn't called from a signal handler,
123 which is unsafe because the interpreter isn't reentrant. */
127 /* If non-nil, Lisp code must not be run since some part of Emacs is
128 in an inconsistent state. Currently, x-create-frame uses this to
129 avoid triggering window-configuration-change-hook while the new
130 frame is half-initialized. */
131 Lisp_Object inhibit_lisp_code
;
133 static Lisp_Object
funcall_lambda (Lisp_Object
, ptrdiff_t, Lisp_Object
*);
134 static int interactive_p (int);
135 static Lisp_Object
apply_lambda (Lisp_Object fun
, Lisp_Object args
);
138 init_eval_once (void)
141 specpdl
= xmalloc (size
* sizeof *specpdl
);
143 specpdl_ptr
= specpdl
;
144 /* Don't forget to update docs (lispref node "Local Variables"). */
145 max_specpdl_size
= 1300; /* 1000 is not enough for CEDET's c-by.el. */
146 max_lisp_eval_depth
= 600;
154 specpdl_ptr
= specpdl
;
159 debug_on_next_call
= 0;
164 /* This is less than the initial value of num_nonmacro_input_events. */
165 when_entered_debugger
= -1;
168 /* Unwind-protect function used by call_debugger. */
171 restore_stack_limits (Lisp_Object data
)
173 max_specpdl_size
= XINT (XCAR (data
));
174 max_lisp_eval_depth
= XINT (XCDR (data
));
178 /* Call the Lisp debugger, giving it argument ARG. */
181 call_debugger (Lisp_Object arg
)
183 int debug_while_redisplaying
;
184 ptrdiff_t count
= SPECPDL_INDEX ();
186 EMACS_INT old_max
= max_specpdl_size
;
188 /* Temporarily bump up the stack limits,
189 so the debugger won't run out of stack. */
191 max_specpdl_size
+= 1;
192 record_unwind_protect (restore_stack_limits
,
193 Fcons (make_number (old_max
),
194 make_number (max_lisp_eval_depth
)));
195 max_specpdl_size
= old_max
;
197 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
198 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
200 if (max_specpdl_size
- 100 < SPECPDL_INDEX ())
201 max_specpdl_size
= SPECPDL_INDEX () + 100;
203 #ifdef HAVE_WINDOW_SYSTEM
204 if (display_hourglass_p
)
208 debug_on_next_call
= 0;
209 when_entered_debugger
= num_nonmacro_input_events
;
211 /* Resetting redisplaying_p to 0 makes sure that debug output is
212 displayed if the debugger is invoked during redisplay. */
213 debug_while_redisplaying
= redisplaying_p
;
215 specbind (intern ("debugger-may-continue"),
216 debug_while_redisplaying
? Qnil
: Qt
);
217 specbind (Qinhibit_redisplay
, Qnil
);
218 specbind (Qdebug_on_error
, Qnil
);
220 #if 0 /* Binding this prevents execution of Lisp code during
221 redisplay, which necessarily leads to display problems. */
222 specbind (Qinhibit_eval_during_redisplay
, Qt
);
225 val
= apply1 (Vdebugger
, arg
);
227 /* Interrupting redisplay and resuming it later is not safe under
228 all circumstances. So, when the debugger returns, abort the
229 interrupted redisplay by going back to the top-level. */
230 if (debug_while_redisplaying
)
233 return unbind_to (count
, val
);
237 do_debug_on_call (Lisp_Object code
)
239 debug_on_next_call
= 0;
240 backtrace_list
->debug_on_exit
= 1;
241 call_debugger (Fcons (code
, Qnil
));
244 /* NOTE!!! Every function that can call EVAL must protect its args
245 and temporaries from garbage collection while it needs them.
246 The definition of `For' shows what you have to do. */
248 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
249 doc
: /* Eval args until one of them yields non-nil, then return that value.
250 The remaining args are not evalled at all.
251 If all args return nil, return nil.
252 usage: (or CONDITIONS...) */)
255 register Lisp_Object val
= Qnil
;
262 val
= eval_sub (XCAR (args
));
272 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
273 doc
: /* Eval args until one of them yields nil, then return nil.
274 The remaining args are not evalled at all.
275 If no arg yields nil, return the last arg's value.
276 usage: (and CONDITIONS...) */)
279 register Lisp_Object val
= Qt
;
286 val
= eval_sub (XCAR (args
));
296 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
297 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
298 Returns the value of THEN or the value of the last of the ELSE's.
299 THEN must be one expression, but ELSE... can be zero or more expressions.
300 If COND yields nil, and there are no ELSE's, the value is nil.
301 usage: (if COND THEN ELSE...) */)
304 register Lisp_Object cond
;
308 cond
= eval_sub (Fcar (args
));
312 return eval_sub (Fcar (Fcdr (args
)));
313 return Fprogn (Fcdr (Fcdr (args
)));
316 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
317 doc
: /* Try each clause until one succeeds.
318 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
319 and, if the value is non-nil, this clause succeeds:
320 then the expressions in BODY are evaluated and the last one's
321 value is the value of the cond-form.
322 If no clause succeeds, cond returns nil.
323 If a clause has one element, as in (CONDITION),
324 CONDITION's value if non-nil is returned from the cond-form.
325 usage: (cond CLAUSES...) */)
328 register Lisp_Object clause
, val
;
335 clause
= Fcar (args
);
336 val
= eval_sub (Fcar (clause
));
339 if (!EQ (XCDR (clause
), Qnil
))
340 val
= Fprogn (XCDR (clause
));
350 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
351 doc
: /* Eval BODY forms sequentially and return value of last one.
352 usage: (progn BODY...) */)
355 register Lisp_Object val
= Qnil
;
362 val
= eval_sub (XCAR (args
));
370 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
371 doc
: /* Eval FIRST and BODY sequentially; return value from FIRST.
372 The value of FIRST is saved during the evaluation of the remaining args,
373 whose values are discarded.
374 usage: (prog1 FIRST BODY...) */)
378 register Lisp_Object args_left
;
379 struct gcpro gcpro1
, gcpro2
;
385 val
= eval_sub (XCAR (args_left
));
386 while (CONSP (args_left
= XCDR (args_left
)))
387 eval_sub (XCAR (args_left
));
393 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
394 doc
: /* Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
395 The value of FORM2 is saved during the evaluation of the
396 remaining args, whose values are discarded.
397 usage: (prog2 FORM1 FORM2 BODY...) */)
403 eval_sub (XCAR (args
));
405 return Fprog1 (XCDR (args
));
408 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
409 doc
: /* Set each SYM to the value of its VAL.
410 The symbols SYM are variables; they are literal (not evaluated).
411 The values VAL are expressions; they are evaluated.
412 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
413 The second VAL is not computed until after the first SYM is set, and so on;
414 each VAL can use the new value of variables set earlier in the `setq'.
415 The return value of the `setq' form is the value of the last VAL.
416 usage: (setq [SYM VAL]...) */)
419 register Lisp_Object args_left
;
420 register Lisp_Object val
, sym
, lex_binding
;
431 val
= eval_sub (Fcar (Fcdr (args_left
)));
432 sym
= Fcar (args_left
);
434 /* Like for eval_sub, we do not check declared_special here since
435 it's been done when let-binding. */
436 if (!NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
438 && !NILP (lex_binding
439 = Fassq (sym
, Vinternal_interpreter_environment
)))
440 XSETCDR (lex_binding
, val
); /* SYM is lexically bound. */
442 Fset (sym
, val
); /* SYM is dynamically bound. */
444 args_left
= Fcdr (Fcdr (args_left
));
446 while (!NILP (args_left
));
452 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
453 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
454 Warning: `quote' does not construct its return value, but just returns
455 the value that was pre-constructed by the Lisp reader (see info node
456 `(elisp)Printed Representation').
457 This means that '(a . b) is not identical to (cons 'a 'b): the former
458 does not cons. Quoting should be reserved for constants that will
459 never be modified by side-effects, unless you like self-modifying code.
460 See the common pitfall in info node `(elisp)Rearrangement' for an example
461 of unexpected results when a quoted object is modified.
462 usage: (quote ARG) */)
465 if (!NILP (Fcdr (args
)))
466 xsignal2 (Qwrong_number_of_arguments
, Qquote
, Flength (args
));
470 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
471 doc
: /* Like `quote', but preferred for objects which are functions.
472 In byte compilation, `function' causes its argument to be compiled.
473 `quote' cannot do that.
474 usage: (function ARG) */)
477 Lisp_Object quoted
= XCAR (args
);
479 if (!NILP (Fcdr (args
)))
480 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
482 if (!NILP (Vinternal_interpreter_environment
)
484 && EQ (XCAR (quoted
), Qlambda
))
485 /* This is a lambda expression within a lexical environment;
486 return an interpreted closure instead of a simple lambda. */
487 return Fcons (Qclosure
, Fcons (Vinternal_interpreter_environment
,
490 /* Simply quote the argument. */
495 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
496 doc
: /* Return t if the containing function was run directly by user input.
497 This means that the function was called with `call-interactively'
498 \(which includes being called as the binding of a key)
499 and input is currently coming from the keyboard (not a keyboard macro),
500 and Emacs is not running in batch mode (`noninteractive' is nil).
502 The only known proper use of `interactive-p' is in deciding whether to
503 display a helpful message, or how to display it. If you're thinking
504 of using it for any other purpose, it is quite likely that you're
505 making a mistake. Think: what do you want to do when the command is
506 called from a keyboard macro?
508 To test whether your function was called with `call-interactively',
509 either (i) add an extra optional argument and give it an `interactive'
510 spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
511 use `called-interactively-p'. */)
514 return interactive_p (1) ? Qt
: Qnil
;
518 DEFUN ("called-interactively-p", Fcalled_interactively_p
, Scalled_interactively_p
, 0, 1, 0,
519 doc
: /* Return t if the containing function was called by `call-interactively'.
520 If KIND is `interactive', then only return t if the call was made
521 interactively by the user, i.e. not in `noninteractive' mode nor
522 when `executing-kbd-macro'.
523 If KIND is `any', on the other hand, it will return t for any kind of
524 interactive call, including being called as the binding of a key, or
525 from a keyboard macro, or in `noninteractive' mode.
527 The only known proper use of `interactive' for KIND is in deciding
528 whether to display a helpful message, or how to display it. If you're
529 thinking of using it for any other purpose, it is quite likely that
530 you're making a mistake. Think: what do you want to do when the
531 command is called from a keyboard macro?
533 This function is meant for implementing advice and other
534 function-modifying features. Instead of using this, it is sometimes
535 cleaner to give your function an extra optional argument whose
536 `interactive' spec specifies non-nil unconditionally (\"p\" is a good
537 way to do this), or via (not (or executing-kbd-macro noninteractive)). */)
540 return ((INTERACTIVE
|| !EQ (kind
, intern ("interactive")))
541 && interactive_p (1)) ? Qt
: Qnil
;
545 /* Return 1 if function in which this appears was called using
548 EXCLUDE_SUBRS_P non-zero means always return 0 if the function
549 called is a built-in. */
552 interactive_p (int exclude_subrs_p
)
554 struct backtrace
*btp
;
557 btp
= backtrace_list
;
559 /* If this isn't a byte-compiled function, there may be a frame at
560 the top for Finteractive_p. If so, skip it. */
561 fun
= Findirect_function (*btp
->function
, Qnil
);
562 if (SUBRP (fun
) && (XSUBR (fun
) == &Sinteractive_p
563 || XSUBR (fun
) == &Scalled_interactively_p
))
566 /* If we're running an Emacs 18-style byte-compiled function, there
567 may be a frame for Fbytecode at the top level. In any version of
568 Emacs there can be Fbytecode frames for subexpressions evaluated
569 inside catch and condition-case. Skip past them.
571 If this isn't a byte-compiled function, then we may now be
572 looking at several frames for special forms. Skip past them. */
574 && (EQ (*btp
->function
, Qbytecode
)
575 || btp
->nargs
== UNEVALLED
))
578 /* `btp' now points at the frame of the innermost function that isn't
579 a special form, ignoring frames for Finteractive_p and/or
580 Fbytecode at the top. If this frame is for a built-in function
581 (such as load or eval-region) return nil. */
582 fun
= Findirect_function (*btp
->function
, Qnil
);
583 if (exclude_subrs_p
&& SUBRP (fun
))
586 /* `btp' points to the frame of a Lisp function that called interactive-p.
587 Return t if that function was called interactively. */
588 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
594 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
595 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
596 Aliased variables always have the same value; setting one sets the other.
597 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
598 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
599 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
600 itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
601 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
602 The return value is BASE-VARIABLE. */)
603 (Lisp_Object new_alias
, Lisp_Object base_variable
, Lisp_Object docstring
)
605 struct Lisp_Symbol
*sym
;
607 CHECK_SYMBOL (new_alias
);
608 CHECK_SYMBOL (base_variable
);
610 sym
= XSYMBOL (new_alias
);
613 /* Not sure why, but why not? */
614 error ("Cannot make a constant an alias");
616 switch (sym
->redirect
)
618 case SYMBOL_FORWARDED
:
619 error ("Cannot make an internal variable an alias");
620 case SYMBOL_LOCALIZED
:
621 error ("Don't know how to make a localized variable an alias");
624 /* http://lists.gnu.org/archive/html/emacs-devel/2008-04/msg00834.html
625 If n_a is bound, but b_v is not, set the value of b_v to n_a,
626 so that old-code that affects n_a before the aliasing is setup
628 if (NILP (Fboundp (base_variable
)))
629 set_internal (base_variable
, find_symbol_value (new_alias
), Qnil
, 1);
632 struct specbinding
*p
;
634 for (p
= specpdl_ptr
; p
> specpdl
; )
635 if ((--p
)->func
== NULL
637 CONSP (p
->symbol
) ? XCAR (p
->symbol
) : p
->symbol
)))
638 error ("Don't know how to make a let-bound variable an alias");
641 sym
->declared_special
= 1;
642 XSYMBOL (base_variable
)->declared_special
= 1;
643 sym
->redirect
= SYMBOL_VARALIAS
;
644 SET_SYMBOL_ALIAS (sym
, XSYMBOL (base_variable
));
645 sym
->constant
= SYMBOL_CONSTANT_P (base_variable
);
646 LOADHIST_ATTACH (new_alias
);
647 /* Even if docstring is nil: remove old docstring. */
648 Fput (new_alias
, Qvariable_documentation
, docstring
);
650 return base_variable
;
654 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
655 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
656 You are not required to define a variable in order to use it, but
657 defining it lets you supply an initial value and documentation, which
658 can be referred to by the Emacs help facilities and other programming
659 tools. The `defvar' form also declares the variable as \"special\",
660 so that it is always dynamically bound even if `lexical-binding' is t.
662 The optional argument INITVALUE is evaluated, and used to set SYMBOL,
663 only if SYMBOL's value is void. If SYMBOL is buffer-local, its
664 default value is what is set; buffer-local values are not affected.
665 If INITVALUE is missing, SYMBOL's value is not set.
667 If SYMBOL has a local binding, then this form affects the local
668 binding. This is usually not what you want. Thus, if you need to
669 load a file defining variables, with this form or with `defconst' or
670 `defcustom', you should always load that file _outside_ any bindings
671 for these variables. \(`defconst' and `defcustom' behave similarly in
674 The optional argument DOCSTRING is a documentation string for the
677 To define a user option, use `defcustom' instead of `defvar'.
678 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
681 register Lisp_Object sym
, tem
, tail
;
685 if (!NILP (Fcdr (Fcdr (tail
))))
686 error ("Too many arguments");
688 tem
= Fdefault_boundp (sym
);
691 /* Do it before evaluating the initial value, for self-references. */
692 XSYMBOL (sym
)->declared_special
= 1;
695 Fset_default (sym
, eval_sub (Fcar (tail
)));
697 { /* Check if there is really a global binding rather than just a let
698 binding that shadows the global unboundness of the var. */
699 volatile struct specbinding
*pdl
= specpdl_ptr
;
700 while (pdl
> specpdl
)
702 if (EQ ((--pdl
)->symbol
, sym
) && !pdl
->func
703 && EQ (pdl
->old_value
, Qunbound
))
705 message_with_string ("Warning: defvar ignored because %s is let-bound",
706 SYMBOL_NAME (sym
), 1);
715 if (!NILP (Vpurify_flag
))
716 tem
= Fpurecopy (tem
);
717 Fput (sym
, Qvariable_documentation
, tem
);
719 LOADHIST_ATTACH (sym
);
721 else if (!NILP (Vinternal_interpreter_environment
)
722 && !XSYMBOL (sym
)->declared_special
)
723 /* A simple (defvar foo) with lexical scoping does "nothing" except
724 declare that var to be dynamically scoped *locally* (i.e. within
725 the current file or let-block). */
726 Vinternal_interpreter_environment
=
727 Fcons (sym
, Vinternal_interpreter_environment
);
730 /* Simple (defvar <var>) should not count as a definition at all.
731 It could get in the way of other definitions, and unloading this
732 package could try to make the variable unbound. */
738 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
739 doc
: /* Define SYMBOL as a constant variable.
740 This declares that neither programs nor users should ever change the
741 value. This constancy is not actually enforced by Emacs Lisp, but
742 SYMBOL is marked as a special variable so that it is never lexically
745 The `defconst' form always sets the value of SYMBOL to the result of
746 evalling INITVALUE. If SYMBOL is buffer-local, its default value is
747 what is set; buffer-local values are not affected. If SYMBOL has a
748 local binding, then this form sets the local binding's value.
749 However, you should normally not make local bindings for variables
750 defined with this form.
752 The optional DOCSTRING specifies the variable's documentation string.
753 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
756 register Lisp_Object sym
, tem
;
759 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
760 error ("Too many arguments");
762 tem
= eval_sub (Fcar (Fcdr (args
)));
763 if (!NILP (Vpurify_flag
))
764 tem
= Fpurecopy (tem
);
765 Fset_default (sym
, tem
);
766 XSYMBOL (sym
)->declared_special
= 1;
767 tem
= Fcar (Fcdr (Fcdr (args
)));
770 if (!NILP (Vpurify_flag
))
771 tem
= Fpurecopy (tem
);
772 Fput (sym
, Qvariable_documentation
, tem
);
774 Fput (sym
, Qrisky_local_variable
, Qt
);
775 LOADHIST_ATTACH (sym
);
779 /* Make SYMBOL lexically scoped. */
780 DEFUN ("internal-make-var-non-special", Fmake_var_non_special
,
781 Smake_var_non_special
, 1, 1, 0,
782 doc
: /* Internal function. */)
785 CHECK_SYMBOL (symbol
);
786 XSYMBOL (symbol
)->declared_special
= 0;
791 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
792 doc
: /* Bind variables according to VARLIST then eval BODY.
793 The value of the last form in BODY is returned.
794 Each element of VARLIST is a symbol (which is bound to nil)
795 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
796 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
797 usage: (let* VARLIST BODY...) */)
800 Lisp_Object varlist
, var
, val
, elt
, lexenv
;
801 ptrdiff_t count
= SPECPDL_INDEX ();
802 struct gcpro gcpro1
, gcpro2
, gcpro3
;
804 GCPRO3 (args
, elt
, varlist
);
806 lexenv
= Vinternal_interpreter_environment
;
808 varlist
= Fcar (args
);
809 while (CONSP (varlist
))
813 elt
= XCAR (varlist
);
819 else if (! NILP (Fcdr (Fcdr (elt
))))
820 signal_error ("`let' bindings can have only one value-form", elt
);
824 val
= eval_sub (Fcar (Fcdr (elt
)));
827 if (!NILP (lexenv
) && SYMBOLP (var
)
828 && !XSYMBOL (var
)->declared_special
829 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
830 /* Lexically bind VAR by adding it to the interpreter's binding
834 = Fcons (Fcons (var
, val
), Vinternal_interpreter_environment
);
835 if (EQ (Vinternal_interpreter_environment
, lexenv
))
836 /* Save the old lexical environment on the specpdl stack,
837 but only for the first lexical binding, since we'll never
838 need to revert to one of the intermediate ones. */
839 specbind (Qinternal_interpreter_environment
, newenv
);
841 Vinternal_interpreter_environment
= newenv
;
846 varlist
= XCDR (varlist
);
849 val
= Fprogn (Fcdr (args
));
850 return unbind_to (count
, val
);
853 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
854 doc
: /* Bind variables according to VARLIST then eval BODY.
855 The value of the last form in BODY is returned.
856 Each element of VARLIST is a symbol (which is bound to nil)
857 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
858 All the VALUEFORMs are evalled before any symbols are bound.
859 usage: (let VARLIST BODY...) */)
862 Lisp_Object
*temps
, tem
, lexenv
;
863 register Lisp_Object elt
, varlist
;
864 ptrdiff_t count
= SPECPDL_INDEX ();
866 struct gcpro gcpro1
, gcpro2
;
869 varlist
= Fcar (args
);
871 /* Make space to hold the values to give the bound variables. */
872 elt
= Flength (varlist
);
873 SAFE_ALLOCA_LISP (temps
, XFASTINT (elt
));
875 /* Compute the values and store them in `temps'. */
877 GCPRO2 (args
, *temps
);
880 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
883 elt
= XCAR (varlist
);
885 temps
[argnum
++] = Qnil
;
886 else if (! NILP (Fcdr (Fcdr (elt
))))
887 signal_error ("`let' bindings can have only one value-form", elt
);
889 temps
[argnum
++] = eval_sub (Fcar (Fcdr (elt
)));
890 gcpro2
.nvars
= argnum
;
894 lexenv
= Vinternal_interpreter_environment
;
896 varlist
= Fcar (args
);
897 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
901 elt
= XCAR (varlist
);
902 var
= SYMBOLP (elt
) ? elt
: Fcar (elt
);
903 tem
= temps
[argnum
++];
905 if (!NILP (lexenv
) && SYMBOLP (var
)
906 && !XSYMBOL (var
)->declared_special
907 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
908 /* Lexically bind VAR by adding it to the lexenv alist. */
909 lexenv
= Fcons (Fcons (var
, tem
), lexenv
);
911 /* Dynamically bind VAR. */
915 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
916 /* Instantiate a new lexical environment. */
917 specbind (Qinternal_interpreter_environment
, lexenv
);
919 elt
= Fprogn (Fcdr (args
));
921 return unbind_to (count
, elt
);
924 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
925 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
926 The order of execution is thus TEST, BODY, TEST, BODY and so on
927 until TEST returns nil.
928 usage: (while TEST BODY...) */)
931 Lisp_Object test
, body
;
932 struct gcpro gcpro1
, gcpro2
;
938 while (!NILP (eval_sub (test
)))
948 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
949 doc
: /* Return result of expanding macros at top level of FORM.
950 If FORM is not a macro call, it is returned unchanged.
951 Otherwise, the macro is expanded and the expansion is considered
952 in place of FORM. When a non-macro-call results, it is returned.
954 The second optional arg ENVIRONMENT specifies an environment of macro
955 definitions to shadow the loaded ones for use in file byte-compilation. */)
956 (Lisp_Object form
, Lisp_Object environment
)
958 /* With cleanups from Hallvard Furuseth. */
959 register Lisp_Object expander
, sym
, def
, tem
;
963 /* Come back here each time we expand a macro call,
964 in case it expands into another macro call. */
967 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
968 def
= sym
= XCAR (form
);
970 /* Trace symbols aliases to other symbols
971 until we get a symbol that is not an alias. */
972 while (SYMBOLP (def
))
976 tem
= Fassq (sym
, environment
);
979 def
= XSYMBOL (sym
)->function
;
980 if (!EQ (def
, Qunbound
))
985 /* Right now TEM is the result from SYM in ENVIRONMENT,
986 and if TEM is nil then DEF is SYM's function definition. */
989 /* SYM is not mentioned in ENVIRONMENT.
990 Look at its function definition. */
991 if (EQ (def
, Qunbound
) || !CONSP (def
))
992 /* Not defined or definition not suitable. */
994 if (EQ (XCAR (def
), Qautoload
))
996 /* Autoloading function: will it be a macro when loaded? */
997 tem
= Fnth (make_number (4), def
);
998 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
999 /* Yes, load it and try again. */
1001 struct gcpro gcpro1
;
1003 do_autoload (def
, sym
);
1010 else if (!EQ (XCAR (def
), Qmacro
))
1012 else expander
= XCDR (def
);
1016 expander
= XCDR (tem
);
1017 if (NILP (expander
))
1021 Lisp_Object newform
= apply1 (expander
, XCDR (form
));
1022 if (EQ (form
, newform
))
1031 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1032 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1033 TAG is evalled to get the tag to use; it must not be nil.
1035 Then the BODY is executed.
1036 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
1037 If no throw happens, `catch' returns the value of the last BODY form.
1038 If a throw happens, it specifies the value to return from `catch'.
1039 usage: (catch TAG BODY...) */)
1042 register Lisp_Object tag
;
1043 struct gcpro gcpro1
;
1046 tag
= eval_sub (Fcar (args
));
1048 return internal_catch (tag
, Fprogn
, Fcdr (args
));
1051 /* Set up a catch, then call C function FUNC on argument ARG.
1052 FUNC should return a Lisp_Object.
1053 This is how catches are done from within C code. */
1056 internal_catch (Lisp_Object tag
, Lisp_Object (*func
) (Lisp_Object
), Lisp_Object arg
)
1058 /* This structure is made part of the chain `catchlist'. */
1061 /* Fill in the components of c, and put it on the list. */
1065 c
.backlist
= backtrace_list
;
1066 c
.handlerlist
= handlerlist
;
1067 c
.lisp_eval_depth
= lisp_eval_depth
;
1068 c
.pdlcount
= SPECPDL_INDEX ();
1069 c
.poll_suppress_count
= poll_suppress_count
;
1070 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1071 c
.gcpro
= gcprolist
;
1072 c
.byte_stack
= byte_stack_list
;
1076 if (! _setjmp (c
.jmp
))
1077 c
.val
= (*func
) (arg
);
1079 /* Throw works by a longjmp that comes right here. */
1084 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1085 jump to that CATCH, returning VALUE as the value of that catch.
1087 This is the guts Fthrow and Fsignal; they differ only in the way
1088 they choose the catch tag to throw to. A catch tag for a
1089 condition-case form has a TAG of Qnil.
1091 Before each catch is discarded, unbind all special bindings and
1092 execute all unwind-protect clauses made above that catch. Unwind
1093 the handler stack as we go, so that the proper handlers are in
1094 effect for each unwind-protect clause we run. At the end, restore
1095 some static info saved in CATCH, and longjmp to the location
1098 This is used for correct unwinding in Fthrow and Fsignal. */
1100 static _Noreturn
void
1101 unwind_to_catch (struct catchtag
*catch, Lisp_Object value
)
1105 /* Save the value in the tag. */
1108 /* Restore certain special C variables. */
1109 set_poll_suppress_count (catch->poll_suppress_count
);
1110 UNBLOCK_INPUT_TO (catch->interrupt_input_blocked
);
1111 handling_signal
= 0;
1116 last_time
= catchlist
== catch;
1118 /* Unwind the specpdl stack, and then restore the proper set of
1120 unbind_to (catchlist
->pdlcount
, Qnil
);
1121 handlerlist
= catchlist
->handlerlist
;
1122 catchlist
= catchlist
->next
;
1124 while (! last_time
);
1127 /* If x_catch_errors was done, turn it off now.
1128 (First we give unbind_to a chance to do that.) */
1129 #if 0 /* This would disable x_catch_errors after x_connection_closed.
1130 The catch must remain in effect during that delicate
1131 state. --lorentey */
1132 x_fully_uncatch_errors ();
1136 byte_stack_list
= catch->byte_stack
;
1137 gcprolist
= catch->gcpro
;
1139 gcpro_level
= gcprolist
? gcprolist
->level
+ 1 : 0;
1141 backtrace_list
= catch->backlist
;
1142 lisp_eval_depth
= catch->lisp_eval_depth
;
1144 _longjmp (catch->jmp
, 1);
1147 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1148 doc
: /* Throw to the catch for TAG and return VALUE from it.
1149 Both TAG and VALUE are evalled. */)
1150 (register Lisp_Object tag
, Lisp_Object value
)
1152 register struct catchtag
*c
;
1155 for (c
= catchlist
; c
; c
= c
->next
)
1157 if (EQ (c
->tag
, tag
))
1158 unwind_to_catch (c
, value
);
1160 xsignal2 (Qno_catch
, tag
, value
);
1164 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1165 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1166 If BODYFORM completes normally, its value is returned
1167 after executing the UNWINDFORMS.
1168 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1169 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1173 ptrdiff_t count
= SPECPDL_INDEX ();
1175 record_unwind_protect (Fprogn
, Fcdr (args
));
1176 val
= eval_sub (Fcar (args
));
1177 return unbind_to (count
, val
);
1180 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1181 doc
: /* Regain control when an error is signaled.
1182 Executes BODYFORM and returns its value if no error happens.
1183 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1184 where the BODY is made of Lisp expressions.
1186 A handler is applicable to an error
1187 if CONDITION-NAME is one of the error's condition names.
1188 If an error happens, the first applicable handler is run.
1190 The car of a handler may be a list of condition names instead of a
1191 single condition name; then it handles all of them. If the special
1192 condition name `debug' is present in this list, it allows another
1193 condition in the list to run the debugger if `debug-on-error' and the
1194 other usual mechanisms says it should (otherwise, `condition-case'
1195 suppresses the debugger).
1197 When a handler handles an error, control returns to the `condition-case'
1198 and it executes the handler's BODY...
1199 with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
1200 \(If VAR is nil, the handler can't access that information.)
1201 Then the value of the last BODY form is returned from the `condition-case'
1204 See also the function `signal' for more info.
1205 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1208 register Lisp_Object bodyform
, handlers
;
1209 volatile Lisp_Object var
;
1212 bodyform
= Fcar (Fcdr (args
));
1213 handlers
= Fcdr (Fcdr (args
));
1215 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1218 /* Like Fcondition_case, but the args are separate
1219 rather than passed in a list. Used by Fbyte_code. */
1222 internal_lisp_condition_case (volatile Lisp_Object var
, Lisp_Object bodyform
,
1223 Lisp_Object handlers
)
1231 for (val
= handlers
; CONSP (val
); val
= XCDR (val
))
1237 && (SYMBOLP (XCAR (tem
))
1238 || CONSP (XCAR (tem
))))))
1239 error ("Invalid condition handler: %s",
1240 SDATA (Fprin1_to_string (tem
, Qt
)));
1245 c
.backlist
= backtrace_list
;
1246 c
.handlerlist
= handlerlist
;
1247 c
.lisp_eval_depth
= lisp_eval_depth
;
1248 c
.pdlcount
= SPECPDL_INDEX ();
1249 c
.poll_suppress_count
= poll_suppress_count
;
1250 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1251 c
.gcpro
= gcprolist
;
1252 c
.byte_stack
= byte_stack_list
;
1253 if (_setjmp (c
.jmp
))
1256 specbind (h
.var
, c
.val
);
1257 val
= Fprogn (Fcdr (h
.chosen_clause
));
1259 /* Note that this just undoes the binding of h.var; whoever
1260 longjumped to us unwound the stack to c.pdlcount before
1262 unbind_to (c
.pdlcount
, Qnil
);
1269 h
.handler
= handlers
;
1270 h
.next
= handlerlist
;
1274 val
= eval_sub (bodyform
);
1276 handlerlist
= h
.next
;
1280 /* Call the function BFUN with no arguments, catching errors within it
1281 according to HANDLERS. If there is an error, call HFUN with
1282 one argument which is the data that describes the error:
1285 HANDLERS can be a list of conditions to catch.
1286 If HANDLERS is Qt, catch all errors.
1287 If HANDLERS is Qerror, catch all errors
1288 but allow the debugger to run if that is enabled. */
1291 internal_condition_case (Lisp_Object (*bfun
) (void), Lisp_Object handlers
,
1292 Lisp_Object (*hfun
) (Lisp_Object
))
1300 c
.backlist
= backtrace_list
;
1301 c
.handlerlist
= handlerlist
;
1302 c
.lisp_eval_depth
= lisp_eval_depth
;
1303 c
.pdlcount
= SPECPDL_INDEX ();
1304 c
.poll_suppress_count
= poll_suppress_count
;
1305 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1306 c
.gcpro
= gcprolist
;
1307 c
.byte_stack
= byte_stack_list
;
1308 if (_setjmp (c
.jmp
))
1310 return (*hfun
) (c
.val
);
1314 h
.handler
= handlers
;
1316 h
.next
= handlerlist
;
1322 handlerlist
= h
.next
;
1326 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1329 internal_condition_case_1 (Lisp_Object (*bfun
) (Lisp_Object
), Lisp_Object arg
,
1330 Lisp_Object handlers
, Lisp_Object (*hfun
) (Lisp_Object
))
1338 c
.backlist
= backtrace_list
;
1339 c
.handlerlist
= handlerlist
;
1340 c
.lisp_eval_depth
= lisp_eval_depth
;
1341 c
.pdlcount
= SPECPDL_INDEX ();
1342 c
.poll_suppress_count
= poll_suppress_count
;
1343 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1344 c
.gcpro
= gcprolist
;
1345 c
.byte_stack
= byte_stack_list
;
1346 if (_setjmp (c
.jmp
))
1348 return (*hfun
) (c
.val
);
1352 h
.handler
= handlers
;
1354 h
.next
= handlerlist
;
1358 val
= (*bfun
) (arg
);
1360 handlerlist
= h
.next
;
1364 /* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as
1368 internal_condition_case_2 (Lisp_Object (*bfun
) (Lisp_Object
, Lisp_Object
),
1371 Lisp_Object handlers
,
1372 Lisp_Object (*hfun
) (Lisp_Object
))
1380 c
.backlist
= backtrace_list
;
1381 c
.handlerlist
= handlerlist
;
1382 c
.lisp_eval_depth
= lisp_eval_depth
;
1383 c
.pdlcount
= SPECPDL_INDEX ();
1384 c
.poll_suppress_count
= poll_suppress_count
;
1385 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1386 c
.gcpro
= gcprolist
;
1387 c
.byte_stack
= byte_stack_list
;
1388 if (_setjmp (c
.jmp
))
1390 return (*hfun
) (c
.val
);
1394 h
.handler
= handlers
;
1396 h
.next
= handlerlist
;
1400 val
= (*bfun
) (arg1
, arg2
);
1402 handlerlist
= h
.next
;
1406 /* Like internal_condition_case but call BFUN with NARGS as first,
1407 and ARGS as second argument. */
1410 internal_condition_case_n (Lisp_Object (*bfun
) (ptrdiff_t, Lisp_Object
*),
1413 Lisp_Object handlers
,
1414 Lisp_Object (*hfun
) (Lisp_Object
))
1422 c
.backlist
= backtrace_list
;
1423 c
.handlerlist
= handlerlist
;
1424 c
.lisp_eval_depth
= lisp_eval_depth
;
1425 c
.pdlcount
= SPECPDL_INDEX ();
1426 c
.poll_suppress_count
= poll_suppress_count
;
1427 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1428 c
.gcpro
= gcprolist
;
1429 c
.byte_stack
= byte_stack_list
;
1430 if (_setjmp (c
.jmp
))
1432 return (*hfun
) (c
.val
);
1436 h
.handler
= handlers
;
1438 h
.next
= handlerlist
;
1442 val
= (*bfun
) (nargs
, args
);
1444 handlerlist
= h
.next
;
1449 static Lisp_Object
find_handler_clause (Lisp_Object
, Lisp_Object
);
1450 static int maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
,
1454 process_quit_flag (void)
1456 Lisp_Object flag
= Vquit_flag
;
1458 if (EQ (flag
, Qkill_emacs
))
1460 if (EQ (Vthrow_on_input
, flag
))
1461 Fthrow (Vthrow_on_input
, Qt
);
1462 Fsignal (Qquit
, Qnil
);
1465 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1466 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1467 This function does not return.
1469 An error symbol is a symbol with an `error-conditions' property
1470 that is a list of condition names.
1471 A handler for any of those names will get to handle this signal.
1472 The symbol `error' should normally be one of them.
1474 DATA should be a list. Its elements are printed as part of the error message.
1475 See Info anchor `(elisp)Definition of signal' for some details on how this
1476 error message is constructed.
1477 If the signal is handled, DATA is made available to the handler.
1478 See also the function `condition-case'. */)
1479 (Lisp_Object error_symbol
, Lisp_Object data
)
1481 /* When memory is full, ERROR-SYMBOL is nil,
1482 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1483 That is a special case--don't do this in other situations. */
1484 Lisp_Object conditions
;
1486 Lisp_Object real_error_symbol
1487 = (NILP (error_symbol
) ? Fcar (data
) : error_symbol
);
1488 register Lisp_Object clause
= Qnil
;
1490 struct backtrace
*bp
;
1492 immediate_quit
= handling_signal
= 0;
1494 if (gc_in_progress
|| waiting_for_input
)
1497 #if 0 /* rms: I don't know why this was here,
1498 but it is surely wrong for an error that is handled. */
1499 #ifdef HAVE_WINDOW_SYSTEM
1500 if (display_hourglass_p
)
1501 cancel_hourglass ();
1505 /* This hook is used by edebug. */
1506 if (! NILP (Vsignal_hook_function
)
1507 && ! NILP (error_symbol
))
1509 /* Edebug takes care of restoring these variables when it exits. */
1510 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1511 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1513 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1514 max_specpdl_size
= SPECPDL_INDEX () + 40;
1516 call2 (Vsignal_hook_function
, error_symbol
, data
);
1519 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1521 /* Remember from where signal was called. Skip over the frame for
1522 `signal' itself. If a frame for `error' follows, skip that,
1523 too. Don't do this when ERROR_SYMBOL is nil, because that
1524 is a memory-full error. */
1525 Vsignaling_function
= Qnil
;
1526 if (backtrace_list
&& !NILP (error_symbol
))
1528 bp
= backtrace_list
->next
;
1529 if (bp
&& bp
->function
&& EQ (*bp
->function
, Qerror
))
1531 if (bp
&& bp
->function
)
1532 Vsignaling_function
= *bp
->function
;
1535 for (h
= handlerlist
; h
; h
= h
->next
)
1537 clause
= find_handler_clause (h
->handler
, conditions
);
1542 if (/* Don't run the debugger for a memory-full error.
1543 (There is no room in memory to do that!) */
1544 !NILP (error_symbol
)
1545 && (!NILP (Vdebug_on_signal
)
1546 /* If no handler is present now, try to run the debugger. */
1548 /* A `debug' symbol in the handler list disables the normal
1549 suppression of the debugger. */
1550 || (CONSP (clause
) && CONSP (XCAR (clause
))
1551 && !NILP (Fmemq (Qdebug
, XCAR (clause
))))
1552 /* Special handler that means "print a message and run debugger
1554 || EQ (h
->handler
, Qerror
)))
1557 = maybe_call_debugger (conditions
, error_symbol
, data
);
1558 /* We can't return values to code which signaled an error, but we
1559 can continue code which has signaled a quit. */
1560 if (debugger_called
&& EQ (real_error_symbol
, Qquit
))
1566 Lisp_Object unwind_data
1567 = (NILP (error_symbol
) ? data
: Fcons (error_symbol
, data
));
1569 h
->chosen_clause
= clause
;
1570 unwind_to_catch (h
->tag
, unwind_data
);
1575 Fthrow (Qtop_level
, Qt
);
1578 if (! NILP (error_symbol
))
1579 data
= Fcons (error_symbol
, data
);
1581 string
= Ferror_message_string (data
);
1582 fatal ("%s", SDATA (string
));
1585 /* Internal version of Fsignal that never returns.
1586 Used for anything but Qquit (which can return from Fsignal). */
1589 xsignal (Lisp_Object error_symbol
, Lisp_Object data
)
1591 Fsignal (error_symbol
, data
);
1595 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1598 xsignal0 (Lisp_Object error_symbol
)
1600 xsignal (error_symbol
, Qnil
);
1604 xsignal1 (Lisp_Object error_symbol
, Lisp_Object arg
)
1606 xsignal (error_symbol
, list1 (arg
));
1610 xsignal2 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
)
1612 xsignal (error_symbol
, list2 (arg1
, arg2
));
1616 xsignal3 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
1618 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1621 /* Signal `error' with message S, and additional arg ARG.
1622 If ARG is not a genuine list, make it a one-element list. */
1625 signal_error (const char *s
, Lisp_Object arg
)
1627 Lisp_Object tortoise
, hare
;
1629 hare
= tortoise
= arg
;
1630 while (CONSP (hare
))
1637 tortoise
= XCDR (tortoise
);
1639 if (EQ (hare
, tortoise
))
1644 arg
= Fcons (arg
, Qnil
); /* Make it a list. */
1646 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1650 /* Return nonzero if LIST is a non-nil atom or
1651 a list containing one of CONDITIONS. */
1654 wants_debugger (Lisp_Object list
, Lisp_Object conditions
)
1661 while (CONSP (conditions
))
1663 Lisp_Object
this, tail
;
1664 this = XCAR (conditions
);
1665 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1666 if (EQ (XCAR (tail
), this))
1668 conditions
= XCDR (conditions
);
1673 /* Return 1 if an error with condition-symbols CONDITIONS,
1674 and described by SIGNAL-DATA, should skip the debugger
1675 according to debugger-ignored-errors. */
1678 skip_debugger (Lisp_Object conditions
, Lisp_Object data
)
1681 int first_string
= 1;
1682 Lisp_Object error_message
;
1684 error_message
= Qnil
;
1685 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1687 if (STRINGP (XCAR (tail
)))
1691 error_message
= Ferror_message_string (data
);
1695 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1700 Lisp_Object contail
;
1702 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1703 if (EQ (XCAR (tail
), XCAR (contail
)))
1711 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1712 SIG and DATA describe the signal. There are two ways to pass them:
1713 = SIG is the error symbol, and DATA is the rest of the data.
1714 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1715 This is for memory-full errors only. */
1717 maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
, Lisp_Object data
)
1719 Lisp_Object combined_data
;
1721 combined_data
= Fcons (sig
, data
);
1724 /* Don't try to run the debugger with interrupts blocked.
1725 The editing loop would return anyway. */
1727 /* Does user want to enter debugger for this kind of error? */
1730 : wants_debugger (Vdebug_on_error
, conditions
))
1731 && ! skip_debugger (conditions
, combined_data
)
1732 /* RMS: What's this for? */
1733 && when_entered_debugger
< num_nonmacro_input_events
)
1735 call_debugger (Fcons (Qerror
, Fcons (combined_data
, Qnil
)));
1743 find_handler_clause (Lisp_Object handlers
, Lisp_Object conditions
)
1745 register Lisp_Object h
;
1747 /* t is used by handlers for all conditions, set up by C code. */
1748 if (EQ (handlers
, Qt
))
1751 /* error is used similarly, but means print an error message
1752 and run the debugger if that is enabled. */
1753 if (EQ (handlers
, Qerror
))
1756 for (h
= handlers
; CONSP (h
); h
= XCDR (h
))
1758 Lisp_Object handler
= XCAR (h
);
1759 Lisp_Object condit
, tem
;
1761 if (!CONSP (handler
))
1763 condit
= XCAR (handler
);
1764 /* Handle a single condition name in handler HANDLER. */
1765 if (SYMBOLP (condit
))
1767 tem
= Fmemq (Fcar (handler
), conditions
);
1771 /* Handle a list of condition names in handler HANDLER. */
1772 else if (CONSP (condit
))
1775 for (tail
= condit
; CONSP (tail
); tail
= XCDR (tail
))
1777 tem
= Fmemq (XCAR (tail
), conditions
);
1788 /* Dump an error message; called like vprintf. */
1790 verror (const char *m
, va_list ap
)
1793 ptrdiff_t size
= sizeof buf
;
1794 ptrdiff_t size_max
= STRING_BYTES_BOUND
+ 1;
1799 used
= evxprintf (&buffer
, &size
, buf
, size_max
, m
, ap
);
1800 string
= make_string (buffer
, used
);
1804 xsignal1 (Qerror
, string
);
1808 /* Dump an error message; called like printf. */
1812 error (const char *m
, ...)
1820 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
1821 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
1822 This means it contains a description for how to read arguments to give it.
1823 The value is nil for an invalid function or a symbol with no function
1826 Interactively callable functions include strings and vectors (treated
1827 as keyboard macros), lambda-expressions that contain a top-level call
1828 to `interactive', autoload definitions made by `autoload' with non-nil
1829 fourth argument, and some of the built-in functions of Lisp.
1831 Also, a symbol satisfies `commandp' if its function definition does so.
1833 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
1834 then strings and vectors are not accepted. */)
1835 (Lisp_Object function
, Lisp_Object for_call_interactively
)
1837 register Lisp_Object fun
;
1838 register Lisp_Object funcar
;
1839 Lisp_Object if_prop
= Qnil
;
1843 fun
= indirect_function (fun
); /* Check cycles. */
1844 if (NILP (fun
) || EQ (fun
, Qunbound
))
1847 /* Check an `interactive-form' property if present, analogous to the
1848 function-documentation property. */
1850 while (SYMBOLP (fun
))
1852 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
1855 fun
= Fsymbol_function (fun
);
1858 /* Emacs primitives are interactive if their DEFUN specifies an
1859 interactive spec. */
1861 return XSUBR (fun
)->intspec
? Qt
: if_prop
;
1863 /* Bytecode objects are interactive if they are long enough to
1864 have an element whose index is COMPILED_INTERACTIVE, which is
1865 where the interactive spec is stored. */
1866 else if (COMPILEDP (fun
))
1867 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
1870 /* Strings and vectors are keyboard macros. */
1871 if (STRINGP (fun
) || VECTORP (fun
))
1872 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
1874 /* Lists may represent commands. */
1877 funcar
= XCAR (fun
);
1878 if (EQ (funcar
, Qclosure
))
1879 return (!NILP (Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
)))))
1881 else if (EQ (funcar
, Qlambda
))
1882 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
1883 else if (EQ (funcar
, Qautoload
))
1884 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
1889 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1890 doc
: /* Define FUNCTION to autoload from FILE.
1891 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
1892 Third arg DOCSTRING is documentation for the function.
1893 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
1894 Fifth arg TYPE indicates the type of the object:
1895 nil or omitted says FUNCTION is a function,
1896 `keymap' says FUNCTION is really a keymap, and
1897 `macro' or t says FUNCTION is really a macro.
1898 Third through fifth args give info about the real definition.
1899 They default to nil.
1900 If FUNCTION is already defined other than as an autoload,
1901 this does nothing and returns nil. */)
1902 (Lisp_Object function
, Lisp_Object file
, Lisp_Object docstring
, Lisp_Object interactive
, Lisp_Object type
)
1904 CHECK_SYMBOL (function
);
1905 CHECK_STRING (file
);
1907 /* If function is defined and not as an autoload, don't override. */
1908 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
1909 && !(CONSP (XSYMBOL (function
)->function
)
1910 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
1913 if (NILP (Vpurify_flag
))
1914 /* Only add entries after dumping, because the ones before are
1915 not useful and else we get loads of them from the loaddefs.el. */
1916 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
1917 else if (EQ (docstring
, make_number (0)))
1918 /* `read1' in lread.c has found the docstring starting with "\
1919 and assumed the docstring will be provided by Snarf-documentation, so it
1920 passed us 0 instead. But that leads to accidental sharing in purecopy's
1921 hash-consing, so we use a (hopefully) unique integer instead. */
1922 docstring
= make_number (XUNTAG (function
, Lisp_Symbol
));
1923 return Ffset (function
,
1924 Fpurecopy (list5 (Qautoload
, file
, docstring
,
1925 interactive
, type
)));
1929 un_autoload (Lisp_Object oldqueue
)
1931 register Lisp_Object queue
, first
, second
;
1933 /* Queue to unwind is current value of Vautoload_queue.
1934 oldqueue is the shadowed value to leave in Vautoload_queue. */
1935 queue
= Vautoload_queue
;
1936 Vautoload_queue
= oldqueue
;
1937 while (CONSP (queue
))
1939 first
= XCAR (queue
);
1940 second
= Fcdr (first
);
1941 first
= Fcar (first
);
1942 if (EQ (first
, make_number (0)))
1945 Ffset (first
, second
);
1946 queue
= XCDR (queue
);
1951 /* Load an autoloaded function.
1952 FUNNAME is the symbol which is the function's name.
1953 FUNDEF is the autoload definition (a list). */
1956 do_autoload (Lisp_Object fundef
, Lisp_Object funname
)
1958 ptrdiff_t count
= SPECPDL_INDEX ();
1960 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1962 /* This is to make sure that loadup.el gives a clear picture
1963 of what files are preloaded and when. */
1964 if (! NILP (Vpurify_flag
))
1965 error ("Attempt to autoload %s while preparing to dump",
1966 SDATA (SYMBOL_NAME (funname
)));
1969 CHECK_SYMBOL (funname
);
1970 GCPRO3 (fun
, funname
, fundef
);
1972 /* Preserve the match data. */
1973 record_unwind_save_match_data ();
1975 /* If autoloading gets an error (which includes the error of failing
1976 to define the function being called), we use Vautoload_queue
1977 to undo function definitions and `provide' calls made by
1978 the function. We do this in the specific case of autoloading
1979 because autoloading is not an explicit request "load this file",
1980 but rather a request to "call this function".
1982 The value saved here is to be restored into Vautoload_queue. */
1983 record_unwind_protect (un_autoload
, Vautoload_queue
);
1984 Vautoload_queue
= Qt
;
1985 Fload (Fcar (Fcdr (fundef
)), Qnil
, Qt
, Qnil
, Qt
);
1987 /* Once loading finishes, don't undo it. */
1988 Vautoload_queue
= Qt
;
1989 unbind_to (count
, Qnil
);
1991 fun
= Findirect_function (fun
, Qnil
);
1993 if (!NILP (Fequal (fun
, fundef
)))
1994 error ("Autoloading failed to define function %s",
1995 SDATA (SYMBOL_NAME (funname
)));
2000 DEFUN ("eval", Feval
, Seval
, 1, 2, 0,
2001 doc
: /* Evaluate FORM and return its value.
2002 If LEXICAL is t, evaluate using lexical scoping. */)
2003 (Lisp_Object form
, Lisp_Object lexical
)
2005 ptrdiff_t count
= SPECPDL_INDEX ();
2006 specbind (Qinternal_interpreter_environment
,
2007 NILP (lexical
) ? Qnil
: Fcons (Qt
, Qnil
));
2008 return unbind_to (count
, eval_sub (form
));
2011 /* Eval a sub-expression of the current expression (i.e. in the same
2014 eval_sub (Lisp_Object form
)
2016 Lisp_Object fun
, val
, original_fun
, original_args
;
2018 struct backtrace backtrace
;
2019 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2021 if (handling_signal
)
2026 /* Look up its binding in the lexical environment.
2027 We do not pay attention to the declared_special flag here, since we
2028 already did that when let-binding the variable. */
2029 Lisp_Object lex_binding
2030 = !NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
2031 ? Fassq (form
, Vinternal_interpreter_environment
)
2033 if (CONSP (lex_binding
))
2034 return XCDR (lex_binding
);
2036 return Fsymbol_value (form
);
2043 if ((consing_since_gc
> gc_cons_threshold
2044 && consing_since_gc
> gc_relative_threshold
)
2046 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2049 Fgarbage_collect ();
2053 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2055 if (max_lisp_eval_depth
< 100)
2056 max_lisp_eval_depth
= 100;
2057 if (lisp_eval_depth
> max_lisp_eval_depth
)
2058 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2061 original_fun
= XCAR (form
);
2062 original_args
= XCDR (form
);
2064 backtrace
.next
= backtrace_list
;
2065 backtrace_list
= &backtrace
;
2066 backtrace
.function
= &original_fun
; /* This also protects them from gc. */
2067 backtrace
.args
= &original_args
;
2068 backtrace
.nargs
= UNEVALLED
;
2069 backtrace
.debug_on_exit
= 0;
2071 if (debug_on_next_call
)
2072 do_debug_on_call (Qt
);
2074 /* At this point, only original_fun and original_args
2075 have values that will be used below. */
2078 /* Optimize for no indirection. */
2080 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2081 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2082 fun
= indirect_function (fun
);
2086 Lisp_Object numargs
;
2087 Lisp_Object argvals
[8];
2088 Lisp_Object args_left
;
2089 register int i
, maxargs
;
2091 args_left
= original_args
;
2092 numargs
= Flength (args_left
);
2096 if (XINT (numargs
) < XSUBR (fun
)->min_args
2097 || (XSUBR (fun
)->max_args
>= 0
2098 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2099 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2101 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2102 val
= (XSUBR (fun
)->function
.aUNEVALLED
) (args_left
);
2103 else if (XSUBR (fun
)->max_args
== MANY
)
2105 /* Pass a vector of evaluated arguments. */
2107 ptrdiff_t argnum
= 0;
2110 SAFE_ALLOCA_LISP (vals
, XINT (numargs
));
2112 GCPRO3 (args_left
, fun
, fun
);
2116 while (!NILP (args_left
))
2118 vals
[argnum
++] = eval_sub (Fcar (args_left
));
2119 args_left
= Fcdr (args_left
);
2120 gcpro3
.nvars
= argnum
;
2123 backtrace
.args
= vals
;
2124 backtrace
.nargs
= XINT (numargs
);
2126 val
= (XSUBR (fun
)->function
.aMANY
) (XINT (numargs
), vals
);
2132 GCPRO3 (args_left
, fun
, fun
);
2133 gcpro3
.var
= argvals
;
2136 maxargs
= XSUBR (fun
)->max_args
;
2137 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
2139 argvals
[i
] = eval_sub (Fcar (args_left
));
2145 backtrace
.args
= argvals
;
2146 backtrace
.nargs
= XINT (numargs
);
2151 val
= (XSUBR (fun
)->function
.a0 ());
2154 val
= (XSUBR (fun
)->function
.a1 (argvals
[0]));
2157 val
= (XSUBR (fun
)->function
.a2 (argvals
[0], argvals
[1]));
2160 val
= (XSUBR (fun
)->function
.a3
2161 (argvals
[0], argvals
[1], argvals
[2]));
2164 val
= (XSUBR (fun
)->function
.a4
2165 (argvals
[0], argvals
[1], argvals
[2], argvals
[3]));
2168 val
= (XSUBR (fun
)->function
.a5
2169 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2173 val
= (XSUBR (fun
)->function
.a6
2174 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2175 argvals
[4], argvals
[5]));
2178 val
= (XSUBR (fun
)->function
.a7
2179 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2180 argvals
[4], argvals
[5], argvals
[6]));
2184 val
= (XSUBR (fun
)->function
.a8
2185 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2186 argvals
[4], argvals
[5], argvals
[6], argvals
[7]));
2190 /* Someone has created a subr that takes more arguments than
2191 is supported by this code. We need to either rewrite the
2192 subr to use a different argument protocol, or add more
2193 cases to this switch. */
2198 else if (COMPILEDP (fun
))
2199 val
= apply_lambda (fun
, original_args
);
2202 if (EQ (fun
, Qunbound
))
2203 xsignal1 (Qvoid_function
, original_fun
);
2205 xsignal1 (Qinvalid_function
, original_fun
);
2206 funcar
= XCAR (fun
);
2207 if (!SYMBOLP (funcar
))
2208 xsignal1 (Qinvalid_function
, original_fun
);
2209 if (EQ (funcar
, Qautoload
))
2211 do_autoload (fun
, original_fun
);
2214 if (EQ (funcar
, Qmacro
))
2215 val
= eval_sub (apply1 (Fcdr (fun
), original_args
));
2216 else if (EQ (funcar
, Qlambda
)
2217 || EQ (funcar
, Qclosure
))
2218 val
= apply_lambda (fun
, original_args
);
2220 xsignal1 (Qinvalid_function
, original_fun
);
2225 if (backtrace
.debug_on_exit
)
2226 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2227 backtrace_list
= backtrace
.next
;
2232 DEFUN ("apply", Fapply
, Sapply
, 1, MANY
, 0,
2233 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2234 Then return the value FUNCTION returns.
2235 Thus, (apply '+ 1 2 '(3 4)) returns 10.
2236 usage: (apply FUNCTION &rest ARGUMENTS) */)
2237 (ptrdiff_t nargs
, Lisp_Object
*args
)
2241 register Lisp_Object spread_arg
;
2242 register Lisp_Object
*funcall_args
;
2243 Lisp_Object fun
, retval
;
2244 struct gcpro gcpro1
;
2249 spread_arg
= args
[nargs
- 1];
2250 CHECK_LIST (spread_arg
);
2252 numargs
= XINT (Flength (spread_arg
));
2255 return Ffuncall (nargs
- 1, args
);
2256 else if (numargs
== 1)
2258 args
[nargs
- 1] = XCAR (spread_arg
);
2259 return Ffuncall (nargs
, args
);
2262 numargs
+= nargs
- 2;
2264 /* Optimize for no indirection. */
2265 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2266 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2267 fun
= indirect_function (fun
);
2268 if (EQ (fun
, Qunbound
))
2270 /* Let funcall get the error. */
2277 if (numargs
< XSUBR (fun
)->min_args
2278 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2279 goto funcall
; /* Let funcall get the error. */
2280 else if (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
> numargs
)
2282 /* Avoid making funcall cons up a yet another new vector of arguments
2283 by explicitly supplying nil's for optional values. */
2284 SAFE_ALLOCA_LISP (funcall_args
, 1 + XSUBR (fun
)->max_args
);
2285 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2286 funcall_args
[++i
] = Qnil
;
2287 GCPRO1 (*funcall_args
);
2288 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2292 /* We add 1 to numargs because funcall_args includes the
2293 function itself as well as its arguments. */
2296 SAFE_ALLOCA_LISP (funcall_args
, 1 + numargs
);
2297 GCPRO1 (*funcall_args
);
2298 gcpro1
.nvars
= 1 + numargs
;
2301 memcpy (funcall_args
, args
, nargs
* sizeof (Lisp_Object
));
2302 /* Spread the last arg we got. Its first element goes in
2303 the slot that it used to occupy, hence this value of I. */
2305 while (!NILP (spread_arg
))
2307 funcall_args
[i
++] = XCAR (spread_arg
);
2308 spread_arg
= XCDR (spread_arg
);
2311 /* By convention, the caller needs to gcpro Ffuncall's args. */
2312 retval
= Ffuncall (gcpro1
.nvars
, funcall_args
);
2319 /* Run hook variables in various ways. */
2322 funcall_nil (ptrdiff_t nargs
, Lisp_Object
*args
)
2324 Ffuncall (nargs
, args
);
2328 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2329 doc
: /* Run each hook in HOOKS.
2330 Each argument should be a symbol, a hook variable.
2331 These symbols are processed in the order specified.
2332 If a hook symbol has a non-nil value, that value may be a function
2333 or a list of functions to be called to run the hook.
2334 If the value is a function, it is called with no arguments.
2335 If it is a list, the elements are called, in order, with no arguments.
2337 Major modes should not use this function directly to run their mode
2338 hook; they should use `run-mode-hooks' instead.
2340 Do not use `make-local-variable' to make a hook variable buffer-local.
2341 Instead, use `add-hook' and specify t for the LOCAL argument.
2342 usage: (run-hooks &rest HOOKS) */)
2343 (ptrdiff_t nargs
, Lisp_Object
*args
)
2345 Lisp_Object hook
[1];
2348 for (i
= 0; i
< nargs
; i
++)
2351 run_hook_with_args (1, hook
, funcall_nil
);
2357 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2358 Srun_hook_with_args
, 1, MANY
, 0,
2359 doc
: /* Run HOOK with the specified arguments ARGS.
2360 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2361 value, that value may be a function or a list of functions to be
2362 called to run the hook. If the value is a function, it is called with
2363 the given arguments and its return value is returned. If it is a list
2364 of functions, those functions are called, in order,
2365 with the given arguments ARGS.
2366 It is best not to depend on the value returned by `run-hook-with-args',
2369 Do not use `make-local-variable' to make a hook variable buffer-local.
2370 Instead, use `add-hook' and specify t for the LOCAL argument.
2371 usage: (run-hook-with-args HOOK &rest ARGS) */)
2372 (ptrdiff_t nargs
, Lisp_Object
*args
)
2374 return run_hook_with_args (nargs
, args
, funcall_nil
);
2377 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2378 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2379 doc
: /* Run HOOK with the specified arguments ARGS.
2380 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2381 value, that value may be a function or a list of functions to be
2382 called to run the hook. If the value is a function, it is called with
2383 the given arguments and its return value is returned.
2384 If it is a list of functions, those functions are called, in order,
2385 with the given arguments ARGS, until one of them
2386 returns a non-nil value. Then we return that value.
2387 However, if they all return nil, we return nil.
2389 Do not use `make-local-variable' to make a hook variable buffer-local.
2390 Instead, use `add-hook' and specify t for the LOCAL argument.
2391 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2392 (ptrdiff_t nargs
, Lisp_Object
*args
)
2394 return run_hook_with_args (nargs
, args
, Ffuncall
);
2398 funcall_not (ptrdiff_t nargs
, Lisp_Object
*args
)
2400 return NILP (Ffuncall (nargs
, args
)) ? Qt
: Qnil
;
2403 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2404 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2405 doc
: /* Run HOOK with the specified arguments ARGS.
2406 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2407 value, that value may be a function or a list of functions to be
2408 called to run the hook. If the value is a function, it is called with
2409 the given arguments and its return value is returned.
2410 If it is a list of functions, those functions are called, in order,
2411 with the given arguments ARGS, until one of them returns nil.
2412 Then we return nil. However, if they all return non-nil, we return non-nil.
2414 Do not use `make-local-variable' to make a hook variable buffer-local.
2415 Instead, use `add-hook' and specify t for the LOCAL argument.
2416 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2417 (ptrdiff_t nargs
, Lisp_Object
*args
)
2419 return NILP (run_hook_with_args (nargs
, args
, funcall_not
)) ? Qt
: Qnil
;
2423 run_hook_wrapped_funcall (ptrdiff_t nargs
, Lisp_Object
*args
)
2425 Lisp_Object tmp
= args
[0], ret
;
2428 ret
= Ffuncall (nargs
, args
);
2434 DEFUN ("run-hook-wrapped", Frun_hook_wrapped
, Srun_hook_wrapped
, 2, MANY
, 0,
2435 doc
: /* Run HOOK, passing each function through WRAP-FUNCTION.
2436 I.e. instead of calling each function FUN directly with arguments ARGS,
2437 it calls WRAP-FUNCTION with arguments FUN and ARGS.
2438 As soon as a call to WRAP-FUNCTION returns non-nil, `run-hook-wrapped'
2439 aborts and returns that value.
2440 usage: (run-hook-wrapped HOOK WRAP-FUNCTION &rest ARGS) */)
2441 (ptrdiff_t nargs
, Lisp_Object
*args
)
2443 return run_hook_with_args (nargs
, args
, run_hook_wrapped_funcall
);
2446 /* ARGS[0] should be a hook symbol.
2447 Call each of the functions in the hook value, passing each of them
2448 as arguments all the rest of ARGS (all NARGS - 1 elements).
2449 FUNCALL specifies how to call each function on the hook.
2450 The caller (or its caller, etc) must gcpro all of ARGS,
2451 except that it isn't necessary to gcpro ARGS[0]. */
2454 run_hook_with_args (ptrdiff_t nargs
, Lisp_Object
*args
,
2455 Lisp_Object (*funcall
) (ptrdiff_t nargs
, Lisp_Object
*args
))
2457 Lisp_Object sym
, val
, ret
= Qnil
;
2458 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2460 /* If we are dying or still initializing,
2461 don't do anything--it would probably crash if we tried. */
2462 if (NILP (Vrun_hooks
))
2466 val
= find_symbol_value (sym
);
2468 if (EQ (val
, Qunbound
) || NILP (val
))
2470 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2473 return funcall (nargs
, args
);
2477 Lisp_Object global_vals
= Qnil
;
2478 GCPRO3 (sym
, val
, global_vals
);
2481 CONSP (val
) && NILP (ret
);
2484 if (EQ (XCAR (val
), Qt
))
2486 /* t indicates this hook has a local binding;
2487 it means to run the global binding too. */
2488 global_vals
= Fdefault_value (sym
);
2489 if (NILP (global_vals
)) continue;
2491 if (!CONSP (global_vals
) || EQ (XCAR (global_vals
), Qlambda
))
2493 args
[0] = global_vals
;
2494 ret
= funcall (nargs
, args
);
2499 CONSP (global_vals
) && NILP (ret
);
2500 global_vals
= XCDR (global_vals
))
2502 args
[0] = XCAR (global_vals
);
2503 /* In a global value, t should not occur. If it does, we
2504 must ignore it to avoid an endless loop. */
2505 if (!EQ (args
[0], Qt
))
2506 ret
= funcall (nargs
, args
);
2512 args
[0] = XCAR (val
);
2513 ret
= funcall (nargs
, args
);
2522 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2525 run_hook_with_args_2 (Lisp_Object hook
, Lisp_Object arg1
, Lisp_Object arg2
)
2527 Lisp_Object temp
[3];
2532 Frun_hook_with_args (3, temp
);
2535 /* Apply fn to arg. */
2537 apply1 (Lisp_Object fn
, Lisp_Object arg
)
2539 struct gcpro gcpro1
;
2543 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2546 Lisp_Object args
[2];
2550 RETURN_UNGCPRO (Fapply (2, args
));
2554 /* Call function fn on no arguments. */
2556 call0 (Lisp_Object fn
)
2558 struct gcpro gcpro1
;
2561 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2564 /* Call function fn with 1 argument arg1. */
2567 call1 (Lisp_Object fn
, Lisp_Object arg1
)
2569 struct gcpro gcpro1
;
2570 Lisp_Object args
[2];
2576 RETURN_UNGCPRO (Ffuncall (2, args
));
2579 /* Call function fn with 2 arguments arg1, arg2. */
2582 call2 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
)
2584 struct gcpro gcpro1
;
2585 Lisp_Object args
[3];
2591 RETURN_UNGCPRO (Ffuncall (3, args
));
2594 /* Call function fn with 3 arguments arg1, arg2, arg3. */
2597 call3 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2599 struct gcpro gcpro1
;
2600 Lisp_Object args
[4];
2607 RETURN_UNGCPRO (Ffuncall (4, args
));
2610 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
2613 call4 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2616 struct gcpro gcpro1
;
2617 Lisp_Object args
[5];
2625 RETURN_UNGCPRO (Ffuncall (5, args
));
2628 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
2631 call5 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2632 Lisp_Object arg4
, Lisp_Object arg5
)
2634 struct gcpro gcpro1
;
2635 Lisp_Object args
[6];
2644 RETURN_UNGCPRO (Ffuncall (6, args
));
2647 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
2650 call6 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2651 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
)
2653 struct gcpro gcpro1
;
2654 Lisp_Object args
[7];
2664 RETURN_UNGCPRO (Ffuncall (7, args
));
2667 /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
2670 call7 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2671 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
)
2673 struct gcpro gcpro1
;
2674 Lisp_Object args
[8];
2685 RETURN_UNGCPRO (Ffuncall (8, args
));
2688 /* The caller should GCPRO all the elements of ARGS. */
2690 DEFUN ("functionp", Ffunctionp
, Sfunctionp
, 1, 1, 0,
2691 doc
: /* Non-nil if OBJECT is a function. */)
2692 (Lisp_Object object
)
2694 if (SYMBOLP (object
) && !NILP (Ffboundp (object
)))
2696 object
= Findirect_function (object
, Qt
);
2698 if (CONSP (object
) && EQ (XCAR (object
), Qautoload
))
2700 /* Autoloaded symbols are functions, except if they load
2701 macros or keymaps. */
2703 for (i
= 0; i
< 4 && CONSP (object
); i
++)
2704 object
= XCDR (object
);
2706 return (CONSP (object
) && !NILP (XCAR (object
))) ? Qnil
: Qt
;
2711 return (XSUBR (object
)->max_args
!= UNEVALLED
) ? Qt
: Qnil
;
2712 else if (COMPILEDP (object
))
2714 else if (CONSP (object
))
2716 Lisp_Object car
= XCAR (object
);
2717 return (EQ (car
, Qlambda
) || EQ (car
, Qclosure
)) ? Qt
: Qnil
;
2723 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2724 doc
: /* Call first argument as a function, passing remaining arguments to it.
2725 Return the value that function returns.
2726 Thus, (funcall 'cons 'x 'y) returns (x . y).
2727 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2728 (ptrdiff_t nargs
, Lisp_Object
*args
)
2730 Lisp_Object fun
, original_fun
;
2732 ptrdiff_t numargs
= nargs
- 1;
2733 Lisp_Object lisp_numargs
;
2735 struct backtrace backtrace
;
2736 register Lisp_Object
*internal_args
;
2740 if ((consing_since_gc
> gc_cons_threshold
2741 && consing_since_gc
> gc_relative_threshold
)
2743 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2744 Fgarbage_collect ();
2746 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2748 if (max_lisp_eval_depth
< 100)
2749 max_lisp_eval_depth
= 100;
2750 if (lisp_eval_depth
> max_lisp_eval_depth
)
2751 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2754 backtrace
.next
= backtrace_list
;
2755 backtrace_list
= &backtrace
;
2756 backtrace
.function
= &args
[0];
2757 backtrace
.args
= &args
[1];
2758 backtrace
.nargs
= nargs
- 1;
2759 backtrace
.debug_on_exit
= 0;
2761 if (debug_on_next_call
)
2762 do_debug_on_call (Qlambda
);
2766 original_fun
= args
[0];
2770 /* Optimize for no indirection. */
2772 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2773 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2774 fun
= indirect_function (fun
);
2778 if (numargs
< XSUBR (fun
)->min_args
2779 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2781 XSETFASTINT (lisp_numargs
, numargs
);
2782 xsignal2 (Qwrong_number_of_arguments
, original_fun
, lisp_numargs
);
2785 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2786 xsignal1 (Qinvalid_function
, original_fun
);
2788 else if (XSUBR (fun
)->max_args
== MANY
)
2789 val
= (XSUBR (fun
)->function
.aMANY
) (numargs
, args
+ 1);
2792 if (XSUBR (fun
)->max_args
> numargs
)
2794 internal_args
= alloca (XSUBR (fun
)->max_args
2795 * sizeof *internal_args
);
2796 memcpy (internal_args
, args
+ 1, numargs
* sizeof (Lisp_Object
));
2797 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2798 internal_args
[i
] = Qnil
;
2801 internal_args
= args
+ 1;
2802 switch (XSUBR (fun
)->max_args
)
2805 val
= (XSUBR (fun
)->function
.a0 ());
2808 val
= (XSUBR (fun
)->function
.a1 (internal_args
[0]));
2811 val
= (XSUBR (fun
)->function
.a2
2812 (internal_args
[0], internal_args
[1]));
2815 val
= (XSUBR (fun
)->function
.a3
2816 (internal_args
[0], internal_args
[1], internal_args
[2]));
2819 val
= (XSUBR (fun
)->function
.a4
2820 (internal_args
[0], internal_args
[1], internal_args
[2],
2824 val
= (XSUBR (fun
)->function
.a5
2825 (internal_args
[0], internal_args
[1], internal_args
[2],
2826 internal_args
[3], internal_args
[4]));
2829 val
= (XSUBR (fun
)->function
.a6
2830 (internal_args
[0], internal_args
[1], internal_args
[2],
2831 internal_args
[3], internal_args
[4], internal_args
[5]));
2834 val
= (XSUBR (fun
)->function
.a7
2835 (internal_args
[0], internal_args
[1], internal_args
[2],
2836 internal_args
[3], internal_args
[4], internal_args
[5],
2841 val
= (XSUBR (fun
)->function
.a8
2842 (internal_args
[0], internal_args
[1], internal_args
[2],
2843 internal_args
[3], internal_args
[4], internal_args
[5],
2844 internal_args
[6], internal_args
[7]));
2849 /* If a subr takes more than 8 arguments without using MANY
2850 or UNEVALLED, we need to extend this function to support it.
2851 Until this is done, there is no way to call the function. */
2856 else if (COMPILEDP (fun
))
2857 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2860 if (EQ (fun
, Qunbound
))
2861 xsignal1 (Qvoid_function
, original_fun
);
2863 xsignal1 (Qinvalid_function
, original_fun
);
2864 funcar
= XCAR (fun
);
2865 if (!SYMBOLP (funcar
))
2866 xsignal1 (Qinvalid_function
, original_fun
);
2867 if (EQ (funcar
, Qlambda
)
2868 || EQ (funcar
, Qclosure
))
2869 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2870 else if (EQ (funcar
, Qautoload
))
2872 do_autoload (fun
, original_fun
);
2877 xsignal1 (Qinvalid_function
, original_fun
);
2881 if (backtrace
.debug_on_exit
)
2882 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2883 backtrace_list
= backtrace
.next
;
2888 apply_lambda (Lisp_Object fun
, Lisp_Object args
)
2890 Lisp_Object args_left
;
2893 register Lisp_Object
*arg_vector
;
2894 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2895 register Lisp_Object tem
;
2898 numargs
= XFASTINT (Flength (args
));
2899 SAFE_ALLOCA_LISP (arg_vector
, numargs
);
2902 GCPRO3 (*arg_vector
, args_left
, fun
);
2905 for (i
= 0; i
< numargs
; )
2907 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2908 tem
= eval_sub (tem
);
2909 arg_vector
[i
++] = tem
;
2915 backtrace_list
->args
= arg_vector
;
2916 backtrace_list
->nargs
= i
;
2917 tem
= funcall_lambda (fun
, numargs
, arg_vector
);
2919 /* Do the debug-on-exit now, while arg_vector still exists. */
2920 if (backtrace_list
->debug_on_exit
)
2921 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
2922 /* Don't do it again when we return to eval. */
2923 backtrace_list
->debug_on_exit
= 0;
2928 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2929 and return the result of evaluation.
2930 FUN must be either a lambda-expression or a compiled-code object. */
2933 funcall_lambda (Lisp_Object fun
, ptrdiff_t nargs
,
2934 register Lisp_Object
*arg_vector
)
2936 Lisp_Object val
, syms_left
, next
, lexenv
;
2937 ptrdiff_t count
= SPECPDL_INDEX ();
2943 if (EQ (XCAR (fun
), Qclosure
))
2945 fun
= XCDR (fun
); /* Drop `closure'. */
2946 lexenv
= XCAR (fun
);
2947 CHECK_LIST_CONS (fun
, fun
);
2951 syms_left
= XCDR (fun
);
2952 if (CONSP (syms_left
))
2953 syms_left
= XCAR (syms_left
);
2955 xsignal1 (Qinvalid_function
, fun
);
2957 else if (COMPILEDP (fun
))
2959 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
2960 if (INTEGERP (syms_left
))
2961 /* A byte-code object with a non-nil `push args' slot means we
2962 shouldn't bind any arguments, instead just call the byte-code
2963 interpreter directly; it will push arguments as necessary.
2965 Byte-code objects with either a non-existent, or a nil value for
2966 the `push args' slot (the default), have dynamically-bound
2967 arguments, and use the argument-binding code below instead (as do
2968 all interpreted functions, even lexically bound ones). */
2970 /* If we have not actually read the bytecode string
2971 and constants vector yet, fetch them from the file. */
2972 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
2973 Ffetch_bytecode (fun
);
2974 return exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
2975 AREF (fun
, COMPILED_CONSTANTS
),
2976 AREF (fun
, COMPILED_STACK_DEPTH
),
2985 i
= optional
= rest
= 0;
2986 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
2990 next
= XCAR (syms_left
);
2991 if (!SYMBOLP (next
))
2992 xsignal1 (Qinvalid_function
, fun
);
2994 if (EQ (next
, Qand_rest
))
2996 else if (EQ (next
, Qand_optional
))
3003 arg
= Flist (nargs
- i
, &arg_vector
[i
]);
3007 arg
= arg_vector
[i
++];
3009 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3013 /* Bind the argument. */
3014 if (!NILP (lexenv
) && SYMBOLP (next
))
3015 /* Lexically bind NEXT by adding it to the lexenv alist. */
3016 lexenv
= Fcons (Fcons (next
, arg
), lexenv
);
3018 /* Dynamically bind NEXT. */
3019 specbind (next
, arg
);
3023 if (!NILP (syms_left
))
3024 xsignal1 (Qinvalid_function
, fun
);
3026 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3028 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
3029 /* Instantiate a new lexical environment. */
3030 specbind (Qinternal_interpreter_environment
, lexenv
);
3033 val
= Fprogn (XCDR (XCDR (fun
)));
3036 /* If we have not actually read the bytecode string
3037 and constants vector yet, fetch them from the file. */
3038 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3039 Ffetch_bytecode (fun
);
3040 val
= exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
3041 AREF (fun
, COMPILED_CONSTANTS
),
3042 AREF (fun
, COMPILED_STACK_DEPTH
),
3046 return unbind_to (count
, val
);
3049 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3051 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3052 (Lisp_Object object
)
3056 if (COMPILEDP (object
) && CONSP (AREF (object
, COMPILED_BYTECODE
)))
3058 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3061 tem
= AREF (object
, COMPILED_BYTECODE
);
3062 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3063 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3065 error ("Invalid byte code");
3067 ASET (object
, COMPILED_BYTECODE
, XCAR (tem
));
3068 ASET (object
, COMPILED_CONSTANTS
, XCDR (tem
));
3076 register ptrdiff_t count
= SPECPDL_INDEX ();
3077 ptrdiff_t max_size
= min (max_specpdl_size
, PTRDIFF_MAX
);
3078 if (max_size
<= specpdl_size
)
3080 if (max_specpdl_size
< 400)
3081 max_size
= max_specpdl_size
= 400;
3082 if (max_size
<= specpdl_size
)
3083 signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil
);
3085 specpdl
= xpalloc (specpdl
, &specpdl_size
, 1, max_size
, sizeof *specpdl
);
3086 specpdl_ptr
= specpdl
+ count
;
3089 /* `specpdl_ptr->symbol' is a field which describes which variable is
3090 let-bound, so it can be properly undone when we unbind_to.
3091 It can have the following two shapes:
3092 - SYMBOL : if it's a plain symbol, it means that we have let-bound
3093 a symbol that is not buffer-local (at least at the time
3094 the let binding started). Note also that it should not be
3095 aliased (i.e. when let-binding V1 that's aliased to V2, we want
3097 - (SYMBOL WHERE . BUFFER) : this means that it is a let-binding for
3098 variable SYMBOL which can be buffer-local. WHERE tells us
3099 which buffer is affected (or nil if the let-binding affects the
3100 global value of the variable) and BUFFER tells us which buffer was
3101 current (i.e. if WHERE is non-nil, then BUFFER==WHERE, otherwise
3102 BUFFER did not yet have a buffer-local value). */
3105 specbind (Lisp_Object symbol
, Lisp_Object value
)
3107 struct Lisp_Symbol
*sym
;
3109 eassert (!handling_signal
);
3111 CHECK_SYMBOL (symbol
);
3112 sym
= XSYMBOL (symbol
);
3113 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3117 switch (sym
->redirect
)
3119 case SYMBOL_VARALIAS
:
3120 sym
= indirect_variable (sym
); XSETSYMBOL (symbol
, sym
); goto start
;
3121 case SYMBOL_PLAINVAL
:
3122 /* The most common case is that of a non-constant symbol with a
3123 trivial value. Make that as fast as we can. */
3124 specpdl_ptr
->symbol
= symbol
;
3125 specpdl_ptr
->old_value
= SYMBOL_VAL (sym
);
3126 specpdl_ptr
->func
= NULL
;
3129 SET_SYMBOL_VAL (sym
, value
);
3131 set_internal (symbol
, value
, Qnil
, 1);
3133 case SYMBOL_LOCALIZED
:
3134 if (SYMBOL_BLV (sym
)->frame_local
)
3135 error ("Frame-local vars cannot be let-bound");
3136 case SYMBOL_FORWARDED
:
3138 Lisp_Object ovalue
= find_symbol_value (symbol
);
3139 specpdl_ptr
->func
= 0;
3140 specpdl_ptr
->old_value
= ovalue
;
3142 eassert (sym
->redirect
!= SYMBOL_LOCALIZED
3143 || (EQ (SYMBOL_BLV (sym
)->where
,
3144 SYMBOL_BLV (sym
)->frame_local
?
3145 Fselected_frame () : Fcurrent_buffer ())));
3147 if (sym
->redirect
== SYMBOL_LOCALIZED
3148 || BUFFER_OBJFWDP (SYMBOL_FWD (sym
)))
3150 Lisp_Object where
, cur_buf
= Fcurrent_buffer ();
3152 /* For a local variable, record both the symbol and which
3153 buffer's or frame's value we are saving. */
3154 if (!NILP (Flocal_variable_p (symbol
, Qnil
)))
3156 eassert (sym
->redirect
!= SYMBOL_LOCALIZED
3157 || (BLV_FOUND (SYMBOL_BLV (sym
))
3158 && EQ (cur_buf
, SYMBOL_BLV (sym
)->where
)));
3161 else if (sym
->redirect
== SYMBOL_LOCALIZED
3162 && BLV_FOUND (SYMBOL_BLV (sym
)))
3163 where
= SYMBOL_BLV (sym
)->where
;
3167 /* We're not using the `unused' slot in the specbinding
3168 structure because this would mean we have to do more
3169 work for simple variables. */
3170 /* FIXME: The third value `current_buffer' is only used in
3171 let_shadows_buffer_binding_p which is itself only used
3172 in set_internal for local_if_set. */
3173 eassert (NILP (where
) || EQ (where
, cur_buf
));
3174 specpdl_ptr
->symbol
= Fcons (symbol
, Fcons (where
, cur_buf
));
3176 /* If SYMBOL is a per-buffer variable which doesn't have a
3177 buffer-local value here, make the `let' change the global
3178 value by changing the value of SYMBOL in all buffers not
3179 having their own value. This is consistent with what
3180 happens with other buffer-local variables. */
3182 && sym
->redirect
== SYMBOL_FORWARDED
)
3184 eassert (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)));
3186 Fset_default (symbol
, value
);
3191 specpdl_ptr
->symbol
= symbol
;
3194 set_internal (symbol
, value
, Qnil
, 1);
3202 record_unwind_protect (Lisp_Object (*function
) (Lisp_Object
), Lisp_Object arg
)
3204 eassert (!handling_signal
);
3206 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3208 specpdl_ptr
->func
= function
;
3209 specpdl_ptr
->symbol
= Qnil
;
3210 specpdl_ptr
->old_value
= arg
;
3215 unbind_to (ptrdiff_t count
, Lisp_Object value
)
3217 Lisp_Object quitf
= Vquit_flag
;
3218 struct gcpro gcpro1
, gcpro2
;
3220 GCPRO2 (value
, quitf
);
3223 while (specpdl_ptr
!= specpdl
+ count
)
3225 /* Copy the binding, and decrement specpdl_ptr, before we do
3226 the work to unbind it. We decrement first
3227 so that an error in unbinding won't try to unbind
3228 the same entry again, and we copy the binding first
3229 in case more bindings are made during some of the code we run. */
3231 struct specbinding this_binding
;
3232 this_binding
= *--specpdl_ptr
;
3234 if (this_binding
.func
!= 0)
3235 (*this_binding
.func
) (this_binding
.old_value
);
3236 /* If the symbol is a list, it is really (SYMBOL WHERE
3237 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3238 frame. If WHERE is a buffer or frame, this indicates we
3239 bound a variable that had a buffer-local or frame-local
3240 binding. WHERE nil means that the variable had the default
3241 value when it was bound. CURRENT-BUFFER is the buffer that
3242 was current when the variable was bound. */
3243 else if (CONSP (this_binding
.symbol
))
3245 Lisp_Object symbol
, where
;
3247 symbol
= XCAR (this_binding
.symbol
);
3248 where
= XCAR (XCDR (this_binding
.symbol
));
3251 Fset_default (symbol
, this_binding
.old_value
);
3252 /* If `where' is non-nil, reset the value in the appropriate
3253 local binding, but only if that binding still exists. */
3254 else if (BUFFERP (where
)
3255 ? !NILP (Flocal_variable_p (symbol
, where
))
3256 : !NILP (Fassq (symbol
, XFRAME (where
)->param_alist
)))
3257 set_internal (symbol
, this_binding
.old_value
, where
, 1);
3259 /* If variable has a trivial value (no forwarding), we can
3260 just set it. No need to check for constant symbols here,
3261 since that was already done by specbind. */
3262 else if (XSYMBOL (this_binding
.symbol
)->redirect
== SYMBOL_PLAINVAL
)
3263 SET_SYMBOL_VAL (XSYMBOL (this_binding
.symbol
),
3264 this_binding
.old_value
);
3266 /* NOTE: we only ever come here if make_local_foo was used for
3267 the first time on this var within this let. */
3268 Fset_default (this_binding
.symbol
, this_binding
.old_value
);
3271 if (NILP (Vquit_flag
) && !NILP (quitf
))
3278 DEFUN ("special-variable-p", Fspecial_variable_p
, Sspecial_variable_p
, 1, 1, 0,
3279 doc
: /* Return non-nil if SYMBOL's global binding has been declared special.
3280 A special variable is one that will be bound dynamically, even in a
3281 context where binding is lexical by default. */)
3282 (Lisp_Object symbol
)
3284 CHECK_SYMBOL (symbol
);
3285 return XSYMBOL (symbol
)->declared_special
? Qt
: Qnil
;
3289 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3290 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3291 The debugger is entered when that frame exits, if the flag is non-nil. */)
3292 (Lisp_Object level
, Lisp_Object flag
)
3294 register struct backtrace
*backlist
= backtrace_list
;
3295 register EMACS_INT i
;
3297 CHECK_NUMBER (level
);
3299 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
3301 backlist
= backlist
->next
;
3305 backlist
->debug_on_exit
= !NILP (flag
);
3310 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3311 doc
: /* Print a trace of Lisp function calls currently active.
3312 Output stream used is value of `standard-output'. */)
3315 register struct backtrace
*backlist
= backtrace_list
;
3318 struct gcpro gcpro1
;
3319 Lisp_Object old_print_level
= Vprint_level
;
3321 if (NILP (Vprint_level
))
3322 XSETFASTINT (Vprint_level
, 8);
3329 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
3330 if (backlist
->nargs
== UNEVALLED
)
3332 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
3333 write_string ("\n", -1);
3337 tem
= *backlist
->function
;
3338 Fprin1 (tem
, Qnil
); /* This can QUIT. */
3339 write_string ("(", -1);
3340 if (backlist
->nargs
== MANY
)
3341 { /* FIXME: Can this happen? */
3343 for (tail
= *backlist
->args
, i
= 0;
3345 tail
= Fcdr (tail
), i
= 1)
3347 if (i
) write_string (" ", -1);
3348 Fprin1 (Fcar (tail
), Qnil
);
3354 for (i
= 0; i
< backlist
->nargs
; i
++)
3356 if (i
) write_string (" ", -1);
3357 Fprin1 (backlist
->args
[i
], Qnil
);
3360 write_string (")\n", -1);
3362 backlist
= backlist
->next
;
3365 Vprint_level
= old_print_level
;
3370 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, NULL
,
3371 doc
: /* Return the function and arguments NFRAMES up from current execution point.
3372 If that frame has not evaluated the arguments yet (or is a special form),
3373 the value is (nil FUNCTION ARG-FORMS...).
3374 If that frame has evaluated its arguments and called its function already,
3375 the value is (t FUNCTION ARG-VALUES...).
3376 A &rest arg is represented as the tail of the list ARG-VALUES.
3377 FUNCTION is whatever was supplied as car of evaluated list,
3378 or a lambda expression for macro calls.
3379 If NFRAMES is more than the number of frames, the value is nil. */)
3380 (Lisp_Object nframes
)
3382 register struct backtrace
*backlist
= backtrace_list
;
3383 register EMACS_INT i
;
3386 CHECK_NATNUM (nframes
);
3388 /* Find the frame requested. */
3389 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3390 backlist
= backlist
->next
;
3394 if (backlist
->nargs
== UNEVALLED
)
3395 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3398 if (backlist
->nargs
== MANY
) /* FIXME: Can this happen? */
3399 tem
= *backlist
->args
;
3401 tem
= Flist (backlist
->nargs
, backlist
->args
);
3403 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3410 mark_backtrace (void)
3412 register struct backtrace
*backlist
;
3415 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3417 mark_object (*backlist
->function
);
3419 if (backlist
->nargs
== UNEVALLED
3420 || backlist
->nargs
== MANY
) /* FIXME: Can this happen? */
3423 i
= backlist
->nargs
;
3425 mark_object (backlist
->args
[i
]);
3433 DEFVAR_INT ("max-specpdl-size", max_specpdl_size
,
3434 doc
: /* Limit on number of Lisp variable bindings and `unwind-protect's.
3435 If Lisp code tries to increase the total number past this amount,
3436 an error is signaled.
3437 You can safely use a value considerably larger than the default value,
3438 if that proves inconveniently small. However, if you increase it too far,
3439 Emacs could run out of memory trying to make the stack bigger. */);
3441 DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth
,
3442 doc
: /* Limit on depth in `eval', `apply' and `funcall' before error.
3444 This limit serves to catch infinite recursions for you before they cause
3445 actual stack overflow in C, which would be fatal for Emacs.
3446 You can safely make it considerably larger than its default value,
3447 if that proves inconveniently small. However, if you increase it too far,
3448 Emacs could overflow the real C stack, and crash. */);
3450 DEFVAR_LISP ("quit-flag", Vquit_flag
,
3451 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3452 If the value is t, that means do an ordinary quit.
3453 If the value equals `throw-on-input', that means quit by throwing
3454 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3455 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3456 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3459 DEFVAR_LISP ("inhibit-quit", Vinhibit_quit
,
3460 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3461 Note that `quit-flag' will still be set by typing C-g,
3462 so a quit will be signaled as soon as `inhibit-quit' is nil.
3463 To prevent this happening, set `quit-flag' to nil
3464 before making `inhibit-quit' nil. */);
3465 Vinhibit_quit
= Qnil
;
3467 DEFSYM (Qinhibit_quit
, "inhibit-quit");
3468 DEFSYM (Qautoload
, "autoload");
3469 DEFSYM (Qdebug_on_error
, "debug-on-error");
3470 DEFSYM (Qmacro
, "macro");
3471 DEFSYM (Qdeclare
, "declare");
3473 /* Note that the process handling also uses Qexit, but we don't want
3474 to staticpro it twice, so we just do it here. */
3475 DEFSYM (Qexit
, "exit");
3477 DEFSYM (Qinteractive
, "interactive");
3478 DEFSYM (Qcommandp
, "commandp");
3479 DEFSYM (Qand_rest
, "&rest");
3480 DEFSYM (Qand_optional
, "&optional");
3481 DEFSYM (Qclosure
, "closure");
3482 DEFSYM (Qdebug
, "debug");
3484 DEFVAR_LISP ("debug-on-error", Vdebug_on_error
,
3485 doc
: /* Non-nil means enter debugger if an error is signaled.
3486 Does not apply to errors handled by `condition-case' or those
3487 matched by `debug-ignored-errors'.
3488 If the value is a list, an error only means to enter the debugger
3489 if one of its condition symbols appears in the list.
3490 When you evaluate an expression interactively, this variable
3491 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3492 The command `toggle-debug-on-error' toggles this.
3493 See also the variable `debug-on-quit'. */);
3494 Vdebug_on_error
= Qnil
;
3496 DEFVAR_LISP ("debug-ignored-errors", Vdebug_ignored_errors
,
3497 doc
: /* List of errors for which the debugger should not be called.
3498 Each element may be a condition-name or a regexp that matches error messages.
3499 If any element applies to a given error, that error skips the debugger
3500 and just returns to top level.
3501 This overrides the variable `debug-on-error'.
3502 It does not apply to errors handled by `condition-case'. */);
3503 Vdebug_ignored_errors
= Qnil
;
3505 DEFVAR_BOOL ("debug-on-quit", debug_on_quit
,
3506 doc
: /* Non-nil means enter debugger if quit is signaled (C-g, for example).
3507 Does not apply if quit is handled by a `condition-case'. */);
3510 DEFVAR_BOOL ("debug-on-next-call", debug_on_next_call
,
3511 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3513 DEFVAR_BOOL ("debugger-may-continue", debugger_may_continue
,
3514 doc
: /* Non-nil means debugger may continue execution.
3515 This is nil when the debugger is called under circumstances where it
3516 might not be safe to continue. */);
3517 debugger_may_continue
= 1;
3519 DEFVAR_LISP ("debugger", Vdebugger
,
3520 doc
: /* Function to call to invoke debugger.
3521 If due to frame exit, args are `exit' and the value being returned;
3522 this function's value will be returned instead of that.
3523 If due to error, args are `error' and a list of the args to `signal'.
3524 If due to `apply' or `funcall' entry, one arg, `lambda'.
3525 If due to `eval' entry, one arg, t. */);
3528 DEFVAR_LISP ("signal-hook-function", Vsignal_hook_function
,
3529 doc
: /* If non-nil, this is a function for `signal' to call.
3530 It receives the same arguments that `signal' was given.
3531 The Edebug package uses this to regain control. */);
3532 Vsignal_hook_function
= Qnil
;
3534 DEFVAR_LISP ("debug-on-signal", Vdebug_on_signal
,
3535 doc
: /* Non-nil means call the debugger regardless of condition handlers.
3536 Note that `debug-on-error', `debug-on-quit' and friends
3537 still determine whether to handle the particular condition. */);
3538 Vdebug_on_signal
= Qnil
;
3540 /* When lexical binding is being used,
3541 Vinternal_interpreter_environment is non-nil, and contains an alist
3542 of lexically-bound variable, or (t), indicating an empty
3543 environment. The lisp name of this variable would be
3544 `internal-interpreter-environment' if it weren't hidden.
3545 Every element of this list can be either a cons (VAR . VAL)
3546 specifying a lexical binding, or a single symbol VAR indicating
3547 that this variable should use dynamic scoping. */
3548 DEFSYM (Qinternal_interpreter_environment
,
3549 "internal-interpreter-environment");
3550 DEFVAR_LISP ("internal-interpreter-environment",
3551 Vinternal_interpreter_environment
,
3552 doc
: /* If non-nil, the current lexical environment of the lisp interpreter.
3553 When lexical binding is not being used, this variable is nil.
3554 A value of `(t)' indicates an empty environment, otherwise it is an
3555 alist of active lexical bindings. */);
3556 Vinternal_interpreter_environment
= Qnil
;
3557 /* Don't export this variable to Elisp, so no one can mess with it
3558 (Just imagine if someone makes it buffer-local). */
3559 Funintern (Qinternal_interpreter_environment
, Qnil
);
3561 DEFSYM (Vrun_hooks
, "run-hooks");
3563 staticpro (&Vautoload_queue
);
3564 Vautoload_queue
= Qnil
;
3565 staticpro (&Vsignaling_function
);
3566 Vsignaling_function
= Qnil
;
3568 inhibit_lisp_code
= Qnil
;
3579 defsubr (&Sfunction
);
3581 defsubr (&Sdefvaralias
);
3582 defsubr (&Sdefconst
);
3583 defsubr (&Smake_var_non_special
);
3587 defsubr (&Smacroexpand
);
3590 defsubr (&Sunwind_protect
);
3591 defsubr (&Scondition_case
);
3593 defsubr (&Sinteractive_p
);
3594 defsubr (&Scalled_interactively_p
);
3595 defsubr (&Scommandp
);
3596 defsubr (&Sautoload
);
3599 defsubr (&Sfuncall
);
3600 defsubr (&Srun_hooks
);
3601 defsubr (&Srun_hook_with_args
);
3602 defsubr (&Srun_hook_with_args_until_success
);
3603 defsubr (&Srun_hook_with_args_until_failure
);
3604 defsubr (&Srun_hook_wrapped
);
3605 defsubr (&Sfetch_bytecode
);
3606 defsubr (&Sbacktrace_debug
);
3607 defsubr (&Sbacktrace
);
3608 defsubr (&Sbacktrace_frame
);
3609 defsubr (&Sspecial_variable_p
);
3610 defsubr (&Sfunctionp
);