1 /* Evaluator for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1999, 2000, 2001,
3 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 2011 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
25 #include "blockinput.h"
28 #include "dispextern.h"
29 #include "frame.h" /* For XFRAME. */
35 /* This definition is duplicated in alloc.c and keyboard.c */
36 /* Putting it in lisp.h makes cc bomb out! */
40 struct backtrace
*next
;
41 Lisp_Object
*function
;
42 Lisp_Object
*args
; /* Points to vector of args. */
43 int nargs
; /* Length of vector.
44 If nargs is UNEVALLED, args points to slot holding
45 list of unevalled args */
47 /* Nonzero means call value of debugger when done with this operation. */
51 struct backtrace
*backtrace_list
;
53 struct catchtag
*catchlist
;
56 /* Count levels of GCPRO to detect failure to UNGCPRO. */
60 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
61 Lisp_Object Qinhibit_quit
;
62 Lisp_Object Qand_rest
, Qand_optional
;
63 Lisp_Object Qdebug_on_error
;
67 /* This holds either the symbol `run-hooks' or nil.
68 It is nil at an early stage of startup, and when Emacs
71 Lisp_Object Vrun_hooks
;
73 /* Non-nil means record all fset's and provide's, to be undone
74 if the file being autoloaded is not fully loaded.
75 They are recorded by being consed onto the front of Vautoload_queue:
76 (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide. */
78 Lisp_Object Vautoload_queue
;
80 /* Current number of specbindings allocated in specpdl. */
82 EMACS_INT specpdl_size
;
84 /* Pointer to beginning of specpdl. */
86 struct specbinding
*specpdl
;
88 /* Pointer to first unused element in specpdl. */
90 struct specbinding
*specpdl_ptr
;
92 /* Depth in Lisp evaluations and function calls. */
94 EMACS_INT lisp_eval_depth
;
96 /* The value of num_nonmacro_input_events as of the last time we
97 started to enter the debugger. If we decide to enter the debugger
98 again when this is still equal to num_nonmacro_input_events, then we
99 know that the debugger itself has an error, and we should just
100 signal the error instead of entering an infinite loop of debugger
103 int when_entered_debugger
;
105 /* The function from which the last `signal' was called. Set in
108 Lisp_Object Vsignaling_function
;
110 /* Set to non-zero while processing X events. Checked in Feval to
111 make sure the Lisp interpreter isn't called from a signal handler,
112 which is unsafe because the interpreter isn't reentrant. */
116 static Lisp_Object
funcall_lambda (Lisp_Object
, int, Lisp_Object
*);
117 static void unwind_to_catch (struct catchtag
*, Lisp_Object
) NO_RETURN
;
118 static int interactive_p (int);
119 static Lisp_Object
apply_lambda (Lisp_Object
, Lisp_Object
, int);
122 init_eval_once (void)
125 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
126 specpdl_ptr
= specpdl
;
127 /* Don't forget to update docs (lispref node "Local Variables"). */
128 max_specpdl_size
= 1000;
129 max_lisp_eval_depth
= 600;
137 specpdl_ptr
= specpdl
;
142 debug_on_next_call
= 0;
147 /* This is less than the initial value of num_nonmacro_input_events. */
148 when_entered_debugger
= -1;
151 /* unwind-protect function used by call_debugger. */
154 restore_stack_limits (Lisp_Object data
)
156 max_specpdl_size
= XINT (XCAR (data
));
157 max_lisp_eval_depth
= XINT (XCDR (data
));
161 /* Call the Lisp debugger, giving it argument ARG. */
164 call_debugger (Lisp_Object arg
)
166 int debug_while_redisplaying
;
167 int count
= SPECPDL_INDEX ();
169 EMACS_INT old_max
= max_specpdl_size
;
171 /* Temporarily bump up the stack limits,
172 so the debugger won't run out of stack. */
174 max_specpdl_size
+= 1;
175 record_unwind_protect (restore_stack_limits
,
176 Fcons (make_number (old_max
),
177 make_number (max_lisp_eval_depth
)));
178 max_specpdl_size
= old_max
;
180 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
181 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
183 if (SPECPDL_INDEX () + 100 > max_specpdl_size
)
184 max_specpdl_size
= SPECPDL_INDEX () + 100;
186 #ifdef HAVE_WINDOW_SYSTEM
187 if (display_hourglass_p
)
191 debug_on_next_call
= 0;
192 when_entered_debugger
= num_nonmacro_input_events
;
194 /* Resetting redisplaying_p to 0 makes sure that debug output is
195 displayed if the debugger is invoked during redisplay. */
196 debug_while_redisplaying
= redisplaying_p
;
198 specbind (intern ("debugger-may-continue"),
199 debug_while_redisplaying
? Qnil
: Qt
);
200 specbind (Qinhibit_redisplay
, Qnil
);
201 specbind (Qdebug_on_error
, Qnil
);
203 #if 0 /* Binding this prevents execution of Lisp code during
204 redisplay, which necessarily leads to display problems. */
205 specbind (Qinhibit_eval_during_redisplay
, Qt
);
208 val
= apply1 (Vdebugger
, arg
);
210 /* Interrupting redisplay and resuming it later is not safe under
211 all circumstances. So, when the debugger returns, abort the
212 interrupted redisplay by going back to the top-level. */
213 if (debug_while_redisplaying
)
216 return unbind_to (count
, val
);
220 do_debug_on_call (Lisp_Object code
)
222 debug_on_next_call
= 0;
223 backtrace_list
->debug_on_exit
= 1;
224 call_debugger (Fcons (code
, Qnil
));
227 /* NOTE!!! Every function that can call EVAL must protect its args
228 and temporaries from garbage collection while it needs them.
229 The definition of `For' shows what you have to do. */
231 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
232 doc
: /* Eval args until one of them yields non-nil, then return that value.
233 The remaining args are not evalled at all.
234 If all args return nil, return nil.
235 usage: (or CONDITIONS...) */)
238 register Lisp_Object val
= Qnil
;
245 val
= Feval (XCAR (args
));
255 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
256 doc
: /* Eval args until one of them yields nil, then return nil.
257 The remaining args are not evalled at all.
258 If no arg yields nil, return the last arg's value.
259 usage: (and CONDITIONS...) */)
262 register Lisp_Object val
= Qt
;
269 val
= Feval (XCAR (args
));
279 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
280 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
281 Returns the value of THEN or the value of the last of the ELSE's.
282 THEN must be one expression, but ELSE... can be zero or more expressions.
283 If COND yields nil, and there are no ELSE's, the value is nil.
284 usage: (if COND THEN ELSE...) */)
287 register Lisp_Object cond
;
291 cond
= Feval (Fcar (args
));
295 return Feval (Fcar (Fcdr (args
)));
296 return Fprogn (Fcdr (Fcdr (args
)));
299 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
300 doc
: /* Try each clause until one succeeds.
301 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
302 and, if the value is non-nil, this clause succeeds:
303 then the expressions in BODY are evaluated and the last one's
304 value is the value of the cond-form.
305 If no clause succeeds, cond returns nil.
306 If a clause has one element, as in (CONDITION),
307 CONDITION's value if non-nil is returned from the cond-form.
308 usage: (cond CLAUSES...) */)
311 register Lisp_Object clause
, val
;
318 clause
= Fcar (args
);
319 val
= Feval (Fcar (clause
));
322 if (!EQ (XCDR (clause
), Qnil
))
323 val
= Fprogn (XCDR (clause
));
333 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
334 doc
: /* Eval BODY forms sequentially and return value of last one.
335 usage: (progn BODY...) */)
338 register Lisp_Object val
= Qnil
;
345 val
= Feval (XCAR (args
));
353 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
354 doc
: /* Eval FIRST and BODY sequentially; return value from FIRST.
355 The value of FIRST is saved during the evaluation of the remaining args,
356 whose values are discarded.
357 usage: (prog1 FIRST BODY...) */)
361 register Lisp_Object args_left
;
362 struct gcpro gcpro1
, gcpro2
;
363 register int argnum
= 0;
375 val
= Feval (Fcar (args_left
));
377 Feval (Fcar (args_left
));
378 args_left
= Fcdr (args_left
);
380 while (!NILP(args_left
));
386 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
387 doc
: /* Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
388 The value of FORM2 is saved during the evaluation of the
389 remaining args, whose values are discarded.
390 usage: (prog2 FORM1 FORM2 BODY...) */)
394 register Lisp_Object args_left
;
395 struct gcpro gcpro1
, gcpro2
;
396 register int argnum
= -1;
410 val
= Feval (Fcar (args_left
));
412 Feval (Fcar (args_left
));
413 args_left
= Fcdr (args_left
);
415 while (!NILP (args_left
));
421 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
422 doc
: /* Set each SYM to the value of its VAL.
423 The symbols SYM are variables; they are literal (not evaluated).
424 The values VAL are expressions; they are evaluated.
425 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
426 The second VAL is not computed until after the first SYM is set, and so on;
427 each VAL can use the new value of variables set earlier in the `setq'.
428 The return value of the `setq' form is the value of the last VAL.
429 usage: (setq [SYM VAL]...) */)
432 register Lisp_Object args_left
;
433 register Lisp_Object val
, sym
;
444 val
= Feval (Fcar (Fcdr (args_left
)));
445 sym
= Fcar (args_left
);
447 args_left
= Fcdr (Fcdr (args_left
));
449 while (!NILP(args_left
));
455 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
456 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
457 usage: (quote ARG) */)
460 if (!NILP (Fcdr (args
)))
461 xsignal2 (Qwrong_number_of_arguments
, Qquote
, Flength (args
));
465 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
466 doc
: /* Like `quote', but preferred for objects which are functions.
467 In byte compilation, `function' causes its argument to be compiled.
468 `quote' cannot do that.
469 usage: (function ARG) */)
472 if (!NILP (Fcdr (args
)))
473 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
478 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
479 doc
: /* Return t if the containing function was run directly by user input.
480 This means that the function was called with `call-interactively'
481 \(which includes being called as the binding of a key)
482 and input is currently coming from the keyboard (not a keyboard macro),
483 and Emacs is not running in batch mode (`noninteractive' is nil).
485 The only known proper use of `interactive-p' is in deciding whether to
486 display a helpful message, or how to display it. If you're thinking
487 of using it for any other purpose, it is quite likely that you're
488 making a mistake. Think: what do you want to do when the command is
489 called from a keyboard macro?
491 To test whether your function was called with `call-interactively',
492 either (i) add an extra optional argument and give it an `interactive'
493 spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
494 use `called-interactively-p'. */)
497 return (INTERACTIVE
&& interactive_p (1)) ? Qt
: Qnil
;
501 DEFUN ("called-interactively-p", Fcalled_interactively_p
, Scalled_interactively_p
, 0, 1, 0,
502 doc
: /* Return t if the containing function was called by `call-interactively'.
503 If KIND is `interactive', then only return t if the call was made
504 interactively by the user, i.e. not in `noninteractive' mode nor
505 when `executing-kbd-macro'.
506 If KIND is `any', on the other hand, it will return t for any kind of
507 interactive call, including being called as the binding of a key, or
508 from a keyboard macro, or in `noninteractive' mode.
510 The only known proper use of `interactive' for KIND is in deciding
511 whether to display a helpful message, or how to display it. If you're
512 thinking of using it for any other purpose, it is quite likely that
513 you're making a mistake. Think: what do you want to do when the
514 command is called from a keyboard macro?
516 This function is meant for implementing advice and other
517 function-modifying features. Instead of using this, it is sometimes
518 cleaner to give your function an extra optional argument whose
519 `interactive' spec specifies non-nil unconditionally (\"p\" is a good
520 way to do this), or via (not (or executing-kbd-macro noninteractive)). */)
523 return ((INTERACTIVE
|| !EQ (kind
, intern ("interactive")))
524 && interactive_p (1)) ? Qt
: Qnil
;
528 /* Return 1 if function in which this appears was called using
531 EXCLUDE_SUBRS_P non-zero means always return 0 if the function
532 called is a built-in. */
535 interactive_p (int exclude_subrs_p
)
537 struct backtrace
*btp
;
540 btp
= backtrace_list
;
542 /* If this isn't a byte-compiled function, there may be a frame at
543 the top for Finteractive_p. If so, skip it. */
544 fun
= Findirect_function (*btp
->function
, Qnil
);
545 if (SUBRP (fun
) && (XSUBR (fun
) == &Sinteractive_p
546 || XSUBR (fun
) == &Scalled_interactively_p
))
549 /* If we're running an Emacs 18-style byte-compiled function, there
550 may be a frame for Fbytecode at the top level. In any version of
551 Emacs there can be Fbytecode frames for subexpressions evaluated
552 inside catch and condition-case. Skip past them.
554 If this isn't a byte-compiled function, then we may now be
555 looking at several frames for special forms. Skip past them. */
557 && (EQ (*btp
->function
, Qbytecode
)
558 || btp
->nargs
== UNEVALLED
))
561 /* btp now points at the frame of the innermost function that isn't
562 a special form, ignoring frames for Finteractive_p and/or
563 Fbytecode at the top. If this frame is for a built-in function
564 (such as load or eval-region) return nil. */
565 fun
= Findirect_function (*btp
->function
, Qnil
);
566 if (exclude_subrs_p
&& SUBRP (fun
))
569 /* btp points to the frame of a Lisp function that called interactive-p.
570 Return t if that function was called interactively. */
571 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
577 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
578 doc
: /* Define NAME as a function.
579 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
580 See also the function `interactive'.
581 usage: (defun NAME ARGLIST [DOCSTRING] BODY...) */)
584 register Lisp_Object fn_name
;
585 register Lisp_Object defn
;
587 fn_name
= Fcar (args
);
588 CHECK_SYMBOL (fn_name
);
589 defn
= Fcons (Qlambda
, Fcdr (args
));
590 if (!NILP (Vpurify_flag
))
591 defn
= Fpurecopy (defn
);
592 if (CONSP (XSYMBOL (fn_name
)->function
)
593 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
594 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
595 Ffset (fn_name
, defn
);
596 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
600 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
601 doc
: /* Define NAME as a macro.
602 The actual definition looks like
603 (macro lambda ARGLIST [DOCSTRING] [DECL] BODY...).
604 When the macro is called, as in (NAME ARGS...),
605 the function (lambda ARGLIST BODY...) is applied to
606 the list ARGS... as it appears in the expression,
607 and the result should be a form to be evaluated instead of the original.
609 DECL is a declaration, optional, which can specify how to indent
610 calls to this macro, how Edebug should handle it, and which argument
611 should be treated as documentation. It looks like this:
613 The elements can look like this:
615 Set NAME's `lisp-indent-function' property to INDENT.
618 Set NAME's `edebug-form-spec' property to DEBUG. (This is
619 equivalent to writing a `def-edebug-spec' for the macro.)
622 Set NAME's `doc-string-elt' property to ELT.
624 usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */)
627 register Lisp_Object fn_name
;
628 register Lisp_Object defn
;
629 Lisp_Object lambda_list
, doc
, tail
;
631 fn_name
= Fcar (args
);
632 CHECK_SYMBOL (fn_name
);
633 lambda_list
= Fcar (Fcdr (args
));
634 tail
= Fcdr (Fcdr (args
));
637 if (STRINGP (Fcar (tail
)))
643 if (CONSP (Fcar (tail
))
644 && EQ (Fcar (Fcar (tail
)), Qdeclare
))
646 if (!NILP (Vmacro_declaration_function
))
650 call2 (Vmacro_declaration_function
, fn_name
, Fcar (tail
));
658 tail
= Fcons (lambda_list
, tail
);
660 tail
= Fcons (lambda_list
, Fcons (doc
, tail
));
661 defn
= Fcons (Qmacro
, Fcons (Qlambda
, tail
));
663 if (!NILP (Vpurify_flag
))
664 defn
= Fpurecopy (defn
);
665 if (CONSP (XSYMBOL (fn_name
)->function
)
666 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
667 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
668 Ffset (fn_name
, defn
);
669 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
674 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
675 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
676 Aliased variables always have the same value; setting one sets the other.
677 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
678 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
679 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
680 itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
681 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
682 The return value is BASE-VARIABLE. */)
683 (Lisp_Object new_alias
, Lisp_Object base_variable
, Lisp_Object docstring
)
685 struct Lisp_Symbol
*sym
;
687 CHECK_SYMBOL (new_alias
);
688 CHECK_SYMBOL (base_variable
);
690 sym
= XSYMBOL (new_alias
);
693 /* Not sure why, but why not? */
694 error ("Cannot make a constant an alias");
696 switch (sym
->redirect
)
698 case SYMBOL_FORWARDED
:
699 error ("Cannot make an internal variable an alias");
700 case SYMBOL_LOCALIZED
:
701 error ("Don't know how to make a localized variable an alias");
704 /* http://lists.gnu.org/archive/html/emacs-devel/2008-04/msg00834.html
705 If n_a is bound, but b_v is not, set the value of b_v to n_a,
706 so that old-code that affects n_a before the aliasing is setup
708 if (NILP (Fboundp (base_variable
)))
709 set_internal (base_variable
, find_symbol_value (new_alias
), Qnil
, 1);
712 struct specbinding
*p
;
714 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
717 CONSP (p
->symbol
) ? XCAR (p
->symbol
) : p
->symbol
)))
718 error ("Don't know how to make a let-bound variable an alias");
721 sym
->redirect
= SYMBOL_VARALIAS
;
722 SET_SYMBOL_ALIAS (sym
, XSYMBOL (base_variable
));
723 sym
->constant
= SYMBOL_CONSTANT_P (base_variable
);
724 LOADHIST_ATTACH (new_alias
);
725 /* Even if docstring is nil: remove old docstring. */
726 Fput (new_alias
, Qvariable_documentation
, docstring
);
728 return base_variable
;
732 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
733 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
734 You are not required to define a variable in order to use it,
735 but the definition can supply documentation and an initial value
736 in a way that tags can recognize.
738 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.
739 If SYMBOL is buffer-local, its default value is what is set;
740 buffer-local values are not affected.
741 INITVALUE and DOCSTRING are optional.
742 If DOCSTRING starts with *, this variable is identified as a user option.
743 This means that M-x set-variable recognizes it.
744 See also `user-variable-p'.
745 If INITVALUE is missing, SYMBOL's value is not set.
747 If SYMBOL has a local binding, then this form affects the local
748 binding. This is usually not what you want. Thus, if you need to
749 load a file defining variables, with this form or with `defconst' or
750 `defcustom', you should always load that file _outside_ any bindings
751 for these variables. \(`defconst' and `defcustom' behave similarly in
753 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
756 register Lisp_Object sym
, tem
, tail
;
760 if (!NILP (Fcdr (Fcdr (tail
))))
761 error ("Too many arguments");
763 tem
= Fdefault_boundp (sym
);
766 if (SYMBOL_CONSTANT_P (sym
))
768 /* For upward compatibility, allow (defvar :foo (quote :foo)). */
769 Lisp_Object tem
= Fcar (tail
);
771 && EQ (XCAR (tem
), Qquote
)
772 && CONSP (XCDR (tem
))
773 && EQ (XCAR (XCDR (tem
)), sym
)))
774 error ("Constant symbol `%s' specified in defvar",
775 SDATA (SYMBOL_NAME (sym
)));
779 Fset_default (sym
, Feval (Fcar (tail
)));
781 { /* Check if there is really a global binding rather than just a let
782 binding that shadows the global unboundness of the var. */
783 volatile struct specbinding
*pdl
= specpdl_ptr
;
784 while (--pdl
>= specpdl
)
786 if (EQ (pdl
->symbol
, sym
) && !pdl
->func
787 && EQ (pdl
->old_value
, Qunbound
))
789 message_with_string ("Warning: defvar ignored because %s is let-bound",
790 SYMBOL_NAME (sym
), 1);
799 if (!NILP (Vpurify_flag
))
800 tem
= Fpurecopy (tem
);
801 Fput (sym
, Qvariable_documentation
, tem
);
803 LOADHIST_ATTACH (sym
);
806 /* Simple (defvar <var>) should not count as a definition at all.
807 It could get in the way of other definitions, and unloading this
808 package could try to make the variable unbound. */
814 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
815 doc
: /* Define SYMBOL as a constant variable.
816 The intent is that neither programs nor users should ever change this value.
817 Always sets the value of SYMBOL to the result of evalling INITVALUE.
818 If SYMBOL is buffer-local, its default value is what is set;
819 buffer-local values are not affected.
820 DOCSTRING is optional.
822 If SYMBOL has a local binding, then this form sets the local binding's
823 value. However, you should normally not make local bindings for
824 variables defined with this form.
825 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
828 register Lisp_Object sym
, tem
;
831 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
832 error ("Too many arguments");
834 tem
= Feval (Fcar (Fcdr (args
)));
835 if (!NILP (Vpurify_flag
))
836 tem
= Fpurecopy (tem
);
837 Fset_default (sym
, tem
);
838 tem
= Fcar (Fcdr (Fcdr (args
)));
841 if (!NILP (Vpurify_flag
))
842 tem
= Fpurecopy (tem
);
843 Fput (sym
, Qvariable_documentation
, tem
);
845 Fput (sym
, Qrisky_local_variable
, Qt
);
846 LOADHIST_ATTACH (sym
);
850 /* Error handler used in Fuser_variable_p. */
852 user_variable_p_eh (Lisp_Object ignore
)
858 lisp_indirect_variable (Lisp_Object sym
)
860 XSETSYMBOL (sym
, indirect_variable (XSYMBOL (sym
)));
864 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
865 doc
: /* Return t if VARIABLE is intended to be set and modified by users.
866 \(The alternative is a variable used internally in a Lisp program.)
867 A variable is a user variable if
868 \(1) the first character of its documentation is `*', or
869 \(2) it is customizable (its property list contains a non-nil value
870 of `standard-value' or `custom-autoload'), or
871 \(3) it is an alias for another user variable.
872 Return nil if VARIABLE is an alias and there is a loop in the
873 chain of symbols. */)
874 (Lisp_Object variable
)
876 Lisp_Object documentation
;
878 if (!SYMBOLP (variable
))
881 /* If indirect and there's an alias loop, don't check anything else. */
882 if (XSYMBOL (variable
)->redirect
== SYMBOL_VARALIAS
883 && NILP (internal_condition_case_1 (lisp_indirect_variable
, variable
,
884 Qt
, user_variable_p_eh
)))
889 documentation
= Fget (variable
, Qvariable_documentation
);
890 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
892 if (STRINGP (documentation
)
893 && ((unsigned char) SREF (documentation
, 0) == '*'))
895 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
896 if (CONSP (documentation
)
897 && STRINGP (XCAR (documentation
))
898 && INTEGERP (XCDR (documentation
))
899 && XINT (XCDR (documentation
)) < 0)
901 /* Customizable? See `custom-variable-p'. */
902 if ((!NILP (Fget (variable
, intern ("standard-value"))))
903 || (!NILP (Fget (variable
, intern ("custom-autoload")))))
906 if (!(XSYMBOL (variable
)->redirect
== SYMBOL_VARALIAS
))
909 /* An indirect variable? Let's follow the chain. */
910 XSETSYMBOL (variable
, SYMBOL_ALIAS (XSYMBOL (variable
)));
914 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
915 doc
: /* Bind variables according to VARLIST then eval BODY.
916 The value of the last form in BODY is returned.
917 Each element of VARLIST is a symbol (which is bound to nil)
918 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
919 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
920 usage: (let* VARLIST BODY...) */)
923 Lisp_Object varlist
, val
, elt
;
924 int count
= SPECPDL_INDEX ();
925 struct gcpro gcpro1
, gcpro2
, gcpro3
;
927 GCPRO3 (args
, elt
, varlist
);
929 varlist
= Fcar (args
);
930 while (!NILP (varlist
))
933 elt
= Fcar (varlist
);
935 specbind (elt
, Qnil
);
936 else if (! NILP (Fcdr (Fcdr (elt
))))
937 signal_error ("`let' bindings can have only one value-form", elt
);
940 val
= Feval (Fcar (Fcdr (elt
)));
941 specbind (Fcar (elt
), val
);
943 varlist
= Fcdr (varlist
);
946 val
= Fprogn (Fcdr (args
));
947 return unbind_to (count
, val
);
950 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
951 doc
: /* Bind variables according to VARLIST then eval BODY.
952 The value of the last form in BODY is returned.
953 Each element of VARLIST is a symbol (which is bound to nil)
954 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
955 All the VALUEFORMs are evalled before any symbols are bound.
956 usage: (let VARLIST BODY...) */)
959 Lisp_Object
*temps
, tem
;
960 register Lisp_Object elt
, varlist
;
961 int count
= SPECPDL_INDEX ();
963 struct gcpro gcpro1
, gcpro2
;
966 varlist
= Fcar (args
);
968 /* Make space to hold the values to give the bound variables */
969 elt
= Flength (varlist
);
970 SAFE_ALLOCA_LISP (temps
, XFASTINT (elt
));
972 /* Compute the values and store them in `temps' */
974 GCPRO2 (args
, *temps
);
977 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
980 elt
= XCAR (varlist
);
982 temps
[argnum
++] = Qnil
;
983 else if (! NILP (Fcdr (Fcdr (elt
))))
984 signal_error ("`let' bindings can have only one value-form", elt
);
986 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
987 gcpro2
.nvars
= argnum
;
991 varlist
= Fcar (args
);
992 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
994 elt
= XCAR (varlist
);
995 tem
= temps
[argnum
++];
999 specbind (Fcar (elt
), tem
);
1002 elt
= Fprogn (Fcdr (args
));
1004 return unbind_to (count
, elt
);
1007 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
1008 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
1009 The order of execution is thus TEST, BODY, TEST, BODY and so on
1010 until TEST returns nil.
1011 usage: (while TEST BODY...) */)
1014 Lisp_Object test
, body
;
1015 struct gcpro gcpro1
, gcpro2
;
1017 GCPRO2 (test
, body
);
1021 while (!NILP (Feval (test
)))
1031 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
1032 doc
: /* Return result of expanding macros at top level of FORM.
1033 If FORM is not a macro call, it is returned unchanged.
1034 Otherwise, the macro is expanded and the expansion is considered
1035 in place of FORM. When a non-macro-call results, it is returned.
1037 The second optional arg ENVIRONMENT specifies an environment of macro
1038 definitions to shadow the loaded ones for use in file byte-compilation. */)
1039 (Lisp_Object form
, Lisp_Object environment
)
1041 /* With cleanups from Hallvard Furuseth. */
1042 register Lisp_Object expander
, sym
, def
, tem
;
1046 /* Come back here each time we expand a macro call,
1047 in case it expands into another macro call. */
1050 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1051 def
= sym
= XCAR (form
);
1053 /* Trace symbols aliases to other symbols
1054 until we get a symbol that is not an alias. */
1055 while (SYMBOLP (def
))
1059 tem
= Fassq (sym
, environment
);
1062 def
= XSYMBOL (sym
)->function
;
1063 if (!EQ (def
, Qunbound
))
1068 /* Right now TEM is the result from SYM in ENVIRONMENT,
1069 and if TEM is nil then DEF is SYM's function definition. */
1072 /* SYM is not mentioned in ENVIRONMENT.
1073 Look at its function definition. */
1074 if (EQ (def
, Qunbound
) || !CONSP (def
))
1075 /* Not defined or definition not suitable */
1077 if (EQ (XCAR (def
), Qautoload
))
1079 /* Autoloading function: will it be a macro when loaded? */
1080 tem
= Fnth (make_number (4), def
);
1081 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
1082 /* Yes, load it and try again. */
1084 struct gcpro gcpro1
;
1086 do_autoload (def
, sym
);
1093 else if (!EQ (XCAR (def
), Qmacro
))
1095 else expander
= XCDR (def
);
1099 expander
= XCDR (tem
);
1100 if (NILP (expander
))
1103 form
= apply1 (expander
, XCDR (form
));
1108 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1109 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1110 TAG is evalled to get the tag to use; it must not be nil.
1112 Then the BODY is executed.
1113 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
1114 If no throw happens, `catch' returns the value of the last BODY form.
1115 If a throw happens, it specifies the value to return from `catch'.
1116 usage: (catch TAG BODY...) */)
1119 register Lisp_Object tag
;
1120 struct gcpro gcpro1
;
1123 tag
= Feval (Fcar (args
));
1125 return internal_catch (tag
, Fprogn
, Fcdr (args
));
1128 /* Set up a catch, then call C function FUNC on argument ARG.
1129 FUNC should return a Lisp_Object.
1130 This is how catches are done from within C code. */
1133 internal_catch (Lisp_Object tag
, Lisp_Object (*func
) (Lisp_Object
), Lisp_Object arg
)
1135 /* This structure is made part of the chain `catchlist'. */
1138 /* Fill in the components of c, and put it on the list. */
1142 c
.backlist
= backtrace_list
;
1143 c
.handlerlist
= handlerlist
;
1144 c
.lisp_eval_depth
= lisp_eval_depth
;
1145 c
.pdlcount
= SPECPDL_INDEX ();
1146 c
.poll_suppress_count
= poll_suppress_count
;
1147 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1148 c
.gcpro
= gcprolist
;
1149 c
.byte_stack
= byte_stack_list
;
1153 if (! _setjmp (c
.jmp
))
1154 c
.val
= (*func
) (arg
);
1156 /* Throw works by a longjmp that comes right here. */
1161 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1162 jump to that CATCH, returning VALUE as the value of that catch.
1164 This is the guts Fthrow and Fsignal; they differ only in the way
1165 they choose the catch tag to throw to. A catch tag for a
1166 condition-case form has a TAG of Qnil.
1168 Before each catch is discarded, unbind all special bindings and
1169 execute all unwind-protect clauses made above that catch. Unwind
1170 the handler stack as we go, so that the proper handlers are in
1171 effect for each unwind-protect clause we run. At the end, restore
1172 some static info saved in CATCH, and longjmp to the location
1175 This is used for correct unwinding in Fthrow and Fsignal. */
1178 unwind_to_catch (struct catchtag
*catch, Lisp_Object value
)
1180 register int last_time
;
1182 /* Save the value in the tag. */
1185 /* Restore certain special C variables. */
1186 set_poll_suppress_count (catch->poll_suppress_count
);
1187 UNBLOCK_INPUT_TO (catch->interrupt_input_blocked
);
1188 handling_signal
= 0;
1193 last_time
= catchlist
== catch;
1195 /* Unwind the specpdl stack, and then restore the proper set of
1197 unbind_to (catchlist
->pdlcount
, Qnil
);
1198 handlerlist
= catchlist
->handlerlist
;
1199 catchlist
= catchlist
->next
;
1201 while (! last_time
);
1204 /* If x_catch_errors was done, turn it off now.
1205 (First we give unbind_to a chance to do that.) */
1206 #if 0 /* This would disable x_catch_errors after x_connection_closed.
1207 The catch must remain in effect during that delicate
1208 state. --lorentey */
1209 x_fully_uncatch_errors ();
1213 byte_stack_list
= catch->byte_stack
;
1214 gcprolist
= catch->gcpro
;
1217 gcpro_level
= gcprolist
->level
+ 1;
1221 backtrace_list
= catch->backlist
;
1222 lisp_eval_depth
= catch->lisp_eval_depth
;
1224 _longjmp (catch->jmp
, 1);
1227 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1228 doc
: /* Throw to the catch for TAG and return VALUE from it.
1229 Both TAG and VALUE are evalled. */)
1230 (register Lisp_Object tag
, Lisp_Object value
)
1232 register struct catchtag
*c
;
1235 for (c
= catchlist
; c
; c
= c
->next
)
1237 if (EQ (c
->tag
, tag
))
1238 unwind_to_catch (c
, value
);
1240 xsignal2 (Qno_catch
, tag
, value
);
1244 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1245 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1246 If BODYFORM completes normally, its value is returned
1247 after executing the UNWINDFORMS.
1248 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1249 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1253 int count
= SPECPDL_INDEX ();
1255 record_unwind_protect (Fprogn
, Fcdr (args
));
1256 val
= Feval (Fcar (args
));
1257 return unbind_to (count
, val
);
1260 /* Chain of condition handlers currently in effect.
1261 The elements of this chain are contained in the stack frames
1262 of Fcondition_case and internal_condition_case.
1263 When an error is signaled (by calling Fsignal, below),
1264 this chain is searched for an element that applies. */
1266 struct handler
*handlerlist
;
1268 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1269 doc
: /* Regain control when an error is signaled.
1270 Executes BODYFORM and returns its value if no error happens.
1271 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1272 where the BODY is made of Lisp expressions.
1274 A handler is applicable to an error
1275 if CONDITION-NAME is one of the error's condition names.
1276 If an error happens, the first applicable handler is run.
1278 The car of a handler may be a list of condition names
1279 instead of a single condition name. Then it handles all of them.
1281 When a handler handles an error, control returns to the `condition-case'
1282 and it executes the handler's BODY...
1283 with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
1284 \(If VAR is nil, the handler can't access that information.)
1285 Then the value of the last BODY form is returned from the `condition-case'
1288 See also the function `signal' for more info.
1289 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1292 register Lisp_Object bodyform
, handlers
;
1293 volatile Lisp_Object var
;
1296 bodyform
= Fcar (Fcdr (args
));
1297 handlers
= Fcdr (Fcdr (args
));
1299 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1302 /* Like Fcondition_case, but the args are separate
1303 rather than passed in a list. Used by Fbyte_code. */
1306 internal_lisp_condition_case (volatile Lisp_Object var
, Lisp_Object bodyform
,
1307 Lisp_Object handlers
)
1315 for (val
= handlers
; CONSP (val
); val
= XCDR (val
))
1321 && (SYMBOLP (XCAR (tem
))
1322 || CONSP (XCAR (tem
))))))
1323 error ("Invalid condition handler", tem
);
1328 c
.backlist
= backtrace_list
;
1329 c
.handlerlist
= handlerlist
;
1330 c
.lisp_eval_depth
= lisp_eval_depth
;
1331 c
.pdlcount
= SPECPDL_INDEX ();
1332 c
.poll_suppress_count
= poll_suppress_count
;
1333 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1334 c
.gcpro
= gcprolist
;
1335 c
.byte_stack
= byte_stack_list
;
1336 if (_setjmp (c
.jmp
))
1339 specbind (h
.var
, c
.val
);
1340 val
= Fprogn (Fcdr (h
.chosen_clause
));
1342 /* Note that this just undoes the binding of h.var; whoever
1343 longjumped to us unwound the stack to c.pdlcount before
1345 unbind_to (c
.pdlcount
, Qnil
);
1352 h
.handler
= handlers
;
1353 h
.next
= handlerlist
;
1357 val
= Feval (bodyform
);
1359 handlerlist
= h
.next
;
1363 /* Call the function BFUN with no arguments, catching errors within it
1364 according to HANDLERS. If there is an error, call HFUN with
1365 one argument which is the data that describes the error:
1368 HANDLERS can be a list of conditions to catch.
1369 If HANDLERS is Qt, catch all errors.
1370 If HANDLERS is Qerror, catch all errors
1371 but allow the debugger to run if that is enabled. */
1374 internal_condition_case (Lisp_Object (*bfun
) (void), Lisp_Object handlers
,
1375 Lisp_Object (*hfun
) (Lisp_Object
))
1381 /* Since Fsignal will close off all calls to x_catch_errors,
1382 we will get the wrong results if some are not closed now. */
1384 if (x_catching_errors ())
1390 c
.backlist
= backtrace_list
;
1391 c
.handlerlist
= handlerlist
;
1392 c
.lisp_eval_depth
= lisp_eval_depth
;
1393 c
.pdlcount
= SPECPDL_INDEX ();
1394 c
.poll_suppress_count
= poll_suppress_count
;
1395 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1396 c
.gcpro
= gcprolist
;
1397 c
.byte_stack
= byte_stack_list
;
1398 if (_setjmp (c
.jmp
))
1400 return (*hfun
) (c
.val
);
1404 h
.handler
= handlers
;
1406 h
.next
= handlerlist
;
1412 handlerlist
= h
.next
;
1416 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1419 internal_condition_case_1 (Lisp_Object (*bfun
) (Lisp_Object
), Lisp_Object arg
,
1420 Lisp_Object handlers
, Lisp_Object (*hfun
) (Lisp_Object
))
1426 /* Since Fsignal will close off all calls to x_catch_errors,
1427 we will get the wrong results if some are not closed now. */
1429 if (x_catching_errors ())
1435 c
.backlist
= backtrace_list
;
1436 c
.handlerlist
= handlerlist
;
1437 c
.lisp_eval_depth
= lisp_eval_depth
;
1438 c
.pdlcount
= SPECPDL_INDEX ();
1439 c
.poll_suppress_count
= poll_suppress_count
;
1440 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1441 c
.gcpro
= gcprolist
;
1442 c
.byte_stack
= byte_stack_list
;
1443 if (_setjmp (c
.jmp
))
1445 return (*hfun
) (c
.val
);
1449 h
.handler
= handlers
;
1451 h
.next
= handlerlist
;
1455 val
= (*bfun
) (arg
);
1457 handlerlist
= h
.next
;
1461 /* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as
1465 internal_condition_case_2 (Lisp_Object (*bfun
) (Lisp_Object
, Lisp_Object
),
1468 Lisp_Object handlers
,
1469 Lisp_Object (*hfun
) (Lisp_Object
))
1475 /* Since Fsignal will close off all calls to x_catch_errors,
1476 we will get the wrong results if some are not closed now. */
1478 if (x_catching_errors ())
1484 c
.backlist
= backtrace_list
;
1485 c
.handlerlist
= handlerlist
;
1486 c
.lisp_eval_depth
= lisp_eval_depth
;
1487 c
.pdlcount
= SPECPDL_INDEX ();
1488 c
.poll_suppress_count
= poll_suppress_count
;
1489 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1490 c
.gcpro
= gcprolist
;
1491 c
.byte_stack
= byte_stack_list
;
1492 if (_setjmp (c
.jmp
))
1494 return (*hfun
) (c
.val
);
1498 h
.handler
= handlers
;
1500 h
.next
= handlerlist
;
1504 val
= (*bfun
) (arg1
, arg2
);
1506 handlerlist
= h
.next
;
1510 /* Like internal_condition_case but call BFUN with NARGS as first,
1511 and ARGS as second argument. */
1514 internal_condition_case_n (Lisp_Object (*bfun
) (int, Lisp_Object
*),
1517 Lisp_Object handlers
,
1518 Lisp_Object (*hfun
) (Lisp_Object
))
1524 /* Since Fsignal will close off all calls to x_catch_errors,
1525 we will get the wrong results if some are not closed now. */
1527 if (x_catching_errors ())
1533 c
.backlist
= backtrace_list
;
1534 c
.handlerlist
= handlerlist
;
1535 c
.lisp_eval_depth
= lisp_eval_depth
;
1536 c
.pdlcount
= SPECPDL_INDEX ();
1537 c
.poll_suppress_count
= poll_suppress_count
;
1538 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1539 c
.gcpro
= gcprolist
;
1540 c
.byte_stack
= byte_stack_list
;
1541 if (_setjmp (c
.jmp
))
1543 return (*hfun
) (c
.val
);
1547 h
.handler
= handlers
;
1549 h
.next
= handlerlist
;
1553 val
= (*bfun
) (nargs
, args
);
1555 handlerlist
= h
.next
;
1560 static Lisp_Object
find_handler_clause (Lisp_Object
, Lisp_Object
,
1561 Lisp_Object
, Lisp_Object
);
1563 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1564 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1565 This function does not return.
1567 An error symbol is a symbol with an `error-conditions' property
1568 that is a list of condition names.
1569 A handler for any of those names will get to handle this signal.
1570 The symbol `error' should normally be one of them.
1572 DATA should be a list. Its elements are printed as part of the error message.
1573 See Info anchor `(elisp)Definition of signal' for some details on how this
1574 error message is constructed.
1575 If the signal is handled, DATA is made available to the handler.
1576 See also the function `condition-case'. */)
1577 (Lisp_Object error_symbol
, Lisp_Object data
)
1579 /* When memory is full, ERROR-SYMBOL is nil,
1580 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1581 That is a special case--don't do this in other situations. */
1582 register struct handler
*allhandlers
= handlerlist
;
1583 Lisp_Object conditions
;
1585 Lisp_Object real_error_symbol
;
1586 struct backtrace
*bp
;
1588 immediate_quit
= handling_signal
= 0;
1590 if (gc_in_progress
|| waiting_for_input
)
1593 if (NILP (error_symbol
))
1594 real_error_symbol
= Fcar (data
);
1596 real_error_symbol
= error_symbol
;
1598 #if 0 /* rms: I don't know why this was here,
1599 but it is surely wrong for an error that is handled. */
1600 #ifdef HAVE_WINDOW_SYSTEM
1601 if (display_hourglass_p
)
1602 cancel_hourglass ();
1606 /* This hook is used by edebug. */
1607 if (! NILP (Vsignal_hook_function
)
1608 && ! NILP (error_symbol
))
1610 /* Edebug takes care of restoring these variables when it exits. */
1611 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1612 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1614 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1615 max_specpdl_size
= SPECPDL_INDEX () + 40;
1617 call2 (Vsignal_hook_function
, error_symbol
, data
);
1620 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1622 /* Remember from where signal was called. Skip over the frame for
1623 `signal' itself. If a frame for `error' follows, skip that,
1624 too. Don't do this when ERROR_SYMBOL is nil, because that
1625 is a memory-full error. */
1626 Vsignaling_function
= Qnil
;
1627 if (backtrace_list
&& !NILP (error_symbol
))
1629 bp
= backtrace_list
->next
;
1630 if (bp
&& bp
->function
&& EQ (*bp
->function
, Qerror
))
1632 if (bp
&& bp
->function
)
1633 Vsignaling_function
= *bp
->function
;
1636 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1638 register Lisp_Object clause
;
1640 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1641 error_symbol
, data
);
1643 if (EQ (clause
, Qlambda
))
1645 /* We can't return values to code which signaled an error, but we
1646 can continue code which has signaled a quit. */
1647 if (EQ (real_error_symbol
, Qquit
))
1650 error ("Cannot return from the debugger in an error");
1655 Lisp_Object unwind_data
;
1656 struct handler
*h
= handlerlist
;
1658 handlerlist
= allhandlers
;
1660 if (NILP (error_symbol
))
1663 unwind_data
= Fcons (error_symbol
, data
);
1664 h
->chosen_clause
= clause
;
1665 unwind_to_catch (h
->tag
, unwind_data
);
1669 handlerlist
= allhandlers
;
1670 /* If no handler is present now, try to run the debugger,
1671 and if that fails, throw to top level. */
1672 find_handler_clause (Qerror
, conditions
, error_symbol
, data
);
1674 Fthrow (Qtop_level
, Qt
);
1676 if (! NILP (error_symbol
))
1677 data
= Fcons (error_symbol
, data
);
1679 string
= Ferror_message_string (data
);
1680 fatal ("%s", SDATA (string
), 0);
1683 /* Internal version of Fsignal that never returns.
1684 Used for anything but Qquit (which can return from Fsignal). */
1687 xsignal (Lisp_Object error_symbol
, Lisp_Object data
)
1689 Fsignal (error_symbol
, data
);
1693 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1696 xsignal0 (Lisp_Object error_symbol
)
1698 xsignal (error_symbol
, Qnil
);
1702 xsignal1 (Lisp_Object error_symbol
, Lisp_Object arg
)
1704 xsignal (error_symbol
, list1 (arg
));
1708 xsignal2 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
)
1710 xsignal (error_symbol
, list2 (arg1
, arg2
));
1714 xsignal3 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
1716 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1719 /* Signal `error' with message S, and additional arg ARG.
1720 If ARG is not a genuine list, make it a one-element list. */
1723 signal_error (const char *s
, Lisp_Object arg
)
1725 Lisp_Object tortoise
, hare
;
1727 hare
= tortoise
= arg
;
1728 while (CONSP (hare
))
1735 tortoise
= XCDR (tortoise
);
1737 if (EQ (hare
, tortoise
))
1742 arg
= Fcons (arg
, Qnil
); /* Make it a list. */
1744 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1748 /* Return nonzero if LIST is a non-nil atom or
1749 a list containing one of CONDITIONS. */
1752 wants_debugger (Lisp_Object list
, Lisp_Object conditions
)
1759 while (CONSP (conditions
))
1761 Lisp_Object
this, tail
;
1762 this = XCAR (conditions
);
1763 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1764 if (EQ (XCAR (tail
), this))
1766 conditions
= XCDR (conditions
);
1771 /* Return 1 if an error with condition-symbols CONDITIONS,
1772 and described by SIGNAL-DATA, should skip the debugger
1773 according to debugger-ignored-errors. */
1776 skip_debugger (Lisp_Object conditions
, Lisp_Object data
)
1779 int first_string
= 1;
1780 Lisp_Object error_message
;
1782 error_message
= Qnil
;
1783 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1785 if (STRINGP (XCAR (tail
)))
1789 error_message
= Ferror_message_string (data
);
1793 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1798 Lisp_Object contail
;
1800 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1801 if (EQ (XCAR (tail
), XCAR (contail
)))
1809 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1810 SIG and DATA describe the signal, as in find_handler_clause. */
1813 maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
, Lisp_Object data
)
1815 Lisp_Object combined_data
;
1817 combined_data
= Fcons (sig
, data
);
1820 /* Don't try to run the debugger with interrupts blocked.
1821 The editing loop would return anyway. */
1823 /* Does user want to enter debugger for this kind of error? */
1826 : wants_debugger (Vdebug_on_error
, conditions
))
1827 && ! skip_debugger (conditions
, combined_data
)
1828 /* rms: what's this for? */
1829 && when_entered_debugger
< num_nonmacro_input_events
)
1831 call_debugger (Fcons (Qerror
, Fcons (combined_data
, Qnil
)));
1838 /* Value of Qlambda means we have called debugger and user has continued.
1839 There are two ways to pass SIG and DATA:
1840 = SIG is the error symbol, and DATA is the rest of the data.
1841 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1842 This is for memory-full errors only.
1844 We need to increase max_specpdl_size temporarily around
1845 anything we do that can push on the specpdl, so as not to get
1846 a second error here in case we're handling specpdl overflow. */
1849 find_handler_clause (Lisp_Object handlers
, Lisp_Object conditions
,
1850 Lisp_Object sig
, Lisp_Object data
)
1852 register Lisp_Object h
;
1853 register Lisp_Object tem
;
1854 int debugger_called
= 0;
1855 int debugger_considered
= 0;
1857 /* t is used by handlers for all conditions, set up by C code. */
1858 if (EQ (handlers
, Qt
))
1861 /* Don't run the debugger for a memory-full error.
1862 (There is no room in memory to do that!) */
1864 debugger_considered
= 1;
1866 /* error is used similarly, but means print an error message
1867 and run the debugger if that is enabled. */
1868 if (EQ (handlers
, Qerror
)
1869 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1870 there is a handler. */
1872 if (!NILP (sig
) && wants_debugger (Vstack_trace_on_error
, conditions
))
1874 max_lisp_eval_depth
+= 15;
1879 internal_with_output_to_temp_buffer
1881 (Lisp_Object (*) (Lisp_Object
)) Fbacktrace
,
1884 max_lisp_eval_depth
-= 15;
1887 if (!debugger_considered
)
1889 debugger_considered
= 1;
1890 debugger_called
= maybe_call_debugger (conditions
, sig
, data
);
1893 /* If there is no handler, return saying whether we ran the debugger. */
1894 if (EQ (handlers
, Qerror
))
1896 if (debugger_called
)
1902 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1904 Lisp_Object handler
, condit
;
1907 if (!CONSP (handler
))
1909 condit
= Fcar (handler
);
1910 /* Handle a single condition name in handler HANDLER. */
1911 if (SYMBOLP (condit
))
1913 tem
= Fmemq (Fcar (handler
), conditions
);
1917 /* Handle a list of condition names in handler HANDLER. */
1918 else if (CONSP (condit
))
1921 for (tail
= condit
; CONSP (tail
); tail
= XCDR (tail
))
1923 tem
= Fmemq (Fcar (tail
), conditions
);
1926 /* This handler is going to apply.
1927 Does it allow the debugger to run first? */
1928 if (! debugger_considered
&& !NILP (Fmemq (Qdebug
, condit
)))
1929 maybe_call_debugger (conditions
, sig
, data
);
1940 /* dump an error message; called like vprintf */
1942 verror (const char *m
, va_list ap
)
1945 EMACS_INT size
= 200;
1957 used
= doprnt (buffer
, size
, m
, m
+ mlen
, ap
);
1962 buffer
= (char *) xrealloc (buffer
, size
);
1965 buffer
= (char *) xmalloc (size
);
1970 string
= build_string (buffer
);
1974 xsignal1 (Qerror
, string
);
1978 /* dump an error message; called like printf */
1982 error (const char *m
, ...)
1990 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
1991 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
1992 This means it contains a description for how to read arguments to give it.
1993 The value is nil for an invalid function or a symbol with no function
1996 Interactively callable functions include strings and vectors (treated
1997 as keyboard macros), lambda-expressions that contain a top-level call
1998 to `interactive', autoload definitions made by `autoload' with non-nil
1999 fourth argument, and some of the built-in functions of Lisp.
2001 Also, a symbol satisfies `commandp' if its function definition does so.
2003 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
2004 then strings and vectors are not accepted. */)
2005 (Lisp_Object function
, Lisp_Object for_call_interactively
)
2007 register Lisp_Object fun
;
2008 register Lisp_Object funcar
;
2009 Lisp_Object if_prop
= Qnil
;
2013 fun
= indirect_function (fun
); /* Check cycles. */
2014 if (NILP (fun
) || EQ (fun
, Qunbound
))
2017 /* Check an `interactive-form' property if present, analogous to the
2018 function-documentation property. */
2020 while (SYMBOLP (fun
))
2022 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
2025 fun
= Fsymbol_function (fun
);
2028 /* Emacs primitives are interactive if their DEFUN specifies an
2029 interactive spec. */
2031 return XSUBR (fun
)->intspec
? Qt
: if_prop
;
2033 /* Bytecode objects are interactive if they are long enough to
2034 have an element whose index is COMPILED_INTERACTIVE, which is
2035 where the interactive spec is stored. */
2036 else if (COMPILEDP (fun
))
2037 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
2040 /* Strings and vectors are keyboard macros. */
2041 if (STRINGP (fun
) || VECTORP (fun
))
2042 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
2044 /* Lists may represent commands. */
2047 funcar
= XCAR (fun
);
2048 if (EQ (funcar
, Qlambda
))
2049 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
2050 if (EQ (funcar
, Qautoload
))
2051 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
2056 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
2057 doc
: /* Define FUNCTION to autoload from FILE.
2058 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
2059 Third arg DOCSTRING is documentation for the function.
2060 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
2061 Fifth arg TYPE indicates the type of the object:
2062 nil or omitted says FUNCTION is a function,
2063 `keymap' says FUNCTION is really a keymap, and
2064 `macro' or t says FUNCTION is really a macro.
2065 Third through fifth args give info about the real definition.
2066 They default to nil.
2067 If FUNCTION is already defined other than as an autoload,
2068 this does nothing and returns nil. */)
2069 (Lisp_Object function
, Lisp_Object file
, Lisp_Object docstring
, Lisp_Object interactive
, Lisp_Object type
)
2071 CHECK_SYMBOL (function
);
2072 CHECK_STRING (file
);
2074 /* If function is defined and not as an autoload, don't override */
2075 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
2076 && !(CONSP (XSYMBOL (function
)->function
)
2077 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
2080 if (NILP (Vpurify_flag
))
2081 /* Only add entries after dumping, because the ones before are
2082 not useful and else we get loads of them from the loaddefs.el. */
2083 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
2085 /* We don't want the docstring in purespace (instead,
2086 Snarf-documentation should (hopefully) overwrite it).
2087 We used to use 0 here, but that leads to accidental sharing in
2088 purecopy's hash-consing, so we use a (hopefully) unique integer
2090 docstring
= make_number (XHASH (function
));
2091 return Ffset (function
,
2092 Fpurecopy (list5 (Qautoload
, file
, docstring
,
2093 interactive
, type
)));
2097 un_autoload (Lisp_Object oldqueue
)
2099 register Lisp_Object queue
, first
, second
;
2101 /* Queue to unwind is current value of Vautoload_queue.
2102 oldqueue is the shadowed value to leave in Vautoload_queue. */
2103 queue
= Vautoload_queue
;
2104 Vautoload_queue
= oldqueue
;
2105 while (CONSP (queue
))
2107 first
= XCAR (queue
);
2108 second
= Fcdr (first
);
2109 first
= Fcar (first
);
2110 if (EQ (first
, make_number (0)))
2113 Ffset (first
, second
);
2114 queue
= XCDR (queue
);
2119 /* Load an autoloaded function.
2120 FUNNAME is the symbol which is the function's name.
2121 FUNDEF is the autoload definition (a list). */
2124 do_autoload (Lisp_Object fundef
, Lisp_Object funname
)
2126 int count
= SPECPDL_INDEX ();
2128 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2130 /* This is to make sure that loadup.el gives a clear picture
2131 of what files are preloaded and when. */
2132 if (! NILP (Vpurify_flag
))
2133 error ("Attempt to autoload %s while preparing to dump",
2134 SDATA (SYMBOL_NAME (funname
)));
2137 CHECK_SYMBOL (funname
);
2138 GCPRO3 (fun
, funname
, fundef
);
2140 /* Preserve the match data. */
2141 record_unwind_save_match_data ();
2143 /* If autoloading gets an error (which includes the error of failing
2144 to define the function being called), we use Vautoload_queue
2145 to undo function definitions and `provide' calls made by
2146 the function. We do this in the specific case of autoloading
2147 because autoloading is not an explicit request "load this file",
2148 but rather a request to "call this function".
2150 The value saved here is to be restored into Vautoload_queue. */
2151 record_unwind_protect (un_autoload
, Vautoload_queue
);
2152 Vautoload_queue
= Qt
;
2153 Fload (Fcar (Fcdr (fundef
)), Qnil
, Qt
, Qnil
, Qt
);
2155 /* Once loading finishes, don't undo it. */
2156 Vautoload_queue
= Qt
;
2157 unbind_to (count
, Qnil
);
2159 fun
= Findirect_function (fun
, Qnil
);
2161 if (!NILP (Fequal (fun
, fundef
)))
2162 error ("Autoloading failed to define function %s",
2163 SDATA (SYMBOL_NAME (funname
)));
2168 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
2169 doc
: /* Evaluate FORM and return its value. */)
2172 Lisp_Object fun
, val
, original_fun
, original_args
;
2174 struct backtrace backtrace
;
2175 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2177 if (handling_signal
)
2181 return Fsymbol_value (form
);
2186 if ((consing_since_gc
> gc_cons_threshold
2187 && consing_since_gc
> gc_relative_threshold
)
2189 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2192 Fgarbage_collect ();
2196 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2198 if (max_lisp_eval_depth
< 100)
2199 max_lisp_eval_depth
= 100;
2200 if (lisp_eval_depth
> max_lisp_eval_depth
)
2201 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2204 original_fun
= Fcar (form
);
2205 original_args
= Fcdr (form
);
2207 backtrace
.next
= backtrace_list
;
2208 backtrace_list
= &backtrace
;
2209 backtrace
.function
= &original_fun
; /* This also protects them from gc */
2210 backtrace
.args
= &original_args
;
2211 backtrace
.nargs
= UNEVALLED
;
2212 backtrace
.evalargs
= 1;
2213 backtrace
.debug_on_exit
= 0;
2215 if (debug_on_next_call
)
2216 do_debug_on_call (Qt
);
2218 /* At this point, only original_fun and original_args
2219 have values that will be used below */
2222 /* Optimize for no indirection. */
2224 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2225 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2226 fun
= indirect_function (fun
);
2230 Lisp_Object numargs
;
2231 Lisp_Object argvals
[8];
2232 Lisp_Object args_left
;
2233 register int i
, maxargs
;
2235 args_left
= original_args
;
2236 numargs
= Flength (args_left
);
2240 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
2241 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2242 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2244 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2246 backtrace
.evalargs
= 0;
2247 val
= (XSUBR (fun
)->function
.aUNEVALLED
) (args_left
);
2249 else if (XSUBR (fun
)->max_args
== MANY
)
2251 /* Pass a vector of evaluated arguments */
2253 register int argnum
= 0;
2256 SAFE_ALLOCA_LISP (vals
, XINT (numargs
));
2258 GCPRO3 (args_left
, fun
, fun
);
2262 while (!NILP (args_left
))
2264 vals
[argnum
++] = Feval (Fcar (args_left
));
2265 args_left
= Fcdr (args_left
);
2266 gcpro3
.nvars
= argnum
;
2269 backtrace
.args
= vals
;
2270 backtrace
.nargs
= XINT (numargs
);
2272 val
= (XSUBR (fun
)->function
.aMANY
) (XINT (numargs
), vals
);
2278 GCPRO3 (args_left
, fun
, fun
);
2279 gcpro3
.var
= argvals
;
2282 maxargs
= XSUBR (fun
)->max_args
;
2283 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
2285 argvals
[i
] = Feval (Fcar (args_left
));
2291 backtrace
.args
= argvals
;
2292 backtrace
.nargs
= XINT (numargs
);
2297 val
= (XSUBR (fun
)->function
.a0 ());
2300 val
= (XSUBR (fun
)->function
.a1 (argvals
[0]));
2303 val
= (XSUBR (fun
)->function
.a2 (argvals
[0], argvals
[1]));
2306 val
= (XSUBR (fun
)->function
.a3
2307 (argvals
[0], argvals
[1], argvals
[2]));
2310 val
= (XSUBR (fun
)->function
.a4
2311 (argvals
[0], argvals
[1], argvals
[2], argvals
[3]));
2314 val
= (XSUBR (fun
)->function
.a5
2315 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2319 val
= (XSUBR (fun
)->function
.a6
2320 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2321 argvals
[4], argvals
[5]));
2324 val
= (XSUBR (fun
)->function
.a7
2325 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2326 argvals
[4], argvals
[5], argvals
[6]));
2330 val
= (XSUBR (fun
)->function
.a8
2331 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2332 argvals
[4], argvals
[5], argvals
[6], argvals
[7]));
2336 /* Someone has created a subr that takes more arguments than
2337 is supported by this code. We need to either rewrite the
2338 subr to use a different argument protocol, or add more
2339 cases to this switch. */
2344 else if (COMPILEDP (fun
))
2345 val
= apply_lambda (fun
, original_args
, 1);
2348 if (EQ (fun
, Qunbound
))
2349 xsignal1 (Qvoid_function
, original_fun
);
2351 xsignal1 (Qinvalid_function
, original_fun
);
2352 funcar
= XCAR (fun
);
2353 if (!SYMBOLP (funcar
))
2354 xsignal1 (Qinvalid_function
, original_fun
);
2355 if (EQ (funcar
, Qautoload
))
2357 do_autoload (fun
, original_fun
);
2360 if (EQ (funcar
, Qmacro
))
2361 val
= Feval (apply1 (Fcdr (fun
), original_args
));
2362 else if (EQ (funcar
, Qlambda
))
2363 val
= apply_lambda (fun
, original_args
, 1);
2365 xsignal1 (Qinvalid_function
, original_fun
);
2370 if (backtrace
.debug_on_exit
)
2371 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2372 backtrace_list
= backtrace
.next
;
2377 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
2378 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2379 Then return the value FUNCTION returns.
2380 Thus, (apply '+ 1 2 '(3 4)) returns 10.
2381 usage: (apply FUNCTION &rest ARGUMENTS) */)
2382 (int nargs
, Lisp_Object
*args
)
2384 register int i
, numargs
;
2385 register Lisp_Object spread_arg
;
2386 register Lisp_Object
*funcall_args
;
2387 Lisp_Object fun
, retval
;
2388 struct gcpro gcpro1
;
2393 spread_arg
= args
[nargs
- 1];
2394 CHECK_LIST (spread_arg
);
2396 numargs
= XINT (Flength (spread_arg
));
2399 return Ffuncall (nargs
- 1, args
);
2400 else if (numargs
== 1)
2402 args
[nargs
- 1] = XCAR (spread_arg
);
2403 return Ffuncall (nargs
, args
);
2406 numargs
+= nargs
- 2;
2408 /* Optimize for no indirection. */
2409 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2410 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2411 fun
= indirect_function (fun
);
2412 if (EQ (fun
, Qunbound
))
2414 /* Let funcall get the error */
2421 if (numargs
< XSUBR (fun
)->min_args
2422 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2423 goto funcall
; /* Let funcall get the error */
2424 else if (XSUBR (fun
)->max_args
> numargs
)
2426 /* Avoid making funcall cons up a yet another new vector of arguments
2427 by explicitly supplying nil's for optional values */
2428 SAFE_ALLOCA_LISP (funcall_args
, 1 + XSUBR (fun
)->max_args
);
2429 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2430 funcall_args
[++i
] = Qnil
;
2431 GCPRO1 (*funcall_args
);
2432 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2436 /* We add 1 to numargs because funcall_args includes the
2437 function itself as well as its arguments. */
2440 SAFE_ALLOCA_LISP (funcall_args
, 1 + numargs
);
2441 GCPRO1 (*funcall_args
);
2442 gcpro1
.nvars
= 1 + numargs
;
2445 memcpy (funcall_args
, args
, nargs
* sizeof (Lisp_Object
));
2446 /* Spread the last arg we got. Its first element goes in
2447 the slot that it used to occupy, hence this value of I. */
2449 while (!NILP (spread_arg
))
2451 funcall_args
[i
++] = XCAR (spread_arg
);
2452 spread_arg
= XCDR (spread_arg
);
2455 /* By convention, the caller needs to gcpro Ffuncall's args. */
2456 retval
= Ffuncall (gcpro1
.nvars
, funcall_args
);
2463 /* Run hook variables in various ways. */
2465 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
2466 static Lisp_Object
run_hook_with_args (int, Lisp_Object
*,
2467 enum run_hooks_condition
);
2469 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2470 doc
: /* Run each hook in HOOKS.
2471 Each argument should be a symbol, a hook variable.
2472 These symbols are processed in the order specified.
2473 If a hook symbol has a non-nil value, that value may be a function
2474 or a list of functions to be called to run the hook.
2475 If the value is a function, it is called with no arguments.
2476 If it is a list, the elements are called, in order, with no arguments.
2478 Major modes should not use this function directly to run their mode
2479 hook; they should use `run-mode-hooks' instead.
2481 Do not use `make-local-variable' to make a hook variable buffer-local.
2482 Instead, use `add-hook' and specify t for the LOCAL argument.
2483 usage: (run-hooks &rest HOOKS) */)
2484 (int nargs
, Lisp_Object
*args
)
2486 Lisp_Object hook
[1];
2489 for (i
= 0; i
< nargs
; i
++)
2492 run_hook_with_args (1, hook
, to_completion
);
2498 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2499 Srun_hook_with_args
, 1, MANY
, 0,
2500 doc
: /* Run HOOK with the specified arguments ARGS.
2501 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2502 value, that value may be a function or a list of functions to be
2503 called to run the hook. If the value is a function, it is called with
2504 the given arguments and its return value is returned. If it is a list
2505 of functions, those functions are called, in order,
2506 with the given arguments ARGS.
2507 It is best not to depend on the value returned by `run-hook-with-args',
2510 Do not use `make-local-variable' to make a hook variable buffer-local.
2511 Instead, use `add-hook' and specify t for the LOCAL argument.
2512 usage: (run-hook-with-args HOOK &rest ARGS) */)
2513 (int nargs
, Lisp_Object
*args
)
2515 return run_hook_with_args (nargs
, args
, to_completion
);
2518 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2519 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2520 doc
: /* Run HOOK with the specified arguments ARGS.
2521 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2522 value, that value may be a function or a list of functions to be
2523 called to run the hook. If the value is a function, it is called with
2524 the given arguments and its return value is returned.
2525 If it is a list of functions, those functions are called, in order,
2526 with the given arguments ARGS, until one of them
2527 returns a non-nil value. Then we return that value.
2528 However, if they all return nil, we return nil.
2530 Do not use `make-local-variable' to make a hook variable buffer-local.
2531 Instead, use `add-hook' and specify t for the LOCAL argument.
2532 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2533 (int nargs
, Lisp_Object
*args
)
2535 return run_hook_with_args (nargs
, args
, until_success
);
2538 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2539 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2540 doc
: /* Run HOOK with the specified arguments ARGS.
2541 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2542 value, that value may be a function or a list of functions to be
2543 called to run the hook. If the value is a function, it is called with
2544 the given arguments and its return value is returned.
2545 If it is a list of functions, those functions are called, in order,
2546 with the given arguments ARGS, until one of them returns nil.
2547 Then we return nil. However, if they all return non-nil, we return non-nil.
2549 Do not use `make-local-variable' to make a hook variable buffer-local.
2550 Instead, use `add-hook' and specify t for the LOCAL argument.
2551 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2552 (int nargs
, Lisp_Object
*args
)
2554 return run_hook_with_args (nargs
, args
, until_failure
);
2557 /* ARGS[0] should be a hook symbol.
2558 Call each of the functions in the hook value, passing each of them
2559 as arguments all the rest of ARGS (all NARGS - 1 elements).
2560 COND specifies a condition to test after each call
2561 to decide whether to stop.
2562 The caller (or its caller, etc) must gcpro all of ARGS,
2563 except that it isn't necessary to gcpro ARGS[0]. */
2566 run_hook_with_args (int nargs
, Lisp_Object
*args
, enum run_hooks_condition cond
)
2568 Lisp_Object sym
, val
, ret
;
2569 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2571 /* If we are dying or still initializing,
2572 don't do anything--it would probably crash if we tried. */
2573 if (NILP (Vrun_hooks
))
2577 val
= find_symbol_value (sym
);
2578 ret
= (cond
== until_failure
? Qt
: Qnil
);
2580 if (EQ (val
, Qunbound
) || NILP (val
))
2582 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2585 return Ffuncall (nargs
, args
);
2589 Lisp_Object globals
= Qnil
;
2590 GCPRO3 (sym
, val
, globals
);
2593 CONSP (val
) && ((cond
== to_completion
)
2594 || (cond
== until_success
? NILP (ret
)
2598 if (EQ (XCAR (val
), Qt
))
2600 /* t indicates this hook has a local binding;
2601 it means to run the global binding too. */
2602 globals
= Fdefault_value (sym
);
2603 if (NILP (globals
)) continue;
2605 if (!CONSP (globals
) || EQ (XCAR (globals
), Qlambda
))
2608 ret
= Ffuncall (nargs
, args
);
2613 CONSP (globals
) && ((cond
== to_completion
)
2614 || (cond
== until_success
? NILP (ret
)
2616 globals
= XCDR (globals
))
2618 args
[0] = XCAR (globals
);
2619 /* In a global value, t should not occur. If it does, we
2620 must ignore it to avoid an endless loop. */
2621 if (!EQ (args
[0], Qt
))
2622 ret
= Ffuncall (nargs
, args
);
2628 args
[0] = XCAR (val
);
2629 ret
= Ffuncall (nargs
, args
);
2638 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2641 run_hook_with_args_2 (Lisp_Object hook
, Lisp_Object arg1
, Lisp_Object arg2
)
2643 Lisp_Object temp
[3];
2648 Frun_hook_with_args (3, temp
);
2651 /* Apply fn to arg */
2653 apply1 (Lisp_Object fn
, Lisp_Object arg
)
2655 struct gcpro gcpro1
;
2659 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2662 Lisp_Object args
[2];
2666 RETURN_UNGCPRO (Fapply (2, args
));
2670 /* Call function fn on no arguments */
2672 call0 (Lisp_Object fn
)
2674 struct gcpro gcpro1
;
2677 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2680 /* Call function fn with 1 argument arg1 */
2683 call1 (Lisp_Object fn
, Lisp_Object arg1
)
2685 struct gcpro gcpro1
;
2686 Lisp_Object args
[2];
2692 RETURN_UNGCPRO (Ffuncall (2, args
));
2695 /* Call function fn with 2 arguments arg1, arg2 */
2698 call2 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
)
2700 struct gcpro gcpro1
;
2701 Lisp_Object args
[3];
2707 RETURN_UNGCPRO (Ffuncall (3, args
));
2710 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2713 call3 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2715 struct gcpro gcpro1
;
2716 Lisp_Object args
[4];
2723 RETURN_UNGCPRO (Ffuncall (4, args
));
2726 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2729 call4 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2732 struct gcpro gcpro1
;
2733 Lisp_Object args
[5];
2741 RETURN_UNGCPRO (Ffuncall (5, args
));
2744 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2747 call5 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2748 Lisp_Object arg4
, Lisp_Object arg5
)
2750 struct gcpro gcpro1
;
2751 Lisp_Object args
[6];
2760 RETURN_UNGCPRO (Ffuncall (6, args
));
2763 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2766 call6 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2767 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
)
2769 struct gcpro gcpro1
;
2770 Lisp_Object args
[7];
2780 RETURN_UNGCPRO (Ffuncall (7, args
));
2783 /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7 */
2786 call7 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2787 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
)
2789 struct gcpro gcpro1
;
2790 Lisp_Object args
[8];
2801 RETURN_UNGCPRO (Ffuncall (8, args
));
2804 /* The caller should GCPRO all the elements of ARGS. */
2806 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2807 doc
: /* Call first argument as a function, passing remaining arguments to it.
2808 Return the value that function returns.
2809 Thus, (funcall 'cons 'x 'y) returns (x . y).
2810 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2811 (int nargs
, Lisp_Object
*args
)
2813 Lisp_Object fun
, original_fun
;
2815 int numargs
= nargs
- 1;
2816 Lisp_Object lisp_numargs
;
2818 struct backtrace backtrace
;
2819 register Lisp_Object
*internal_args
;
2823 if ((consing_since_gc
> gc_cons_threshold
2824 && consing_since_gc
> gc_relative_threshold
)
2826 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2827 Fgarbage_collect ();
2829 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2831 if (max_lisp_eval_depth
< 100)
2832 max_lisp_eval_depth
= 100;
2833 if (lisp_eval_depth
> max_lisp_eval_depth
)
2834 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2837 backtrace
.next
= backtrace_list
;
2838 backtrace_list
= &backtrace
;
2839 backtrace
.function
= &args
[0];
2840 backtrace
.args
= &args
[1];
2841 backtrace
.nargs
= nargs
- 1;
2842 backtrace
.evalargs
= 0;
2843 backtrace
.debug_on_exit
= 0;
2845 if (debug_on_next_call
)
2846 do_debug_on_call (Qlambda
);
2850 original_fun
= args
[0];
2854 /* Optimize for no indirection. */
2856 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2857 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2858 fun
= indirect_function (fun
);
2862 if (numargs
< XSUBR (fun
)->min_args
2863 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2865 XSETFASTINT (lisp_numargs
, numargs
);
2866 xsignal2 (Qwrong_number_of_arguments
, original_fun
, lisp_numargs
);
2869 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2870 xsignal1 (Qinvalid_function
, original_fun
);
2872 else if (XSUBR (fun
)->max_args
== MANY
)
2873 val
= (XSUBR (fun
)->function
.aMANY
) (numargs
, args
+ 1);
2876 if (XSUBR (fun
)->max_args
> numargs
)
2878 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2879 memcpy (internal_args
, args
+ 1, numargs
* sizeof (Lisp_Object
));
2880 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2881 internal_args
[i
] = Qnil
;
2884 internal_args
= args
+ 1;
2885 switch (XSUBR (fun
)->max_args
)
2888 val
= (XSUBR (fun
)->function
.a0 ());
2891 val
= (XSUBR (fun
)->function
.a1 (internal_args
[0]));
2894 val
= (XSUBR (fun
)->function
.a2
2895 (internal_args
[0], internal_args
[1]));
2898 val
= (XSUBR (fun
)->function
.a3
2899 (internal_args
[0], internal_args
[1], internal_args
[2]));
2902 val
= (XSUBR (fun
)->function
.a4
2903 (internal_args
[0], internal_args
[1], internal_args
[2],
2907 val
= (XSUBR (fun
)->function
.a5
2908 (internal_args
[0], internal_args
[1], internal_args
[2],
2909 internal_args
[3], internal_args
[4]));
2912 val
= (XSUBR (fun
)->function
.a6
2913 (internal_args
[0], internal_args
[1], internal_args
[2],
2914 internal_args
[3], internal_args
[4], internal_args
[5]));
2917 val
= (XSUBR (fun
)->function
.a7
2918 (internal_args
[0], internal_args
[1], internal_args
[2],
2919 internal_args
[3], internal_args
[4], internal_args
[5],
2924 val
= (XSUBR (fun
)->function
.a8
2925 (internal_args
[0], internal_args
[1], internal_args
[2],
2926 internal_args
[3], internal_args
[4], internal_args
[5],
2927 internal_args
[6], internal_args
[7]));
2932 /* If a subr takes more than 8 arguments without using MANY
2933 or UNEVALLED, we need to extend this function to support it.
2934 Until this is done, there is no way to call the function. */
2939 else if (COMPILEDP (fun
))
2940 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2943 if (EQ (fun
, Qunbound
))
2944 xsignal1 (Qvoid_function
, original_fun
);
2946 xsignal1 (Qinvalid_function
, original_fun
);
2947 funcar
= XCAR (fun
);
2948 if (!SYMBOLP (funcar
))
2949 xsignal1 (Qinvalid_function
, original_fun
);
2950 if (EQ (funcar
, Qlambda
))
2951 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2952 else if (EQ (funcar
, Qautoload
))
2954 do_autoload (fun
, original_fun
);
2959 xsignal1 (Qinvalid_function
, original_fun
);
2963 if (backtrace
.debug_on_exit
)
2964 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2965 backtrace_list
= backtrace
.next
;
2970 apply_lambda (Lisp_Object fun
, Lisp_Object args
, int eval_flag
)
2972 Lisp_Object args_left
;
2973 Lisp_Object numargs
;
2974 register Lisp_Object
*arg_vector
;
2975 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2977 register Lisp_Object tem
;
2980 numargs
= Flength (args
);
2981 SAFE_ALLOCA_LISP (arg_vector
, XINT (numargs
));
2984 GCPRO3 (*arg_vector
, args_left
, fun
);
2987 for (i
= 0; i
< XINT (numargs
);)
2989 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2990 if (eval_flag
) tem
= Feval (tem
);
2991 arg_vector
[i
++] = tem
;
2999 backtrace_list
->args
= arg_vector
;
3000 backtrace_list
->nargs
= i
;
3002 backtrace_list
->evalargs
= 0;
3003 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
3005 /* Do the debug-on-exit now, while arg_vector still exists. */
3006 if (backtrace_list
->debug_on_exit
)
3007 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
3008 /* Don't do it again when we return to eval. */
3009 backtrace_list
->debug_on_exit
= 0;
3014 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
3015 and return the result of evaluation.
3016 FUN must be either a lambda-expression or a compiled-code object. */
3019 funcall_lambda (Lisp_Object fun
, int nargs
, register Lisp_Object
*arg_vector
)
3021 Lisp_Object val
, syms_left
, next
;
3022 int count
= SPECPDL_INDEX ();
3023 int i
, optional
, rest
;
3027 syms_left
= XCDR (fun
);
3028 if (CONSP (syms_left
))
3029 syms_left
= XCAR (syms_left
);
3031 xsignal1 (Qinvalid_function
, fun
);
3033 else if (COMPILEDP (fun
))
3034 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3038 i
= optional
= rest
= 0;
3039 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3043 next
= XCAR (syms_left
);
3044 if (!SYMBOLP (next
))
3045 xsignal1 (Qinvalid_function
, fun
);
3047 if (EQ (next
, Qand_rest
))
3049 else if (EQ (next
, Qand_optional
))
3053 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
3057 specbind (next
, arg_vector
[i
++]);
3059 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3061 specbind (next
, Qnil
);
3064 if (!NILP (syms_left
))
3065 xsignal1 (Qinvalid_function
, fun
);
3067 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3070 val
= Fprogn (XCDR (XCDR (fun
)));
3073 /* If we have not actually read the bytecode string
3074 and constants vector yet, fetch them from the file. */
3075 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3076 Ffetch_bytecode (fun
);
3077 val
= Fbyte_code (AREF (fun
, COMPILED_BYTECODE
),
3078 AREF (fun
, COMPILED_CONSTANTS
),
3079 AREF (fun
, COMPILED_STACK_DEPTH
));
3082 return unbind_to (count
, val
);
3085 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3087 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3088 (Lisp_Object object
)
3092 if (COMPILEDP (object
) && CONSP (AREF (object
, COMPILED_BYTECODE
)))
3094 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3097 tem
= AREF (object
, COMPILED_BYTECODE
);
3098 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3099 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3101 error ("Invalid byte code");
3103 ASET (object
, COMPILED_BYTECODE
, XCAR (tem
));
3104 ASET (object
, COMPILED_CONSTANTS
, XCDR (tem
));
3112 register int count
= SPECPDL_INDEX ();
3113 if (specpdl_size
>= max_specpdl_size
)
3115 if (max_specpdl_size
< 400)
3116 max_specpdl_size
= 400;
3117 if (specpdl_size
>= max_specpdl_size
)
3118 signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil
);
3121 if (specpdl_size
> max_specpdl_size
)
3122 specpdl_size
= max_specpdl_size
;
3123 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
3124 specpdl_ptr
= specpdl
+ count
;
3127 /* specpdl_ptr->symbol is a field which describes which variable is
3128 let-bound, so it can be properly undone when we unbind_to.
3129 It can have the following two shapes:
3130 - SYMBOL : if it's a plain symbol, it means that we have let-bound
3131 a symbol that is not buffer-local (at least at the time
3132 the let binding started). Note also that it should not be
3133 aliased (i.e. when let-binding V1 that's aliased to V2, we want
3135 - (SYMBOL WHERE . BUFFER) : this means that it is a let-binding for
3136 variable SYMBOL which can be buffer-local. WHERE tells us
3137 which buffer is affected (or nil if the let-binding affects the
3138 global value of the variable) and BUFFER tells us which buffer was
3139 current (i.e. if WHERE is non-nil, then BUFFER==WHERE, otherwise
3140 BUFFER did not yet have a buffer-local value). */
3143 specbind (Lisp_Object symbol
, Lisp_Object value
)
3145 struct Lisp_Symbol
*sym
;
3147 eassert (!handling_signal
);
3149 CHECK_SYMBOL (symbol
);
3150 sym
= XSYMBOL (symbol
);
3151 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3155 switch (sym
->redirect
)
3157 case SYMBOL_VARALIAS
:
3158 sym
= indirect_variable (sym
); XSETSYMBOL (symbol
, sym
); goto start
;
3159 case SYMBOL_PLAINVAL
:
3160 /* The most common case is that of a non-constant symbol with a
3161 trivial value. Make that as fast as we can. */
3162 specpdl_ptr
->symbol
= symbol
;
3163 specpdl_ptr
->old_value
= SYMBOL_VAL (sym
);
3164 specpdl_ptr
->func
= NULL
;
3167 SET_SYMBOL_VAL (sym
, value
);
3169 set_internal (symbol
, value
, Qnil
, 1);
3171 case SYMBOL_LOCALIZED
:
3172 if (SYMBOL_BLV (sym
)->frame_local
)
3173 error ("Frame-local vars cannot be let-bound");
3174 case SYMBOL_FORWARDED
:
3176 Lisp_Object ovalue
= find_symbol_value (symbol
);
3177 specpdl_ptr
->func
= 0;
3178 specpdl_ptr
->old_value
= ovalue
;
3180 eassert (sym
->redirect
!= SYMBOL_LOCALIZED
3181 || (EQ (SYMBOL_BLV (sym
)->where
,
3182 SYMBOL_BLV (sym
)->frame_local
?
3183 Fselected_frame () : Fcurrent_buffer ())));
3185 if (sym
->redirect
== SYMBOL_LOCALIZED
3186 || BUFFER_OBJFWDP (SYMBOL_FWD (sym
)))
3188 Lisp_Object where
, cur_buf
= Fcurrent_buffer ();
3190 /* For a local variable, record both the symbol and which
3191 buffer's or frame's value we are saving. */
3192 if (!NILP (Flocal_variable_p (symbol
, Qnil
)))
3194 eassert (sym
->redirect
!= SYMBOL_LOCALIZED
3195 || (BLV_FOUND (SYMBOL_BLV (sym
))
3196 && EQ (cur_buf
, SYMBOL_BLV (sym
)->where
)));
3199 else if (sym
->redirect
== SYMBOL_LOCALIZED
3200 && BLV_FOUND (SYMBOL_BLV (sym
)))
3201 where
= SYMBOL_BLV (sym
)->where
;
3205 /* We're not using the `unused' slot in the specbinding
3206 structure because this would mean we have to do more
3207 work for simple variables. */
3208 /* FIXME: The third value `current_buffer' is only used in
3209 let_shadows_buffer_binding_p which is itself only used
3210 in set_internal for local_if_set. */
3211 eassert (NILP (where
) || EQ (where
, cur_buf
));
3212 specpdl_ptr
->symbol
= Fcons (symbol
, Fcons (where
, cur_buf
));
3214 /* If SYMBOL is a per-buffer variable which doesn't have a
3215 buffer-local value here, make the `let' change the global
3216 value by changing the value of SYMBOL in all buffers not
3217 having their own value. This is consistent with what
3218 happens with other buffer-local variables. */
3220 && sym
->redirect
== SYMBOL_FORWARDED
)
3222 eassert (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)));
3224 Fset_default (symbol
, value
);
3229 specpdl_ptr
->symbol
= symbol
;
3232 set_internal (symbol
, value
, Qnil
, 1);
3240 record_unwind_protect (Lisp_Object (*function
) (Lisp_Object
), Lisp_Object arg
)
3242 eassert (!handling_signal
);
3244 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3246 specpdl_ptr
->func
= function
;
3247 specpdl_ptr
->symbol
= Qnil
;
3248 specpdl_ptr
->old_value
= arg
;
3253 unbind_to (int count
, Lisp_Object value
)
3255 Lisp_Object quitf
= Vquit_flag
;
3256 struct gcpro gcpro1
, gcpro2
;
3258 GCPRO2 (value
, quitf
);
3261 while (specpdl_ptr
!= specpdl
+ count
)
3263 /* Copy the binding, and decrement specpdl_ptr, before we do
3264 the work to unbind it. We decrement first
3265 so that an error in unbinding won't try to unbind
3266 the same entry again, and we copy the binding first
3267 in case more bindings are made during some of the code we run. */
3269 struct specbinding this_binding
;
3270 this_binding
= *--specpdl_ptr
;
3272 if (this_binding
.func
!= 0)
3273 (*this_binding
.func
) (this_binding
.old_value
);
3274 /* If the symbol is a list, it is really (SYMBOL WHERE
3275 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3276 frame. If WHERE is a buffer or frame, this indicates we
3277 bound a variable that had a buffer-local or frame-local
3278 binding. WHERE nil means that the variable had the default
3279 value when it was bound. CURRENT-BUFFER is the buffer that
3280 was current when the variable was bound. */
3281 else if (CONSP (this_binding
.symbol
))
3283 Lisp_Object symbol
, where
;
3285 symbol
= XCAR (this_binding
.symbol
);
3286 where
= XCAR (XCDR (this_binding
.symbol
));
3289 Fset_default (symbol
, this_binding
.old_value
);
3290 /* If `where' is non-nil, reset the value in the appropriate
3291 local binding, but only if that binding still exists. */
3292 else if (BUFFERP (where
)
3293 ? !NILP (Flocal_variable_p (symbol
, where
))
3294 : !NILP (Fassq (symbol
, XFRAME (where
)->param_alist
)))
3295 set_internal (symbol
, this_binding
.old_value
, where
, 1);
3297 /* If variable has a trivial value (no forwarding), we can
3298 just set it. No need to check for constant symbols here,
3299 since that was already done by specbind. */
3300 else if (XSYMBOL (this_binding
.symbol
)->redirect
== SYMBOL_PLAINVAL
)
3301 SET_SYMBOL_VAL (XSYMBOL (this_binding
.symbol
),
3302 this_binding
.old_value
);
3304 /* NOTE: we only ever come here if make_local_foo was used for
3305 the first time on this var within this let. */
3306 Fset_default (this_binding
.symbol
, this_binding
.old_value
);
3309 if (NILP (Vquit_flag
) && !NILP (quitf
))
3316 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3317 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3318 The debugger is entered when that frame exits, if the flag is non-nil. */)
3319 (Lisp_Object level
, Lisp_Object flag
)
3321 register struct backtrace
*backlist
= backtrace_list
;
3324 CHECK_NUMBER (level
);
3326 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
3328 backlist
= backlist
->next
;
3332 backlist
->debug_on_exit
= !NILP (flag
);
3337 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3338 doc
: /* Print a trace of Lisp function calls currently active.
3339 Output stream used is value of `standard-output'. */)
3342 register struct backtrace
*backlist
= backtrace_list
;
3346 struct gcpro gcpro1
;
3347 Lisp_Object old_print_level
= Vprint_level
;
3349 if (NILP (Vprint_level
))
3350 XSETFASTINT (Vprint_level
, 8);
3357 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
3358 if (backlist
->nargs
== UNEVALLED
)
3360 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
3361 write_string ("\n", -1);
3365 tem
= *backlist
->function
;
3366 Fprin1 (tem
, Qnil
); /* This can QUIT */
3367 write_string ("(", -1);
3368 if (backlist
->nargs
== MANY
)
3370 for (tail
= *backlist
->args
, i
= 0;
3372 tail
= Fcdr (tail
), i
++)
3374 if (i
) write_string (" ", -1);
3375 Fprin1 (Fcar (tail
), Qnil
);
3380 for (i
= 0; i
< backlist
->nargs
; i
++)
3382 if (i
) write_string (" ", -1);
3383 Fprin1 (backlist
->args
[i
], Qnil
);
3386 write_string (")\n", -1);
3388 backlist
= backlist
->next
;
3391 Vprint_level
= old_print_level
;
3396 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, NULL
,
3397 doc
: /* Return the function and arguments NFRAMES up from current execution point.
3398 If that frame has not evaluated the arguments yet (or is a special form),
3399 the value is (nil FUNCTION ARG-FORMS...).
3400 If that frame has evaluated its arguments and called its function already,
3401 the value is (t FUNCTION ARG-VALUES...).
3402 A &rest arg is represented as the tail of the list ARG-VALUES.
3403 FUNCTION is whatever was supplied as car of evaluated list,
3404 or a lambda expression for macro calls.
3405 If NFRAMES is more than the number of frames, the value is nil. */)
3406 (Lisp_Object nframes
)
3408 register struct backtrace
*backlist
= backtrace_list
;
3412 CHECK_NATNUM (nframes
);
3414 /* Find the frame requested. */
3415 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3416 backlist
= backlist
->next
;
3420 if (backlist
->nargs
== UNEVALLED
)
3421 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3424 if (backlist
->nargs
== MANY
)
3425 tem
= *backlist
->args
;
3427 tem
= Flist (backlist
->nargs
, backlist
->args
);
3429 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3435 mark_backtrace (void)
3437 register struct backtrace
*backlist
;
3440 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3442 mark_object (*backlist
->function
);
3444 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3447 i
= backlist
->nargs
- 1;
3449 mark_object (backlist
->args
[i
]);
3456 DEFVAR_INT ("max-specpdl-size", max_specpdl_size
,
3457 doc
: /* *Limit on number of Lisp variable bindings and `unwind-protect's.
3458 If Lisp code tries to increase the total number past this amount,
3459 an error is signaled.
3460 You can safely use a value considerably larger than the default value,
3461 if that proves inconveniently small. However, if you increase it too far,
3462 Emacs could run out of memory trying to make the stack bigger. */);
3464 DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth
,
3465 doc
: /* *Limit on depth in `eval', `apply' and `funcall' before error.
3467 This limit serves to catch infinite recursions for you before they cause
3468 actual stack overflow in C, which would be fatal for Emacs.
3469 You can safely make it considerably larger than its default value,
3470 if that proves inconveniently small. However, if you increase it too far,
3471 Emacs could overflow the real C stack, and crash. */);
3473 DEFVAR_LISP ("quit-flag", Vquit_flag
,
3474 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3475 If the value is t, that means do an ordinary quit.
3476 If the value equals `throw-on-input', that means quit by throwing
3477 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3478 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3479 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3482 DEFVAR_LISP ("inhibit-quit", Vinhibit_quit
,
3483 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3484 Note that `quit-flag' will still be set by typing C-g,
3485 so a quit will be signaled as soon as `inhibit-quit' is nil.
3486 To prevent this happening, set `quit-flag' to nil
3487 before making `inhibit-quit' nil. */);
3488 Vinhibit_quit
= Qnil
;
3490 Qinhibit_quit
= intern_c_string ("inhibit-quit");
3491 staticpro (&Qinhibit_quit
);
3493 Qautoload
= intern_c_string ("autoload");
3494 staticpro (&Qautoload
);
3496 Qdebug_on_error
= intern_c_string ("debug-on-error");
3497 staticpro (&Qdebug_on_error
);
3499 Qmacro
= intern_c_string ("macro");
3500 staticpro (&Qmacro
);
3502 Qdeclare
= intern_c_string ("declare");
3503 staticpro (&Qdeclare
);
3505 /* Note that the process handling also uses Qexit, but we don't want
3506 to staticpro it twice, so we just do it here. */
3507 Qexit
= intern_c_string ("exit");
3510 Qinteractive
= intern_c_string ("interactive");
3511 staticpro (&Qinteractive
);
3513 Qcommandp
= intern_c_string ("commandp");
3514 staticpro (&Qcommandp
);
3516 Qdefun
= intern_c_string ("defun");
3517 staticpro (&Qdefun
);
3519 Qand_rest
= intern_c_string ("&rest");
3520 staticpro (&Qand_rest
);
3522 Qand_optional
= intern_c_string ("&optional");
3523 staticpro (&Qand_optional
);
3525 Qdebug
= intern_c_string ("debug");
3526 staticpro (&Qdebug
);
3528 DEFVAR_LISP ("stack-trace-on-error", Vstack_trace_on_error
,
3529 doc
: /* *Non-nil means errors display a backtrace buffer.
3530 More precisely, this happens for any error that is handled
3531 by the editor command loop.
3532 If the value is a list, an error only means to display a backtrace
3533 if one of its condition symbols appears in the list. */);
3534 Vstack_trace_on_error
= Qnil
;
3536 DEFVAR_LISP ("debug-on-error", Vdebug_on_error
,
3537 doc
: /* *Non-nil means enter debugger if an error is signaled.
3538 Does not apply to errors handled by `condition-case' or those
3539 matched by `debug-ignored-errors'.
3540 If the value is a list, an error only means to enter the debugger
3541 if one of its condition symbols appears in the list.
3542 When you evaluate an expression interactively, this variable
3543 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3544 The command `toggle-debug-on-error' toggles this.
3545 See also the variable `debug-on-quit'. */);
3546 Vdebug_on_error
= Qnil
;
3548 DEFVAR_LISP ("debug-ignored-errors", Vdebug_ignored_errors
,
3549 doc
: /* *List of errors for which the debugger should not be called.
3550 Each element may be a condition-name or a regexp that matches error messages.
3551 If any element applies to a given error, that error skips the debugger
3552 and just returns to top level.
3553 This overrides the variable `debug-on-error'.
3554 It does not apply to errors handled by `condition-case'. */);
3555 Vdebug_ignored_errors
= Qnil
;
3557 DEFVAR_BOOL ("debug-on-quit", debug_on_quit
,
3558 doc
: /* *Non-nil means enter debugger if quit is signaled (C-g, for example).
3559 Does not apply if quit is handled by a `condition-case'. */);
3562 DEFVAR_BOOL ("debug-on-next-call", debug_on_next_call
,
3563 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3565 DEFVAR_BOOL ("debugger-may-continue", debugger_may_continue
,
3566 doc
: /* Non-nil means debugger may continue execution.
3567 This is nil when the debugger is called under circumstances where it
3568 might not be safe to continue. */);
3569 debugger_may_continue
= 1;
3571 DEFVAR_LISP ("debugger", Vdebugger
,
3572 doc
: /* Function to call to invoke debugger.
3573 If due to frame exit, args are `exit' and the value being returned;
3574 this function's value will be returned instead of that.
3575 If due to error, args are `error' and a list of the args to `signal'.
3576 If due to `apply' or `funcall' entry, one arg, `lambda'.
3577 If due to `eval' entry, one arg, t. */);
3580 DEFVAR_LISP ("signal-hook-function", Vsignal_hook_function
,
3581 doc
: /* If non-nil, this is a function for `signal' to call.
3582 It receives the same arguments that `signal' was given.
3583 The Edebug package uses this to regain control. */);
3584 Vsignal_hook_function
= Qnil
;
3586 DEFVAR_LISP ("debug-on-signal", Vdebug_on_signal
,
3587 doc
: /* *Non-nil means call the debugger regardless of condition handlers.
3588 Note that `debug-on-error', `debug-on-quit' and friends
3589 still determine whether to handle the particular condition. */);
3590 Vdebug_on_signal
= Qnil
;
3592 DEFVAR_LISP ("macro-declaration-function", Vmacro_declaration_function
,
3593 doc
: /* Function to process declarations in a macro definition.
3594 The function will be called with two args MACRO and DECL.
3595 MACRO is the name of the macro being defined.
3596 DECL is a list `(declare ...)' containing the declarations.
3597 The value the function returns is not used. */);
3598 Vmacro_declaration_function
= Qnil
;
3600 Vrun_hooks
= intern_c_string ("run-hooks");
3601 staticpro (&Vrun_hooks
);
3603 staticpro (&Vautoload_queue
);
3604 Vautoload_queue
= Qnil
;
3605 staticpro (&Vsignaling_function
);
3606 Vsignaling_function
= Qnil
;
3617 defsubr (&Sfunction
);
3619 defsubr (&Sdefmacro
);
3621 defsubr (&Sdefvaralias
);
3622 defsubr (&Sdefconst
);
3623 defsubr (&Suser_variable_p
);
3627 defsubr (&Smacroexpand
);
3630 defsubr (&Sunwind_protect
);
3631 defsubr (&Scondition_case
);
3633 defsubr (&Sinteractive_p
);
3634 defsubr (&Scalled_interactively_p
);
3635 defsubr (&Scommandp
);
3636 defsubr (&Sautoload
);
3639 defsubr (&Sfuncall
);
3640 defsubr (&Srun_hooks
);
3641 defsubr (&Srun_hook_with_args
);
3642 defsubr (&Srun_hook_with_args_until_success
);
3643 defsubr (&Srun_hook_with_args_until_failure
);
3644 defsubr (&Sfetch_bytecode
);
3645 defsubr (&Sbacktrace_debug
);
3646 defsubr (&Sbacktrace
);
3647 defsubr (&Sbacktrace_frame
);