1 /* Evaluator for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1987, 1993-1995, 1999-2011 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/>. */
23 #include "blockinput.h"
26 #include "dispextern.h"
27 #include "frame.h" /* For XFRAME. */
33 /* This definition is duplicated in alloc.c and keyboard.c */
34 /* Putting it in lisp.h makes cc bomb out! */
38 struct backtrace
*next
;
39 Lisp_Object
*function
;
40 Lisp_Object
*args
; /* Points to vector of args. */
41 int nargs
; /* Length of vector.
42 If nargs is UNEVALLED, args points to slot holding
43 list of unevalled args */
45 /* Nonzero means call value of debugger when done with this operation. */
49 struct backtrace
*backtrace_list
;
51 struct catchtag
*catchlist
;
54 /* Count levels of GCPRO to detect failure to UNGCPRO. */
58 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
59 Lisp_Object Qinhibit_quit
;
60 Lisp_Object Qand_rest
, Qand_optional
;
61 Lisp_Object Qdebug_on_error
;
65 /* This holds either the symbol `run-hooks' or nil.
66 It is nil at an early stage of startup, and when Emacs
69 Lisp_Object Vrun_hooks
;
71 /* Non-nil means record all fset's and provide's, to be undone
72 if the file being autoloaded is not fully loaded.
73 They are recorded by being consed onto the front of Vautoload_queue:
74 (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide. */
76 Lisp_Object Vautoload_queue
;
78 /* Current number of specbindings allocated in specpdl. */
80 EMACS_INT specpdl_size
;
82 /* Pointer to beginning of specpdl. */
84 struct specbinding
*specpdl
;
86 /* Pointer to first unused element in specpdl. */
88 struct specbinding
*specpdl_ptr
;
90 /* Depth in Lisp evaluations and function calls. */
92 EMACS_INT lisp_eval_depth
;
94 /* The value of num_nonmacro_input_events as of the last time we
95 started to enter the debugger. If we decide to enter the debugger
96 again when this is still equal to num_nonmacro_input_events, then we
97 know that the debugger itself has an error, and we should just
98 signal the error instead of entering an infinite loop of debugger
101 int when_entered_debugger
;
103 /* The function from which the last `signal' was called. Set in
106 Lisp_Object Vsignaling_function
;
108 /* Set to non-zero while processing X events. Checked in Feval to
109 make sure the Lisp interpreter isn't called from a signal handler,
110 which is unsafe because the interpreter isn't reentrant. */
114 static Lisp_Object
funcall_lambda (Lisp_Object
, int, Lisp_Object
*);
115 static void unwind_to_catch (struct catchtag
*, Lisp_Object
) NO_RETURN
;
116 static int interactive_p (int);
117 static Lisp_Object
apply_lambda (Lisp_Object
, Lisp_Object
, int);
120 init_eval_once (void)
123 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
124 specpdl_ptr
= specpdl
;
125 /* Don't forget to update docs (lispref node "Local Variables"). */
126 max_specpdl_size
= 1000;
127 max_lisp_eval_depth
= 600;
135 specpdl_ptr
= specpdl
;
140 debug_on_next_call
= 0;
145 /* This is less than the initial value of num_nonmacro_input_events. */
146 when_entered_debugger
= -1;
149 /* unwind-protect function used by call_debugger. */
152 restore_stack_limits (Lisp_Object data
)
154 max_specpdl_size
= XINT (XCAR (data
));
155 max_lisp_eval_depth
= XINT (XCDR (data
));
159 /* Call the Lisp debugger, giving it argument ARG. */
162 call_debugger (Lisp_Object arg
)
164 int debug_while_redisplaying
;
165 int count
= SPECPDL_INDEX ();
167 EMACS_INT old_max
= max_specpdl_size
;
169 /* Temporarily bump up the stack limits,
170 so the debugger won't run out of stack. */
172 max_specpdl_size
+= 1;
173 record_unwind_protect (restore_stack_limits
,
174 Fcons (make_number (old_max
),
175 make_number (max_lisp_eval_depth
)));
176 max_specpdl_size
= old_max
;
178 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
179 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
181 if (SPECPDL_INDEX () + 100 > max_specpdl_size
)
182 max_specpdl_size
= SPECPDL_INDEX () + 100;
184 #ifdef HAVE_WINDOW_SYSTEM
185 if (display_hourglass_p
)
189 debug_on_next_call
= 0;
190 when_entered_debugger
= num_nonmacro_input_events
;
192 /* Resetting redisplaying_p to 0 makes sure that debug output is
193 displayed if the debugger is invoked during redisplay. */
194 debug_while_redisplaying
= redisplaying_p
;
196 specbind (intern ("debugger-may-continue"),
197 debug_while_redisplaying
? Qnil
: Qt
);
198 specbind (Qinhibit_redisplay
, Qnil
);
199 specbind (Qdebug_on_error
, Qnil
);
201 #if 0 /* Binding this prevents execution of Lisp code during
202 redisplay, which necessarily leads to display problems. */
203 specbind (Qinhibit_eval_during_redisplay
, Qt
);
206 val
= apply1 (Vdebugger
, arg
);
208 /* Interrupting redisplay and resuming it later is not safe under
209 all circumstances. So, when the debugger returns, abort the
210 interrupted redisplay by going back to the top-level. */
211 if (debug_while_redisplaying
)
214 return unbind_to (count
, val
);
218 do_debug_on_call (Lisp_Object code
)
220 debug_on_next_call
= 0;
221 backtrace_list
->debug_on_exit
= 1;
222 call_debugger (Fcons (code
, Qnil
));
225 /* NOTE!!! Every function that can call EVAL must protect its args
226 and temporaries from garbage collection while it needs them.
227 The definition of `For' shows what you have to do. */
229 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
230 doc
: /* Eval args until one of them yields non-nil, then return that value.
231 The remaining args are not evalled at all.
232 If all args return nil, return nil.
233 usage: (or CONDITIONS...) */)
236 register Lisp_Object val
= Qnil
;
243 val
= Feval (XCAR (args
));
253 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
254 doc
: /* Eval args until one of them yields nil, then return nil.
255 The remaining args are not evalled at all.
256 If no arg yields nil, return the last arg's value.
257 usage: (and CONDITIONS...) */)
260 register Lisp_Object val
= Qt
;
267 val
= Feval (XCAR (args
));
277 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
278 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
279 Returns the value of THEN or the value of the last of the ELSE's.
280 THEN must be one expression, but ELSE... can be zero or more expressions.
281 If COND yields nil, and there are no ELSE's, the value is nil.
282 usage: (if COND THEN ELSE...) */)
285 register Lisp_Object cond
;
289 cond
= Feval (Fcar (args
));
293 return Feval (Fcar (Fcdr (args
)));
294 return Fprogn (Fcdr (Fcdr (args
)));
297 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
298 doc
: /* Try each clause until one succeeds.
299 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
300 and, if the value is non-nil, this clause succeeds:
301 then the expressions in BODY are evaluated and the last one's
302 value is the value of the cond-form.
303 If no clause succeeds, cond returns nil.
304 If a clause has one element, as in (CONDITION),
305 CONDITION's value if non-nil is returned from the cond-form.
306 usage: (cond CLAUSES...) */)
309 register Lisp_Object clause
, val
;
316 clause
= Fcar (args
);
317 val
= Feval (Fcar (clause
));
320 if (!EQ (XCDR (clause
), Qnil
))
321 val
= Fprogn (XCDR (clause
));
331 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
332 doc
: /* Eval BODY forms sequentially and return value of last one.
333 usage: (progn BODY...) */)
336 register Lisp_Object val
= Qnil
;
343 val
= Feval (XCAR (args
));
351 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
352 doc
: /* Eval FIRST and BODY sequentially; return value from FIRST.
353 The value of FIRST is saved during the evaluation of the remaining args,
354 whose values are discarded.
355 usage: (prog1 FIRST BODY...) */)
359 register Lisp_Object args_left
;
360 struct gcpro gcpro1
, gcpro2
;
361 register int argnum
= 0;
373 val
= Feval (Fcar (args_left
));
375 Feval (Fcar (args_left
));
376 args_left
= Fcdr (args_left
);
378 while (!NILP(args_left
));
384 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
385 doc
: /* Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
386 The value of FORM2 is saved during the evaluation of the
387 remaining args, whose values are discarded.
388 usage: (prog2 FORM1 FORM2 BODY...) */)
392 register Lisp_Object args_left
;
393 struct gcpro gcpro1
, gcpro2
;
394 register int argnum
= -1;
408 val
= Feval (Fcar (args_left
));
410 Feval (Fcar (args_left
));
411 args_left
= Fcdr (args_left
);
413 while (!NILP (args_left
));
419 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
420 doc
: /* Set each SYM to the value of its VAL.
421 The symbols SYM are variables; they are literal (not evaluated).
422 The values VAL are expressions; they are evaluated.
423 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
424 The second VAL is not computed until after the first SYM is set, and so on;
425 each VAL can use the new value of variables set earlier in the `setq'.
426 The return value of the `setq' form is the value of the last VAL.
427 usage: (setq [SYM VAL]...) */)
430 register Lisp_Object args_left
;
431 register Lisp_Object val
, sym
;
442 val
= Feval (Fcar (Fcdr (args_left
)));
443 sym
= Fcar (args_left
);
445 args_left
= Fcdr (Fcdr (args_left
));
447 while (!NILP(args_left
));
453 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
454 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
455 usage: (quote ARG) */)
458 if (!NILP (Fcdr (args
)))
459 xsignal2 (Qwrong_number_of_arguments
, Qquote
, Flength (args
));
463 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
464 doc
: /* Like `quote', but preferred for objects which are functions.
465 In byte compilation, `function' causes its argument to be compiled.
466 `quote' cannot do that.
467 usage: (function ARG) */)
470 if (!NILP (Fcdr (args
)))
471 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
476 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
477 doc
: /* Return t if the containing function was run directly by user input.
478 This means that the function was called with `call-interactively'
479 \(which includes being called as the binding of a key)
480 and input is currently coming from the keyboard (not a keyboard macro),
481 and Emacs is not running in batch mode (`noninteractive' is nil).
483 The only known proper use of `interactive-p' is in deciding whether to
484 display a helpful message, or how to display it. If you're thinking
485 of using it for any other purpose, it is quite likely that you're
486 making a mistake. Think: what do you want to do when the command is
487 called from a keyboard macro?
489 To test whether your function was called with `call-interactively',
490 either (i) add an extra optional argument and give it an `interactive'
491 spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
492 use `called-interactively-p'. */)
495 return (INTERACTIVE
&& interactive_p (1)) ? Qt
: Qnil
;
499 DEFUN ("called-interactively-p", Fcalled_interactively_p
, Scalled_interactively_p
, 0, 1, 0,
500 doc
: /* Return t if the containing function was called by `call-interactively'.
501 If KIND is `interactive', then only return t if the call was made
502 interactively by the user, i.e. not in `noninteractive' mode nor
503 when `executing-kbd-macro'.
504 If KIND is `any', on the other hand, it will return t for any kind of
505 interactive call, including being called as the binding of a key, or
506 from a keyboard macro, or in `noninteractive' mode.
508 The only known proper use of `interactive' for KIND is in deciding
509 whether to display a helpful message, or how to display it. If you're
510 thinking of using it for any other purpose, it is quite likely that
511 you're making a mistake. Think: what do you want to do when the
512 command is called from a keyboard macro?
514 This function is meant for implementing advice and other
515 function-modifying features. Instead of using this, it is sometimes
516 cleaner to give your function an extra optional argument whose
517 `interactive' spec specifies non-nil unconditionally (\"p\" is a good
518 way to do this), or via (not (or executing-kbd-macro noninteractive)). */)
521 return ((INTERACTIVE
|| !EQ (kind
, intern ("interactive")))
522 && interactive_p (1)) ? Qt
: Qnil
;
526 /* Return 1 if function in which this appears was called using
529 EXCLUDE_SUBRS_P non-zero means always return 0 if the function
530 called is a built-in. */
533 interactive_p (int exclude_subrs_p
)
535 struct backtrace
*btp
;
538 btp
= backtrace_list
;
540 /* If this isn't a byte-compiled function, there may be a frame at
541 the top for Finteractive_p. If so, skip it. */
542 fun
= Findirect_function (*btp
->function
, Qnil
);
543 if (SUBRP (fun
) && (XSUBR (fun
) == &Sinteractive_p
544 || XSUBR (fun
) == &Scalled_interactively_p
))
547 /* If we're running an Emacs 18-style byte-compiled function, there
548 may be a frame for Fbytecode at the top level. In any version of
549 Emacs there can be Fbytecode frames for subexpressions evaluated
550 inside catch and condition-case. Skip past them.
552 If this isn't a byte-compiled function, then we may now be
553 looking at several frames for special forms. Skip past them. */
555 && (EQ (*btp
->function
, Qbytecode
)
556 || btp
->nargs
== UNEVALLED
))
559 /* btp now points at the frame of the innermost function that isn't
560 a special form, ignoring frames for Finteractive_p and/or
561 Fbytecode at the top. If this frame is for a built-in function
562 (such as load or eval-region) return nil. */
563 fun
= Findirect_function (*btp
->function
, Qnil
);
564 if (exclude_subrs_p
&& SUBRP (fun
))
567 /* btp points to the frame of a Lisp function that called interactive-p.
568 Return t if that function was called interactively. */
569 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
575 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
576 doc
: /* Define NAME as a function.
577 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
578 See also the function `interactive'.
579 usage: (defun NAME ARGLIST [DOCSTRING] BODY...) */)
582 register Lisp_Object fn_name
;
583 register Lisp_Object defn
;
585 fn_name
= Fcar (args
);
586 CHECK_SYMBOL (fn_name
);
587 defn
= Fcons (Qlambda
, Fcdr (args
));
588 if (!NILP (Vpurify_flag
))
589 defn
= Fpurecopy (defn
);
590 if (CONSP (XSYMBOL (fn_name
)->function
)
591 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
592 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
593 Ffset (fn_name
, defn
);
594 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
598 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
599 doc
: /* Define NAME as a macro.
600 The actual definition looks like
601 (macro lambda ARGLIST [DOCSTRING] [DECL] BODY...).
602 When the macro is called, as in (NAME ARGS...),
603 the function (lambda ARGLIST BODY...) is applied to
604 the list ARGS... as it appears in the expression,
605 and the result should be a form to be evaluated instead of the original.
607 DECL is a declaration, optional, which can specify how to indent
608 calls to this macro, how Edebug should handle it, and which argument
609 should be treated as documentation. It looks like this:
611 The elements can look like this:
613 Set NAME's `lisp-indent-function' property to INDENT.
616 Set NAME's `edebug-form-spec' property to DEBUG. (This is
617 equivalent to writing a `def-edebug-spec' for the macro.)
620 Set NAME's `doc-string-elt' property to ELT.
622 usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */)
625 register Lisp_Object fn_name
;
626 register Lisp_Object defn
;
627 Lisp_Object lambda_list
, doc
, tail
;
629 fn_name
= Fcar (args
);
630 CHECK_SYMBOL (fn_name
);
631 lambda_list
= Fcar (Fcdr (args
));
632 tail
= Fcdr (Fcdr (args
));
635 if (STRINGP (Fcar (tail
)))
641 if (CONSP (Fcar (tail
))
642 && EQ (Fcar (Fcar (tail
)), Qdeclare
))
644 if (!NILP (Vmacro_declaration_function
))
648 call2 (Vmacro_declaration_function
, fn_name
, Fcar (tail
));
656 tail
= Fcons (lambda_list
, tail
);
658 tail
= Fcons (lambda_list
, Fcons (doc
, tail
));
659 defn
= Fcons (Qmacro
, Fcons (Qlambda
, tail
));
661 if (!NILP (Vpurify_flag
))
662 defn
= Fpurecopy (defn
);
663 if (CONSP (XSYMBOL (fn_name
)->function
)
664 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
665 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
666 Ffset (fn_name
, defn
);
667 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
672 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
673 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
674 Aliased variables always have the same value; setting one sets the other.
675 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
676 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
677 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
678 itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
679 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
680 The return value is BASE-VARIABLE. */)
681 (Lisp_Object new_alias
, Lisp_Object base_variable
, Lisp_Object docstring
)
683 struct Lisp_Symbol
*sym
;
685 CHECK_SYMBOL (new_alias
);
686 CHECK_SYMBOL (base_variable
);
688 sym
= XSYMBOL (new_alias
);
691 /* Not sure why, but why not? */
692 error ("Cannot make a constant an alias");
694 switch (sym
->redirect
)
696 case SYMBOL_FORWARDED
:
697 error ("Cannot make an internal variable an alias");
698 case SYMBOL_LOCALIZED
:
699 error ("Don't know how to make a localized variable an alias");
702 /* http://lists.gnu.org/archive/html/emacs-devel/2008-04/msg00834.html
703 If n_a is bound, but b_v is not, set the value of b_v to n_a,
704 so that old-code that affects n_a before the aliasing is setup
706 if (NILP (Fboundp (base_variable
)))
707 set_internal (base_variable
, find_symbol_value (new_alias
), Qnil
, 1);
710 struct specbinding
*p
;
712 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
715 CONSP (p
->symbol
) ? XCAR (p
->symbol
) : p
->symbol
)))
716 error ("Don't know how to make a let-bound variable an alias");
719 sym
->redirect
= SYMBOL_VARALIAS
;
720 SET_SYMBOL_ALIAS (sym
, XSYMBOL (base_variable
));
721 sym
->constant
= SYMBOL_CONSTANT_P (base_variable
);
722 LOADHIST_ATTACH (new_alias
);
723 /* Even if docstring is nil: remove old docstring. */
724 Fput (new_alias
, Qvariable_documentation
, docstring
);
726 return base_variable
;
730 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
731 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
732 You are not required to define a variable in order to use it,
733 but the definition can supply documentation and an initial value
734 in a way that tags can recognize.
736 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.
737 If SYMBOL is buffer-local, its default value is what is set;
738 buffer-local values are not affected.
739 INITVALUE and DOCSTRING are optional.
740 If DOCSTRING starts with *, this variable is identified as a user option.
741 This means that M-x set-variable recognizes it.
742 See also `user-variable-p'.
743 If INITVALUE is missing, SYMBOL's value is not set.
745 If SYMBOL has a local binding, then this form affects the local
746 binding. This is usually not what you want. Thus, if you need to
747 load a file defining variables, with this form or with `defconst' or
748 `defcustom', you should always load that file _outside_ any bindings
749 for these variables. \(`defconst' and `defcustom' behave similarly in
751 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
754 register Lisp_Object sym
, tem
, tail
;
758 if (!NILP (Fcdr (Fcdr (tail
))))
759 error ("Too many arguments");
761 tem
= Fdefault_boundp (sym
);
764 if (SYMBOL_CONSTANT_P (sym
))
766 /* For upward compatibility, allow (defvar :foo (quote :foo)). */
767 Lisp_Object tem
= Fcar (tail
);
769 && EQ (XCAR (tem
), Qquote
)
770 && CONSP (XCDR (tem
))
771 && EQ (XCAR (XCDR (tem
)), sym
)))
772 error ("Constant symbol `%s' specified in defvar",
773 SDATA (SYMBOL_NAME (sym
)));
777 Fset_default (sym
, Feval (Fcar (tail
)));
779 { /* Check if there is really a global binding rather than just a let
780 binding that shadows the global unboundness of the var. */
781 volatile struct specbinding
*pdl
= specpdl_ptr
;
782 while (--pdl
>= specpdl
)
784 if (EQ (pdl
->symbol
, sym
) && !pdl
->func
785 && EQ (pdl
->old_value
, Qunbound
))
787 message_with_string ("Warning: defvar ignored because %s is let-bound",
788 SYMBOL_NAME (sym
), 1);
797 if (!NILP (Vpurify_flag
))
798 tem
= Fpurecopy (tem
);
799 Fput (sym
, Qvariable_documentation
, tem
);
801 LOADHIST_ATTACH (sym
);
804 /* Simple (defvar <var>) should not count as a definition at all.
805 It could get in the way of other definitions, and unloading this
806 package could try to make the variable unbound. */
812 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
813 doc
: /* Define SYMBOL as a constant variable.
814 The intent is that neither programs nor users should ever change this value.
815 Always sets the value of SYMBOL to the result of evalling INITVALUE.
816 If SYMBOL is buffer-local, its default value is what is set;
817 buffer-local values are not affected.
818 DOCSTRING is optional.
820 If SYMBOL has a local binding, then this form sets the local binding's
821 value. However, you should normally not make local bindings for
822 variables defined with this form.
823 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
826 register Lisp_Object sym
, tem
;
829 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
830 error ("Too many arguments");
832 tem
= Feval (Fcar (Fcdr (args
)));
833 if (!NILP (Vpurify_flag
))
834 tem
= Fpurecopy (tem
);
835 Fset_default (sym
, tem
);
836 tem
= Fcar (Fcdr (Fcdr (args
)));
839 if (!NILP (Vpurify_flag
))
840 tem
= Fpurecopy (tem
);
841 Fput (sym
, Qvariable_documentation
, tem
);
843 Fput (sym
, Qrisky_local_variable
, Qt
);
844 LOADHIST_ATTACH (sym
);
848 /* Error handler used in Fuser_variable_p. */
850 user_variable_p_eh (Lisp_Object ignore
)
856 lisp_indirect_variable (Lisp_Object sym
)
858 XSETSYMBOL (sym
, indirect_variable (XSYMBOL (sym
)));
862 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
863 doc
: /* Return t if VARIABLE is intended to be set and modified by users.
864 \(The alternative is a variable used internally in a Lisp program.)
865 A variable is a user variable if
866 \(1) the first character of its documentation is `*', or
867 \(2) it is customizable (its property list contains a non-nil value
868 of `standard-value' or `custom-autoload'), or
869 \(3) it is an alias for another user variable.
870 Return nil if VARIABLE is an alias and there is a loop in the
871 chain of symbols. */)
872 (Lisp_Object variable
)
874 Lisp_Object documentation
;
876 if (!SYMBOLP (variable
))
879 /* If indirect and there's an alias loop, don't check anything else. */
880 if (XSYMBOL (variable
)->redirect
== SYMBOL_VARALIAS
881 && NILP (internal_condition_case_1 (lisp_indirect_variable
, variable
,
882 Qt
, user_variable_p_eh
)))
887 documentation
= Fget (variable
, Qvariable_documentation
);
888 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
890 if (STRINGP (documentation
)
891 && ((unsigned char) SREF (documentation
, 0) == '*'))
893 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
894 if (CONSP (documentation
)
895 && STRINGP (XCAR (documentation
))
896 && INTEGERP (XCDR (documentation
))
897 && XINT (XCDR (documentation
)) < 0)
899 /* Customizable? See `custom-variable-p'. */
900 if ((!NILP (Fget (variable
, intern ("standard-value"))))
901 || (!NILP (Fget (variable
, intern ("custom-autoload")))))
904 if (!(XSYMBOL (variable
)->redirect
== SYMBOL_VARALIAS
))
907 /* An indirect variable? Let's follow the chain. */
908 XSETSYMBOL (variable
, SYMBOL_ALIAS (XSYMBOL (variable
)));
912 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
913 doc
: /* Bind variables according to VARLIST then eval BODY.
914 The value of the last form in BODY is returned.
915 Each element of VARLIST is a symbol (which is bound to nil)
916 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
917 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
918 usage: (let* VARLIST BODY...) */)
921 Lisp_Object varlist
, val
, elt
;
922 int count
= SPECPDL_INDEX ();
923 struct gcpro gcpro1
, gcpro2
, gcpro3
;
925 GCPRO3 (args
, elt
, varlist
);
927 varlist
= Fcar (args
);
928 while (!NILP (varlist
))
931 elt
= Fcar (varlist
);
933 specbind (elt
, Qnil
);
934 else if (! NILP (Fcdr (Fcdr (elt
))))
935 signal_error ("`let' bindings can have only one value-form", elt
);
938 val
= Feval (Fcar (Fcdr (elt
)));
939 specbind (Fcar (elt
), val
);
941 varlist
= Fcdr (varlist
);
944 val
= Fprogn (Fcdr (args
));
945 return unbind_to (count
, val
);
948 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
949 doc
: /* Bind variables according to VARLIST then eval BODY.
950 The value of the last form in BODY is returned.
951 Each element of VARLIST is a symbol (which is bound to nil)
952 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
953 All the VALUEFORMs are evalled before any symbols are bound.
954 usage: (let VARLIST BODY...) */)
957 Lisp_Object
*temps
, tem
;
958 register Lisp_Object elt
, varlist
;
959 int count
= SPECPDL_INDEX ();
961 struct gcpro gcpro1
, gcpro2
;
964 varlist
= Fcar (args
);
966 /* Make space to hold the values to give the bound variables */
967 elt
= Flength (varlist
);
968 SAFE_ALLOCA_LISP (temps
, XFASTINT (elt
));
970 /* Compute the values and store them in `temps' */
972 GCPRO2 (args
, *temps
);
975 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
978 elt
= XCAR (varlist
);
980 temps
[argnum
++] = Qnil
;
981 else if (! NILP (Fcdr (Fcdr (elt
))))
982 signal_error ("`let' bindings can have only one value-form", elt
);
984 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
985 gcpro2
.nvars
= argnum
;
989 varlist
= Fcar (args
);
990 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
992 elt
= XCAR (varlist
);
993 tem
= temps
[argnum
++];
997 specbind (Fcar (elt
), tem
);
1000 elt
= Fprogn (Fcdr (args
));
1002 return unbind_to (count
, elt
);
1005 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
1006 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
1007 The order of execution is thus TEST, BODY, TEST, BODY and so on
1008 until TEST returns nil.
1009 usage: (while TEST BODY...) */)
1012 Lisp_Object test
, body
;
1013 struct gcpro gcpro1
, gcpro2
;
1015 GCPRO2 (test
, body
);
1019 while (!NILP (Feval (test
)))
1029 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
1030 doc
: /* Return result of expanding macros at top level of FORM.
1031 If FORM is not a macro call, it is returned unchanged.
1032 Otherwise, the macro is expanded and the expansion is considered
1033 in place of FORM. When a non-macro-call results, it is returned.
1035 The second optional arg ENVIRONMENT specifies an environment of macro
1036 definitions to shadow the loaded ones for use in file byte-compilation. */)
1037 (Lisp_Object form
, Lisp_Object environment
)
1039 /* With cleanups from Hallvard Furuseth. */
1040 register Lisp_Object expander
, sym
, def
, tem
;
1044 /* Come back here each time we expand a macro call,
1045 in case it expands into another macro call. */
1048 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1049 def
= sym
= XCAR (form
);
1051 /* Trace symbols aliases to other symbols
1052 until we get a symbol that is not an alias. */
1053 while (SYMBOLP (def
))
1057 tem
= Fassq (sym
, environment
);
1060 def
= XSYMBOL (sym
)->function
;
1061 if (!EQ (def
, Qunbound
))
1066 /* Right now TEM is the result from SYM in ENVIRONMENT,
1067 and if TEM is nil then DEF is SYM's function definition. */
1070 /* SYM is not mentioned in ENVIRONMENT.
1071 Look at its function definition. */
1072 if (EQ (def
, Qunbound
) || !CONSP (def
))
1073 /* Not defined or definition not suitable */
1075 if (EQ (XCAR (def
), Qautoload
))
1077 /* Autoloading function: will it be a macro when loaded? */
1078 tem
= Fnth (make_number (4), def
);
1079 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
1080 /* Yes, load it and try again. */
1082 struct gcpro gcpro1
;
1084 do_autoload (def
, sym
);
1091 else if (!EQ (XCAR (def
), Qmacro
))
1093 else expander
= XCDR (def
);
1097 expander
= XCDR (tem
);
1098 if (NILP (expander
))
1101 form
= apply1 (expander
, XCDR (form
));
1106 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1107 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1108 TAG is evalled to get the tag to use; it must not be nil.
1110 Then the BODY is executed.
1111 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
1112 If no throw happens, `catch' returns the value of the last BODY form.
1113 If a throw happens, it specifies the value to return from `catch'.
1114 usage: (catch TAG BODY...) */)
1117 register Lisp_Object tag
;
1118 struct gcpro gcpro1
;
1121 tag
= Feval (Fcar (args
));
1123 return internal_catch (tag
, Fprogn
, Fcdr (args
));
1126 /* Set up a catch, then call C function FUNC on argument ARG.
1127 FUNC should return a Lisp_Object.
1128 This is how catches are done from within C code. */
1131 internal_catch (Lisp_Object tag
, Lisp_Object (*func
) (Lisp_Object
), Lisp_Object arg
)
1133 /* This structure is made part of the chain `catchlist'. */
1136 /* Fill in the components of c, and put it on the list. */
1140 c
.backlist
= backtrace_list
;
1141 c
.handlerlist
= handlerlist
;
1142 c
.lisp_eval_depth
= lisp_eval_depth
;
1143 c
.pdlcount
= SPECPDL_INDEX ();
1144 c
.poll_suppress_count
= poll_suppress_count
;
1145 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1146 c
.gcpro
= gcprolist
;
1147 c
.byte_stack
= byte_stack_list
;
1151 if (! _setjmp (c
.jmp
))
1152 c
.val
= (*func
) (arg
);
1154 /* Throw works by a longjmp that comes right here. */
1159 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1160 jump to that CATCH, returning VALUE as the value of that catch.
1162 This is the guts Fthrow and Fsignal; they differ only in the way
1163 they choose the catch tag to throw to. A catch tag for a
1164 condition-case form has a TAG of Qnil.
1166 Before each catch is discarded, unbind all special bindings and
1167 execute all unwind-protect clauses made above that catch. Unwind
1168 the handler stack as we go, so that the proper handlers are in
1169 effect for each unwind-protect clause we run. At the end, restore
1170 some static info saved in CATCH, and longjmp to the location
1173 This is used for correct unwinding in Fthrow and Fsignal. */
1176 unwind_to_catch (struct catchtag
*catch, Lisp_Object value
)
1178 register int last_time
;
1180 /* Save the value in the tag. */
1183 /* Restore certain special C variables. */
1184 set_poll_suppress_count (catch->poll_suppress_count
);
1185 UNBLOCK_INPUT_TO (catch->interrupt_input_blocked
);
1186 handling_signal
= 0;
1191 last_time
= catchlist
== catch;
1193 /* Unwind the specpdl stack, and then restore the proper set of
1195 unbind_to (catchlist
->pdlcount
, Qnil
);
1196 handlerlist
= catchlist
->handlerlist
;
1197 catchlist
= catchlist
->next
;
1199 while (! last_time
);
1202 /* If x_catch_errors was done, turn it off now.
1203 (First we give unbind_to a chance to do that.) */
1204 #if 0 /* This would disable x_catch_errors after x_connection_closed.
1205 The catch must remain in effect during that delicate
1206 state. --lorentey */
1207 x_fully_uncatch_errors ();
1211 byte_stack_list
= catch->byte_stack
;
1212 gcprolist
= catch->gcpro
;
1215 gcpro_level
= gcprolist
->level
+ 1;
1219 backtrace_list
= catch->backlist
;
1220 lisp_eval_depth
= catch->lisp_eval_depth
;
1222 _longjmp (catch->jmp
, 1);
1225 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1226 doc
: /* Throw to the catch for TAG and return VALUE from it.
1227 Both TAG and VALUE are evalled. */)
1228 (register Lisp_Object tag
, Lisp_Object value
)
1230 register struct catchtag
*c
;
1233 for (c
= catchlist
; c
; c
= c
->next
)
1235 if (EQ (c
->tag
, tag
))
1236 unwind_to_catch (c
, value
);
1238 xsignal2 (Qno_catch
, tag
, value
);
1242 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1243 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1244 If BODYFORM completes normally, its value is returned
1245 after executing the UNWINDFORMS.
1246 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1247 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1251 int count
= SPECPDL_INDEX ();
1253 record_unwind_protect (Fprogn
, Fcdr (args
));
1254 val
= Feval (Fcar (args
));
1255 return unbind_to (count
, val
);
1258 /* Chain of condition handlers currently in effect.
1259 The elements of this chain are contained in the stack frames
1260 of Fcondition_case and internal_condition_case.
1261 When an error is signaled (by calling Fsignal, below),
1262 this chain is searched for an element that applies. */
1264 struct handler
*handlerlist
;
1266 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1267 doc
: /* Regain control when an error is signaled.
1268 Executes BODYFORM and returns its value if no error happens.
1269 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1270 where the BODY is made of Lisp expressions.
1272 A handler is applicable to an error
1273 if CONDITION-NAME is one of the error's condition names.
1274 If an error happens, the first applicable handler is run.
1276 The car of a handler may be a list of condition names
1277 instead of a single condition name. Then it handles all of them.
1279 When a handler handles an error, control returns to the `condition-case'
1280 and it executes the handler's BODY...
1281 with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
1282 \(If VAR is nil, the handler can't access that information.)
1283 Then the value of the last BODY form is returned from the `condition-case'
1286 See also the function `signal' for more info.
1287 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1290 register Lisp_Object bodyform
, handlers
;
1291 volatile Lisp_Object var
;
1294 bodyform
= Fcar (Fcdr (args
));
1295 handlers
= Fcdr (Fcdr (args
));
1297 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1300 /* Like Fcondition_case, but the args are separate
1301 rather than passed in a list. Used by Fbyte_code. */
1304 internal_lisp_condition_case (volatile Lisp_Object var
, Lisp_Object bodyform
,
1305 Lisp_Object handlers
)
1313 for (val
= handlers
; CONSP (val
); val
= XCDR (val
))
1319 && (SYMBOLP (XCAR (tem
))
1320 || CONSP (XCAR (tem
))))))
1321 error ("Invalid condition handler", tem
);
1326 c
.backlist
= backtrace_list
;
1327 c
.handlerlist
= handlerlist
;
1328 c
.lisp_eval_depth
= lisp_eval_depth
;
1329 c
.pdlcount
= SPECPDL_INDEX ();
1330 c
.poll_suppress_count
= poll_suppress_count
;
1331 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1332 c
.gcpro
= gcprolist
;
1333 c
.byte_stack
= byte_stack_list
;
1334 if (_setjmp (c
.jmp
))
1337 specbind (h
.var
, c
.val
);
1338 val
= Fprogn (Fcdr (h
.chosen_clause
));
1340 /* Note that this just undoes the binding of h.var; whoever
1341 longjumped to us unwound the stack to c.pdlcount before
1343 unbind_to (c
.pdlcount
, Qnil
);
1350 h
.handler
= handlers
;
1351 h
.next
= handlerlist
;
1355 val
= Feval (bodyform
);
1357 handlerlist
= h
.next
;
1361 /* Call the function BFUN with no arguments, catching errors within it
1362 according to HANDLERS. If there is an error, call HFUN with
1363 one argument which is the data that describes the error:
1366 HANDLERS can be a list of conditions to catch.
1367 If HANDLERS is Qt, catch all errors.
1368 If HANDLERS is Qerror, catch all errors
1369 but allow the debugger to run if that is enabled. */
1372 internal_condition_case (Lisp_Object (*bfun
) (void), Lisp_Object handlers
,
1373 Lisp_Object (*hfun
) (Lisp_Object
))
1379 /* Since Fsignal will close off all calls to x_catch_errors,
1380 we will get the wrong results if some are not closed now. */
1382 if (x_catching_errors ())
1388 c
.backlist
= backtrace_list
;
1389 c
.handlerlist
= handlerlist
;
1390 c
.lisp_eval_depth
= lisp_eval_depth
;
1391 c
.pdlcount
= SPECPDL_INDEX ();
1392 c
.poll_suppress_count
= poll_suppress_count
;
1393 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1394 c
.gcpro
= gcprolist
;
1395 c
.byte_stack
= byte_stack_list
;
1396 if (_setjmp (c
.jmp
))
1398 return (*hfun
) (c
.val
);
1402 h
.handler
= handlers
;
1404 h
.next
= handlerlist
;
1410 handlerlist
= h
.next
;
1414 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1417 internal_condition_case_1 (Lisp_Object (*bfun
) (Lisp_Object
), Lisp_Object arg
,
1418 Lisp_Object handlers
, Lisp_Object (*hfun
) (Lisp_Object
))
1424 /* Since Fsignal will close off all calls to x_catch_errors,
1425 we will get the wrong results if some are not closed now. */
1427 if (x_catching_errors ())
1433 c
.backlist
= backtrace_list
;
1434 c
.handlerlist
= handlerlist
;
1435 c
.lisp_eval_depth
= lisp_eval_depth
;
1436 c
.pdlcount
= SPECPDL_INDEX ();
1437 c
.poll_suppress_count
= poll_suppress_count
;
1438 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1439 c
.gcpro
= gcprolist
;
1440 c
.byte_stack
= byte_stack_list
;
1441 if (_setjmp (c
.jmp
))
1443 return (*hfun
) (c
.val
);
1447 h
.handler
= handlers
;
1449 h
.next
= handlerlist
;
1453 val
= (*bfun
) (arg
);
1455 handlerlist
= h
.next
;
1459 /* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as
1463 internal_condition_case_2 (Lisp_Object (*bfun
) (Lisp_Object
, Lisp_Object
),
1466 Lisp_Object handlers
,
1467 Lisp_Object (*hfun
) (Lisp_Object
))
1473 /* Since Fsignal will close off all calls to x_catch_errors,
1474 we will get the wrong results if some are not closed now. */
1476 if (x_catching_errors ())
1482 c
.backlist
= backtrace_list
;
1483 c
.handlerlist
= handlerlist
;
1484 c
.lisp_eval_depth
= lisp_eval_depth
;
1485 c
.pdlcount
= SPECPDL_INDEX ();
1486 c
.poll_suppress_count
= poll_suppress_count
;
1487 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1488 c
.gcpro
= gcprolist
;
1489 c
.byte_stack
= byte_stack_list
;
1490 if (_setjmp (c
.jmp
))
1492 return (*hfun
) (c
.val
);
1496 h
.handler
= handlers
;
1498 h
.next
= handlerlist
;
1502 val
= (*bfun
) (arg1
, arg2
);
1504 handlerlist
= h
.next
;
1508 /* Like internal_condition_case but call BFUN with NARGS as first,
1509 and ARGS as second argument. */
1512 internal_condition_case_n (Lisp_Object (*bfun
) (int, Lisp_Object
*),
1515 Lisp_Object handlers
,
1516 Lisp_Object (*hfun
) (Lisp_Object
))
1522 /* Since Fsignal will close off all calls to x_catch_errors,
1523 we will get the wrong results if some are not closed now. */
1525 if (x_catching_errors ())
1531 c
.backlist
= backtrace_list
;
1532 c
.handlerlist
= handlerlist
;
1533 c
.lisp_eval_depth
= lisp_eval_depth
;
1534 c
.pdlcount
= SPECPDL_INDEX ();
1535 c
.poll_suppress_count
= poll_suppress_count
;
1536 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1537 c
.gcpro
= gcprolist
;
1538 c
.byte_stack
= byte_stack_list
;
1539 if (_setjmp (c
.jmp
))
1541 return (*hfun
) (c
.val
);
1545 h
.handler
= handlers
;
1547 h
.next
= handlerlist
;
1551 val
= (*bfun
) (nargs
, args
);
1553 handlerlist
= h
.next
;
1558 static Lisp_Object
find_handler_clause (Lisp_Object
, Lisp_Object
,
1559 Lisp_Object
, Lisp_Object
);
1561 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1562 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1563 This function does not return.
1565 An error symbol is a symbol with an `error-conditions' property
1566 that is a list of condition names.
1567 A handler for any of those names will get to handle this signal.
1568 The symbol `error' should normally be one of them.
1570 DATA should be a list. Its elements are printed as part of the error message.
1571 See Info anchor `(elisp)Definition of signal' for some details on how this
1572 error message is constructed.
1573 If the signal is handled, DATA is made available to the handler.
1574 See also the function `condition-case'. */)
1575 (Lisp_Object error_symbol
, Lisp_Object data
)
1577 /* When memory is full, ERROR-SYMBOL is nil,
1578 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1579 That is a special case--don't do this in other situations. */
1580 register struct handler
*allhandlers
= handlerlist
;
1581 Lisp_Object conditions
;
1583 Lisp_Object real_error_symbol
;
1584 struct backtrace
*bp
;
1586 immediate_quit
= handling_signal
= 0;
1588 if (gc_in_progress
|| waiting_for_input
)
1591 if (NILP (error_symbol
))
1592 real_error_symbol
= Fcar (data
);
1594 real_error_symbol
= error_symbol
;
1596 #if 0 /* rms: I don't know why this was here,
1597 but it is surely wrong for an error that is handled. */
1598 #ifdef HAVE_WINDOW_SYSTEM
1599 if (display_hourglass_p
)
1600 cancel_hourglass ();
1604 /* This hook is used by edebug. */
1605 if (! NILP (Vsignal_hook_function
)
1606 && ! NILP (error_symbol
))
1608 /* Edebug takes care of restoring these variables when it exits. */
1609 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1610 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1612 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1613 max_specpdl_size
= SPECPDL_INDEX () + 40;
1615 call2 (Vsignal_hook_function
, error_symbol
, data
);
1618 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1620 /* Remember from where signal was called. Skip over the frame for
1621 `signal' itself. If a frame for `error' follows, skip that,
1622 too. Don't do this when ERROR_SYMBOL is nil, because that
1623 is a memory-full error. */
1624 Vsignaling_function
= Qnil
;
1625 if (backtrace_list
&& !NILP (error_symbol
))
1627 bp
= backtrace_list
->next
;
1628 if (bp
&& bp
->function
&& EQ (*bp
->function
, Qerror
))
1630 if (bp
&& bp
->function
)
1631 Vsignaling_function
= *bp
->function
;
1634 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1636 register Lisp_Object clause
;
1638 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1639 error_symbol
, data
);
1641 if (EQ (clause
, Qlambda
))
1643 /* We can't return values to code which signaled an error, but we
1644 can continue code which has signaled a quit. */
1645 if (EQ (real_error_symbol
, Qquit
))
1648 error ("Cannot return from the debugger in an error");
1653 Lisp_Object unwind_data
;
1654 struct handler
*h
= handlerlist
;
1656 handlerlist
= allhandlers
;
1658 if (NILP (error_symbol
))
1661 unwind_data
= Fcons (error_symbol
, data
);
1662 h
->chosen_clause
= clause
;
1663 unwind_to_catch (h
->tag
, unwind_data
);
1667 handlerlist
= allhandlers
;
1668 /* If no handler is present now, try to run the debugger,
1669 and if that fails, throw to top level. */
1670 find_handler_clause (Qerror
, conditions
, error_symbol
, data
);
1672 Fthrow (Qtop_level
, Qt
);
1674 if (! NILP (error_symbol
))
1675 data
= Fcons (error_symbol
, data
);
1677 string
= Ferror_message_string (data
);
1678 fatal ("%s", SDATA (string
), 0);
1681 /* Internal version of Fsignal that never returns.
1682 Used for anything but Qquit (which can return from Fsignal). */
1685 xsignal (Lisp_Object error_symbol
, Lisp_Object data
)
1687 Fsignal (error_symbol
, data
);
1691 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1694 xsignal0 (Lisp_Object error_symbol
)
1696 xsignal (error_symbol
, Qnil
);
1700 xsignal1 (Lisp_Object error_symbol
, Lisp_Object arg
)
1702 xsignal (error_symbol
, list1 (arg
));
1706 xsignal2 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
)
1708 xsignal (error_symbol
, list2 (arg1
, arg2
));
1712 xsignal3 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
1714 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1717 /* Signal `error' with message S, and additional arg ARG.
1718 If ARG is not a genuine list, make it a one-element list. */
1721 signal_error (const char *s
, Lisp_Object arg
)
1723 Lisp_Object tortoise
, hare
;
1725 hare
= tortoise
= arg
;
1726 while (CONSP (hare
))
1733 tortoise
= XCDR (tortoise
);
1735 if (EQ (hare
, tortoise
))
1740 arg
= Fcons (arg
, Qnil
); /* Make it a list. */
1742 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1746 /* Return nonzero if LIST is a non-nil atom or
1747 a list containing one of CONDITIONS. */
1750 wants_debugger (Lisp_Object list
, Lisp_Object conditions
)
1757 while (CONSP (conditions
))
1759 Lisp_Object
this, tail
;
1760 this = XCAR (conditions
);
1761 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1762 if (EQ (XCAR (tail
), this))
1764 conditions
= XCDR (conditions
);
1769 /* Return 1 if an error with condition-symbols CONDITIONS,
1770 and described by SIGNAL-DATA, should skip the debugger
1771 according to debugger-ignored-errors. */
1774 skip_debugger (Lisp_Object conditions
, Lisp_Object data
)
1777 int first_string
= 1;
1778 Lisp_Object error_message
;
1780 error_message
= Qnil
;
1781 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1783 if (STRINGP (XCAR (tail
)))
1787 error_message
= Ferror_message_string (data
);
1791 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1796 Lisp_Object contail
;
1798 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1799 if (EQ (XCAR (tail
), XCAR (contail
)))
1807 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1808 SIG and DATA describe the signal, as in find_handler_clause. */
1811 maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
, Lisp_Object data
)
1813 Lisp_Object combined_data
;
1815 combined_data
= Fcons (sig
, data
);
1818 /* Don't try to run the debugger with interrupts blocked.
1819 The editing loop would return anyway. */
1821 /* Does user want to enter debugger for this kind of error? */
1824 : wants_debugger (Vdebug_on_error
, conditions
))
1825 && ! skip_debugger (conditions
, combined_data
)
1826 /* rms: what's this for? */
1827 && when_entered_debugger
< num_nonmacro_input_events
)
1829 call_debugger (Fcons (Qerror
, Fcons (combined_data
, Qnil
)));
1836 /* Value of Qlambda means we have called debugger and user has continued.
1837 There are two ways to pass SIG and DATA:
1838 = SIG is the error symbol, and DATA is the rest of the data.
1839 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1840 This is for memory-full errors only.
1842 We need to increase max_specpdl_size temporarily around
1843 anything we do that can push on the specpdl, so as not to get
1844 a second error here in case we're handling specpdl overflow. */
1847 find_handler_clause (Lisp_Object handlers
, Lisp_Object conditions
,
1848 Lisp_Object sig
, Lisp_Object data
)
1850 register Lisp_Object h
;
1851 register Lisp_Object tem
;
1852 int debugger_called
= 0;
1853 int debugger_considered
= 0;
1855 /* t is used by handlers for all conditions, set up by C code. */
1856 if (EQ (handlers
, Qt
))
1859 /* Don't run the debugger for a memory-full error.
1860 (There is no room in memory to do that!) */
1862 debugger_considered
= 1;
1864 /* error is used similarly, but means print an error message
1865 and run the debugger if that is enabled. */
1866 if (EQ (handlers
, Qerror
)
1867 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1868 there is a handler. */
1870 if (!NILP (sig
) && wants_debugger (Vstack_trace_on_error
, conditions
))
1872 max_lisp_eval_depth
+= 15;
1877 internal_with_output_to_temp_buffer
1879 (Lisp_Object (*) (Lisp_Object
)) Fbacktrace
,
1882 max_lisp_eval_depth
-= 15;
1885 if (!debugger_considered
)
1887 debugger_considered
= 1;
1888 debugger_called
= maybe_call_debugger (conditions
, sig
, data
);
1891 /* If there is no handler, return saying whether we ran the debugger. */
1892 if (EQ (handlers
, Qerror
))
1894 if (debugger_called
)
1900 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1902 Lisp_Object handler
, condit
;
1905 if (!CONSP (handler
))
1907 condit
= Fcar (handler
);
1908 /* Handle a single condition name in handler HANDLER. */
1909 if (SYMBOLP (condit
))
1911 tem
= Fmemq (Fcar (handler
), conditions
);
1915 /* Handle a list of condition names in handler HANDLER. */
1916 else if (CONSP (condit
))
1919 for (tail
= condit
; CONSP (tail
); tail
= XCDR (tail
))
1921 tem
= Fmemq (Fcar (tail
), conditions
);
1924 /* This handler is going to apply.
1925 Does it allow the debugger to run first? */
1926 if (! debugger_considered
&& !NILP (Fmemq (Qdebug
, condit
)))
1927 maybe_call_debugger (conditions
, sig
, data
);
1938 /* dump an error message; called like vprintf */
1940 verror (const char *m
, va_list ap
)
1943 EMACS_INT size
= 200;
1955 used
= doprnt (buffer
, size
, m
, m
+ mlen
, ap
);
1960 buffer
= (char *) xrealloc (buffer
, size
);
1963 buffer
= (char *) xmalloc (size
);
1968 string
= build_string (buffer
);
1972 xsignal1 (Qerror
, string
);
1976 /* dump an error message; called like printf */
1980 error (const char *m
, ...)
1988 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
1989 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
1990 This means it contains a description for how to read arguments to give it.
1991 The value is nil for an invalid function or a symbol with no function
1994 Interactively callable functions include strings and vectors (treated
1995 as keyboard macros), lambda-expressions that contain a top-level call
1996 to `interactive', autoload definitions made by `autoload' with non-nil
1997 fourth argument, and some of the built-in functions of Lisp.
1999 Also, a symbol satisfies `commandp' if its function definition does so.
2001 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
2002 then strings and vectors are not accepted. */)
2003 (Lisp_Object function
, Lisp_Object for_call_interactively
)
2005 register Lisp_Object fun
;
2006 register Lisp_Object funcar
;
2007 Lisp_Object if_prop
= Qnil
;
2011 fun
= indirect_function (fun
); /* Check cycles. */
2012 if (NILP (fun
) || EQ (fun
, Qunbound
))
2015 /* Check an `interactive-form' property if present, analogous to the
2016 function-documentation property. */
2018 while (SYMBOLP (fun
))
2020 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
2023 fun
= Fsymbol_function (fun
);
2026 /* Emacs primitives are interactive if their DEFUN specifies an
2027 interactive spec. */
2029 return XSUBR (fun
)->intspec
? Qt
: if_prop
;
2031 /* Bytecode objects are interactive if they are long enough to
2032 have an element whose index is COMPILED_INTERACTIVE, which is
2033 where the interactive spec is stored. */
2034 else if (COMPILEDP (fun
))
2035 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
2038 /* Strings and vectors are keyboard macros. */
2039 if (STRINGP (fun
) || VECTORP (fun
))
2040 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
2042 /* Lists may represent commands. */
2045 funcar
= XCAR (fun
);
2046 if (EQ (funcar
, Qlambda
))
2047 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
2048 if (EQ (funcar
, Qautoload
))
2049 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
2054 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
2055 doc
: /* Define FUNCTION to autoload from FILE.
2056 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
2057 Third arg DOCSTRING is documentation for the function.
2058 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
2059 Fifth arg TYPE indicates the type of the object:
2060 nil or omitted says FUNCTION is a function,
2061 `keymap' says FUNCTION is really a keymap, and
2062 `macro' or t says FUNCTION is really a macro.
2063 Third through fifth args give info about the real definition.
2064 They default to nil.
2065 If FUNCTION is already defined other than as an autoload,
2066 this does nothing and returns nil. */)
2067 (Lisp_Object function
, Lisp_Object file
, Lisp_Object docstring
, Lisp_Object interactive
, Lisp_Object type
)
2069 CHECK_SYMBOL (function
);
2070 CHECK_STRING (file
);
2072 /* If function is defined and not as an autoload, don't override */
2073 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
2074 && !(CONSP (XSYMBOL (function
)->function
)
2075 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
2078 if (NILP (Vpurify_flag
))
2079 /* Only add entries after dumping, because the ones before are
2080 not useful and else we get loads of them from the loaddefs.el. */
2081 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
2083 /* We don't want the docstring in purespace (instead,
2084 Snarf-documentation should (hopefully) overwrite it).
2085 We used to use 0 here, but that leads to accidental sharing in
2086 purecopy's hash-consing, so we use a (hopefully) unique integer
2088 docstring
= make_number (XHASH (function
));
2089 return Ffset (function
,
2090 Fpurecopy (list5 (Qautoload
, file
, docstring
,
2091 interactive
, type
)));
2095 un_autoload (Lisp_Object oldqueue
)
2097 register Lisp_Object queue
, first
, second
;
2099 /* Queue to unwind is current value of Vautoload_queue.
2100 oldqueue is the shadowed value to leave in Vautoload_queue. */
2101 queue
= Vautoload_queue
;
2102 Vautoload_queue
= oldqueue
;
2103 while (CONSP (queue
))
2105 first
= XCAR (queue
);
2106 second
= Fcdr (first
);
2107 first
= Fcar (first
);
2108 if (EQ (first
, make_number (0)))
2111 Ffset (first
, second
);
2112 queue
= XCDR (queue
);
2117 /* Load an autoloaded function.
2118 FUNNAME is the symbol which is the function's name.
2119 FUNDEF is the autoload definition (a list). */
2122 do_autoload (Lisp_Object fundef
, Lisp_Object funname
)
2124 int count
= SPECPDL_INDEX ();
2126 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2128 /* This is to make sure that loadup.el gives a clear picture
2129 of what files are preloaded and when. */
2130 if (! NILP (Vpurify_flag
))
2131 error ("Attempt to autoload %s while preparing to dump",
2132 SDATA (SYMBOL_NAME (funname
)));
2135 CHECK_SYMBOL (funname
);
2136 GCPRO3 (fun
, funname
, fundef
);
2138 /* Preserve the match data. */
2139 record_unwind_save_match_data ();
2141 /* If autoloading gets an error (which includes the error of failing
2142 to define the function being called), we use Vautoload_queue
2143 to undo function definitions and `provide' calls made by
2144 the function. We do this in the specific case of autoloading
2145 because autoloading is not an explicit request "load this file",
2146 but rather a request to "call this function".
2148 The value saved here is to be restored into Vautoload_queue. */
2149 record_unwind_protect (un_autoload
, Vautoload_queue
);
2150 Vautoload_queue
= Qt
;
2151 Fload (Fcar (Fcdr (fundef
)), Qnil
, Qt
, Qnil
, Qt
);
2153 /* Once loading finishes, don't undo it. */
2154 Vautoload_queue
= Qt
;
2155 unbind_to (count
, Qnil
);
2157 fun
= Findirect_function (fun
, Qnil
);
2159 if (!NILP (Fequal (fun
, fundef
)))
2160 error ("Autoloading failed to define function %s",
2161 SDATA (SYMBOL_NAME (funname
)));
2166 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
2167 doc
: /* Evaluate FORM and return its value. */)
2170 Lisp_Object fun
, val
, original_fun
, original_args
;
2172 struct backtrace backtrace
;
2173 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2175 if (handling_signal
)
2179 return Fsymbol_value (form
);
2184 if ((consing_since_gc
> gc_cons_threshold
2185 && consing_since_gc
> gc_relative_threshold
)
2187 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2190 Fgarbage_collect ();
2194 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2196 if (max_lisp_eval_depth
< 100)
2197 max_lisp_eval_depth
= 100;
2198 if (lisp_eval_depth
> max_lisp_eval_depth
)
2199 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2202 original_fun
= Fcar (form
);
2203 original_args
= Fcdr (form
);
2205 backtrace
.next
= backtrace_list
;
2206 backtrace_list
= &backtrace
;
2207 backtrace
.function
= &original_fun
; /* This also protects them from gc */
2208 backtrace
.args
= &original_args
;
2209 backtrace
.nargs
= UNEVALLED
;
2210 backtrace
.evalargs
= 1;
2211 backtrace
.debug_on_exit
= 0;
2213 if (debug_on_next_call
)
2214 do_debug_on_call (Qt
);
2216 /* At this point, only original_fun and original_args
2217 have values that will be used below */
2220 /* Optimize for no indirection. */
2222 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2223 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2224 fun
= indirect_function (fun
);
2228 Lisp_Object numargs
;
2229 Lisp_Object argvals
[8];
2230 Lisp_Object args_left
;
2231 register int i
, maxargs
;
2233 args_left
= original_args
;
2234 numargs
= Flength (args_left
);
2238 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
2239 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2240 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2242 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2244 backtrace
.evalargs
= 0;
2245 val
= (XSUBR (fun
)->function
.aUNEVALLED
) (args_left
);
2247 else if (XSUBR (fun
)->max_args
== MANY
)
2249 /* Pass a vector of evaluated arguments */
2251 register int argnum
= 0;
2254 SAFE_ALLOCA_LISP (vals
, XINT (numargs
));
2256 GCPRO3 (args_left
, fun
, fun
);
2260 while (!NILP (args_left
))
2262 vals
[argnum
++] = Feval (Fcar (args_left
));
2263 args_left
= Fcdr (args_left
);
2264 gcpro3
.nvars
= argnum
;
2267 backtrace
.args
= vals
;
2268 backtrace
.nargs
= XINT (numargs
);
2270 val
= (XSUBR (fun
)->function
.aMANY
) (XINT (numargs
), vals
);
2276 GCPRO3 (args_left
, fun
, fun
);
2277 gcpro3
.var
= argvals
;
2280 maxargs
= XSUBR (fun
)->max_args
;
2281 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
2283 argvals
[i
] = Feval (Fcar (args_left
));
2289 backtrace
.args
= argvals
;
2290 backtrace
.nargs
= XINT (numargs
);
2295 val
= (XSUBR (fun
)->function
.a0 ());
2298 val
= (XSUBR (fun
)->function
.a1 (argvals
[0]));
2301 val
= (XSUBR (fun
)->function
.a2 (argvals
[0], argvals
[1]));
2304 val
= (XSUBR (fun
)->function
.a3
2305 (argvals
[0], argvals
[1], argvals
[2]));
2308 val
= (XSUBR (fun
)->function
.a4
2309 (argvals
[0], argvals
[1], argvals
[2], argvals
[3]));
2312 val
= (XSUBR (fun
)->function
.a5
2313 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2317 val
= (XSUBR (fun
)->function
.a6
2318 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2319 argvals
[4], argvals
[5]));
2322 val
= (XSUBR (fun
)->function
.a7
2323 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2324 argvals
[4], argvals
[5], argvals
[6]));
2328 val
= (XSUBR (fun
)->function
.a8
2329 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2330 argvals
[4], argvals
[5], argvals
[6], argvals
[7]));
2334 /* Someone has created a subr that takes more arguments than
2335 is supported by this code. We need to either rewrite the
2336 subr to use a different argument protocol, or add more
2337 cases to this switch. */
2342 else if (COMPILEDP (fun
))
2343 val
= apply_lambda (fun
, original_args
, 1);
2346 if (EQ (fun
, Qunbound
))
2347 xsignal1 (Qvoid_function
, original_fun
);
2349 xsignal1 (Qinvalid_function
, original_fun
);
2350 funcar
= XCAR (fun
);
2351 if (!SYMBOLP (funcar
))
2352 xsignal1 (Qinvalid_function
, original_fun
);
2353 if (EQ (funcar
, Qautoload
))
2355 do_autoload (fun
, original_fun
);
2358 if (EQ (funcar
, Qmacro
))
2359 val
= Feval (apply1 (Fcdr (fun
), original_args
));
2360 else if (EQ (funcar
, Qlambda
))
2361 val
= apply_lambda (fun
, original_args
, 1);
2363 xsignal1 (Qinvalid_function
, original_fun
);
2368 if (backtrace
.debug_on_exit
)
2369 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2370 backtrace_list
= backtrace
.next
;
2375 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
2376 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2377 Then return the value FUNCTION returns.
2378 Thus, (apply '+ 1 2 '(3 4)) returns 10.
2379 usage: (apply FUNCTION &rest ARGUMENTS) */)
2380 (int nargs
, Lisp_Object
*args
)
2382 register int i
, numargs
;
2383 register Lisp_Object spread_arg
;
2384 register Lisp_Object
*funcall_args
;
2385 Lisp_Object fun
, retval
;
2386 struct gcpro gcpro1
;
2391 spread_arg
= args
[nargs
- 1];
2392 CHECK_LIST (spread_arg
);
2394 numargs
= XINT (Flength (spread_arg
));
2397 return Ffuncall (nargs
- 1, args
);
2398 else if (numargs
== 1)
2400 args
[nargs
- 1] = XCAR (spread_arg
);
2401 return Ffuncall (nargs
, args
);
2404 numargs
+= nargs
- 2;
2406 /* Optimize for no indirection. */
2407 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2408 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2409 fun
= indirect_function (fun
);
2410 if (EQ (fun
, Qunbound
))
2412 /* Let funcall get the error */
2419 if (numargs
< XSUBR (fun
)->min_args
2420 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2421 goto funcall
; /* Let funcall get the error */
2422 else if (XSUBR (fun
)->max_args
> numargs
)
2424 /* Avoid making funcall cons up a yet another new vector of arguments
2425 by explicitly supplying nil's for optional values */
2426 SAFE_ALLOCA_LISP (funcall_args
, 1 + XSUBR (fun
)->max_args
);
2427 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2428 funcall_args
[++i
] = Qnil
;
2429 GCPRO1 (*funcall_args
);
2430 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2434 /* We add 1 to numargs because funcall_args includes the
2435 function itself as well as its arguments. */
2438 SAFE_ALLOCA_LISP (funcall_args
, 1 + numargs
);
2439 GCPRO1 (*funcall_args
);
2440 gcpro1
.nvars
= 1 + numargs
;
2443 memcpy (funcall_args
, args
, nargs
* sizeof (Lisp_Object
));
2444 /* Spread the last arg we got. Its first element goes in
2445 the slot that it used to occupy, hence this value of I. */
2447 while (!NILP (spread_arg
))
2449 funcall_args
[i
++] = XCAR (spread_arg
);
2450 spread_arg
= XCDR (spread_arg
);
2453 /* By convention, the caller needs to gcpro Ffuncall's args. */
2454 retval
= Ffuncall (gcpro1
.nvars
, funcall_args
);
2461 /* Run hook variables in various ways. */
2463 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
2464 static Lisp_Object
run_hook_with_args (int, Lisp_Object
*,
2465 enum run_hooks_condition
);
2467 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2468 doc
: /* Run each hook in HOOKS.
2469 Each argument should be a symbol, a hook variable.
2470 These symbols are processed in the order specified.
2471 If a hook symbol has a non-nil value, that value may be a function
2472 or a list of functions to be called to run the hook.
2473 If the value is a function, it is called with no arguments.
2474 If it is a list, the elements are called, in order, with no arguments.
2476 Major modes should not use this function directly to run their mode
2477 hook; they should use `run-mode-hooks' instead.
2479 Do not use `make-local-variable' to make a hook variable buffer-local.
2480 Instead, use `add-hook' and specify t for the LOCAL argument.
2481 usage: (run-hooks &rest HOOKS) */)
2482 (int nargs
, Lisp_Object
*args
)
2484 Lisp_Object hook
[1];
2487 for (i
= 0; i
< nargs
; i
++)
2490 run_hook_with_args (1, hook
, to_completion
);
2496 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2497 Srun_hook_with_args
, 1, MANY
, 0,
2498 doc
: /* Run HOOK with the specified arguments ARGS.
2499 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2500 value, that value may be a function or a list of functions to be
2501 called to run the hook. If the value is a function, it is called with
2502 the given arguments and its return value is returned. If it is a list
2503 of functions, those functions are called, in order,
2504 with the given arguments ARGS.
2505 It is best not to depend on the value returned by `run-hook-with-args',
2508 Do not use `make-local-variable' to make a hook variable buffer-local.
2509 Instead, use `add-hook' and specify t for the LOCAL argument.
2510 usage: (run-hook-with-args HOOK &rest ARGS) */)
2511 (int nargs
, Lisp_Object
*args
)
2513 return run_hook_with_args (nargs
, args
, to_completion
);
2516 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2517 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2518 doc
: /* Run HOOK with the specified arguments ARGS.
2519 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2520 value, that value may be a function or a list of functions to be
2521 called to run the hook. If the value is a function, it is called with
2522 the given arguments and its return value is returned.
2523 If it is a list of functions, those functions are called, in order,
2524 with the given arguments ARGS, until one of them
2525 returns a non-nil value. Then we return that value.
2526 However, if they all return nil, we return nil.
2528 Do not use `make-local-variable' to make a hook variable buffer-local.
2529 Instead, use `add-hook' and specify t for the LOCAL argument.
2530 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2531 (int nargs
, Lisp_Object
*args
)
2533 return run_hook_with_args (nargs
, args
, until_success
);
2536 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2537 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2538 doc
: /* Run HOOK with the specified arguments ARGS.
2539 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2540 value, that value may be a function or a list of functions to be
2541 called to run the hook. If the value is a function, it is called with
2542 the given arguments and its return value is returned.
2543 If it is a list of functions, those functions are called, in order,
2544 with the given arguments ARGS, until one of them returns nil.
2545 Then we return nil. However, if they all return non-nil, we return non-nil.
2547 Do not use `make-local-variable' to make a hook variable buffer-local.
2548 Instead, use `add-hook' and specify t for the LOCAL argument.
2549 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2550 (int nargs
, Lisp_Object
*args
)
2552 return run_hook_with_args (nargs
, args
, until_failure
);
2555 /* ARGS[0] should be a hook symbol.
2556 Call each of the functions in the hook value, passing each of them
2557 as arguments all the rest of ARGS (all NARGS - 1 elements).
2558 COND specifies a condition to test after each call
2559 to decide whether to stop.
2560 The caller (or its caller, etc) must gcpro all of ARGS,
2561 except that it isn't necessary to gcpro ARGS[0]. */
2564 run_hook_with_args (int nargs
, Lisp_Object
*args
, enum run_hooks_condition cond
)
2566 Lisp_Object sym
, val
, ret
;
2567 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2569 /* If we are dying or still initializing,
2570 don't do anything--it would probably crash if we tried. */
2571 if (NILP (Vrun_hooks
))
2575 val
= find_symbol_value (sym
);
2576 ret
= (cond
== until_failure
? Qt
: Qnil
);
2578 if (EQ (val
, Qunbound
) || NILP (val
))
2580 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2583 return Ffuncall (nargs
, args
);
2587 Lisp_Object globals
= Qnil
;
2588 GCPRO3 (sym
, val
, globals
);
2591 CONSP (val
) && ((cond
== to_completion
)
2592 || (cond
== until_success
? NILP (ret
)
2596 if (EQ (XCAR (val
), Qt
))
2598 /* t indicates this hook has a local binding;
2599 it means to run the global binding too. */
2600 globals
= Fdefault_value (sym
);
2601 if (NILP (globals
)) continue;
2603 if (!CONSP (globals
) || EQ (XCAR (globals
), Qlambda
))
2606 ret
= Ffuncall (nargs
, args
);
2611 CONSP (globals
) && ((cond
== to_completion
)
2612 || (cond
== until_success
? NILP (ret
)
2614 globals
= XCDR (globals
))
2616 args
[0] = XCAR (globals
);
2617 /* In a global value, t should not occur. If it does, we
2618 must ignore it to avoid an endless loop. */
2619 if (!EQ (args
[0], Qt
))
2620 ret
= Ffuncall (nargs
, args
);
2626 args
[0] = XCAR (val
);
2627 ret
= Ffuncall (nargs
, args
);
2636 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2639 run_hook_with_args_2 (Lisp_Object hook
, Lisp_Object arg1
, Lisp_Object arg2
)
2641 Lisp_Object temp
[3];
2646 Frun_hook_with_args (3, temp
);
2649 /* Apply fn to arg */
2651 apply1 (Lisp_Object fn
, Lisp_Object arg
)
2653 struct gcpro gcpro1
;
2657 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2660 Lisp_Object args
[2];
2664 RETURN_UNGCPRO (Fapply (2, args
));
2668 /* Call function fn on no arguments */
2670 call0 (Lisp_Object fn
)
2672 struct gcpro gcpro1
;
2675 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2678 /* Call function fn with 1 argument arg1 */
2681 call1 (Lisp_Object fn
, Lisp_Object arg1
)
2683 struct gcpro gcpro1
;
2684 Lisp_Object args
[2];
2690 RETURN_UNGCPRO (Ffuncall (2, args
));
2693 /* Call function fn with 2 arguments arg1, arg2 */
2696 call2 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
)
2698 struct gcpro gcpro1
;
2699 Lisp_Object args
[3];
2705 RETURN_UNGCPRO (Ffuncall (3, args
));
2708 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2711 call3 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2713 struct gcpro gcpro1
;
2714 Lisp_Object args
[4];
2721 RETURN_UNGCPRO (Ffuncall (4, args
));
2724 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2727 call4 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2730 struct gcpro gcpro1
;
2731 Lisp_Object args
[5];
2739 RETURN_UNGCPRO (Ffuncall (5, args
));
2742 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2745 call5 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2746 Lisp_Object arg4
, Lisp_Object arg5
)
2748 struct gcpro gcpro1
;
2749 Lisp_Object args
[6];
2758 RETURN_UNGCPRO (Ffuncall (6, args
));
2761 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2764 call6 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2765 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
)
2767 struct gcpro gcpro1
;
2768 Lisp_Object args
[7];
2778 RETURN_UNGCPRO (Ffuncall (7, args
));
2781 /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7 */
2784 call7 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2785 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
)
2787 struct gcpro gcpro1
;
2788 Lisp_Object args
[8];
2799 RETURN_UNGCPRO (Ffuncall (8, args
));
2802 /* The caller should GCPRO all the elements of ARGS. */
2804 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2805 doc
: /* Call first argument as a function, passing remaining arguments to it.
2806 Return the value that function returns.
2807 Thus, (funcall 'cons 'x 'y) returns (x . y).
2808 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2809 (int nargs
, Lisp_Object
*args
)
2811 Lisp_Object fun
, original_fun
;
2813 int numargs
= nargs
- 1;
2814 Lisp_Object lisp_numargs
;
2816 struct backtrace backtrace
;
2817 register Lisp_Object
*internal_args
;
2821 if ((consing_since_gc
> gc_cons_threshold
2822 && consing_since_gc
> gc_relative_threshold
)
2824 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2825 Fgarbage_collect ();
2827 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2829 if (max_lisp_eval_depth
< 100)
2830 max_lisp_eval_depth
= 100;
2831 if (lisp_eval_depth
> max_lisp_eval_depth
)
2832 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2835 backtrace
.next
= backtrace_list
;
2836 backtrace_list
= &backtrace
;
2837 backtrace
.function
= &args
[0];
2838 backtrace
.args
= &args
[1];
2839 backtrace
.nargs
= nargs
- 1;
2840 backtrace
.evalargs
= 0;
2841 backtrace
.debug_on_exit
= 0;
2843 if (debug_on_next_call
)
2844 do_debug_on_call (Qlambda
);
2848 original_fun
= args
[0];
2852 /* Optimize for no indirection. */
2854 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2855 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2856 fun
= indirect_function (fun
);
2860 if (numargs
< XSUBR (fun
)->min_args
2861 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2863 XSETFASTINT (lisp_numargs
, numargs
);
2864 xsignal2 (Qwrong_number_of_arguments
, original_fun
, lisp_numargs
);
2867 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2868 xsignal1 (Qinvalid_function
, original_fun
);
2870 else if (XSUBR (fun
)->max_args
== MANY
)
2871 val
= (XSUBR (fun
)->function
.aMANY
) (numargs
, args
+ 1);
2874 if (XSUBR (fun
)->max_args
> numargs
)
2876 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2877 memcpy (internal_args
, args
+ 1, numargs
* sizeof (Lisp_Object
));
2878 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2879 internal_args
[i
] = Qnil
;
2882 internal_args
= args
+ 1;
2883 switch (XSUBR (fun
)->max_args
)
2886 val
= (XSUBR (fun
)->function
.a0 ());
2889 val
= (XSUBR (fun
)->function
.a1 (internal_args
[0]));
2892 val
= (XSUBR (fun
)->function
.a2
2893 (internal_args
[0], internal_args
[1]));
2896 val
= (XSUBR (fun
)->function
.a3
2897 (internal_args
[0], internal_args
[1], internal_args
[2]));
2900 val
= (XSUBR (fun
)->function
.a4
2901 (internal_args
[0], internal_args
[1], internal_args
[2],
2905 val
= (XSUBR (fun
)->function
.a5
2906 (internal_args
[0], internal_args
[1], internal_args
[2],
2907 internal_args
[3], internal_args
[4]));
2910 val
= (XSUBR (fun
)->function
.a6
2911 (internal_args
[0], internal_args
[1], internal_args
[2],
2912 internal_args
[3], internal_args
[4], internal_args
[5]));
2915 val
= (XSUBR (fun
)->function
.a7
2916 (internal_args
[0], internal_args
[1], internal_args
[2],
2917 internal_args
[3], internal_args
[4], internal_args
[5],
2922 val
= (XSUBR (fun
)->function
.a8
2923 (internal_args
[0], internal_args
[1], internal_args
[2],
2924 internal_args
[3], internal_args
[4], internal_args
[5],
2925 internal_args
[6], internal_args
[7]));
2930 /* If a subr takes more than 8 arguments without using MANY
2931 or UNEVALLED, we need to extend this function to support it.
2932 Until this is done, there is no way to call the function. */
2937 else if (COMPILEDP (fun
))
2938 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2941 if (EQ (fun
, Qunbound
))
2942 xsignal1 (Qvoid_function
, original_fun
);
2944 xsignal1 (Qinvalid_function
, original_fun
);
2945 funcar
= XCAR (fun
);
2946 if (!SYMBOLP (funcar
))
2947 xsignal1 (Qinvalid_function
, original_fun
);
2948 if (EQ (funcar
, Qlambda
))
2949 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2950 else if (EQ (funcar
, Qautoload
))
2952 do_autoload (fun
, original_fun
);
2957 xsignal1 (Qinvalid_function
, original_fun
);
2961 if (backtrace
.debug_on_exit
)
2962 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2963 backtrace_list
= backtrace
.next
;
2968 apply_lambda (Lisp_Object fun
, Lisp_Object args
, int eval_flag
)
2970 Lisp_Object args_left
;
2971 Lisp_Object numargs
;
2972 register Lisp_Object
*arg_vector
;
2973 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2975 register Lisp_Object tem
;
2978 numargs
= Flength (args
);
2979 SAFE_ALLOCA_LISP (arg_vector
, XINT (numargs
));
2982 GCPRO3 (*arg_vector
, args_left
, fun
);
2985 for (i
= 0; i
< XINT (numargs
);)
2987 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2988 if (eval_flag
) tem
= Feval (tem
);
2989 arg_vector
[i
++] = tem
;
2997 backtrace_list
->args
= arg_vector
;
2998 backtrace_list
->nargs
= i
;
3000 backtrace_list
->evalargs
= 0;
3001 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
3003 /* Do the debug-on-exit now, while arg_vector still exists. */
3004 if (backtrace_list
->debug_on_exit
)
3005 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
3006 /* Don't do it again when we return to eval. */
3007 backtrace_list
->debug_on_exit
= 0;
3012 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
3013 and return the result of evaluation.
3014 FUN must be either a lambda-expression or a compiled-code object. */
3017 funcall_lambda (Lisp_Object fun
, int nargs
, register Lisp_Object
*arg_vector
)
3019 Lisp_Object val
, syms_left
, next
;
3020 int count
= SPECPDL_INDEX ();
3021 int i
, optional
, rest
;
3025 syms_left
= XCDR (fun
);
3026 if (CONSP (syms_left
))
3027 syms_left
= XCAR (syms_left
);
3029 xsignal1 (Qinvalid_function
, fun
);
3031 else if (COMPILEDP (fun
))
3032 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3036 i
= optional
= rest
= 0;
3037 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3041 next
= XCAR (syms_left
);
3042 if (!SYMBOLP (next
))
3043 xsignal1 (Qinvalid_function
, fun
);
3045 if (EQ (next
, Qand_rest
))
3047 else if (EQ (next
, Qand_optional
))
3051 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
3055 specbind (next
, arg_vector
[i
++]);
3057 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3059 specbind (next
, Qnil
);
3062 if (!NILP (syms_left
))
3063 xsignal1 (Qinvalid_function
, fun
);
3065 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3068 val
= Fprogn (XCDR (XCDR (fun
)));
3071 /* If we have not actually read the bytecode string
3072 and constants vector yet, fetch them from the file. */
3073 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3074 Ffetch_bytecode (fun
);
3075 val
= Fbyte_code (AREF (fun
, COMPILED_BYTECODE
),
3076 AREF (fun
, COMPILED_CONSTANTS
),
3077 AREF (fun
, COMPILED_STACK_DEPTH
));
3080 return unbind_to (count
, val
);
3083 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3085 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3086 (Lisp_Object object
)
3090 if (COMPILEDP (object
) && CONSP (AREF (object
, COMPILED_BYTECODE
)))
3092 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3095 tem
= AREF (object
, COMPILED_BYTECODE
);
3096 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3097 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3099 error ("Invalid byte code");
3101 ASET (object
, COMPILED_BYTECODE
, XCAR (tem
));
3102 ASET (object
, COMPILED_CONSTANTS
, XCDR (tem
));
3110 register int count
= SPECPDL_INDEX ();
3111 if (specpdl_size
>= max_specpdl_size
)
3113 if (max_specpdl_size
< 400)
3114 max_specpdl_size
= 400;
3115 if (specpdl_size
>= max_specpdl_size
)
3116 signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil
);
3119 if (specpdl_size
> max_specpdl_size
)
3120 specpdl_size
= max_specpdl_size
;
3121 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
3122 specpdl_ptr
= specpdl
+ count
;
3125 /* specpdl_ptr->symbol is a field which describes which variable is
3126 let-bound, so it can be properly undone when we unbind_to.
3127 It can have the following two shapes:
3128 - SYMBOL : if it's a plain symbol, it means that we have let-bound
3129 a symbol that is not buffer-local (at least at the time
3130 the let binding started). Note also that it should not be
3131 aliased (i.e. when let-binding V1 that's aliased to V2, we want
3133 - (SYMBOL WHERE . BUFFER) : this means that it is a let-binding for
3134 variable SYMBOL which can be buffer-local. WHERE tells us
3135 which buffer is affected (or nil if the let-binding affects the
3136 global value of the variable) and BUFFER tells us which buffer was
3137 current (i.e. if WHERE is non-nil, then BUFFER==WHERE, otherwise
3138 BUFFER did not yet have a buffer-local value). */
3141 specbind (Lisp_Object symbol
, Lisp_Object value
)
3143 struct Lisp_Symbol
*sym
;
3145 eassert (!handling_signal
);
3147 CHECK_SYMBOL (symbol
);
3148 sym
= XSYMBOL (symbol
);
3149 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3153 switch (sym
->redirect
)
3155 case SYMBOL_VARALIAS
:
3156 sym
= indirect_variable (sym
); XSETSYMBOL (symbol
, sym
); goto start
;
3157 case SYMBOL_PLAINVAL
:
3158 /* The most common case is that of a non-constant symbol with a
3159 trivial value. Make that as fast as we can. */
3160 specpdl_ptr
->symbol
= symbol
;
3161 specpdl_ptr
->old_value
= SYMBOL_VAL (sym
);
3162 specpdl_ptr
->func
= NULL
;
3165 SET_SYMBOL_VAL (sym
, value
);
3167 set_internal (symbol
, value
, Qnil
, 1);
3169 case SYMBOL_LOCALIZED
:
3170 if (SYMBOL_BLV (sym
)->frame_local
)
3171 error ("Frame-local vars cannot be let-bound");
3172 case SYMBOL_FORWARDED
:
3174 Lisp_Object ovalue
= find_symbol_value (symbol
);
3175 specpdl_ptr
->func
= 0;
3176 specpdl_ptr
->old_value
= ovalue
;
3178 eassert (sym
->redirect
!= SYMBOL_LOCALIZED
3179 || (EQ (SYMBOL_BLV (sym
)->where
,
3180 SYMBOL_BLV (sym
)->frame_local
?
3181 Fselected_frame () : Fcurrent_buffer ())));
3183 if (sym
->redirect
== SYMBOL_LOCALIZED
3184 || BUFFER_OBJFWDP (SYMBOL_FWD (sym
)))
3186 Lisp_Object where
, cur_buf
= Fcurrent_buffer ();
3188 /* For a local variable, record both the symbol and which
3189 buffer's or frame's value we are saving. */
3190 if (!NILP (Flocal_variable_p (symbol
, Qnil
)))
3192 eassert (sym
->redirect
!= SYMBOL_LOCALIZED
3193 || (BLV_FOUND (SYMBOL_BLV (sym
))
3194 && EQ (cur_buf
, SYMBOL_BLV (sym
)->where
)));
3197 else if (sym
->redirect
== SYMBOL_LOCALIZED
3198 && BLV_FOUND (SYMBOL_BLV (sym
)))
3199 where
= SYMBOL_BLV (sym
)->where
;
3203 /* We're not using the `unused' slot in the specbinding
3204 structure because this would mean we have to do more
3205 work for simple variables. */
3206 /* FIXME: The third value `current_buffer' is only used in
3207 let_shadows_buffer_binding_p which is itself only used
3208 in set_internal for local_if_set. */
3209 eassert (NILP (where
) || EQ (where
, cur_buf
));
3210 specpdl_ptr
->symbol
= Fcons (symbol
, Fcons (where
, cur_buf
));
3212 /* If SYMBOL is a per-buffer variable which doesn't have a
3213 buffer-local value here, make the `let' change the global
3214 value by changing the value of SYMBOL in all buffers not
3215 having their own value. This is consistent with what
3216 happens with other buffer-local variables. */
3218 && sym
->redirect
== SYMBOL_FORWARDED
)
3220 eassert (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)));
3222 Fset_default (symbol
, value
);
3227 specpdl_ptr
->symbol
= symbol
;
3230 set_internal (symbol
, value
, Qnil
, 1);
3238 record_unwind_protect (Lisp_Object (*function
) (Lisp_Object
), Lisp_Object arg
)
3240 eassert (!handling_signal
);
3242 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3244 specpdl_ptr
->func
= function
;
3245 specpdl_ptr
->symbol
= Qnil
;
3246 specpdl_ptr
->old_value
= arg
;
3251 unbind_to (int count
, Lisp_Object value
)
3253 Lisp_Object quitf
= Vquit_flag
;
3254 struct gcpro gcpro1
, gcpro2
;
3256 GCPRO2 (value
, quitf
);
3259 while (specpdl_ptr
!= specpdl
+ count
)
3261 /* Copy the binding, and decrement specpdl_ptr, before we do
3262 the work to unbind it. We decrement first
3263 so that an error in unbinding won't try to unbind
3264 the same entry again, and we copy the binding first
3265 in case more bindings are made during some of the code we run. */
3267 struct specbinding this_binding
;
3268 this_binding
= *--specpdl_ptr
;
3270 if (this_binding
.func
!= 0)
3271 (*this_binding
.func
) (this_binding
.old_value
);
3272 /* If the symbol is a list, it is really (SYMBOL WHERE
3273 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3274 frame. If WHERE is a buffer or frame, this indicates we
3275 bound a variable that had a buffer-local or frame-local
3276 binding. WHERE nil means that the variable had the default
3277 value when it was bound. CURRENT-BUFFER is the buffer that
3278 was current when the variable was bound. */
3279 else if (CONSP (this_binding
.symbol
))
3281 Lisp_Object symbol
, where
;
3283 symbol
= XCAR (this_binding
.symbol
);
3284 where
= XCAR (XCDR (this_binding
.symbol
));
3287 Fset_default (symbol
, this_binding
.old_value
);
3288 /* If `where' is non-nil, reset the value in the appropriate
3289 local binding, but only if that binding still exists. */
3290 else if (BUFFERP (where
)
3291 ? !NILP (Flocal_variable_p (symbol
, where
))
3292 : !NILP (Fassq (symbol
, XFRAME (where
)->param_alist
)))
3293 set_internal (symbol
, this_binding
.old_value
, where
, 1);
3295 /* If variable has a trivial value (no forwarding), we can
3296 just set it. No need to check for constant symbols here,
3297 since that was already done by specbind. */
3298 else if (XSYMBOL (this_binding
.symbol
)->redirect
== SYMBOL_PLAINVAL
)
3299 SET_SYMBOL_VAL (XSYMBOL (this_binding
.symbol
),
3300 this_binding
.old_value
);
3302 /* NOTE: we only ever come here if make_local_foo was used for
3303 the first time on this var within this let. */
3304 Fset_default (this_binding
.symbol
, this_binding
.old_value
);
3307 if (NILP (Vquit_flag
) && !NILP (quitf
))
3314 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3315 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3316 The debugger is entered when that frame exits, if the flag is non-nil. */)
3317 (Lisp_Object level
, Lisp_Object flag
)
3319 register struct backtrace
*backlist
= backtrace_list
;
3322 CHECK_NUMBER (level
);
3324 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
3326 backlist
= backlist
->next
;
3330 backlist
->debug_on_exit
= !NILP (flag
);
3335 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3336 doc
: /* Print a trace of Lisp function calls currently active.
3337 Output stream used is value of `standard-output'. */)
3340 register struct backtrace
*backlist
= backtrace_list
;
3344 struct gcpro gcpro1
;
3345 Lisp_Object old_print_level
= Vprint_level
;
3347 if (NILP (Vprint_level
))
3348 XSETFASTINT (Vprint_level
, 8);
3355 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
3356 if (backlist
->nargs
== UNEVALLED
)
3358 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
3359 write_string ("\n", -1);
3363 tem
= *backlist
->function
;
3364 Fprin1 (tem
, Qnil
); /* This can QUIT */
3365 write_string ("(", -1);
3366 if (backlist
->nargs
== MANY
)
3368 for (tail
= *backlist
->args
, i
= 0;
3370 tail
= Fcdr (tail
), i
++)
3372 if (i
) write_string (" ", -1);
3373 Fprin1 (Fcar (tail
), Qnil
);
3378 for (i
= 0; i
< backlist
->nargs
; i
++)
3380 if (i
) write_string (" ", -1);
3381 Fprin1 (backlist
->args
[i
], Qnil
);
3384 write_string (")\n", -1);
3386 backlist
= backlist
->next
;
3389 Vprint_level
= old_print_level
;
3394 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, NULL
,
3395 doc
: /* Return the function and arguments NFRAMES up from current execution point.
3396 If that frame has not evaluated the arguments yet (or is a special form),
3397 the value is (nil FUNCTION ARG-FORMS...).
3398 If that frame has evaluated its arguments and called its function already,
3399 the value is (t FUNCTION ARG-VALUES...).
3400 A &rest arg is represented as the tail of the list ARG-VALUES.
3401 FUNCTION is whatever was supplied as car of evaluated list,
3402 or a lambda expression for macro calls.
3403 If NFRAMES is more than the number of frames, the value is nil. */)
3404 (Lisp_Object nframes
)
3406 register struct backtrace
*backlist
= backtrace_list
;
3410 CHECK_NATNUM (nframes
);
3412 /* Find the frame requested. */
3413 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3414 backlist
= backlist
->next
;
3418 if (backlist
->nargs
== UNEVALLED
)
3419 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3422 if (backlist
->nargs
== MANY
)
3423 tem
= *backlist
->args
;
3425 tem
= Flist (backlist
->nargs
, backlist
->args
);
3427 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3433 mark_backtrace (void)
3435 register struct backtrace
*backlist
;
3438 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3440 mark_object (*backlist
->function
);
3442 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3445 i
= backlist
->nargs
- 1;
3447 mark_object (backlist
->args
[i
]);
3454 DEFVAR_INT ("max-specpdl-size", max_specpdl_size
,
3455 doc
: /* *Limit on number of Lisp variable bindings and `unwind-protect's.
3456 If Lisp code tries to increase the total number past this amount,
3457 an error is signaled.
3458 You can safely use a value considerably larger than the default value,
3459 if that proves inconveniently small. However, if you increase it too far,
3460 Emacs could run out of memory trying to make the stack bigger. */);
3462 DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth
,
3463 doc
: /* *Limit on depth in `eval', `apply' and `funcall' before error.
3465 This limit serves to catch infinite recursions for you before they cause
3466 actual stack overflow in C, which would be fatal for Emacs.
3467 You can safely make it considerably larger than its default value,
3468 if that proves inconveniently small. However, if you increase it too far,
3469 Emacs could overflow the real C stack, and crash. */);
3471 DEFVAR_LISP ("quit-flag", Vquit_flag
,
3472 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3473 If the value is t, that means do an ordinary quit.
3474 If the value equals `throw-on-input', that means quit by throwing
3475 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3476 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3477 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3480 DEFVAR_LISP ("inhibit-quit", Vinhibit_quit
,
3481 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3482 Note that `quit-flag' will still be set by typing C-g,
3483 so a quit will be signaled as soon as `inhibit-quit' is nil.
3484 To prevent this happening, set `quit-flag' to nil
3485 before making `inhibit-quit' nil. */);
3486 Vinhibit_quit
= Qnil
;
3488 Qinhibit_quit
= intern_c_string ("inhibit-quit");
3489 staticpro (&Qinhibit_quit
);
3491 Qautoload
= intern_c_string ("autoload");
3492 staticpro (&Qautoload
);
3494 Qdebug_on_error
= intern_c_string ("debug-on-error");
3495 staticpro (&Qdebug_on_error
);
3497 Qmacro
= intern_c_string ("macro");
3498 staticpro (&Qmacro
);
3500 Qdeclare
= intern_c_string ("declare");
3501 staticpro (&Qdeclare
);
3503 /* Note that the process handling also uses Qexit, but we don't want
3504 to staticpro it twice, so we just do it here. */
3505 Qexit
= intern_c_string ("exit");
3508 Qinteractive
= intern_c_string ("interactive");
3509 staticpro (&Qinteractive
);
3511 Qcommandp
= intern_c_string ("commandp");
3512 staticpro (&Qcommandp
);
3514 Qdefun
= intern_c_string ("defun");
3515 staticpro (&Qdefun
);
3517 Qand_rest
= intern_c_string ("&rest");
3518 staticpro (&Qand_rest
);
3520 Qand_optional
= intern_c_string ("&optional");
3521 staticpro (&Qand_optional
);
3523 Qdebug
= intern_c_string ("debug");
3524 staticpro (&Qdebug
);
3526 DEFVAR_LISP ("stack-trace-on-error", Vstack_trace_on_error
,
3527 doc
: /* *Non-nil means errors display a backtrace buffer.
3528 More precisely, this happens for any error that is handled
3529 by the editor command loop.
3530 If the value is a list, an error only means to display a backtrace
3531 if one of its condition symbols appears in the list. */);
3532 Vstack_trace_on_error
= Qnil
;
3534 DEFVAR_LISP ("debug-on-error", Vdebug_on_error
,
3535 doc
: /* *Non-nil means enter debugger if an error is signaled.
3536 Does not apply to errors handled by `condition-case' or those
3537 matched by `debug-ignored-errors'.
3538 If the value is a list, an error only means to enter the debugger
3539 if one of its condition symbols appears in the list.
3540 When you evaluate an expression interactively, this variable
3541 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3542 The command `toggle-debug-on-error' toggles this.
3543 See also the variable `debug-on-quit'. */);
3544 Vdebug_on_error
= Qnil
;
3546 DEFVAR_LISP ("debug-ignored-errors", Vdebug_ignored_errors
,
3547 doc
: /* *List of errors for which the debugger should not be called.
3548 Each element may be a condition-name or a regexp that matches error messages.
3549 If any element applies to a given error, that error skips the debugger
3550 and just returns to top level.
3551 This overrides the variable `debug-on-error'.
3552 It does not apply to errors handled by `condition-case'. */);
3553 Vdebug_ignored_errors
= Qnil
;
3555 DEFVAR_BOOL ("debug-on-quit", debug_on_quit
,
3556 doc
: /* *Non-nil means enter debugger if quit is signaled (C-g, for example).
3557 Does not apply if quit is handled by a `condition-case'. */);
3560 DEFVAR_BOOL ("debug-on-next-call", debug_on_next_call
,
3561 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3563 DEFVAR_BOOL ("debugger-may-continue", debugger_may_continue
,
3564 doc
: /* Non-nil means debugger may continue execution.
3565 This is nil when the debugger is called under circumstances where it
3566 might not be safe to continue. */);
3567 debugger_may_continue
= 1;
3569 DEFVAR_LISP ("debugger", Vdebugger
,
3570 doc
: /* Function to call to invoke debugger.
3571 If due to frame exit, args are `exit' and the value being returned;
3572 this function's value will be returned instead of that.
3573 If due to error, args are `error' and a list of the args to `signal'.
3574 If due to `apply' or `funcall' entry, one arg, `lambda'.
3575 If due to `eval' entry, one arg, t. */);
3578 DEFVAR_LISP ("signal-hook-function", Vsignal_hook_function
,
3579 doc
: /* If non-nil, this is a function for `signal' to call.
3580 It receives the same arguments that `signal' was given.
3581 The Edebug package uses this to regain control. */);
3582 Vsignal_hook_function
= Qnil
;
3584 DEFVAR_LISP ("debug-on-signal", Vdebug_on_signal
,
3585 doc
: /* *Non-nil means call the debugger regardless of condition handlers.
3586 Note that `debug-on-error', `debug-on-quit' and friends
3587 still determine whether to handle the particular condition. */);
3588 Vdebug_on_signal
= Qnil
;
3590 DEFVAR_LISP ("macro-declaration-function", Vmacro_declaration_function
,
3591 doc
: /* Function to process declarations in a macro definition.
3592 The function will be called with two args MACRO and DECL.
3593 MACRO is the name of the macro being defined.
3594 DECL is a list `(declare ...)' containing the declarations.
3595 The value the function returns is not used. */);
3596 Vmacro_declaration_function
= Qnil
;
3598 Vrun_hooks
= intern_c_string ("run-hooks");
3599 staticpro (&Vrun_hooks
);
3601 staticpro (&Vautoload_queue
);
3602 Vautoload_queue
= Qnil
;
3603 staticpro (&Vsignaling_function
);
3604 Vsignaling_function
= Qnil
;
3615 defsubr (&Sfunction
);
3617 defsubr (&Sdefmacro
);
3619 defsubr (&Sdefvaralias
);
3620 defsubr (&Sdefconst
);
3621 defsubr (&Suser_variable_p
);
3625 defsubr (&Smacroexpand
);
3628 defsubr (&Sunwind_protect
);
3629 defsubr (&Scondition_case
);
3631 defsubr (&Sinteractive_p
);
3632 defsubr (&Scalled_interactively_p
);
3633 defsubr (&Scommandp
);
3634 defsubr (&Sautoload
);
3637 defsubr (&Sfuncall
);
3638 defsubr (&Srun_hooks
);
3639 defsubr (&Srun_hook_with_args
);
3640 defsubr (&Srun_hook_with_args_until_success
);
3641 defsubr (&Srun_hook_with_args_until_failure
);
3642 defsubr (&Sfetch_bytecode
);
3643 defsubr (&Sbacktrace_debug
);
3644 defsubr (&Sbacktrace
);
3645 defsubr (&Sbacktrace_frame
);