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 void unwind_to_catch (struct catchtag
*, Lisp_Object
) NO_RETURN
;
135 static int interactive_p (int);
136 static Lisp_Object
apply_lambda (Lisp_Object fun
, Lisp_Object args
);
137 static Lisp_Object
Ffetch_bytecode (Lisp_Object
);
140 init_eval_once (void)
143 specpdl
= (struct specbinding
*) xmalloc (size
* sizeof (struct specbinding
));
145 specpdl_ptr
= specpdl
;
146 /* Don't forget to update docs (lispref node "Local Variables"). */
147 max_specpdl_size
= 1300; /* 1000 is not enough for CEDET's c-by.el. */
148 max_lisp_eval_depth
= 600;
156 specpdl_ptr
= specpdl
;
161 debug_on_next_call
= 0;
166 /* This is less than the initial value of num_nonmacro_input_events. */
167 when_entered_debugger
= -1;
170 /* Unwind-protect function used by call_debugger. */
173 restore_stack_limits (Lisp_Object data
)
175 max_specpdl_size
= XINT (XCAR (data
));
176 max_lisp_eval_depth
= XINT (XCDR (data
));
180 /* Call the Lisp debugger, giving it argument ARG. */
183 call_debugger (Lisp_Object arg
)
185 int debug_while_redisplaying
;
186 ptrdiff_t count
= SPECPDL_INDEX ();
188 EMACS_INT old_max
= max_specpdl_size
;
190 /* Temporarily bump up the stack limits,
191 so the debugger won't run out of stack. */
193 max_specpdl_size
+= 1;
194 record_unwind_protect (restore_stack_limits
,
195 Fcons (make_number (old_max
),
196 make_number (max_lisp_eval_depth
)));
197 max_specpdl_size
= old_max
;
199 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
200 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
202 if (max_specpdl_size
- 100 < SPECPDL_INDEX ())
203 max_specpdl_size
= SPECPDL_INDEX () + 100;
205 #ifdef HAVE_WINDOW_SYSTEM
206 if (display_hourglass_p
)
210 debug_on_next_call
= 0;
211 when_entered_debugger
= num_nonmacro_input_events
;
213 /* Resetting redisplaying_p to 0 makes sure that debug output is
214 displayed if the debugger is invoked during redisplay. */
215 debug_while_redisplaying
= redisplaying_p
;
217 specbind (intern ("debugger-may-continue"),
218 debug_while_redisplaying
? Qnil
: Qt
);
219 specbind (Qinhibit_redisplay
, Qnil
);
220 specbind (Qdebug_on_error
, Qnil
);
222 #if 0 /* Binding this prevents execution of Lisp code during
223 redisplay, which necessarily leads to display problems. */
224 specbind (Qinhibit_eval_during_redisplay
, Qt
);
227 val
= apply1 (Vdebugger
, arg
);
229 /* Interrupting redisplay and resuming it later is not safe under
230 all circumstances. So, when the debugger returns, abort the
231 interrupted redisplay by going back to the top-level. */
232 if (debug_while_redisplaying
)
235 return unbind_to (count
, val
);
239 do_debug_on_call (Lisp_Object code
)
241 debug_on_next_call
= 0;
242 backtrace_list
->debug_on_exit
= 1;
243 call_debugger (Fcons (code
, Qnil
));
246 /* NOTE!!! Every function that can call EVAL must protect its args
247 and temporaries from garbage collection while it needs them.
248 The definition of `For' shows what you have to do. */
250 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
251 doc
: /* Eval args until one of them yields non-nil, then return that value.
252 The remaining args are not evalled at all.
253 If all args return nil, return nil.
254 usage: (or CONDITIONS...) */)
257 register Lisp_Object val
= Qnil
;
264 val
= eval_sub (XCAR (args
));
274 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
275 doc
: /* Eval args until one of them yields nil, then return nil.
276 The remaining args are not evalled at all.
277 If no arg yields nil, return the last arg's value.
278 usage: (and CONDITIONS...) */)
281 register Lisp_Object val
= Qt
;
288 val
= eval_sub (XCAR (args
));
298 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
299 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
300 Returns the value of THEN or the value of the last of the ELSE's.
301 THEN must be one expression, but ELSE... can be zero or more expressions.
302 If COND yields nil, and there are no ELSE's, the value is nil.
303 usage: (if COND THEN ELSE...) */)
306 register Lisp_Object cond
;
310 cond
= eval_sub (Fcar (args
));
314 return eval_sub (Fcar (Fcdr (args
)));
315 return Fprogn (Fcdr (Fcdr (args
)));
318 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
319 doc
: /* Try each clause until one succeeds.
320 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
321 and, if the value is non-nil, this clause succeeds:
322 then the expressions in BODY are evaluated and the last one's
323 value is the value of the cond-form.
324 If no clause succeeds, cond returns nil.
325 If a clause has one element, as in (CONDITION),
326 CONDITION's value if non-nil is returned from the cond-form.
327 usage: (cond CLAUSES...) */)
330 register Lisp_Object clause
, val
;
337 clause
= Fcar (args
);
338 val
= eval_sub (Fcar (clause
));
341 if (!EQ (XCDR (clause
), Qnil
))
342 val
= Fprogn (XCDR (clause
));
352 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
353 doc
: /* Eval BODY forms sequentially and return value of last one.
354 usage: (progn BODY...) */)
357 register Lisp_Object val
= Qnil
;
364 val
= eval_sub (XCAR (args
));
372 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
373 doc
: /* Eval FIRST and BODY sequentially; return value from FIRST.
374 The value of FIRST is saved during the evaluation of the remaining args,
375 whose values are discarded.
376 usage: (prog1 FIRST BODY...) */)
380 register Lisp_Object args_left
;
381 struct gcpro gcpro1
, gcpro2
;
387 val
= eval_sub (XCAR (args_left
));
388 while (CONSP (args_left
= XCDR (args_left
)))
389 eval_sub (XCAR (args_left
));
395 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
396 doc
: /* Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
397 The value of FORM2 is saved during the evaluation of the
398 remaining args, whose values are discarded.
399 usage: (prog2 FORM1 FORM2 BODY...) */)
405 eval_sub (XCAR (args
));
407 return Fprog1 (XCDR (args
));
410 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
411 doc
: /* Set each SYM to the value of its VAL.
412 The symbols SYM are variables; they are literal (not evaluated).
413 The values VAL are expressions; they are evaluated.
414 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
415 The second VAL is not computed until after the first SYM is set, and so on;
416 each VAL can use the new value of variables set earlier in the `setq'.
417 The return value of the `setq' form is the value of the last VAL.
418 usage: (setq [SYM VAL]...) */)
421 register Lisp_Object args_left
;
422 register Lisp_Object val
, sym
, lex_binding
;
433 val
= eval_sub (Fcar (Fcdr (args_left
)));
434 sym
= Fcar (args_left
);
436 /* Like for eval_sub, we do not check declared_special here since
437 it's been done when let-binding. */
438 if (!NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
440 && !NILP (lex_binding
441 = Fassq (sym
, Vinternal_interpreter_environment
)))
442 XSETCDR (lex_binding
, val
); /* SYM is lexically bound. */
444 Fset (sym
, val
); /* SYM is dynamically bound. */
446 args_left
= Fcdr (Fcdr (args_left
));
448 while (!NILP (args_left
));
454 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
455 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
456 Warning: `quote' does not construct its return value, but just returns
457 the value that was pre-constructed by the Lisp reader (see info node
458 `(elisp)Printed Representation').
459 This means that '(a . b) is not identical to (cons 'a 'b): the former
460 does not cons. Quoting should be reserved for constants that will
461 never be modified by side-effects, unless you like self-modifying code.
462 See the common pitfall in info node `(elisp)Rearrangement' for an example
463 of unexpected results when a quoted object is modified.
464 usage: (quote ARG) */)
467 if (!NILP (Fcdr (args
)))
468 xsignal2 (Qwrong_number_of_arguments
, Qquote
, Flength (args
));
472 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
473 doc
: /* Like `quote', but preferred for objects which are functions.
474 In byte compilation, `function' causes its argument to be compiled.
475 `quote' cannot do that.
476 usage: (function ARG) */)
479 Lisp_Object quoted
= XCAR (args
);
481 if (!NILP (Fcdr (args
)))
482 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
484 if (!NILP (Vinternal_interpreter_environment
)
486 && EQ (XCAR (quoted
), Qlambda
))
487 /* This is a lambda expression within a lexical environment;
488 return an interpreted closure instead of a simple lambda. */
489 return Fcons (Qclosure
, Fcons (Vinternal_interpreter_environment
,
492 /* Simply quote the argument. */
497 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
498 doc
: /* Return t if the containing function was run directly by user input.
499 This means that the function was called with `call-interactively'
500 \(which includes being called as the binding of a key)
501 and input is currently coming from the keyboard (not a keyboard macro),
502 and Emacs is not running in batch mode (`noninteractive' is nil).
504 The only known proper use of `interactive-p' is in deciding whether to
505 display a helpful message, or how to display it. If you're thinking
506 of using it for any other purpose, it is quite likely that you're
507 making a mistake. Think: what do you want to do when the command is
508 called from a keyboard macro?
510 To test whether your function was called with `call-interactively',
511 either (i) add an extra optional argument and give it an `interactive'
512 spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
513 use `called-interactively-p'. */)
516 return interactive_p (1) ? Qt
: Qnil
;
520 DEFUN ("called-interactively-p", Fcalled_interactively_p
, Scalled_interactively_p
, 0, 1, 0,
521 doc
: /* Return t if the containing function was called by `call-interactively'.
522 If KIND is `interactive', then only return t if the call was made
523 interactively by the user, i.e. not in `noninteractive' mode nor
524 when `executing-kbd-macro'.
525 If KIND is `any', on the other hand, it will return t for any kind of
526 interactive call, including being called as the binding of a key, or
527 from a keyboard macro, or in `noninteractive' mode.
529 The only known proper use of `interactive' for KIND is in deciding
530 whether to display a helpful message, or how to display it. If you're
531 thinking of using it for any other purpose, it is quite likely that
532 you're making a mistake. Think: what do you want to do when the
533 command is called from a keyboard macro?
535 This function is meant for implementing advice and other
536 function-modifying features. Instead of using this, it is sometimes
537 cleaner to give your function an extra optional argument whose
538 `interactive' spec specifies non-nil unconditionally (\"p\" is a good
539 way to do this), or via (not (or executing-kbd-macro noninteractive)). */)
542 return ((INTERACTIVE
|| !EQ (kind
, intern ("interactive")))
543 && interactive_p (1)) ? Qt
: Qnil
;
547 /* Return 1 if function in which this appears was called using
550 EXCLUDE_SUBRS_P non-zero means always return 0 if the function
551 called is a built-in. */
554 interactive_p (int exclude_subrs_p
)
556 struct backtrace
*btp
;
559 btp
= backtrace_list
;
561 /* If this isn't a byte-compiled function, there may be a frame at
562 the top for Finteractive_p. If so, skip it. */
563 fun
= Findirect_function (*btp
->function
, Qnil
);
564 if (SUBRP (fun
) && (XSUBR (fun
) == &Sinteractive_p
565 || XSUBR (fun
) == &Scalled_interactively_p
))
568 /* If we're running an Emacs 18-style byte-compiled function, there
569 may be a frame for Fbytecode at the top level. In any version of
570 Emacs there can be Fbytecode frames for subexpressions evaluated
571 inside catch and condition-case. Skip past them.
573 If this isn't a byte-compiled function, then we may now be
574 looking at several frames for special forms. Skip past them. */
576 && (EQ (*btp
->function
, Qbytecode
)
577 || btp
->nargs
== UNEVALLED
))
580 /* `btp' now points at the frame of the innermost function that isn't
581 a special form, ignoring frames for Finteractive_p and/or
582 Fbytecode at the top. If this frame is for a built-in function
583 (such as load or eval-region) return nil. */
584 fun
= Findirect_function (*btp
->function
, Qnil
);
585 if (exclude_subrs_p
&& SUBRP (fun
))
588 /* `btp' points to the frame of a Lisp function that called interactive-p.
589 Return t if that function was called interactively. */
590 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
596 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
597 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
598 Aliased variables always have the same value; setting one sets the other.
599 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
600 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
601 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
602 itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
603 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
604 The return value is BASE-VARIABLE. */)
605 (Lisp_Object new_alias
, Lisp_Object base_variable
, Lisp_Object docstring
)
607 struct Lisp_Symbol
*sym
;
609 CHECK_SYMBOL (new_alias
);
610 CHECK_SYMBOL (base_variable
);
612 sym
= XSYMBOL (new_alias
);
615 /* Not sure why, but why not? */
616 error ("Cannot make a constant an alias");
618 switch (sym
->redirect
)
620 case SYMBOL_FORWARDED
:
621 error ("Cannot make an internal variable an alias");
622 case SYMBOL_LOCALIZED
:
623 error ("Don't know how to make a localized variable an alias");
626 /* http://lists.gnu.org/archive/html/emacs-devel/2008-04/msg00834.html
627 If n_a is bound, but b_v is not, set the value of b_v to n_a,
628 so that old-code that affects n_a before the aliasing is setup
630 if (NILP (Fboundp (base_variable
)))
631 set_internal (base_variable
, find_symbol_value (new_alias
), Qnil
, 1);
634 struct specbinding
*p
;
636 for (p
= specpdl_ptr
; p
> specpdl
; )
637 if ((--p
)->func
== NULL
639 CONSP (p
->symbol
) ? XCAR (p
->symbol
) : p
->symbol
)))
640 error ("Don't know how to make a let-bound variable an alias");
643 sym
->declared_special
= 1;
644 XSYMBOL (base_variable
)->declared_special
= 1;
645 sym
->redirect
= SYMBOL_VARALIAS
;
646 SET_SYMBOL_ALIAS (sym
, XSYMBOL (base_variable
));
647 sym
->constant
= SYMBOL_CONSTANT_P (base_variable
);
648 LOADHIST_ATTACH (new_alias
);
649 /* Even if docstring is nil: remove old docstring. */
650 Fput (new_alias
, Qvariable_documentation
, docstring
);
652 return base_variable
;
656 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
657 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
658 You are not required to define a variable in order to use it, but
659 defining it lets you supply an initial value and documentation, which
660 can be referred to by the Emacs help facilities and other programming
661 tools. The `defvar' form also declares the variable as \"special\",
662 so that it is always dynamically bound even if `lexical-binding' is t.
664 The optional argument INITVALUE is evaluated, and used to set SYMBOL,
665 only if SYMBOL's value is void. If SYMBOL is buffer-local, its
666 default value is what is set; buffer-local values are not affected.
667 If INITVALUE is missing, SYMBOL's value is not set.
669 If SYMBOL has a local binding, then this form affects the local
670 binding. This is usually not what you want. Thus, if you need to
671 load a file defining variables, with this form or with `defconst' or
672 `defcustom', you should always load that file _outside_ any bindings
673 for these variables. \(`defconst' and `defcustom' behave similarly in
676 The optional argument DOCSTRING is a documentation string for the
679 To define a user option, use `defcustom' instead of `defvar'.
680 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
683 register Lisp_Object sym
, tem
, tail
;
687 if (!NILP (Fcdr (Fcdr (tail
))))
688 error ("Too many arguments");
690 tem
= Fdefault_boundp (sym
);
693 /* Do it before evaluating the initial value, for self-references. */
694 XSYMBOL (sym
)->declared_special
= 1;
696 if (SYMBOL_CONSTANT_P (sym
))
698 /* For upward compatibility, allow (defvar :foo (quote :foo)). */
699 Lisp_Object tem1
= Fcar (tail
);
701 && EQ (XCAR (tem1
), Qquote
)
702 && CONSP (XCDR (tem1
))
703 && EQ (XCAR (XCDR (tem1
)), sym
)))
704 error ("Constant symbol `%s' specified in defvar",
705 SDATA (SYMBOL_NAME (sym
)));
709 Fset_default (sym
, eval_sub (Fcar (tail
)));
711 { /* Check if there is really a global binding rather than just a let
712 binding that shadows the global unboundness of the var. */
713 volatile struct specbinding
*pdl
= specpdl_ptr
;
714 while (pdl
> specpdl
)
716 if (EQ ((--pdl
)->symbol
, sym
) && !pdl
->func
717 && EQ (pdl
->old_value
, Qunbound
))
719 message_with_string ("Warning: defvar ignored because %s is let-bound",
720 SYMBOL_NAME (sym
), 1);
729 if (!NILP (Vpurify_flag
))
730 tem
= Fpurecopy (tem
);
731 Fput (sym
, Qvariable_documentation
, tem
);
733 LOADHIST_ATTACH (sym
);
735 else if (!NILP (Vinternal_interpreter_environment
)
736 && !XSYMBOL (sym
)->declared_special
)
737 /* A simple (defvar foo) with lexical scoping does "nothing" except
738 declare that var to be dynamically scoped *locally* (i.e. within
739 the current file or let-block). */
740 Vinternal_interpreter_environment
=
741 Fcons (sym
, Vinternal_interpreter_environment
);
744 /* Simple (defvar <var>) should not count as a definition at all.
745 It could get in the way of other definitions, and unloading this
746 package could try to make the variable unbound. */
752 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
753 doc
: /* Define SYMBOL as a constant variable.
754 This declares that neither programs nor users should ever change the
755 value. This constancy is not actually enforced by Emacs Lisp, but
756 SYMBOL is marked as a special variable so that it is never lexically
759 The `defconst' form always sets the value of SYMBOL to the result of
760 evalling INITVALUE. If SYMBOL is buffer-local, its default value is
761 what is set; buffer-local values are not affected. If SYMBOL has a
762 local binding, then this form sets the local binding's value.
763 However, you should normally not make local bindings for variables
764 defined with this form.
766 The optional DOCSTRING specifies the variable's documentation string.
767 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
770 register Lisp_Object sym
, tem
;
773 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
774 error ("Too many arguments");
776 tem
= eval_sub (Fcar (Fcdr (args
)));
777 if (!NILP (Vpurify_flag
))
778 tem
= Fpurecopy (tem
);
779 Fset_default (sym
, tem
);
780 XSYMBOL (sym
)->declared_special
= 1;
781 tem
= Fcar (Fcdr (Fcdr (args
)));
784 if (!NILP (Vpurify_flag
))
785 tem
= Fpurecopy (tem
);
786 Fput (sym
, Qvariable_documentation
, tem
);
788 Fput (sym
, Qrisky_local_variable
, Qt
);
789 LOADHIST_ATTACH (sym
);
794 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
795 doc
: /* Bind variables according to VARLIST then eval BODY.
796 The value of the last form in BODY is returned.
797 Each element of VARLIST is a symbol (which is bound to nil)
798 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
799 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
800 usage: (let* VARLIST BODY...) */)
803 Lisp_Object varlist
, var
, val
, elt
, lexenv
;
804 ptrdiff_t count
= SPECPDL_INDEX ();
805 struct gcpro gcpro1
, gcpro2
, gcpro3
;
807 GCPRO3 (args
, elt
, varlist
);
809 lexenv
= Vinternal_interpreter_environment
;
811 varlist
= Fcar (args
);
812 while (CONSP (varlist
))
816 elt
= XCAR (varlist
);
822 else if (! NILP (Fcdr (Fcdr (elt
))))
823 signal_error ("`let' bindings can have only one value-form", elt
);
827 val
= eval_sub (Fcar (Fcdr (elt
)));
830 if (!NILP (lexenv
) && SYMBOLP (var
)
831 && !XSYMBOL (var
)->declared_special
832 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
833 /* Lexically bind VAR by adding it to the interpreter's binding
837 = Fcons (Fcons (var
, val
), Vinternal_interpreter_environment
);
838 if (EQ (Vinternal_interpreter_environment
, lexenv
))
839 /* Save the old lexical environment on the specpdl stack,
840 but only for the first lexical binding, since we'll never
841 need to revert to one of the intermediate ones. */
842 specbind (Qinternal_interpreter_environment
, newenv
);
844 Vinternal_interpreter_environment
= newenv
;
849 varlist
= XCDR (varlist
);
852 val
= Fprogn (Fcdr (args
));
853 return unbind_to (count
, val
);
856 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
857 doc
: /* Bind variables according to VARLIST then eval BODY.
858 The value of the last form in BODY is returned.
859 Each element of VARLIST is a symbol (which is bound to nil)
860 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
861 All the VALUEFORMs are evalled before any symbols are bound.
862 usage: (let VARLIST BODY...) */)
865 Lisp_Object
*temps
, tem
, lexenv
;
866 register Lisp_Object elt
, varlist
;
867 ptrdiff_t count
= SPECPDL_INDEX ();
869 struct gcpro gcpro1
, gcpro2
;
872 varlist
= Fcar (args
);
874 /* Make space to hold the values to give the bound variables. */
875 elt
= Flength (varlist
);
876 SAFE_ALLOCA_LISP (temps
, XFASTINT (elt
));
878 /* Compute the values and store them in `temps'. */
880 GCPRO2 (args
, *temps
);
883 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
886 elt
= XCAR (varlist
);
888 temps
[argnum
++] = Qnil
;
889 else if (! NILP (Fcdr (Fcdr (elt
))))
890 signal_error ("`let' bindings can have only one value-form", elt
);
892 temps
[argnum
++] = eval_sub (Fcar (Fcdr (elt
)));
893 gcpro2
.nvars
= argnum
;
897 lexenv
= Vinternal_interpreter_environment
;
899 varlist
= Fcar (args
);
900 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
904 elt
= XCAR (varlist
);
905 var
= SYMBOLP (elt
) ? elt
: Fcar (elt
);
906 tem
= temps
[argnum
++];
908 if (!NILP (lexenv
) && SYMBOLP (var
)
909 && !XSYMBOL (var
)->declared_special
910 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
911 /* Lexically bind VAR by adding it to the lexenv alist. */
912 lexenv
= Fcons (Fcons (var
, tem
), lexenv
);
914 /* Dynamically bind VAR. */
918 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
919 /* Instantiate a new lexical environment. */
920 specbind (Qinternal_interpreter_environment
, lexenv
);
922 elt
= Fprogn (Fcdr (args
));
924 return unbind_to (count
, elt
);
927 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
928 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
929 The order of execution is thus TEST, BODY, TEST, BODY and so on
930 until TEST returns nil.
931 usage: (while TEST BODY...) */)
934 Lisp_Object test
, body
;
935 struct gcpro gcpro1
, gcpro2
;
941 while (!NILP (eval_sub (test
)))
951 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
952 doc
: /* Return result of expanding macros at top level of FORM.
953 If FORM is not a macro call, it is returned unchanged.
954 Otherwise, the macro is expanded and the expansion is considered
955 in place of FORM. When a non-macro-call results, it is returned.
957 The second optional arg ENVIRONMENT specifies an environment of macro
958 definitions to shadow the loaded ones for use in file byte-compilation. */)
959 (Lisp_Object form
, Lisp_Object environment
)
961 /* With cleanups from Hallvard Furuseth. */
962 register Lisp_Object expander
, sym
, def
, tem
;
966 /* Come back here each time we expand a macro call,
967 in case it expands into another macro call. */
970 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
971 def
= sym
= XCAR (form
);
973 /* Trace symbols aliases to other symbols
974 until we get a symbol that is not an alias. */
975 while (SYMBOLP (def
))
979 tem
= Fassq (sym
, environment
);
982 def
= XSYMBOL (sym
)->function
;
983 if (!EQ (def
, Qunbound
))
988 /* Right now TEM is the result from SYM in ENVIRONMENT,
989 and if TEM is nil then DEF is SYM's function definition. */
992 /* SYM is not mentioned in ENVIRONMENT.
993 Look at its function definition. */
994 if (EQ (def
, Qunbound
) || !CONSP (def
))
995 /* Not defined or definition not suitable. */
997 if (EQ (XCAR (def
), Qautoload
))
999 /* Autoloading function: will it be a macro when loaded? */
1000 tem
= Fnth (make_number (4), def
);
1001 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
1002 /* Yes, load it and try again. */
1004 struct gcpro gcpro1
;
1006 do_autoload (def
, sym
);
1013 else if (!EQ (XCAR (def
), Qmacro
))
1015 else expander
= XCDR (def
);
1019 expander
= XCDR (tem
);
1020 if (NILP (expander
))
1023 form
= apply1 (expander
, XCDR (form
));
1028 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1029 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1030 TAG is evalled to get the tag to use; it must not be nil.
1032 Then the BODY is executed.
1033 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
1034 If no throw happens, `catch' returns the value of the last BODY form.
1035 If a throw happens, it specifies the value to return from `catch'.
1036 usage: (catch TAG BODY...) */)
1039 register Lisp_Object tag
;
1040 struct gcpro gcpro1
;
1043 tag
= eval_sub (Fcar (args
));
1045 return internal_catch (tag
, Fprogn
, Fcdr (args
));
1048 /* Set up a catch, then call C function FUNC on argument ARG.
1049 FUNC should return a Lisp_Object.
1050 This is how catches are done from within C code. */
1053 internal_catch (Lisp_Object tag
, Lisp_Object (*func
) (Lisp_Object
), Lisp_Object arg
)
1055 /* This structure is made part of the chain `catchlist'. */
1058 /* Fill in the components of c, and put it on the list. */
1062 c
.backlist
= backtrace_list
;
1063 c
.handlerlist
= handlerlist
;
1064 c
.lisp_eval_depth
= lisp_eval_depth
;
1065 c
.pdlcount
= SPECPDL_INDEX ();
1066 c
.poll_suppress_count
= poll_suppress_count
;
1067 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1068 c
.gcpro
= gcprolist
;
1069 c
.byte_stack
= byte_stack_list
;
1073 if (! _setjmp (c
.jmp
))
1074 c
.val
= (*func
) (arg
);
1076 /* Throw works by a longjmp that comes right here. */
1081 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1082 jump to that CATCH, returning VALUE as the value of that catch.
1084 This is the guts Fthrow and Fsignal; they differ only in the way
1085 they choose the catch tag to throw to. A catch tag for a
1086 condition-case form has a TAG of Qnil.
1088 Before each catch is discarded, unbind all special bindings and
1089 execute all unwind-protect clauses made above that catch. Unwind
1090 the handler stack as we go, so that the proper handlers are in
1091 effect for each unwind-protect clause we run. At the end, restore
1092 some static info saved in CATCH, and longjmp to the location
1095 This is used for correct unwinding in Fthrow and Fsignal. */
1098 unwind_to_catch (struct catchtag
*catch, Lisp_Object value
)
1100 register int last_time
;
1102 /* Save the value in the tag. */
1105 /* Restore certain special C variables. */
1106 set_poll_suppress_count (catch->poll_suppress_count
);
1107 UNBLOCK_INPUT_TO (catch->interrupt_input_blocked
);
1108 handling_signal
= 0;
1113 last_time
= catchlist
== catch;
1115 /* Unwind the specpdl stack, and then restore the proper set of
1117 unbind_to (catchlist
->pdlcount
, Qnil
);
1118 handlerlist
= catchlist
->handlerlist
;
1119 catchlist
= catchlist
->next
;
1121 while (! last_time
);
1124 /* If x_catch_errors was done, turn it off now.
1125 (First we give unbind_to a chance to do that.) */
1126 #if 0 /* This would disable x_catch_errors after x_connection_closed.
1127 The catch must remain in effect during that delicate
1128 state. --lorentey */
1129 x_fully_uncatch_errors ();
1133 byte_stack_list
= catch->byte_stack
;
1134 gcprolist
= catch->gcpro
;
1136 gcpro_level
= gcprolist
? gcprolist
->level
+ 1 : 0;
1138 backtrace_list
= catch->backlist
;
1139 lisp_eval_depth
= catch->lisp_eval_depth
;
1141 _longjmp (catch->jmp
, 1);
1144 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1145 doc
: /* Throw to the catch for TAG and return VALUE from it.
1146 Both TAG and VALUE are evalled. */)
1147 (register Lisp_Object tag
, Lisp_Object value
)
1149 register struct catchtag
*c
;
1152 for (c
= catchlist
; c
; c
= c
->next
)
1154 if (EQ (c
->tag
, tag
))
1155 unwind_to_catch (c
, value
);
1157 xsignal2 (Qno_catch
, tag
, value
);
1161 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1162 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1163 If BODYFORM completes normally, its value is returned
1164 after executing the UNWINDFORMS.
1165 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1166 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1170 ptrdiff_t count
= SPECPDL_INDEX ();
1172 record_unwind_protect (Fprogn
, Fcdr (args
));
1173 val
= eval_sub (Fcar (args
));
1174 return unbind_to (count
, val
);
1177 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1178 doc
: /* Regain control when an error is signaled.
1179 Executes BODYFORM and returns its value if no error happens.
1180 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1181 where the BODY is made of Lisp expressions.
1183 A handler is applicable to an error
1184 if CONDITION-NAME is one of the error's condition names.
1185 If an error happens, the first applicable handler is run.
1187 The car of a handler may be a list of condition names instead of a
1188 single condition name; then it handles all of them. If the special
1189 condition name `debug' is present in this list, it allows another
1190 condition in the list to run the debugger if `debug-on-error' and the
1191 other usual mechanisms says it should (otherwise, `condition-case'
1192 suppresses the debugger).
1194 When a handler handles an error, control returns to the `condition-case'
1195 and it executes the handler's BODY...
1196 with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
1197 \(If VAR is nil, the handler can't access that information.)
1198 Then the value of the last BODY form is returned from the `condition-case'
1201 See also the function `signal' for more info.
1202 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1205 register Lisp_Object bodyform
, handlers
;
1206 volatile Lisp_Object var
;
1209 bodyform
= Fcar (Fcdr (args
));
1210 handlers
= Fcdr (Fcdr (args
));
1212 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1215 /* Like Fcondition_case, but the args are separate
1216 rather than passed in a list. Used by Fbyte_code. */
1219 internal_lisp_condition_case (volatile Lisp_Object var
, Lisp_Object bodyform
,
1220 Lisp_Object handlers
)
1228 for (val
= handlers
; CONSP (val
); val
= XCDR (val
))
1234 && (SYMBOLP (XCAR (tem
))
1235 || CONSP (XCAR (tem
))))))
1236 error ("Invalid condition handler: %s",
1237 SDATA (Fprin1_to_string (tem
, Qt
)));
1242 c
.backlist
= backtrace_list
;
1243 c
.handlerlist
= handlerlist
;
1244 c
.lisp_eval_depth
= lisp_eval_depth
;
1245 c
.pdlcount
= SPECPDL_INDEX ();
1246 c
.poll_suppress_count
= poll_suppress_count
;
1247 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1248 c
.gcpro
= gcprolist
;
1249 c
.byte_stack
= byte_stack_list
;
1250 if (_setjmp (c
.jmp
))
1253 specbind (h
.var
, c
.val
);
1254 val
= Fprogn (Fcdr (h
.chosen_clause
));
1256 /* Note that this just undoes the binding of h.var; whoever
1257 longjumped to us unwound the stack to c.pdlcount before
1259 unbind_to (c
.pdlcount
, Qnil
);
1266 h
.handler
= handlers
;
1267 h
.next
= handlerlist
;
1271 val
= eval_sub (bodyform
);
1273 handlerlist
= h
.next
;
1277 /* Call the function BFUN with no arguments, catching errors within it
1278 according to HANDLERS. If there is an error, call HFUN with
1279 one argument which is the data that describes the error:
1282 HANDLERS can be a list of conditions to catch.
1283 If HANDLERS is Qt, catch all errors.
1284 If HANDLERS is Qerror, catch all errors
1285 but allow the debugger to run if that is enabled. */
1288 internal_condition_case (Lisp_Object (*bfun
) (void), Lisp_Object handlers
,
1289 Lisp_Object (*hfun
) (Lisp_Object
))
1297 c
.backlist
= backtrace_list
;
1298 c
.handlerlist
= handlerlist
;
1299 c
.lisp_eval_depth
= lisp_eval_depth
;
1300 c
.pdlcount
= SPECPDL_INDEX ();
1301 c
.poll_suppress_count
= poll_suppress_count
;
1302 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1303 c
.gcpro
= gcprolist
;
1304 c
.byte_stack
= byte_stack_list
;
1305 if (_setjmp (c
.jmp
))
1307 return (*hfun
) (c
.val
);
1311 h
.handler
= handlers
;
1313 h
.next
= handlerlist
;
1319 handlerlist
= h
.next
;
1323 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1326 internal_condition_case_1 (Lisp_Object (*bfun
) (Lisp_Object
), Lisp_Object arg
,
1327 Lisp_Object handlers
, Lisp_Object (*hfun
) (Lisp_Object
))
1335 c
.backlist
= backtrace_list
;
1336 c
.handlerlist
= handlerlist
;
1337 c
.lisp_eval_depth
= lisp_eval_depth
;
1338 c
.pdlcount
= SPECPDL_INDEX ();
1339 c
.poll_suppress_count
= poll_suppress_count
;
1340 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1341 c
.gcpro
= gcprolist
;
1342 c
.byte_stack
= byte_stack_list
;
1343 if (_setjmp (c
.jmp
))
1345 return (*hfun
) (c
.val
);
1349 h
.handler
= handlers
;
1351 h
.next
= handlerlist
;
1355 val
= (*bfun
) (arg
);
1357 handlerlist
= h
.next
;
1361 /* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as
1365 internal_condition_case_2 (Lisp_Object (*bfun
) (Lisp_Object
, Lisp_Object
),
1368 Lisp_Object handlers
,
1369 Lisp_Object (*hfun
) (Lisp_Object
))
1377 c
.backlist
= backtrace_list
;
1378 c
.handlerlist
= handlerlist
;
1379 c
.lisp_eval_depth
= lisp_eval_depth
;
1380 c
.pdlcount
= SPECPDL_INDEX ();
1381 c
.poll_suppress_count
= poll_suppress_count
;
1382 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1383 c
.gcpro
= gcprolist
;
1384 c
.byte_stack
= byte_stack_list
;
1385 if (_setjmp (c
.jmp
))
1387 return (*hfun
) (c
.val
);
1391 h
.handler
= handlers
;
1393 h
.next
= handlerlist
;
1397 val
= (*bfun
) (arg1
, arg2
);
1399 handlerlist
= h
.next
;
1403 /* Like internal_condition_case but call BFUN with NARGS as first,
1404 and ARGS as second argument. */
1407 internal_condition_case_n (Lisp_Object (*bfun
) (ptrdiff_t, Lisp_Object
*),
1410 Lisp_Object handlers
,
1411 Lisp_Object (*hfun
) (Lisp_Object
))
1419 c
.backlist
= backtrace_list
;
1420 c
.handlerlist
= handlerlist
;
1421 c
.lisp_eval_depth
= lisp_eval_depth
;
1422 c
.pdlcount
= SPECPDL_INDEX ();
1423 c
.poll_suppress_count
= poll_suppress_count
;
1424 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1425 c
.gcpro
= gcprolist
;
1426 c
.byte_stack
= byte_stack_list
;
1427 if (_setjmp (c
.jmp
))
1429 return (*hfun
) (c
.val
);
1433 h
.handler
= handlers
;
1435 h
.next
= handlerlist
;
1439 val
= (*bfun
) (nargs
, args
);
1441 handlerlist
= h
.next
;
1446 static Lisp_Object
find_handler_clause (Lisp_Object
, Lisp_Object
);
1447 static int maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
,
1451 process_quit_flag (void)
1453 Lisp_Object flag
= Vquit_flag
;
1455 if (EQ (flag
, Qkill_emacs
))
1457 if (EQ (Vthrow_on_input
, flag
))
1458 Fthrow (Vthrow_on_input
, Qt
);
1459 Fsignal (Qquit
, Qnil
);
1462 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1463 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1464 This function does not return.
1466 An error symbol is a symbol with an `error-conditions' property
1467 that is a list of condition names.
1468 A handler for any of those names will get to handle this signal.
1469 The symbol `error' should normally be one of them.
1471 DATA should be a list. Its elements are printed as part of the error message.
1472 See Info anchor `(elisp)Definition of signal' for some details on how this
1473 error message is constructed.
1474 If the signal is handled, DATA is made available to the handler.
1475 See also the function `condition-case'. */)
1476 (Lisp_Object error_symbol
, Lisp_Object data
)
1478 /* When memory is full, ERROR-SYMBOL is nil,
1479 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1480 That is a special case--don't do this in other situations. */
1481 Lisp_Object conditions
;
1483 Lisp_Object real_error_symbol
1484 = (NILP (error_symbol
) ? Fcar (data
) : error_symbol
);
1485 register Lisp_Object clause
= Qnil
;
1487 struct backtrace
*bp
;
1489 immediate_quit
= handling_signal
= 0;
1491 if (gc_in_progress
|| waiting_for_input
)
1494 #if 0 /* rms: I don't know why this was here,
1495 but it is surely wrong for an error that is handled. */
1496 #ifdef HAVE_WINDOW_SYSTEM
1497 if (display_hourglass_p
)
1498 cancel_hourglass ();
1502 /* This hook is used by edebug. */
1503 if (! NILP (Vsignal_hook_function
)
1504 && ! NILP (error_symbol
))
1506 /* Edebug takes care of restoring these variables when it exits. */
1507 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1508 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1510 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1511 max_specpdl_size
= SPECPDL_INDEX () + 40;
1513 call2 (Vsignal_hook_function
, error_symbol
, data
);
1516 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1518 /* Remember from where signal was called. Skip over the frame for
1519 `signal' itself. If a frame for `error' follows, skip that,
1520 too. Don't do this when ERROR_SYMBOL is nil, because that
1521 is a memory-full error. */
1522 Vsignaling_function
= Qnil
;
1523 if (backtrace_list
&& !NILP (error_symbol
))
1525 bp
= backtrace_list
->next
;
1526 if (bp
&& bp
->function
&& EQ (*bp
->function
, Qerror
))
1528 if (bp
&& bp
->function
)
1529 Vsignaling_function
= *bp
->function
;
1532 for (h
= handlerlist
; h
; h
= h
->next
)
1534 clause
= find_handler_clause (h
->handler
, conditions
);
1539 if (/* Don't run the debugger for a memory-full error.
1540 (There is no room in memory to do that!) */
1541 !NILP (error_symbol
)
1542 && (!NILP (Vdebug_on_signal
)
1543 /* If no handler is present now, try to run the debugger. */
1545 /* A `debug' symbol in the handler list disables the normal
1546 suppression of the debugger. */
1547 || (CONSP (clause
) && CONSP (XCAR (clause
))
1548 && !NILP (Fmemq (Qdebug
, XCAR (clause
))))
1549 /* Special handler that means "print a message and run debugger
1551 || EQ (h
->handler
, Qerror
)))
1554 = maybe_call_debugger (conditions
, error_symbol
, data
);
1555 /* We can't return values to code which signaled an error, but we
1556 can continue code which has signaled a quit. */
1557 if (debugger_called
&& EQ (real_error_symbol
, Qquit
))
1563 Lisp_Object unwind_data
1564 = (NILP (error_symbol
) ? data
: Fcons (error_symbol
, data
));
1566 h
->chosen_clause
= clause
;
1567 unwind_to_catch (h
->tag
, unwind_data
);
1572 Fthrow (Qtop_level
, Qt
);
1575 if (! NILP (error_symbol
))
1576 data
= Fcons (error_symbol
, data
);
1578 string
= Ferror_message_string (data
);
1579 fatal ("%s", SDATA (string
));
1582 /* Internal version of Fsignal that never returns.
1583 Used for anything but Qquit (which can return from Fsignal). */
1586 xsignal (Lisp_Object error_symbol
, Lisp_Object data
)
1588 Fsignal (error_symbol
, data
);
1592 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1595 xsignal0 (Lisp_Object error_symbol
)
1597 xsignal (error_symbol
, Qnil
);
1601 xsignal1 (Lisp_Object error_symbol
, Lisp_Object arg
)
1603 xsignal (error_symbol
, list1 (arg
));
1607 xsignal2 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
)
1609 xsignal (error_symbol
, list2 (arg1
, arg2
));
1613 xsignal3 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
1615 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1618 /* Signal `error' with message S, and additional arg ARG.
1619 If ARG is not a genuine list, make it a one-element list. */
1622 signal_error (const char *s
, Lisp_Object arg
)
1624 Lisp_Object tortoise
, hare
;
1626 hare
= tortoise
= arg
;
1627 while (CONSP (hare
))
1634 tortoise
= XCDR (tortoise
);
1636 if (EQ (hare
, tortoise
))
1641 arg
= Fcons (arg
, Qnil
); /* Make it a list. */
1643 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1647 /* Return nonzero if LIST is a non-nil atom or
1648 a list containing one of CONDITIONS. */
1651 wants_debugger (Lisp_Object list
, Lisp_Object conditions
)
1658 while (CONSP (conditions
))
1660 Lisp_Object
this, tail
;
1661 this = XCAR (conditions
);
1662 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1663 if (EQ (XCAR (tail
), this))
1665 conditions
= XCDR (conditions
);
1670 /* Return 1 if an error with condition-symbols CONDITIONS,
1671 and described by SIGNAL-DATA, should skip the debugger
1672 according to debugger-ignored-errors. */
1675 skip_debugger (Lisp_Object conditions
, Lisp_Object data
)
1678 int first_string
= 1;
1679 Lisp_Object error_message
;
1681 error_message
= Qnil
;
1682 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1684 if (STRINGP (XCAR (tail
)))
1688 error_message
= Ferror_message_string (data
);
1692 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1697 Lisp_Object contail
;
1699 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1700 if (EQ (XCAR (tail
), XCAR (contail
)))
1708 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1709 SIG and DATA describe the signal. There are two ways to pass them:
1710 = SIG is the error symbol, and DATA is the rest of the data.
1711 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1712 This is for memory-full errors only. */
1714 maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
, Lisp_Object data
)
1716 Lisp_Object combined_data
;
1718 combined_data
= Fcons (sig
, data
);
1721 /* Don't try to run the debugger with interrupts blocked.
1722 The editing loop would return anyway. */
1724 /* Does user want to enter debugger for this kind of error? */
1727 : wants_debugger (Vdebug_on_error
, conditions
))
1728 && ! skip_debugger (conditions
, combined_data
)
1729 /* RMS: What's this for? */
1730 && when_entered_debugger
< num_nonmacro_input_events
)
1732 call_debugger (Fcons (Qerror
, Fcons (combined_data
, Qnil
)));
1740 find_handler_clause (Lisp_Object handlers
, Lisp_Object conditions
)
1742 register Lisp_Object h
;
1744 /* t is used by handlers for all conditions, set up by C code. */
1745 if (EQ (handlers
, Qt
))
1748 /* error is used similarly, but means print an error message
1749 and run the debugger if that is enabled. */
1750 if (EQ (handlers
, Qerror
))
1753 for (h
= handlers
; CONSP (h
); h
= XCDR (h
))
1755 Lisp_Object handler
= XCAR (h
);
1756 Lisp_Object condit
, tem
;
1758 if (!CONSP (handler
))
1760 condit
= XCAR (handler
);
1761 /* Handle a single condition name in handler HANDLER. */
1762 if (SYMBOLP (condit
))
1764 tem
= Fmemq (Fcar (handler
), conditions
);
1768 /* Handle a list of condition names in handler HANDLER. */
1769 else if (CONSP (condit
))
1772 for (tail
= condit
; CONSP (tail
); tail
= XCDR (tail
))
1774 tem
= Fmemq (XCAR (tail
), conditions
);
1785 /* Dump an error message; called like vprintf. */
1787 verror (const char *m
, va_list ap
)
1790 ptrdiff_t size
= sizeof buf
;
1791 ptrdiff_t size_max
= STRING_BYTES_BOUND
+ 1;
1796 used
= evxprintf (&buffer
, &size
, buf
, size_max
, m
, ap
);
1797 string
= make_string (buffer
, used
);
1801 xsignal1 (Qerror
, string
);
1805 /* Dump an error message; called like printf. */
1809 error (const char *m
, ...)
1817 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
1818 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
1819 This means it contains a description for how to read arguments to give it.
1820 The value is nil for an invalid function or a symbol with no function
1823 Interactively callable functions include strings and vectors (treated
1824 as keyboard macros), lambda-expressions that contain a top-level call
1825 to `interactive', autoload definitions made by `autoload' with non-nil
1826 fourth argument, and some of the built-in functions of Lisp.
1828 Also, a symbol satisfies `commandp' if its function definition does so.
1830 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
1831 then strings and vectors are not accepted. */)
1832 (Lisp_Object function
, Lisp_Object for_call_interactively
)
1834 register Lisp_Object fun
;
1835 register Lisp_Object funcar
;
1836 Lisp_Object if_prop
= Qnil
;
1840 fun
= indirect_function (fun
); /* Check cycles. */
1841 if (NILP (fun
) || EQ (fun
, Qunbound
))
1844 /* Check an `interactive-form' property if present, analogous to the
1845 function-documentation property. */
1847 while (SYMBOLP (fun
))
1849 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
1852 fun
= Fsymbol_function (fun
);
1855 /* Emacs primitives are interactive if their DEFUN specifies an
1856 interactive spec. */
1858 return XSUBR (fun
)->intspec
? Qt
: if_prop
;
1860 /* Bytecode objects are interactive if they are long enough to
1861 have an element whose index is COMPILED_INTERACTIVE, which is
1862 where the interactive spec is stored. */
1863 else if (COMPILEDP (fun
))
1864 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
1867 /* Strings and vectors are keyboard macros. */
1868 if (STRINGP (fun
) || VECTORP (fun
))
1869 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
1871 /* Lists may represent commands. */
1874 funcar
= XCAR (fun
);
1875 if (EQ (funcar
, Qclosure
))
1876 return (!NILP (Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
)))))
1878 else if (EQ (funcar
, Qlambda
))
1879 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
1880 else if (EQ (funcar
, Qautoload
))
1881 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
1886 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1887 doc
: /* Define FUNCTION to autoload from FILE.
1888 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
1889 Third arg DOCSTRING is documentation for the function.
1890 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
1891 Fifth arg TYPE indicates the type of the object:
1892 nil or omitted says FUNCTION is a function,
1893 `keymap' says FUNCTION is really a keymap, and
1894 `macro' or t says FUNCTION is really a macro.
1895 Third through fifth args give info about the real definition.
1896 They default to nil.
1897 If FUNCTION is already defined other than as an autoload,
1898 this does nothing and returns nil. */)
1899 (Lisp_Object function
, Lisp_Object file
, Lisp_Object docstring
, Lisp_Object interactive
, Lisp_Object type
)
1901 CHECK_SYMBOL (function
);
1902 CHECK_STRING (file
);
1904 /* If function is defined and not as an autoload, don't override. */
1905 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
1906 && !(CONSP (XSYMBOL (function
)->function
)
1907 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
1910 if (NILP (Vpurify_flag
))
1911 /* Only add entries after dumping, because the ones before are
1912 not useful and else we get loads of them from the loaddefs.el. */
1913 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
1914 else if (EQ (docstring
, make_number (0)))
1915 /* `read1' in lread.c has found the docstring starting with "\
1916 and assumed the docstring will be provided by Snarf-documentation, so it
1917 passed us 0 instead. But that leads to accidental sharing in purecopy's
1918 hash-consing, so we use a (hopefully) unique integer instead. */
1919 docstring
= make_number (XUNTAG (function
, Lisp_Symbol
));
1920 return Ffset (function
,
1921 Fpurecopy (list5 (Qautoload
, file
, docstring
,
1922 interactive
, type
)));
1926 un_autoload (Lisp_Object oldqueue
)
1928 register Lisp_Object queue
, first
, second
;
1930 /* Queue to unwind is current value of Vautoload_queue.
1931 oldqueue is the shadowed value to leave in Vautoload_queue. */
1932 queue
= Vautoload_queue
;
1933 Vautoload_queue
= oldqueue
;
1934 while (CONSP (queue
))
1936 first
= XCAR (queue
);
1937 second
= Fcdr (first
);
1938 first
= Fcar (first
);
1939 if (EQ (first
, make_number (0)))
1942 Ffset (first
, second
);
1943 queue
= XCDR (queue
);
1948 /* Load an autoloaded function.
1949 FUNNAME is the symbol which is the function's name.
1950 FUNDEF is the autoload definition (a list). */
1953 do_autoload (Lisp_Object fundef
, Lisp_Object funname
)
1955 ptrdiff_t count
= SPECPDL_INDEX ();
1957 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1959 /* This is to make sure that loadup.el gives a clear picture
1960 of what files are preloaded and when. */
1961 if (! NILP (Vpurify_flag
))
1962 error ("Attempt to autoload %s while preparing to dump",
1963 SDATA (SYMBOL_NAME (funname
)));
1966 CHECK_SYMBOL (funname
);
1967 GCPRO3 (fun
, funname
, fundef
);
1969 /* Preserve the match data. */
1970 record_unwind_save_match_data ();
1972 /* If autoloading gets an error (which includes the error of failing
1973 to define the function being called), we use Vautoload_queue
1974 to undo function definitions and `provide' calls made by
1975 the function. We do this in the specific case of autoloading
1976 because autoloading is not an explicit request "load this file",
1977 but rather a request to "call this function".
1979 The value saved here is to be restored into Vautoload_queue. */
1980 record_unwind_protect (un_autoload
, Vautoload_queue
);
1981 Vautoload_queue
= Qt
;
1982 Fload (Fcar (Fcdr (fundef
)), Qnil
, Qt
, Qnil
, Qt
);
1984 /* Once loading finishes, don't undo it. */
1985 Vautoload_queue
= Qt
;
1986 unbind_to (count
, Qnil
);
1988 fun
= Findirect_function (fun
, Qnil
);
1990 if (!NILP (Fequal (fun
, fundef
)))
1991 error ("Autoloading failed to define function %s",
1992 SDATA (SYMBOL_NAME (funname
)));
1997 DEFUN ("eval", Feval
, Seval
, 1, 2, 0,
1998 doc
: /* Evaluate FORM and return its value.
1999 If LEXICAL is t, evaluate using lexical scoping. */)
2000 (Lisp_Object form
, Lisp_Object lexical
)
2002 ptrdiff_t count
= SPECPDL_INDEX ();
2003 specbind (Qinternal_interpreter_environment
,
2004 NILP (lexical
) ? Qnil
: Fcons (Qt
, Qnil
));
2005 return unbind_to (count
, eval_sub (form
));
2008 /* Eval a sub-expression of the current expression (i.e. in the same
2011 eval_sub (Lisp_Object form
)
2013 Lisp_Object fun
, val
, original_fun
, original_args
;
2015 struct backtrace backtrace
;
2016 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2018 if (handling_signal
)
2023 /* Look up its binding in the lexical environment.
2024 We do not pay attention to the declared_special flag here, since we
2025 already did that when let-binding the variable. */
2026 Lisp_Object lex_binding
2027 = !NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
2028 ? Fassq (form
, Vinternal_interpreter_environment
)
2030 if (CONSP (lex_binding
))
2031 return XCDR (lex_binding
);
2033 return Fsymbol_value (form
);
2040 if ((consing_since_gc
> gc_cons_threshold
2041 && consing_since_gc
> gc_relative_threshold
)
2043 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2046 Fgarbage_collect ();
2050 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2052 if (max_lisp_eval_depth
< 100)
2053 max_lisp_eval_depth
= 100;
2054 if (lisp_eval_depth
> max_lisp_eval_depth
)
2055 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2058 original_fun
= Fcar (form
);
2059 original_args
= Fcdr (form
);
2061 backtrace
.next
= backtrace_list
;
2062 backtrace_list
= &backtrace
;
2063 backtrace
.function
= &original_fun
; /* This also protects them from gc. */
2064 backtrace
.args
= &original_args
;
2065 backtrace
.nargs
= UNEVALLED
;
2066 backtrace
.debug_on_exit
= 0;
2068 if (debug_on_next_call
)
2069 do_debug_on_call (Qt
);
2071 /* At this point, only original_fun and original_args
2072 have values that will be used below. */
2075 /* Optimize for no indirection. */
2077 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2078 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2079 fun
= indirect_function (fun
);
2083 Lisp_Object numargs
;
2084 Lisp_Object argvals
[8];
2085 Lisp_Object args_left
;
2086 register int i
, maxargs
;
2088 args_left
= original_args
;
2089 numargs
= Flength (args_left
);
2093 if (XINT (numargs
) < XSUBR (fun
)->min_args
2094 || (XSUBR (fun
)->max_args
>= 0
2095 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2096 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2098 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2099 val
= (XSUBR (fun
)->function
.aUNEVALLED
) (args_left
);
2100 else if (XSUBR (fun
)->max_args
== MANY
)
2102 /* Pass a vector of evaluated arguments. */
2104 ptrdiff_t argnum
= 0;
2107 SAFE_ALLOCA_LISP (vals
, XINT (numargs
));
2109 GCPRO3 (args_left
, fun
, fun
);
2113 while (!NILP (args_left
))
2115 vals
[argnum
++] = eval_sub (Fcar (args_left
));
2116 args_left
= Fcdr (args_left
);
2117 gcpro3
.nvars
= argnum
;
2120 backtrace
.args
= vals
;
2121 backtrace
.nargs
= XINT (numargs
);
2123 val
= (XSUBR (fun
)->function
.aMANY
) (XINT (numargs
), vals
);
2129 GCPRO3 (args_left
, fun
, fun
);
2130 gcpro3
.var
= argvals
;
2133 maxargs
= XSUBR (fun
)->max_args
;
2134 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
2136 argvals
[i
] = eval_sub (Fcar (args_left
));
2142 backtrace
.args
= argvals
;
2143 backtrace
.nargs
= XINT (numargs
);
2148 val
= (XSUBR (fun
)->function
.a0 ());
2151 val
= (XSUBR (fun
)->function
.a1 (argvals
[0]));
2154 val
= (XSUBR (fun
)->function
.a2 (argvals
[0], argvals
[1]));
2157 val
= (XSUBR (fun
)->function
.a3
2158 (argvals
[0], argvals
[1], argvals
[2]));
2161 val
= (XSUBR (fun
)->function
.a4
2162 (argvals
[0], argvals
[1], argvals
[2], argvals
[3]));
2165 val
= (XSUBR (fun
)->function
.a5
2166 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2170 val
= (XSUBR (fun
)->function
.a6
2171 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2172 argvals
[4], argvals
[5]));
2175 val
= (XSUBR (fun
)->function
.a7
2176 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2177 argvals
[4], argvals
[5], argvals
[6]));
2181 val
= (XSUBR (fun
)->function
.a8
2182 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2183 argvals
[4], argvals
[5], argvals
[6], argvals
[7]));
2187 /* Someone has created a subr that takes more arguments than
2188 is supported by this code. We need to either rewrite the
2189 subr to use a different argument protocol, or add more
2190 cases to this switch. */
2195 else if (COMPILEDP (fun
))
2196 val
= apply_lambda (fun
, original_args
);
2199 if (EQ (fun
, Qunbound
))
2200 xsignal1 (Qvoid_function
, original_fun
);
2202 xsignal1 (Qinvalid_function
, original_fun
);
2203 funcar
= XCAR (fun
);
2204 if (!SYMBOLP (funcar
))
2205 xsignal1 (Qinvalid_function
, original_fun
);
2206 if (EQ (funcar
, Qautoload
))
2208 do_autoload (fun
, original_fun
);
2211 if (EQ (funcar
, Qmacro
))
2212 val
= eval_sub (apply1 (Fcdr (fun
), original_args
));
2213 else if (EQ (funcar
, Qlambda
)
2214 || EQ (funcar
, Qclosure
))
2215 val
= apply_lambda (fun
, original_args
);
2217 xsignal1 (Qinvalid_function
, original_fun
);
2222 if (backtrace
.debug_on_exit
)
2223 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2224 backtrace_list
= backtrace
.next
;
2229 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
2230 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2231 Then return the value FUNCTION returns.
2232 Thus, (apply '+ 1 2 '(3 4)) returns 10.
2233 usage: (apply FUNCTION &rest ARGUMENTS) */)
2234 (ptrdiff_t nargs
, Lisp_Object
*args
)
2238 register Lisp_Object spread_arg
;
2239 register Lisp_Object
*funcall_args
;
2240 Lisp_Object fun
, retval
;
2241 struct gcpro gcpro1
;
2246 spread_arg
= args
[nargs
- 1];
2247 CHECK_LIST (spread_arg
);
2249 numargs
= XINT (Flength (spread_arg
));
2252 return Ffuncall (nargs
- 1, args
);
2253 else if (numargs
== 1)
2255 args
[nargs
- 1] = XCAR (spread_arg
);
2256 return Ffuncall (nargs
, args
);
2259 numargs
+= nargs
- 2;
2261 /* Optimize for no indirection. */
2262 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2263 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2264 fun
= indirect_function (fun
);
2265 if (EQ (fun
, Qunbound
))
2267 /* Let funcall get the error. */
2274 if (numargs
< XSUBR (fun
)->min_args
2275 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2276 goto funcall
; /* Let funcall get the error. */
2277 else if (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
> numargs
)
2279 /* Avoid making funcall cons up a yet another new vector of arguments
2280 by explicitly supplying nil's for optional values. */
2281 SAFE_ALLOCA_LISP (funcall_args
, 1 + XSUBR (fun
)->max_args
);
2282 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2283 funcall_args
[++i
] = Qnil
;
2284 GCPRO1 (*funcall_args
);
2285 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2289 /* We add 1 to numargs because funcall_args includes the
2290 function itself as well as its arguments. */
2293 SAFE_ALLOCA_LISP (funcall_args
, 1 + numargs
);
2294 GCPRO1 (*funcall_args
);
2295 gcpro1
.nvars
= 1 + numargs
;
2298 memcpy (funcall_args
, args
, nargs
* sizeof (Lisp_Object
));
2299 /* Spread the last arg we got. Its first element goes in
2300 the slot that it used to occupy, hence this value of I. */
2302 while (!NILP (spread_arg
))
2304 funcall_args
[i
++] = XCAR (spread_arg
);
2305 spread_arg
= XCDR (spread_arg
);
2308 /* By convention, the caller needs to gcpro Ffuncall's args. */
2309 retval
= Ffuncall (gcpro1
.nvars
, funcall_args
);
2316 /* Run hook variables in various ways. */
2319 funcall_nil (ptrdiff_t nargs
, Lisp_Object
*args
)
2321 Ffuncall (nargs
, args
);
2325 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2326 doc
: /* Run each hook in HOOKS.
2327 Each argument should be a symbol, a hook variable.
2328 These symbols are processed in the order specified.
2329 If a hook symbol has a non-nil value, that value may be a function
2330 or a list of functions to be called to run the hook.
2331 If the value is a function, it is called with no arguments.
2332 If it is a list, the elements are called, in order, with no arguments.
2334 Major modes should not use this function directly to run their mode
2335 hook; they should use `run-mode-hooks' instead.
2337 Do not use `make-local-variable' to make a hook variable buffer-local.
2338 Instead, use `add-hook' and specify t for the LOCAL argument.
2339 usage: (run-hooks &rest HOOKS) */)
2340 (ptrdiff_t nargs
, Lisp_Object
*args
)
2342 Lisp_Object hook
[1];
2345 for (i
= 0; i
< nargs
; i
++)
2348 run_hook_with_args (1, hook
, funcall_nil
);
2354 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2355 Srun_hook_with_args
, 1, MANY
, 0,
2356 doc
: /* Run HOOK with the specified arguments ARGS.
2357 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2358 value, that value may be a function or a list of functions to be
2359 called to run the hook. If the value is a function, it is called with
2360 the given arguments and its return value is returned. If it is a list
2361 of functions, those functions are called, in order,
2362 with the given arguments ARGS.
2363 It is best not to depend on the value returned by `run-hook-with-args',
2366 Do not use `make-local-variable' to make a hook variable buffer-local.
2367 Instead, use `add-hook' and specify t for the LOCAL argument.
2368 usage: (run-hook-with-args HOOK &rest ARGS) */)
2369 (ptrdiff_t nargs
, Lisp_Object
*args
)
2371 return run_hook_with_args (nargs
, args
, funcall_nil
);
2374 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2375 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2376 doc
: /* Run HOOK with the specified arguments ARGS.
2377 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2378 value, that value may be a function or a list of functions to be
2379 called to run the hook. If the value is a function, it is called with
2380 the given arguments and its return value is returned.
2381 If it is a list of functions, those functions are called, in order,
2382 with the given arguments ARGS, until one of them
2383 returns a non-nil value. Then we return that value.
2384 However, if they all return nil, we return nil.
2386 Do not use `make-local-variable' to make a hook variable buffer-local.
2387 Instead, use `add-hook' and specify t for the LOCAL argument.
2388 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2389 (ptrdiff_t nargs
, Lisp_Object
*args
)
2391 return run_hook_with_args (nargs
, args
, Ffuncall
);
2395 funcall_not (ptrdiff_t nargs
, Lisp_Object
*args
)
2397 return NILP (Ffuncall (nargs
, args
)) ? Qt
: Qnil
;
2400 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2401 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2402 doc
: /* Run HOOK with the specified arguments ARGS.
2403 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2404 value, that value may be a function or a list of functions to be
2405 called to run the hook. If the value is a function, it is called with
2406 the given arguments and its return value is returned.
2407 If it is a list of functions, those functions are called, in order,
2408 with the given arguments ARGS, until one of them returns nil.
2409 Then we return nil. However, if they all return non-nil, we return non-nil.
2411 Do not use `make-local-variable' to make a hook variable buffer-local.
2412 Instead, use `add-hook' and specify t for the LOCAL argument.
2413 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2414 (ptrdiff_t nargs
, Lisp_Object
*args
)
2416 return NILP (run_hook_with_args (nargs
, args
, funcall_not
)) ? Qt
: Qnil
;
2420 run_hook_wrapped_funcall (ptrdiff_t nargs
, Lisp_Object
*args
)
2422 Lisp_Object tmp
= args
[0], ret
;
2425 ret
= Ffuncall (nargs
, args
);
2431 DEFUN ("run-hook-wrapped", Frun_hook_wrapped
, Srun_hook_wrapped
, 2, MANY
, 0,
2432 doc
: /* Run HOOK, passing each function through WRAP-FUNCTION.
2433 I.e. instead of calling each function FUN directly with arguments ARGS,
2434 it calls WRAP-FUNCTION with arguments FUN and ARGS.
2435 As soon as a call to WRAP-FUNCTION returns non-nil, `run-hook-wrapped'
2436 aborts and returns that value.
2437 usage: (run-hook-wrapped HOOK WRAP-FUNCTION &rest ARGS) */)
2438 (ptrdiff_t nargs
, Lisp_Object
*args
)
2440 return run_hook_with_args (nargs
, args
, run_hook_wrapped_funcall
);
2443 /* ARGS[0] should be a hook symbol.
2444 Call each of the functions in the hook value, passing each of them
2445 as arguments all the rest of ARGS (all NARGS - 1 elements).
2446 FUNCALL specifies how to call each function on the hook.
2447 The caller (or its caller, etc) must gcpro all of ARGS,
2448 except that it isn't necessary to gcpro ARGS[0]. */
2451 run_hook_with_args (ptrdiff_t nargs
, Lisp_Object
*args
,
2452 Lisp_Object (*funcall
) (ptrdiff_t nargs
, Lisp_Object
*args
))
2454 Lisp_Object sym
, val
, ret
= Qnil
;
2455 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2457 /* If we are dying or still initializing,
2458 don't do anything--it would probably crash if we tried. */
2459 if (NILP (Vrun_hooks
))
2463 val
= find_symbol_value (sym
);
2465 if (EQ (val
, Qunbound
) || NILP (val
))
2467 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2470 return funcall (nargs
, args
);
2474 Lisp_Object global_vals
= Qnil
;
2475 GCPRO3 (sym
, val
, global_vals
);
2478 CONSP (val
) && NILP (ret
);
2481 if (EQ (XCAR (val
), Qt
))
2483 /* t indicates this hook has a local binding;
2484 it means to run the global binding too. */
2485 global_vals
= Fdefault_value (sym
);
2486 if (NILP (global_vals
)) continue;
2488 if (!CONSP (global_vals
) || EQ (XCAR (global_vals
), Qlambda
))
2490 args
[0] = global_vals
;
2491 ret
= funcall (nargs
, args
);
2496 CONSP (global_vals
) && NILP (ret
);
2497 global_vals
= XCDR (global_vals
))
2499 args
[0] = XCAR (global_vals
);
2500 /* In a global value, t should not occur. If it does, we
2501 must ignore it to avoid an endless loop. */
2502 if (!EQ (args
[0], Qt
))
2503 ret
= funcall (nargs
, args
);
2509 args
[0] = XCAR (val
);
2510 ret
= funcall (nargs
, args
);
2519 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2522 run_hook_with_args_2 (Lisp_Object hook
, Lisp_Object arg1
, Lisp_Object arg2
)
2524 Lisp_Object temp
[3];
2529 Frun_hook_with_args (3, temp
);
2532 /* Apply fn to arg. */
2534 apply1 (Lisp_Object fn
, Lisp_Object arg
)
2536 struct gcpro gcpro1
;
2540 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2543 Lisp_Object args
[2];
2547 RETURN_UNGCPRO (Fapply (2, args
));
2551 /* Call function fn on no arguments. */
2553 call0 (Lisp_Object fn
)
2555 struct gcpro gcpro1
;
2558 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2561 /* Call function fn with 1 argument arg1. */
2564 call1 (Lisp_Object fn
, Lisp_Object arg1
)
2566 struct gcpro gcpro1
;
2567 Lisp_Object args
[2];
2573 RETURN_UNGCPRO (Ffuncall (2, args
));
2576 /* Call function fn with 2 arguments arg1, arg2. */
2579 call2 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
)
2581 struct gcpro gcpro1
;
2582 Lisp_Object args
[3];
2588 RETURN_UNGCPRO (Ffuncall (3, args
));
2591 /* Call function fn with 3 arguments arg1, arg2, arg3. */
2594 call3 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2596 struct gcpro gcpro1
;
2597 Lisp_Object args
[4];
2604 RETURN_UNGCPRO (Ffuncall (4, args
));
2607 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
2610 call4 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2613 struct gcpro gcpro1
;
2614 Lisp_Object args
[5];
2622 RETURN_UNGCPRO (Ffuncall (5, args
));
2625 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
2628 call5 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2629 Lisp_Object arg4
, Lisp_Object arg5
)
2631 struct gcpro gcpro1
;
2632 Lisp_Object args
[6];
2641 RETURN_UNGCPRO (Ffuncall (6, args
));
2644 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
2647 call6 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2648 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
)
2650 struct gcpro gcpro1
;
2651 Lisp_Object args
[7];
2661 RETURN_UNGCPRO (Ffuncall (7, args
));
2664 /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
2667 call7 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2668 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
)
2670 struct gcpro gcpro1
;
2671 Lisp_Object args
[8];
2682 RETURN_UNGCPRO (Ffuncall (8, args
));
2685 /* The caller should GCPRO all the elements of ARGS. */
2687 DEFUN ("functionp", Ffunctionp
, Sfunctionp
, 1, 1, 0,
2688 doc
: /* Non-nil if OBJECT is a function. */)
2689 (Lisp_Object object
)
2691 if (SYMBOLP (object
) && !NILP (Ffboundp (object
)))
2693 object
= Findirect_function (object
, Qt
);
2695 if (CONSP (object
) && EQ (XCAR (object
), Qautoload
))
2697 /* Autoloaded symbols are functions, except if they load
2698 macros or keymaps. */
2700 for (i
= 0; i
< 4 && CONSP (object
); i
++)
2701 object
= XCDR (object
);
2703 return (CONSP (object
) && !NILP (XCAR (object
))) ? Qnil
: Qt
;
2708 return (XSUBR (object
)->max_args
!= UNEVALLED
) ? Qt
: Qnil
;
2709 else if (COMPILEDP (object
))
2711 else if (CONSP (object
))
2713 Lisp_Object car
= XCAR (object
);
2714 return (EQ (car
, Qlambda
) || EQ (car
, Qclosure
)) ? Qt
: Qnil
;
2720 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2721 doc
: /* Call first argument as a function, passing remaining arguments to it.
2722 Return the value that function returns.
2723 Thus, (funcall 'cons 'x 'y) returns (x . y).
2724 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2725 (ptrdiff_t nargs
, Lisp_Object
*args
)
2727 Lisp_Object fun
, original_fun
;
2729 ptrdiff_t numargs
= nargs
- 1;
2730 Lisp_Object lisp_numargs
;
2732 struct backtrace backtrace
;
2733 register Lisp_Object
*internal_args
;
2737 if ((consing_since_gc
> gc_cons_threshold
2738 && consing_since_gc
> gc_relative_threshold
)
2740 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2741 Fgarbage_collect ();
2743 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2745 if (max_lisp_eval_depth
< 100)
2746 max_lisp_eval_depth
= 100;
2747 if (lisp_eval_depth
> max_lisp_eval_depth
)
2748 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2751 backtrace
.next
= backtrace_list
;
2752 backtrace_list
= &backtrace
;
2753 backtrace
.function
= &args
[0];
2754 backtrace
.args
= &args
[1];
2755 backtrace
.nargs
= nargs
- 1;
2756 backtrace
.debug_on_exit
= 0;
2758 if (debug_on_next_call
)
2759 do_debug_on_call (Qlambda
);
2763 original_fun
= args
[0];
2767 /* Optimize for no indirection. */
2769 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2770 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2771 fun
= indirect_function (fun
);
2775 if (numargs
< XSUBR (fun
)->min_args
2776 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2778 XSETFASTINT (lisp_numargs
, numargs
);
2779 xsignal2 (Qwrong_number_of_arguments
, original_fun
, lisp_numargs
);
2782 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2783 xsignal1 (Qinvalid_function
, original_fun
);
2785 else if (XSUBR (fun
)->max_args
== MANY
)
2786 val
= (XSUBR (fun
)->function
.aMANY
) (numargs
, args
+ 1);
2789 if (XSUBR (fun
)->max_args
> numargs
)
2791 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2792 memcpy (internal_args
, args
+ 1, numargs
* sizeof (Lisp_Object
));
2793 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2794 internal_args
[i
] = Qnil
;
2797 internal_args
= args
+ 1;
2798 switch (XSUBR (fun
)->max_args
)
2801 val
= (XSUBR (fun
)->function
.a0 ());
2804 val
= (XSUBR (fun
)->function
.a1 (internal_args
[0]));
2807 val
= (XSUBR (fun
)->function
.a2
2808 (internal_args
[0], internal_args
[1]));
2811 val
= (XSUBR (fun
)->function
.a3
2812 (internal_args
[0], internal_args
[1], internal_args
[2]));
2815 val
= (XSUBR (fun
)->function
.a4
2816 (internal_args
[0], internal_args
[1], internal_args
[2],
2820 val
= (XSUBR (fun
)->function
.a5
2821 (internal_args
[0], internal_args
[1], internal_args
[2],
2822 internal_args
[3], internal_args
[4]));
2825 val
= (XSUBR (fun
)->function
.a6
2826 (internal_args
[0], internal_args
[1], internal_args
[2],
2827 internal_args
[3], internal_args
[4], internal_args
[5]));
2830 val
= (XSUBR (fun
)->function
.a7
2831 (internal_args
[0], internal_args
[1], internal_args
[2],
2832 internal_args
[3], internal_args
[4], internal_args
[5],
2837 val
= (XSUBR (fun
)->function
.a8
2838 (internal_args
[0], internal_args
[1], internal_args
[2],
2839 internal_args
[3], internal_args
[4], internal_args
[5],
2840 internal_args
[6], internal_args
[7]));
2845 /* If a subr takes more than 8 arguments without using MANY
2846 or UNEVALLED, we need to extend this function to support it.
2847 Until this is done, there is no way to call the function. */
2852 else if (COMPILEDP (fun
))
2853 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2856 if (EQ (fun
, Qunbound
))
2857 xsignal1 (Qvoid_function
, original_fun
);
2859 xsignal1 (Qinvalid_function
, original_fun
);
2860 funcar
= XCAR (fun
);
2861 if (!SYMBOLP (funcar
))
2862 xsignal1 (Qinvalid_function
, original_fun
);
2863 if (EQ (funcar
, Qlambda
)
2864 || EQ (funcar
, Qclosure
))
2865 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2866 else if (EQ (funcar
, Qautoload
))
2868 do_autoload (fun
, original_fun
);
2873 xsignal1 (Qinvalid_function
, original_fun
);
2877 if (backtrace
.debug_on_exit
)
2878 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2879 backtrace_list
= backtrace
.next
;
2884 apply_lambda (Lisp_Object fun
, Lisp_Object args
)
2886 Lisp_Object args_left
;
2889 register Lisp_Object
*arg_vector
;
2890 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2891 register Lisp_Object tem
;
2894 numargs
= XFASTINT (Flength (args
));
2895 SAFE_ALLOCA_LISP (arg_vector
, numargs
);
2898 GCPRO3 (*arg_vector
, args_left
, fun
);
2901 for (i
= 0; i
< numargs
; )
2903 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2904 tem
= eval_sub (tem
);
2905 arg_vector
[i
++] = tem
;
2911 backtrace_list
->args
= arg_vector
;
2912 backtrace_list
->nargs
= i
;
2913 tem
= funcall_lambda (fun
, numargs
, arg_vector
);
2915 /* Do the debug-on-exit now, while arg_vector still exists. */
2916 if (backtrace_list
->debug_on_exit
)
2917 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
2918 /* Don't do it again when we return to eval. */
2919 backtrace_list
->debug_on_exit
= 0;
2924 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2925 and return the result of evaluation.
2926 FUN must be either a lambda-expression or a compiled-code object. */
2929 funcall_lambda (Lisp_Object fun
, ptrdiff_t nargs
,
2930 register Lisp_Object
*arg_vector
)
2932 Lisp_Object val
, syms_left
, next
, lexenv
;
2933 ptrdiff_t count
= SPECPDL_INDEX ();
2939 if (EQ (XCAR (fun
), Qclosure
))
2941 fun
= XCDR (fun
); /* Drop `closure'. */
2942 lexenv
= XCAR (fun
);
2943 CHECK_LIST_CONS (fun
, fun
);
2947 syms_left
= XCDR (fun
);
2948 if (CONSP (syms_left
))
2949 syms_left
= XCAR (syms_left
);
2951 xsignal1 (Qinvalid_function
, fun
);
2953 else if (COMPILEDP (fun
))
2955 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
2956 if (INTEGERP (syms_left
))
2957 /* A byte-code object with a non-nil `push args' slot means we
2958 shouldn't bind any arguments, instead just call the byte-code
2959 interpreter directly; it will push arguments as necessary.
2961 Byte-code objects with either a non-existent, or a nil value for
2962 the `push args' slot (the default), have dynamically-bound
2963 arguments, and use the argument-binding code below instead (as do
2964 all interpreted functions, even lexically bound ones). */
2966 /* If we have not actually read the bytecode string
2967 and constants vector yet, fetch them from the file. */
2968 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
2969 Ffetch_bytecode (fun
);
2970 return exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
2971 AREF (fun
, COMPILED_CONSTANTS
),
2972 AREF (fun
, COMPILED_STACK_DEPTH
),
2981 i
= optional
= rest
= 0;
2982 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
2986 next
= XCAR (syms_left
);
2987 if (!SYMBOLP (next
))
2988 xsignal1 (Qinvalid_function
, fun
);
2990 if (EQ (next
, Qand_rest
))
2992 else if (EQ (next
, Qand_optional
))
2999 arg
= Flist (nargs
- i
, &arg_vector
[i
]);
3003 arg
= arg_vector
[i
++];
3005 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3009 /* Bind the argument. */
3010 if (!NILP (lexenv
) && SYMBOLP (next
))
3011 /* Lexically bind NEXT by adding it to the lexenv alist. */
3012 lexenv
= Fcons (Fcons (next
, arg
), lexenv
);
3014 /* Dynamically bind NEXT. */
3015 specbind (next
, arg
);
3019 if (!NILP (syms_left
))
3020 xsignal1 (Qinvalid_function
, fun
);
3022 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3024 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
3025 /* Instantiate a new lexical environment. */
3026 specbind (Qinternal_interpreter_environment
, lexenv
);
3029 val
= Fprogn (XCDR (XCDR (fun
)));
3032 /* If we have not actually read the bytecode string
3033 and constants vector yet, fetch them from the file. */
3034 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3035 Ffetch_bytecode (fun
);
3036 val
= exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
3037 AREF (fun
, COMPILED_CONSTANTS
),
3038 AREF (fun
, COMPILED_STACK_DEPTH
),
3042 return unbind_to (count
, val
);
3045 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3047 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3048 (Lisp_Object object
)
3052 if (COMPILEDP (object
) && CONSP (AREF (object
, COMPILED_BYTECODE
)))
3054 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3057 tem
= AREF (object
, COMPILED_BYTECODE
);
3058 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3059 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3061 error ("Invalid byte code");
3063 ASET (object
, COMPILED_BYTECODE
, XCAR (tem
));
3064 ASET (object
, COMPILED_CONSTANTS
, XCDR (tem
));
3072 register ptrdiff_t count
= SPECPDL_INDEX ();
3073 ptrdiff_t max_size
= min (max_specpdl_size
, PTRDIFF_MAX
);
3074 if (max_size
<= specpdl_size
)
3076 if (max_specpdl_size
< 400)
3077 max_size
= max_specpdl_size
= 400;
3078 if (max_size
<= specpdl_size
)
3079 signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil
);
3081 specpdl
= xpalloc (specpdl
, &specpdl_size
, 1, max_size
, sizeof *specpdl
);
3082 specpdl_ptr
= specpdl
+ count
;
3085 /* `specpdl_ptr->symbol' is a field which describes which variable is
3086 let-bound, so it can be properly undone when we unbind_to.
3087 It can have the following two shapes:
3088 - SYMBOL : if it's a plain symbol, it means that we have let-bound
3089 a symbol that is not buffer-local (at least at the time
3090 the let binding started). Note also that it should not be
3091 aliased (i.e. when let-binding V1 that's aliased to V2, we want
3093 - (SYMBOL WHERE . BUFFER) : this means that it is a let-binding for
3094 variable SYMBOL which can be buffer-local. WHERE tells us
3095 which buffer is affected (or nil if the let-binding affects the
3096 global value of the variable) and BUFFER tells us which buffer was
3097 current (i.e. if WHERE is non-nil, then BUFFER==WHERE, otherwise
3098 BUFFER did not yet have a buffer-local value). */
3101 specbind (Lisp_Object symbol
, Lisp_Object value
)
3103 struct Lisp_Symbol
*sym
;
3105 eassert (!handling_signal
);
3107 CHECK_SYMBOL (symbol
);
3108 sym
= XSYMBOL (symbol
);
3109 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3113 switch (sym
->redirect
)
3115 case SYMBOL_VARALIAS
:
3116 sym
= indirect_variable (sym
); XSETSYMBOL (symbol
, sym
); goto start
;
3117 case SYMBOL_PLAINVAL
:
3118 /* The most common case is that of a non-constant symbol with a
3119 trivial value. Make that as fast as we can. */
3120 specpdl_ptr
->symbol
= symbol
;
3121 specpdl_ptr
->old_value
= SYMBOL_VAL (sym
);
3122 specpdl_ptr
->func
= NULL
;
3125 SET_SYMBOL_VAL (sym
, value
);
3127 set_internal (symbol
, value
, Qnil
, 1);
3129 case SYMBOL_LOCALIZED
:
3130 if (SYMBOL_BLV (sym
)->frame_local
)
3131 error ("Frame-local vars cannot be let-bound");
3132 case SYMBOL_FORWARDED
:
3134 Lisp_Object ovalue
= find_symbol_value (symbol
);
3135 specpdl_ptr
->func
= 0;
3136 specpdl_ptr
->old_value
= ovalue
;
3138 eassert (sym
->redirect
!= SYMBOL_LOCALIZED
3139 || (EQ (SYMBOL_BLV (sym
)->where
,
3140 SYMBOL_BLV (sym
)->frame_local
?
3141 Fselected_frame () : Fcurrent_buffer ())));
3143 if (sym
->redirect
== SYMBOL_LOCALIZED
3144 || BUFFER_OBJFWDP (SYMBOL_FWD (sym
)))
3146 Lisp_Object where
, cur_buf
= Fcurrent_buffer ();
3148 /* For a local variable, record both the symbol and which
3149 buffer's or frame's value we are saving. */
3150 if (!NILP (Flocal_variable_p (symbol
, Qnil
)))
3152 eassert (sym
->redirect
!= SYMBOL_LOCALIZED
3153 || (BLV_FOUND (SYMBOL_BLV (sym
))
3154 && EQ (cur_buf
, SYMBOL_BLV (sym
)->where
)));
3157 else if (sym
->redirect
== SYMBOL_LOCALIZED
3158 && BLV_FOUND (SYMBOL_BLV (sym
)))
3159 where
= SYMBOL_BLV (sym
)->where
;
3163 /* We're not using the `unused' slot in the specbinding
3164 structure because this would mean we have to do more
3165 work for simple variables. */
3166 /* FIXME: The third value `current_buffer' is only used in
3167 let_shadows_buffer_binding_p which is itself only used
3168 in set_internal for local_if_set. */
3169 eassert (NILP (where
) || EQ (where
, cur_buf
));
3170 specpdl_ptr
->symbol
= Fcons (symbol
, Fcons (where
, cur_buf
));
3172 /* If SYMBOL is a per-buffer variable which doesn't have a
3173 buffer-local value here, make the `let' change the global
3174 value by changing the value of SYMBOL in all buffers not
3175 having their own value. This is consistent with what
3176 happens with other buffer-local variables. */
3178 && sym
->redirect
== SYMBOL_FORWARDED
)
3180 eassert (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)));
3182 Fset_default (symbol
, value
);
3187 specpdl_ptr
->symbol
= symbol
;
3190 set_internal (symbol
, value
, Qnil
, 1);
3198 record_unwind_protect (Lisp_Object (*function
) (Lisp_Object
), Lisp_Object arg
)
3200 eassert (!handling_signal
);
3202 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3204 specpdl_ptr
->func
= function
;
3205 specpdl_ptr
->symbol
= Qnil
;
3206 specpdl_ptr
->old_value
= arg
;
3211 unbind_to (ptrdiff_t count
, Lisp_Object value
)
3213 Lisp_Object quitf
= Vquit_flag
;
3214 struct gcpro gcpro1
, gcpro2
;
3216 GCPRO2 (value
, quitf
);
3219 while (specpdl_ptr
!= specpdl
+ count
)
3221 /* Copy the binding, and decrement specpdl_ptr, before we do
3222 the work to unbind it. We decrement first
3223 so that an error in unbinding won't try to unbind
3224 the same entry again, and we copy the binding first
3225 in case more bindings are made during some of the code we run. */
3227 struct specbinding this_binding
;
3228 this_binding
= *--specpdl_ptr
;
3230 if (this_binding
.func
!= 0)
3231 (*this_binding
.func
) (this_binding
.old_value
);
3232 /* If the symbol is a list, it is really (SYMBOL WHERE
3233 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3234 frame. If WHERE is a buffer or frame, this indicates we
3235 bound a variable that had a buffer-local or frame-local
3236 binding. WHERE nil means that the variable had the default
3237 value when it was bound. CURRENT-BUFFER is the buffer that
3238 was current when the variable was bound. */
3239 else if (CONSP (this_binding
.symbol
))
3241 Lisp_Object symbol
, where
;
3243 symbol
= XCAR (this_binding
.symbol
);
3244 where
= XCAR (XCDR (this_binding
.symbol
));
3247 Fset_default (symbol
, this_binding
.old_value
);
3248 /* If `where' is non-nil, reset the value in the appropriate
3249 local binding, but only if that binding still exists. */
3250 else if (BUFFERP (where
)
3251 ? !NILP (Flocal_variable_p (symbol
, where
))
3252 : !NILP (Fassq (symbol
, XFRAME (where
)->param_alist
)))
3253 set_internal (symbol
, this_binding
.old_value
, where
, 1);
3255 /* If variable has a trivial value (no forwarding), we can
3256 just set it. No need to check for constant symbols here,
3257 since that was already done by specbind. */
3258 else if (XSYMBOL (this_binding
.symbol
)->redirect
== SYMBOL_PLAINVAL
)
3259 SET_SYMBOL_VAL (XSYMBOL (this_binding
.symbol
),
3260 this_binding
.old_value
);
3262 /* NOTE: we only ever come here if make_local_foo was used for
3263 the first time on this var within this let. */
3264 Fset_default (this_binding
.symbol
, this_binding
.old_value
);
3267 if (NILP (Vquit_flag
) && !NILP (quitf
))
3274 DEFUN ("special-variable-p", Fspecial_variable_p
, Sspecial_variable_p
, 1, 1, 0,
3275 doc
: /* Return non-nil if SYMBOL's global binding has been declared special.
3276 A special variable is one that will be bound dynamically, even in a
3277 context where binding is lexical by default. */)
3278 (Lisp_Object symbol
)
3280 CHECK_SYMBOL (symbol
);
3281 return XSYMBOL (symbol
)->declared_special
? Qt
: Qnil
;
3285 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3286 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3287 The debugger is entered when that frame exits, if the flag is non-nil. */)
3288 (Lisp_Object level
, Lisp_Object flag
)
3290 register struct backtrace
*backlist
= backtrace_list
;
3291 register EMACS_INT i
;
3293 CHECK_NUMBER (level
);
3295 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
3297 backlist
= backlist
->next
;
3301 backlist
->debug_on_exit
= !NILP (flag
);
3306 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3307 doc
: /* Print a trace of Lisp function calls currently active.
3308 Output stream used is value of `standard-output'. */)
3311 register struct backtrace
*backlist
= backtrace_list
;
3314 struct gcpro gcpro1
;
3315 Lisp_Object old_print_level
= Vprint_level
;
3317 if (NILP (Vprint_level
))
3318 XSETFASTINT (Vprint_level
, 8);
3325 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
3326 if (backlist
->nargs
== UNEVALLED
)
3328 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
3329 write_string ("\n", -1);
3333 tem
= *backlist
->function
;
3334 Fprin1 (tem
, Qnil
); /* This can QUIT. */
3335 write_string ("(", -1);
3336 if (backlist
->nargs
== MANY
)
3337 { /* FIXME: Can this happen? */
3339 for (tail
= *backlist
->args
, i
= 0;
3341 tail
= Fcdr (tail
), i
= 1)
3343 if (i
) write_string (" ", -1);
3344 Fprin1 (Fcar (tail
), Qnil
);
3350 for (i
= 0; i
< backlist
->nargs
; i
++)
3352 if (i
) write_string (" ", -1);
3353 Fprin1 (backlist
->args
[i
], Qnil
);
3356 write_string (")\n", -1);
3358 backlist
= backlist
->next
;
3361 Vprint_level
= old_print_level
;
3366 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, NULL
,
3367 doc
: /* Return the function and arguments NFRAMES up from current execution point.
3368 If that frame has not evaluated the arguments yet (or is a special form),
3369 the value is (nil FUNCTION ARG-FORMS...).
3370 If that frame has evaluated its arguments and called its function already,
3371 the value is (t FUNCTION ARG-VALUES...).
3372 A &rest arg is represented as the tail of the list ARG-VALUES.
3373 FUNCTION is whatever was supplied as car of evaluated list,
3374 or a lambda expression for macro calls.
3375 If NFRAMES is more than the number of frames, the value is nil. */)
3376 (Lisp_Object nframes
)
3378 register struct backtrace
*backlist
= backtrace_list
;
3379 register EMACS_INT i
;
3382 CHECK_NATNUM (nframes
);
3384 /* Find the frame requested. */
3385 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3386 backlist
= backlist
->next
;
3390 if (backlist
->nargs
== UNEVALLED
)
3391 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3394 if (backlist
->nargs
== MANY
) /* FIXME: Can this happen? */
3395 tem
= *backlist
->args
;
3397 tem
= Flist (backlist
->nargs
, backlist
->args
);
3399 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3406 mark_backtrace (void)
3408 register struct backtrace
*backlist
;
3411 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3413 mark_object (*backlist
->function
);
3415 if (backlist
->nargs
== UNEVALLED
3416 || backlist
->nargs
== MANY
) /* FIXME: Can this happen? */
3419 i
= backlist
->nargs
;
3421 mark_object (backlist
->args
[i
]);
3429 DEFVAR_INT ("max-specpdl-size", max_specpdl_size
,
3430 doc
: /* Limit on number of Lisp variable bindings and `unwind-protect's.
3431 If Lisp code tries to increase the total number past this amount,
3432 an error is signaled.
3433 You can safely use a value considerably larger than the default value,
3434 if that proves inconveniently small. However, if you increase it too far,
3435 Emacs could run out of memory trying to make the stack bigger. */);
3437 DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth
,
3438 doc
: /* Limit on depth in `eval', `apply' and `funcall' before error.
3440 This limit serves to catch infinite recursions for you before they cause
3441 actual stack overflow in C, which would be fatal for Emacs.
3442 You can safely make it considerably larger than its default value,
3443 if that proves inconveniently small. However, if you increase it too far,
3444 Emacs could overflow the real C stack, and crash. */);
3446 DEFVAR_LISP ("quit-flag", Vquit_flag
,
3447 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3448 If the value is t, that means do an ordinary quit.
3449 If the value equals `throw-on-input', that means quit by throwing
3450 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3451 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3452 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3455 DEFVAR_LISP ("inhibit-quit", Vinhibit_quit
,
3456 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3457 Note that `quit-flag' will still be set by typing C-g,
3458 so a quit will be signaled as soon as `inhibit-quit' is nil.
3459 To prevent this happening, set `quit-flag' to nil
3460 before making `inhibit-quit' nil. */);
3461 Vinhibit_quit
= Qnil
;
3463 DEFSYM (Qinhibit_quit
, "inhibit-quit");
3464 DEFSYM (Qautoload
, "autoload");
3465 DEFSYM (Qdebug_on_error
, "debug-on-error");
3466 DEFSYM (Qmacro
, "macro");
3467 DEFSYM (Qdeclare
, "declare");
3469 /* Note that the process handling also uses Qexit, but we don't want
3470 to staticpro it twice, so we just do it here. */
3471 DEFSYM (Qexit
, "exit");
3473 DEFSYM (Qinteractive
, "interactive");
3474 DEFSYM (Qcommandp
, "commandp");
3475 DEFSYM (Qand_rest
, "&rest");
3476 DEFSYM (Qand_optional
, "&optional");
3477 DEFSYM (Qclosure
, "closure");
3478 DEFSYM (Qdebug
, "debug");
3480 DEFVAR_LISP ("debug-on-error", Vdebug_on_error
,
3481 doc
: /* Non-nil means enter debugger if an error is signaled.
3482 Does not apply to errors handled by `condition-case' or those
3483 matched by `debug-ignored-errors'.
3484 If the value is a list, an error only means to enter the debugger
3485 if one of its condition symbols appears in the list.
3486 When you evaluate an expression interactively, this variable
3487 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3488 The command `toggle-debug-on-error' toggles this.
3489 See also the variable `debug-on-quit'. */);
3490 Vdebug_on_error
= Qnil
;
3492 DEFVAR_LISP ("debug-ignored-errors", Vdebug_ignored_errors
,
3493 doc
: /* List of errors for which the debugger should not be called.
3494 Each element may be a condition-name or a regexp that matches error messages.
3495 If any element applies to a given error, that error skips the debugger
3496 and just returns to top level.
3497 This overrides the variable `debug-on-error'.
3498 It does not apply to errors handled by `condition-case'. */);
3499 Vdebug_ignored_errors
= Qnil
;
3501 DEFVAR_BOOL ("debug-on-quit", debug_on_quit
,
3502 doc
: /* Non-nil means enter debugger if quit is signaled (C-g, for example).
3503 Does not apply if quit is handled by a `condition-case'. */);
3506 DEFVAR_BOOL ("debug-on-next-call", debug_on_next_call
,
3507 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3509 DEFVAR_BOOL ("debugger-may-continue", debugger_may_continue
,
3510 doc
: /* Non-nil means debugger may continue execution.
3511 This is nil when the debugger is called under circumstances where it
3512 might not be safe to continue. */);
3513 debugger_may_continue
= 1;
3515 DEFVAR_LISP ("debugger", Vdebugger
,
3516 doc
: /* Function to call to invoke debugger.
3517 If due to frame exit, args are `exit' and the value being returned;
3518 this function's value will be returned instead of that.
3519 If due to error, args are `error' and a list of the args to `signal'.
3520 If due to `apply' or `funcall' entry, one arg, `lambda'.
3521 If due to `eval' entry, one arg, t. */);
3524 DEFVAR_LISP ("signal-hook-function", Vsignal_hook_function
,
3525 doc
: /* If non-nil, this is a function for `signal' to call.
3526 It receives the same arguments that `signal' was given.
3527 The Edebug package uses this to regain control. */);
3528 Vsignal_hook_function
= Qnil
;
3530 DEFVAR_LISP ("debug-on-signal", Vdebug_on_signal
,
3531 doc
: /* Non-nil means call the debugger regardless of condition handlers.
3532 Note that `debug-on-error', `debug-on-quit' and friends
3533 still determine whether to handle the particular condition. */);
3534 Vdebug_on_signal
= Qnil
;
3536 /* When lexical binding is being used,
3537 Vinternal_interpreter_environment is non-nil, and contains an alist
3538 of lexically-bound variable, or (t), indicating an empty
3539 environment. The lisp name of this variable would be
3540 `internal-interpreter-environment' if it weren't hidden.
3541 Every element of this list can be either a cons (VAR . VAL)
3542 specifying a lexical binding, or a single symbol VAR indicating
3543 that this variable should use dynamic scoping. */
3544 DEFSYM (Qinternal_interpreter_environment
,
3545 "internal-interpreter-environment");
3546 DEFVAR_LISP ("internal-interpreter-environment",
3547 Vinternal_interpreter_environment
,
3548 doc
: /* If non-nil, the current lexical environment of the lisp interpreter.
3549 When lexical binding is not being used, this variable is nil.
3550 A value of `(t)' indicates an empty environment, otherwise it is an
3551 alist of active lexical bindings. */);
3552 Vinternal_interpreter_environment
= Qnil
;
3553 /* Don't export this variable to Elisp, so no one can mess with it
3554 (Just imagine if someone makes it buffer-local). */
3555 Funintern (Qinternal_interpreter_environment
, Qnil
);
3557 DEFSYM (Vrun_hooks
, "run-hooks");
3559 staticpro (&Vautoload_queue
);
3560 Vautoload_queue
= Qnil
;
3561 staticpro (&Vsignaling_function
);
3562 Vsignaling_function
= Qnil
;
3564 inhibit_lisp_code
= Qnil
;
3575 defsubr (&Sfunction
);
3577 defsubr (&Sdefvaralias
);
3578 defsubr (&Sdefconst
);
3582 defsubr (&Smacroexpand
);
3585 defsubr (&Sunwind_protect
);
3586 defsubr (&Scondition_case
);
3588 defsubr (&Sinteractive_p
);
3589 defsubr (&Scalled_interactively_p
);
3590 defsubr (&Scommandp
);
3591 defsubr (&Sautoload
);
3594 defsubr (&Sfuncall
);
3595 defsubr (&Srun_hooks
);
3596 defsubr (&Srun_hook_with_args
);
3597 defsubr (&Srun_hook_with_args_until_success
);
3598 defsubr (&Srun_hook_with_args_until_failure
);
3599 defsubr (&Srun_hook_wrapped
);
3600 defsubr (&Sfetch_bytecode
);
3601 defsubr (&Sbacktrace_debug
);
3602 defsubr (&Sbacktrace
);
3603 defsubr (&Sbacktrace_frame
);
3604 defsubr (&Sspecial_variable_p
);
3605 defsubr (&Sfunctionp
);