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 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"
34 /* This definition is duplicated in alloc.c and keyboard.c */
35 /* Putting it in lisp.h makes cc bomb out! */
39 struct backtrace
*next
;
40 Lisp_Object
*function
;
41 Lisp_Object
*args
; /* Points to vector of args. */
42 int nargs
; /* Length of vector.
43 If nargs is UNEVALLED, args points to slot holding
44 list of unevalled args */
46 /* Nonzero means call value of debugger when done with this operation. */
51 /* Count levels of GCPRO to detect failure to UNGCPRO. */
55 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
56 Lisp_Object Qinhibit_quit
, impl_Vinhibit_quit
, impl_Vquit_flag
;
57 Lisp_Object Qand_rest
, Qand_optional
;
58 Lisp_Object Qdebug_on_error
;
61 extern Lisp_Object Qinteractive_form
;
63 /* This holds either the symbol `run-hooks' or nil.
64 It is nil at an early stage of startup, and when Emacs
67 Lisp_Object Vrun_hooks
;
69 /* Non-nil means record all fset's and provide's, to be undone
70 if the file being autoloaded is not fully loaded.
71 They are recorded by being consed onto the front of Vautoload_queue:
72 (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide. */
74 Lisp_Object Vautoload_queue
;
76 /* Maximum size allowed for specpdl allocation */
78 EMACS_INT max_specpdl_size
;
80 /* Maximum allowed depth in Lisp evaluations and function calls. */
82 EMACS_INT max_lisp_eval_depth
;
84 /* Nonzero means enter debugger before next function call */
86 int debug_on_next_call
;
88 /* Non-zero means debugger may continue. This is zero when the
89 debugger is called during redisplay, where it might not be safe to
90 continue the interrupted redisplay. */
92 int debugger_may_continue
;
94 /* List of conditions (non-nil atom means all) which cause a backtrace
95 if an error is handled by the command loop's error handler. */
97 Lisp_Object impl_Vstack_trace_on_error
;
99 /* List of conditions (non-nil atom means all) which enter the debugger
100 if an error is handled by the command loop's error handler. */
102 Lisp_Object impl_Vdebug_on_error
;
104 /* List of conditions and regexps specifying error messages which
105 do not enter the debugger even if Vdebug_on_error says they should. */
107 Lisp_Object impl_Vdebug_ignored_errors
;
109 /* Non-nil means call the debugger even if the error will be handled. */
111 Lisp_Object impl_Vdebug_on_signal
;
113 /* Hook for edebug to use. */
115 Lisp_Object impl_Vsignal_hook_function
;
117 /* Nonzero means enter debugger if a quit signal
118 is handled by the command loop's error handler. */
122 /* The value of num_nonmacro_input_events as of the last time we
123 started to enter the debugger. If we decide to enter the debugger
124 again when this is still equal to num_nonmacro_input_events, then we
125 know that the debugger itself has an error, and we should just
126 signal the error instead of entering an infinite loop of debugger
129 int when_entered_debugger
;
131 Lisp_Object impl_Vdebugger
;
133 /* The function from which the last `signal' was called. Set in
136 Lisp_Object Vsignaling_function
;
138 /* Set to non-zero while processing X events. Checked in Feval to
139 make sure the Lisp interpreter isn't called from a signal handler,
140 which is unsafe because the interpreter isn't reentrant. */
144 /* Function to process declarations in defmacro forms. */
146 Lisp_Object impl_Vmacro_declaration_function
;
148 extern Lisp_Object Qrisky_local_variable
;
150 extern Lisp_Object Qfunction
;
152 static Lisp_Object funcall_lambda
P_ ((Lisp_Object
, int, Lisp_Object
*));
153 static void unwind_to_catch
P_ ((struct catchtag
*, Lisp_Object
)) NO_RETURN
;
156 /* "gcc -O3" enables automatic function inlining, which optimizes out
157 the arguments for the invocations of these functions, whereas they
158 expect these values on the stack. */
159 Lisp_Object
apply1 () __attribute__((noinline
));
160 Lisp_Object
call2 () __attribute__((noinline
));
167 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
168 specpdl_ptr
= specpdl
;
169 /* Don't forget to update docs (lispref node "Local Variables"). */
170 max_specpdl_size
= 1000;
171 max_lisp_eval_depth
= 500;
179 specpdl_ptr
= specpdl
;
184 debug_on_next_call
= 0;
189 /* This is less than the initial value of num_nonmacro_input_events. */
190 when_entered_debugger
= -1;
194 mark_catchlist (struct catchtag
*catch)
196 for (; catch; catch = catch->next
)
198 mark_object (catch->tag
);
199 mark_object (catch->val
);
203 /* unwind-protect function used by call_debugger. */
206 restore_stack_limits (data
)
209 max_specpdl_size
= XINT (XCAR (data
));
210 max_lisp_eval_depth
= XINT (XCDR (data
));
214 /* Call the Lisp debugger, giving it argument ARG. */
220 int debug_while_redisplaying
;
221 int count
= SPECPDL_INDEX ();
223 int old_max
= max_specpdl_size
;
225 /* Temporarily bump up the stack limits,
226 so the debugger won't run out of stack. */
228 max_specpdl_size
+= 1;
229 record_unwind_protect (restore_stack_limits
,
230 Fcons (make_number (old_max
),
231 make_number (max_lisp_eval_depth
)));
232 max_specpdl_size
= old_max
;
234 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
235 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
237 if (SPECPDL_INDEX () + 100 > max_specpdl_size
)
238 max_specpdl_size
= SPECPDL_INDEX () + 100;
240 #ifdef HAVE_WINDOW_SYSTEM
241 if (display_hourglass_p
)
245 debug_on_next_call
= 0;
246 when_entered_debugger
= num_nonmacro_input_events
;
248 /* Resetting redisplaying_p to 0 makes sure that debug output is
249 displayed if the debugger is invoked during redisplay. */
250 debug_while_redisplaying
= redisplaying_p
;
252 specbind (intern ("debugger-may-continue"),
253 debug_while_redisplaying
? Qnil
: Qt
);
254 specbind (Qinhibit_redisplay
, Qnil
);
255 specbind (Qdebug_on_error
, Qnil
);
257 #if 0 /* Binding this prevents execution of Lisp code during
258 redisplay, which necessarily leads to display problems. */
259 specbind (Qinhibit_eval_during_redisplay
, Qt
);
262 val
= apply1 (Vdebugger
, arg
);
264 /* Interrupting redisplay and resuming it later is not safe under
265 all circumstances. So, when the debugger returns, abort the
266 interrupted redisplay by going back to the top-level. */
267 if (debug_while_redisplaying
)
270 return unbind_to (count
, val
);
274 do_debug_on_call (code
)
277 debug_on_next_call
= 0;
278 backtrace_list
->debug_on_exit
= 1;
279 call_debugger (Fcons (code
, Qnil
));
282 /* NOTE!!! Every function that can call EVAL must protect its args
283 and temporaries from garbage collection while it needs them.
284 The definition of `For' shows what you have to do. */
286 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
287 doc
: /* Eval args until one of them yields non-nil, then return that value.
288 The remaining args are not evalled at all.
289 If all args return nil, return nil.
290 usage: (or CONDITIONS...) */)
294 register Lisp_Object val
= Qnil
;
301 val
= Feval (XCAR (args
));
311 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
312 doc
: /* Eval args until one of them yields nil, then return nil.
313 The remaining args are not evalled at all.
314 If no arg yields nil, return the last arg's value.
315 usage: (and CONDITIONS...) */)
319 register Lisp_Object val
= Qt
;
326 val
= Feval (XCAR (args
));
336 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
337 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
338 Returns the value of THEN or the value of the last of the ELSE's.
339 THEN must be one expression, but ELSE... can be zero or more expressions.
340 If COND yields nil, and there are no ELSE's, the value is nil.
341 usage: (if COND THEN ELSE...) */)
345 register Lisp_Object cond
;
349 cond
= Feval (Fcar (args
));
353 return Feval (Fcar (Fcdr (args
)));
354 return Fprogn (Fcdr (Fcdr (args
)));
357 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
358 doc
: /* Try each clause until one succeeds.
359 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
360 and, if the value is non-nil, this clause succeeds:
361 then the expressions in BODY are evaluated and the last one's
362 value is the value of the cond-form.
363 If no clause succeeds, cond returns nil.
364 If a clause has one element, as in (CONDITION),
365 CONDITION's value if non-nil is returned from the cond-form.
366 usage: (cond CLAUSES...) */)
370 register Lisp_Object clause
, val
;
377 clause
= Fcar (args
);
378 val
= Feval (Fcar (clause
));
381 if (!EQ (XCDR (clause
), Qnil
))
382 val
= Fprogn (XCDR (clause
));
392 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
393 doc
: /* Eval BODY forms sequentially and return value of last one.
394 usage: (progn BODY...) */)
398 register Lisp_Object val
= Qnil
;
405 val
= Feval (XCAR (args
));
413 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
414 doc
: /* Eval FIRST and BODY sequentially; return value from FIRST.
415 The value of FIRST is saved during the evaluation of the remaining args,
416 whose values are discarded.
417 usage: (prog1 FIRST BODY...) */)
422 register Lisp_Object args_left
;
423 struct gcpro gcpro1
, gcpro2
;
424 register int argnum
= 0;
436 val
= Feval (Fcar (args_left
));
438 Feval (Fcar (args_left
));
439 args_left
= Fcdr (args_left
);
441 while (!NILP(args_left
));
447 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
448 doc
: /* Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
449 The value of FORM2 is saved during the evaluation of the
450 remaining args, whose values are discarded.
451 usage: (prog2 FORM1 FORM2 BODY...) */)
456 register Lisp_Object args_left
;
457 struct gcpro gcpro1
, gcpro2
;
458 register int argnum
= -1;
472 val
= Feval (Fcar (args_left
));
474 Feval (Fcar (args_left
));
475 args_left
= Fcdr (args_left
);
477 while (!NILP (args_left
));
483 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
484 doc
: /* Set each SYM to the value of its VAL.
485 The symbols SYM are variables; they are literal (not evaluated).
486 The values VAL are expressions; they are evaluated.
487 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
488 The second VAL is not computed until after the first SYM is set, and so on;
489 each VAL can use the new value of variables set earlier in the `setq'.
490 The return value of the `setq' form is the value of the last VAL.
491 usage: (setq [SYM VAL]...) */)
495 register Lisp_Object args_left
;
496 register Lisp_Object val
, sym
;
507 val
= Feval (Fcar (Fcdr (args_left
)));
508 sym
= Fcar (args_left
);
510 args_left
= Fcdr (Fcdr (args_left
));
512 while (!NILP(args_left
));
518 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
519 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
520 usage: (quote ARG) */)
524 if (!NILP (Fcdr (args
)))
525 xsignal2 (Qwrong_number_of_arguments
, Qquote
, Flength (args
));
529 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
530 doc
: /* Like `quote', but preferred for objects which are functions.
531 In byte compilation, `function' causes its argument to be compiled.
532 `quote' cannot do that.
533 usage: (function ARG) */)
537 if (!NILP (Fcdr (args
)))
538 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
543 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
544 doc
: /* Return t if the containing function was run directly by user input.
545 This means that the function was called with `call-interactively'
546 \(which includes being called as the binding of a key)
547 and input is currently coming from the keyboard (not a keyboard macro),
548 and Emacs is not running in batch mode (`noninteractive' is nil).
550 The only known proper use of `interactive-p' is in deciding whether to
551 display a helpful message, or how to display it. If you're thinking
552 of using it for any other purpose, it is quite likely that you're
553 making a mistake. Think: what do you want to do when the command is
554 called from a keyboard macro?
556 To test whether your function was called with `call-interactively',
557 either (i) add an extra optional argument and give it an `interactive'
558 spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
559 use `called-interactively-p'. */)
562 return (INTERACTIVE
&& interactive_p (1)) ? Qt
: Qnil
;
566 DEFUN ("called-interactively-p", Fcalled_interactively_p
, Scalled_interactively_p
, 0, 1, 0,
567 doc
: /* Return t if the containing function was called by `call-interactively'.
568 If KIND is `interactive', then only return t if the call was made
569 interactively by the user, i.e. not in `noninteractive' mode nor
570 when `executing-kbd-macro'.
571 If KIND is `any', on the other hand, it will return t for any kind of
572 interactive call, including being called as the binding of a key, or
573 from a keyboard macro, or in `noninteractive' mode.
575 The only known proper use of `interactive' for KIND is in deciding
576 whether to display a helpful message, or how to display it. If you're
577 thinking of using it for any other purpose, it is quite likely that
578 you're making a mistake. Think: what do you want to do when the
579 command is called from a keyboard macro?
581 This function is meant for implementing advice and other
582 function-modifying features. Instead of using this, it is sometimes
583 cleaner to give your function an extra optional argument whose
584 `interactive' spec specifies non-nil unconditionally (\"p\" is a good
585 way to do this), or via (not (or executing-kbd-macro noninteractive)). */)
589 return ((INTERACTIVE
|| !EQ (kind
, intern ("interactive")))
590 && interactive_p (1)) ? Qt
: Qnil
;
594 /* Return 1 if function in which this appears was called using
597 EXCLUDE_SUBRS_P non-zero means always return 0 if the function
598 called is a built-in. */
601 interactive_p (exclude_subrs_p
)
604 struct backtrace
*btp
;
607 btp
= backtrace_list
;
609 /* If this isn't a byte-compiled function, there may be a frame at
610 the top for Finteractive_p. If so, skip it. */
611 fun
= Findirect_function (*btp
->function
, Qnil
);
612 if (SUBRP (fun
) && (XSUBR (fun
) == &Sinteractive_p
613 || XSUBR (fun
) == &Scalled_interactively_p
))
616 /* If we're running an Emacs 18-style byte-compiled function, there
617 may be a frame for Fbytecode at the top level. In any version of
618 Emacs there can be Fbytecode frames for subexpressions evaluated
619 inside catch and condition-case. Skip past them.
621 If this isn't a byte-compiled function, then we may now be
622 looking at several frames for special forms. Skip past them. */
624 && (EQ (*btp
->function
, Qbytecode
)
625 || btp
->nargs
== UNEVALLED
))
628 /* btp now points at the frame of the innermost function that isn't
629 a special form, ignoring frames for Finteractive_p and/or
630 Fbytecode at the top. If this frame is for a built-in function
631 (such as load or eval-region) return nil. */
632 fun
= Findirect_function (*btp
->function
, Qnil
);
633 if (exclude_subrs_p
&& SUBRP (fun
))
636 /* btp points to the frame of a Lisp function that called interactive-p.
637 Return t if that function was called interactively. */
638 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
644 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
645 doc
: /* Define NAME as a function.
646 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
647 See also the function `interactive'.
648 usage: (defun NAME ARGLIST [DOCSTRING] BODY...) */)
652 register Lisp_Object fn_name
;
653 register Lisp_Object defn
;
655 fn_name
= Fcar (args
);
656 CHECK_SYMBOL (fn_name
);
657 defn
= Fcons (Qlambda
, Fcdr (args
));
658 if (!NILP (Vpurify_flag
))
659 defn
= Fpurecopy (defn
);
660 if (CONSP (XSYMBOL (fn_name
)->function
)
661 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
662 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
663 Ffset (fn_name
, defn
);
664 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
668 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
669 doc
: /* Define NAME as a macro.
670 The actual definition looks like
671 (macro lambda ARGLIST [DOCSTRING] [DECL] BODY...).
672 When the macro is called, as in (NAME ARGS...),
673 the function (lambda ARGLIST BODY...) is applied to
674 the list ARGS... as it appears in the expression,
675 and the result should be a form to be evaluated instead of the original.
677 DECL is a declaration, optional, which can specify how to indent
678 calls to this macro, how Edebug should handle it, and which argument
679 should be treated as documentation. It looks like this:
681 The elements can look like this:
683 Set NAME's `lisp-indent-function' property to INDENT.
686 Set NAME's `edebug-form-spec' property to DEBUG. (This is
687 equivalent to writing a `def-edebug-spec' for the macro.)
690 Set NAME's `doc-string-elt' property to ELT.
692 usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */)
696 register Lisp_Object fn_name
;
697 register Lisp_Object defn
;
698 Lisp_Object lambda_list
, doc
, tail
;
700 fn_name
= Fcar (args
);
701 CHECK_SYMBOL (fn_name
);
702 lambda_list
= Fcar (Fcdr (args
));
703 tail
= Fcdr (Fcdr (args
));
706 if (STRINGP (Fcar (tail
)))
712 while (CONSP (Fcar (tail
))
713 && EQ (Fcar (Fcar (tail
)), Qdeclare
))
715 if (!NILP (Vmacro_declaration_function
))
719 call2 (Vmacro_declaration_function
, fn_name
, Fcar (tail
));
727 tail
= Fcons (lambda_list
, tail
);
729 tail
= Fcons (lambda_list
, Fcons (doc
, tail
));
730 defn
= Fcons (Qmacro
, Fcons (Qlambda
, tail
));
732 if (!NILP (Vpurify_flag
))
733 defn
= Fpurecopy (defn
);
734 if (CONSP (XSYMBOL (fn_name
)->function
)
735 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
736 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
737 Ffset (fn_name
, defn
);
738 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
743 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
744 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
745 Aliased variables always have the same value; setting one sets the other.
746 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
747 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
748 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
749 itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
750 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
751 The return value is BASE-VARIABLE. */)
752 (new_alias
, base_variable
, docstring
)
753 Lisp_Object new_alias
, base_variable
, docstring
;
755 struct Lisp_Symbol
*sym
;
757 CHECK_SYMBOL (new_alias
);
758 CHECK_SYMBOL (base_variable
);
760 if (SYMBOL_CONSTANT_P (new_alias
))
761 error ("Cannot make a constant an alias");
763 sym
= XSYMBOL (new_alias
);
764 /* http://lists.gnu.org/archive/html/emacs-devel/2008-04/msg00834.html
765 If n_a is bound, but b_v is not, set the value of b_v to n_a.
766 This is for the sake of define-obsolete-variable-alias and user
768 if (NILP (Fboundp (base_variable
)) && !NILP (Fboundp (new_alias
)))
769 XSYMBOL(base_variable
)->value
= sym
->value
;
770 sym
->indirect_variable
= 1;
771 sym
->value
= base_variable
;
772 sym
->constant
= SYMBOL_CONSTANT_P (base_variable
);
773 LOADHIST_ATTACH (new_alias
);
774 if (!NILP (docstring
))
775 Fput (new_alias
, Qvariable_documentation
, docstring
);
777 Fput (new_alias
, Qvariable_documentation
, Qnil
);
779 return base_variable
;
783 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
784 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
785 You are not required to define a variable in order to use it,
786 but the definition can supply documentation and an initial value
787 in a way that tags can recognize.
789 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.
790 If SYMBOL is buffer-local, its default value is what is set;
791 buffer-local values are not affected.
792 INITVALUE and DOCSTRING are optional.
793 If DOCSTRING starts with *, this variable is identified as a user option.
794 This means that M-x set-variable recognizes it.
795 See also `user-variable-p'.
796 If INITVALUE is missing, SYMBOL's value is not set.
798 If SYMBOL has a local binding, then this form affects the local
799 binding. This is usually not what you want. Thus, if you need to
800 load a file defining variables, with this form or with `defconst' or
801 `defcustom', you should always load that file _outside_ any bindings
802 for these variables. \(`defconst' and `defcustom' behave similarly in
804 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
808 register Lisp_Object sym
, tem
, tail
;
812 if (!NILP (Fcdr (Fcdr (tail
))))
813 error ("Too many arguments");
815 tem
= Fdefault_boundp (sym
);
818 if (SYMBOL_CONSTANT_P (sym
))
820 /* For upward compatibility, allow (defvar :foo (quote :foo)). */
821 Lisp_Object tem
= Fcar (tail
);
823 && EQ (XCAR (tem
), Qquote
)
824 && CONSP (XCDR (tem
))
825 && EQ (XCAR (XCDR (tem
)), sym
)))
826 error ("Constant symbol `%s' specified in defvar",
827 SDATA (SYMBOL_NAME (sym
)));
831 Fset_default (sym
, Feval (Fcar (tail
)));
833 { /* Check if there is really a global binding rather than just a let
834 binding that shadows the global unboundness of the var. */
835 volatile struct specbinding
*pdl
= specpdl_ptr
;
836 while (--pdl
>= specpdl
)
838 if (EQ (pdl
->symbol
, sym
) && !pdl
->func
839 && EQ (pdl
->old_value
, Qunbound
))
841 message_with_string ("Warning: defvar ignored because %s is let-bound",
842 SYMBOL_NAME (sym
), 1);
851 if (!NILP (Vpurify_flag
))
852 tem
= Fpurecopy (tem
);
853 Fput (sym
, Qvariable_documentation
, tem
);
855 LOADHIST_ATTACH (sym
);
858 /* Simple (defvar <var>) should not count as a definition at all.
859 It could get in the way of other definitions, and unloading this
860 package could try to make the variable unbound. */
866 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
867 doc
: /* Define SYMBOL as a constant variable.
868 The intent is that neither programs nor users should ever change this value.
869 Always sets the value of SYMBOL to the result of evalling INITVALUE.
870 If SYMBOL is buffer-local, its default value is what is set;
871 buffer-local values are not affected.
872 DOCSTRING is optional.
874 If SYMBOL has a local binding, then this form sets the local binding's
875 value. However, you should normally not make local bindings for
876 variables defined with this form.
877 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
881 register Lisp_Object sym
, tem
;
884 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
885 error ("Too many arguments");
887 tem
= Feval (Fcar (Fcdr (args
)));
888 if (!NILP (Vpurify_flag
))
889 tem
= Fpurecopy (tem
);
890 Fset_default (sym
, tem
);
891 tem
= Fcar (Fcdr (Fcdr (args
)));
894 if (!NILP (Vpurify_flag
))
895 tem
= Fpurecopy (tem
);
896 Fput (sym
, Qvariable_documentation
, tem
);
898 Fput (sym
, Qrisky_local_variable
, Qt
);
899 LOADHIST_ATTACH (sym
);
903 /* Error handler used in Fuser_variable_p. */
905 user_variable_p_eh (ignore
)
912 lisp_indirect_variable (Lisp_Object sym
)
914 XSETSYMBOL (sym
, indirect_variable (XSYMBOL (sym
)));
918 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
919 doc
: /* Return t if VARIABLE is intended to be set and modified by users.
920 \(The alternative is a variable used internally in a Lisp program.)
921 A variable is a user variable if
922 \(1) the first character of its documentation is `*', or
923 \(2) it is customizable (its property list contains a non-nil value
924 of `standard-value' or `custom-autoload'), or
925 \(3) it is an alias for another user variable.
926 Return nil if VARIABLE is an alias and there is a loop in the
927 chain of symbols. */)
929 Lisp_Object variable
;
931 Lisp_Object documentation
;
933 if (!SYMBOLP (variable
))
936 /* If indirect and there's an alias loop, don't check anything else. */
937 if (XSYMBOL (variable
)->indirect_variable
938 && NILP (internal_condition_case_1 (lisp_indirect_variable
, variable
,
939 Qt
, user_variable_p_eh
)))
944 documentation
= Fget (variable
, Qvariable_documentation
);
945 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
947 if (STRINGP (documentation
)
948 && ((unsigned char) SREF (documentation
, 0) == '*'))
950 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
951 if (CONSP (documentation
)
952 && STRINGP (XCAR (documentation
))
953 && INTEGERP (XCDR (documentation
))
954 && XINT (XCDR (documentation
)) < 0)
956 /* Customizable? See `custom-variable-p'. */
957 if ((!NILP (Fget (variable
, intern ("standard-value"))))
958 || (!NILP (Fget (variable
, intern ("custom-autoload")))))
961 if (!XSYMBOL (variable
)->indirect_variable
)
964 /* An indirect variable? Let's follow the chain. */
965 variable
= XSYMBOL (variable
)->value
;
969 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
970 doc
: /* Bind variables according to VARLIST then eval BODY.
971 The value of the last form in BODY is returned.
972 Each element of VARLIST is a symbol (which is bound to nil)
973 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
974 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
975 usage: (let* VARLIST BODY...) */)
979 Lisp_Object varlist
, val
, elt
;
980 int count
= SPECPDL_INDEX ();
981 struct gcpro gcpro1
, gcpro2
, gcpro3
;
983 GCPRO3 (args
, elt
, varlist
);
985 varlist
= Fcar (args
);
986 while (!NILP (varlist
))
989 elt
= Fcar (varlist
);
991 specbind (elt
, Qnil
);
992 else if (! NILP (Fcdr (Fcdr (elt
))))
993 signal_error ("`let' bindings can have only one value-form", elt
);
996 val
= Feval (Fcar (Fcdr (elt
)));
997 specbind (Fcar (elt
), val
);
999 varlist
= Fcdr (varlist
);
1002 val
= Fprogn (Fcdr (args
));
1003 return unbind_to (count
, val
);
1006 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
1007 doc
: /* Bind variables according to VARLIST then eval BODY.
1008 The value of the last form in BODY is returned.
1009 Each element of VARLIST is a symbol (which is bound to nil)
1010 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
1011 All the VALUEFORMs are evalled before any symbols are bound.
1012 usage: (let VARLIST BODY...) */)
1016 Lisp_Object
*temps
, tem
;
1017 register Lisp_Object elt
, varlist
;
1018 int count
= SPECPDL_INDEX ();
1019 register int argnum
;
1020 struct gcpro gcpro1
, gcpro2
;
1022 varlist
= Fcar (args
);
1024 /* Make space to hold the values to give the bound variables */
1025 elt
= Flength (varlist
);
1026 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
1028 /* Compute the values and store them in `temps' */
1030 GCPRO2 (args
, *temps
);
1033 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
1036 elt
= XCAR (varlist
);
1038 temps
[argnum
++] = Qnil
;
1039 else if (! NILP (Fcdr (Fcdr (elt
))))
1040 signal_error ("`let' bindings can have only one value-form", elt
);
1042 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
1043 gcpro2
.nvars
= argnum
;
1047 varlist
= Fcar (args
);
1048 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
1050 elt
= XCAR (varlist
);
1051 tem
= temps
[argnum
++];
1053 specbind (elt
, tem
);
1055 specbind (Fcar (elt
), tem
);
1058 elt
= Fprogn (Fcdr (args
));
1059 return unbind_to (count
, elt
);
1062 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
1063 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
1064 The order of execution is thus TEST, BODY, TEST, BODY and so on
1065 until TEST returns nil.
1066 usage: (while TEST BODY...) */)
1070 Lisp_Object test
, body
;
1071 struct gcpro gcpro1
, gcpro2
;
1073 GCPRO2 (test
, body
);
1077 while (!NILP (Feval (test
)))
1087 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
1088 doc
: /* Return result of expanding macros at top level of FORM.
1089 If FORM is not a macro call, it is returned unchanged.
1090 Otherwise, the macro is expanded and the expansion is considered
1091 in place of FORM. When a non-macro-call results, it is returned.
1093 The second optional arg ENVIRONMENT specifies an environment of macro
1094 definitions to shadow the loaded ones for use in file byte-compilation. */)
1097 Lisp_Object environment
;
1099 /* With cleanups from Hallvard Furuseth. */
1100 register Lisp_Object expander
, sym
, def
, tem
;
1104 /* Come back here each time we expand a macro call,
1105 in case it expands into another macro call. */
1108 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1109 def
= sym
= XCAR (form
);
1111 /* Trace symbols aliases to other symbols
1112 until we get a symbol that is not an alias. */
1113 while (SYMBOLP (def
))
1117 tem
= Fassq (sym
, environment
);
1120 def
= XSYMBOL (sym
)->function
;
1121 if (!EQ (def
, Qunbound
))
1126 /* Right now TEM is the result from SYM in ENVIRONMENT,
1127 and if TEM is nil then DEF is SYM's function definition. */
1130 /* SYM is not mentioned in ENVIRONMENT.
1131 Look at its function definition. */
1132 if (EQ (def
, Qunbound
) || !CONSP (def
))
1133 /* Not defined or definition not suitable */
1135 if (EQ (XCAR (def
), Qautoload
))
1137 /* Autoloading function: will it be a macro when loaded? */
1138 tem
= Fnth (make_number (4), def
);
1139 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
1140 /* Yes, load it and try again. */
1142 struct gcpro gcpro1
;
1144 do_autoload (def
, sym
);
1151 else if (!EQ (XCAR (def
), Qmacro
))
1153 else expander
= XCDR (def
);
1157 expander
= XCDR (tem
);
1158 if (NILP (expander
))
1161 form
= apply1 (expander
, XCDR (form
));
1166 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1167 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1168 TAG is evalled to get the tag to use; it must not be nil.
1170 Then the BODY is executed.
1171 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
1172 If no throw happens, `catch' returns the value of the last BODY form.
1173 If a throw happens, it specifies the value to return from `catch'.
1174 usage: (catch TAG BODY...) */)
1178 register Lisp_Object tag
;
1179 struct gcpro gcpro1
;
1182 tag
= Feval (Fcar (args
));
1184 return internal_catch (tag
, Fprogn
, Fcdr (args
));
1187 /* Set up a catch, then call C function FUNC on argument ARG.
1188 FUNC should return a Lisp_Object.
1189 This is how catches are done from within C code. */
1192 internal_catch (tag
, func
, arg
)
1194 Lisp_Object (*func
) ();
1197 /* This structure is made part of the chain `catchlist'. */
1200 /* Fill in the components of c, and put it on the list. */
1204 c
.backlist
= backtrace_list
;
1205 c
.m_handlerlist
= handlerlist
;
1206 c
.m_lisp_eval_depth
= lisp_eval_depth
;
1207 c
.pdlcount
= SPECPDL_INDEX ();
1208 c
.poll_suppress_count
= poll_suppress_count
;
1209 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1210 c
.gcpro
= gcprolist
;
1211 c
.byte_stack
= byte_stack_list
;
1215 if (! _setjmp (c
.jmp
))
1216 c
.val
= (*func
) (arg
);
1218 /* Throw works by a longjmp that comes right here. */
1223 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1224 jump to that CATCH, returning VALUE as the value of that catch.
1226 This is the guts Fthrow and Fsignal; they differ only in the way
1227 they choose the catch tag to throw to. A catch tag for a
1228 condition-case form has a TAG of Qnil.
1230 Before each catch is discarded, unbind all special bindings and
1231 execute all unwind-protect clauses made above that catch. Unwind
1232 the handler stack as we go, so that the proper handlers are in
1233 effect for each unwind-protect clause we run. At the end, restore
1234 some static info saved in CATCH, and longjmp to the location
1237 This is used for correct unwinding in Fthrow and Fsignal. */
1240 unwind_to_catch (catch, value
)
1241 struct catchtag
*catch;
1244 register int last_time
;
1246 /* Save the value in the tag. */
1249 /* Restore certain special C variables. */
1250 set_poll_suppress_count (catch->poll_suppress_count
);
1251 UNBLOCK_INPUT_TO (catch->interrupt_input_blocked
);
1252 handling_signal
= 0;
1257 last_time
= catchlist
== catch;
1259 /* Unwind the specpdl stack, and then restore the proper set of
1261 unbind_to (catchlist
->pdlcount
, Qnil
);
1262 handlerlist
= catchlist
->m_handlerlist
;
1263 catchlist
= catchlist
->next
;
1265 while (! last_time
);
1268 /* If x_catch_errors was done, turn it off now.
1269 (First we give unbind_to a chance to do that.) */
1270 #if 0 /* This would disable x_catch_errors after x_connection_closed.
1271 * The catch must remain in effect during that delicate
1272 * state. --lorentey */
1273 x_fully_uncatch_errors ();
1277 byte_stack_list
= catch->byte_stack
;
1278 gcprolist
= catch->gcpro
;
1281 gcpro_level
= gcprolist
->level
+ 1;
1285 backtrace_list
= catch->backlist
;
1286 lisp_eval_depth
= catch->m_lisp_eval_depth
;
1288 _longjmp (catch->jmp
, 1);
1291 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1292 doc
: /* Throw to the catch for TAG and return VALUE from it.
1293 Both TAG and VALUE are evalled. */)
1295 register Lisp_Object tag
, value
;
1297 register struct catchtag
*c
;
1300 for (c
= catchlist
; c
; c
= c
->next
)
1302 if (EQ (c
->tag
, tag
))
1303 unwind_to_catch (c
, value
);
1305 xsignal2 (Qno_catch
, tag
, value
);
1309 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1310 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1311 If BODYFORM completes normally, its value is returned
1312 after executing the UNWINDFORMS.
1313 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1314 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1319 int count
= SPECPDL_INDEX ();
1321 record_unwind_protect (Fprogn
, Fcdr (args
));
1322 val
= Feval (Fcar (args
));
1323 return unbind_to (count
, val
);
1326 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1327 doc
: /* Regain control when an error is signaled.
1328 Executes BODYFORM and returns its value if no error happens.
1329 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1330 where the BODY is made of Lisp expressions.
1332 A handler is applicable to an error
1333 if CONDITION-NAME is one of the error's condition names.
1334 If an error happens, the first applicable handler is run.
1336 The car of a handler may be a list of condition names
1337 instead of a single condition name. Then it handles all of them.
1339 When a handler handles an error, control returns to the `condition-case'
1340 and it executes the handler's BODY...
1341 with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
1342 (If VAR is nil, the handler can't access that information.)
1343 Then the value of the last BODY form is returned from the `condition-case'
1346 See also the function `signal' for more info.
1347 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1351 register Lisp_Object bodyform
, handlers
;
1352 volatile Lisp_Object var
;
1355 bodyform
= Fcar (Fcdr (args
));
1356 handlers
= Fcdr (Fcdr (args
));
1358 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1361 /* Like Fcondition_case, but the args are separate
1362 rather than passed in a list. Used by Fbyte_code. */
1365 internal_lisp_condition_case (var
, bodyform
, handlers
)
1366 volatile Lisp_Object var
;
1367 Lisp_Object bodyform
, handlers
;
1375 for (val
= handlers
; CONSP (val
); val
= XCDR (val
))
1381 && (SYMBOLP (XCAR (tem
))
1382 || CONSP (XCAR (tem
))))))
1383 error ("Invalid condition handler", tem
);
1388 c
.backlist
= backtrace_list
;
1389 c
.m_handlerlist
= handlerlist
;
1390 c
.m_lisp_eval_depth
= lisp_eval_depth
;
1391 c
.pdlcount
= SPECPDL_INDEX ();
1392 c
.poll_suppress_count
= poll_suppress_count
;
1393 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1394 c
.gcpro
= gcprolist
;
1395 c
.byte_stack
= byte_stack_list
;
1396 if (_setjmp (c
.jmp
))
1399 specbind (h
.var
, c
.val
);
1400 val
= Fprogn (Fcdr (h
.chosen_clause
));
1402 /* Note that this just undoes the binding of h.var; whoever
1403 longjumped to us unwound the stack to c.pdlcount before
1405 unbind_to (c
.pdlcount
, Qnil
);
1412 h
.handler
= handlers
;
1413 h
.next
= handlerlist
;
1417 val
= Feval (bodyform
);
1419 handlerlist
= h
.next
;
1423 /* Call the function BFUN with no arguments, catching errors within it
1424 according to HANDLERS. If there is an error, call HFUN with
1425 one argument which is the data that describes the error:
1428 HANDLERS can be a list of conditions to catch.
1429 If HANDLERS is Qt, catch all errors.
1430 If HANDLERS is Qerror, catch all errors
1431 but allow the debugger to run if that is enabled. */
1434 internal_condition_case (bfun
, handlers
, hfun
)
1435 Lisp_Object (*bfun
) ();
1436 Lisp_Object handlers
;
1437 Lisp_Object (*hfun
) ();
1443 /* Since Fsignal will close off all calls to x_catch_errors,
1444 we will get the wrong results if some are not closed now. */
1446 if (x_catching_errors ())
1452 c
.backlist
= backtrace_list
;
1453 c
.m_handlerlist
= handlerlist
;
1454 c
.m_lisp_eval_depth
= lisp_eval_depth
;
1455 c
.pdlcount
= SPECPDL_INDEX ();
1456 c
.poll_suppress_count
= poll_suppress_count
;
1457 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1458 c
.gcpro
= gcprolist
;
1459 c
.byte_stack
= byte_stack_list
;
1460 if (_setjmp (c
.jmp
))
1462 return (*hfun
) (c
.val
);
1466 h
.handler
= handlers
;
1468 h
.next
= handlerlist
;
1474 handlerlist
= h
.next
;
1478 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1481 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1482 Lisp_Object (*bfun
) ();
1484 Lisp_Object handlers
;
1485 Lisp_Object (*hfun
) ();
1491 /* Since Fsignal will close off all calls to x_catch_errors,
1492 we will get the wrong results if some are not closed now. */
1494 if (x_catching_errors ())
1500 c
.backlist
= backtrace_list
;
1501 c
.m_handlerlist
= handlerlist
;
1502 c
.m_lisp_eval_depth
= lisp_eval_depth
;
1503 c
.pdlcount
= SPECPDL_INDEX ();
1504 c
.poll_suppress_count
= poll_suppress_count
;
1505 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1506 c
.gcpro
= gcprolist
;
1507 c
.byte_stack
= byte_stack_list
;
1508 if (_setjmp (c
.jmp
))
1510 return (*hfun
) (c
.val
);
1514 h
.handler
= handlers
;
1516 h
.next
= handlerlist
;
1520 val
= (*bfun
) (arg
);
1522 handlerlist
= h
.next
;
1527 /* Like internal_condition_case but call BFUN with NARGS as first,
1528 and ARGS as second argument. */
1531 internal_condition_case_2 (bfun
, nargs
, args
, handlers
, hfun
)
1532 Lisp_Object (*bfun
) ();
1535 Lisp_Object handlers
;
1536 Lisp_Object (*hfun
) ();
1542 /* Since Fsignal will close off all calls to x_catch_errors,
1543 we will get the wrong results if some are not closed now. */
1545 if (x_catching_errors ())
1551 c
.backlist
= backtrace_list
;
1552 c
.m_handlerlist
= handlerlist
;
1553 c
.m_lisp_eval_depth
= lisp_eval_depth
;
1554 c
.pdlcount
= SPECPDL_INDEX ();
1555 c
.poll_suppress_count
= poll_suppress_count
;
1556 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1557 c
.gcpro
= gcprolist
;
1558 c
.byte_stack
= byte_stack_list
;
1559 if (_setjmp (c
.jmp
))
1561 return (*hfun
) (c
.val
);
1565 h
.handler
= handlers
;
1567 h
.next
= handlerlist
;
1571 val
= (*bfun
) (nargs
, args
);
1573 handlerlist
= h
.next
;
1578 static Lisp_Object find_handler_clause
P_ ((Lisp_Object
, Lisp_Object
,
1579 Lisp_Object
, Lisp_Object
));
1581 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1582 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1583 This function does not return.
1585 An error symbol is a symbol with an `error-conditions' property
1586 that is a list of condition names.
1587 A handler for any of those names will get to handle this signal.
1588 The symbol `error' should normally be one of them.
1590 DATA should be a list. Its elements are printed as part of the error message.
1591 See Info anchor `(elisp)Definition of signal' for some details on how this
1592 error message is constructed.
1593 If the signal is handled, DATA is made available to the handler.
1594 See also the function `condition-case'. */)
1595 (error_symbol
, data
)
1596 Lisp_Object error_symbol
, data
;
1598 /* When memory is full, ERROR-SYMBOL is nil,
1599 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1600 That is a special case--don't do this in other situations. */
1601 register struct handler
*allhandlers
= handlerlist
;
1602 Lisp_Object conditions
;
1603 extern int gc_in_progress
;
1604 extern int waiting_for_input
;
1606 Lisp_Object real_error_symbol
;
1607 struct backtrace
*bp
;
1609 immediate_quit
= handling_signal
= 0;
1611 /* How handle waiting_for_input? -- giuseppe*/
1612 if (gc_in_progress
/*|| waiting_for_input*/)
1615 if (NILP (error_symbol
))
1616 real_error_symbol
= Fcar (data
);
1618 real_error_symbol
= error_symbol
;
1620 #if 0 /* rms: I don't know why this was here,
1621 but it is surely wrong for an error that is handled. */
1622 #ifdef HAVE_WINDOW_SYSTEM
1623 if (display_hourglass_p
)
1624 cancel_hourglass ();
1628 /* This hook is used by edebug. */
1629 if (! NILP (Vsignal_hook_function
)
1630 && ! NILP (error_symbol
))
1632 /* Edebug takes care of restoring these variables when it exits. */
1633 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1634 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1636 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1637 max_specpdl_size
= SPECPDL_INDEX () + 40;
1639 call2 (Vsignal_hook_function
, error_symbol
, data
);
1642 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1644 /* Remember from where signal was called. Skip over the frame for
1645 `signal' itself. If a frame for `error' follows, skip that,
1646 too. Don't do this when ERROR_SYMBOL is nil, because that
1647 is a memory-full error. */
1648 Vsignaling_function
= Qnil
;
1649 if (backtrace_list
&& !NILP (error_symbol
))
1651 bp
= backtrace_list
->next
;
1652 if (bp
&& bp
->function
&& EQ (*bp
->function
, Qerror
))
1654 if (bp
&& bp
->function
)
1655 Vsignaling_function
= *bp
->function
;
1658 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1660 register Lisp_Object clause
;
1662 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1663 error_symbol
, data
);
1665 if (EQ (clause
, Qlambda
))
1667 /* We can't return values to code which signaled an error, but we
1668 can continue code which has signaled a quit. */
1669 if (EQ (real_error_symbol
, Qquit
))
1672 error ("Cannot return from the debugger in an error");
1677 Lisp_Object unwind_data
;
1678 struct handler
*h
= handlerlist
;
1680 handlerlist
= allhandlers
;
1682 if (NILP (error_symbol
))
1685 unwind_data
= Fcons (error_symbol
, data
);
1686 h
->chosen_clause
= clause
;
1687 unwind_to_catch (h
->tag
, unwind_data
);
1691 handlerlist
= allhandlers
;
1692 /* If no handler is present now, try to run the debugger,
1693 and if that fails, throw to top level. */
1694 find_handler_clause (Qerror
, conditions
, error_symbol
, data
);
1696 Fthrow (Qtop_level
, Qt
);
1698 if (! NILP (error_symbol
))
1699 data
= Fcons (error_symbol
, data
);
1701 string
= Ferror_message_string (data
);
1702 fatal ("%s", SDATA (string
), 0);
1705 /* Internal version of Fsignal that never returns.
1706 Used for anything but Qquit (which can return from Fsignal). */
1709 xsignal (error_symbol
, data
)
1710 Lisp_Object error_symbol
, data
;
1712 Fsignal (error_symbol
, data
);
1716 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1719 xsignal0 (error_symbol
)
1720 Lisp_Object error_symbol
;
1722 xsignal (error_symbol
, Qnil
);
1726 xsignal1 (error_symbol
, arg
)
1727 Lisp_Object error_symbol
, arg
;
1729 xsignal (error_symbol
, list1 (arg
));
1733 xsignal2 (error_symbol
, arg1
, arg2
)
1734 Lisp_Object error_symbol
, arg1
, arg2
;
1736 xsignal (error_symbol
, list2 (arg1
, arg2
));
1740 xsignal3 (error_symbol
, arg1
, arg2
, arg3
)
1741 Lisp_Object error_symbol
, arg1
, arg2
, arg3
;
1743 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1746 /* Signal `error' with message S, and additional arg ARG.
1747 If ARG is not a genuine list, make it a one-element list. */
1750 signal_error (s
, arg
)
1754 Lisp_Object tortoise
, hare
;
1756 hare
= tortoise
= arg
;
1757 while (CONSP (hare
))
1764 tortoise
= XCDR (tortoise
);
1766 if (EQ (hare
, tortoise
))
1771 arg
= Fcons (arg
, Qnil
); /* Make it a list. */
1773 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1777 /* Return nonzero if LIST is a non-nil atom or
1778 a list containing one of CONDITIONS. */
1781 wants_debugger (list
, conditions
)
1782 Lisp_Object list
, conditions
;
1789 while (CONSP (conditions
))
1791 Lisp_Object
this, tail
;
1792 this = XCAR (conditions
);
1793 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1794 if (EQ (XCAR (tail
), this))
1796 conditions
= XCDR (conditions
);
1801 /* Return 1 if an error with condition-symbols CONDITIONS,
1802 and described by SIGNAL-DATA, should skip the debugger
1803 according to debugger-ignored-errors. */
1806 skip_debugger (conditions
, data
)
1807 Lisp_Object conditions
, data
;
1810 int first_string
= 1;
1811 Lisp_Object error_message
;
1813 error_message
= Qnil
;
1814 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1816 if (STRINGP (XCAR (tail
)))
1820 error_message
= Ferror_message_string (data
);
1824 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1829 Lisp_Object contail
;
1831 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1832 if (EQ (XCAR (tail
), XCAR (contail
)))
1840 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1841 SIG and DATA describe the signal, as in find_handler_clause. */
1844 maybe_call_debugger (conditions
, sig
, data
)
1845 Lisp_Object conditions
, sig
, data
;
1847 Lisp_Object combined_data
;
1849 combined_data
= Fcons (sig
, data
);
1852 /* Don't try to run the debugger with interrupts blocked.
1853 The editing loop would return anyway. */
1855 /* Does user want to enter debugger for this kind of error? */
1858 : wants_debugger (Vdebug_on_error
, conditions
))
1859 && ! skip_debugger (conditions
, combined_data
)
1860 /* rms: what's this for? */
1861 && when_entered_debugger
< num_nonmacro_input_events
)
1863 call_debugger (Fcons (Qerror
, Fcons (combined_data
, Qnil
)));
1870 /* Value of Qlambda means we have called debugger and user has continued.
1871 There are two ways to pass SIG and DATA:
1872 = SIG is the error symbol, and DATA is the rest of the data.
1873 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1874 This is for memory-full errors only.
1876 We need to increase max_specpdl_size temporarily around
1877 anything we do that can push on the specpdl, so as not to get
1878 a second error here in case we're handling specpdl overflow. */
1881 find_handler_clause (handlers
, conditions
, sig
, data
)
1882 Lisp_Object handlers
, conditions
, sig
, data
;
1884 register Lisp_Object h
;
1885 register Lisp_Object tem
;
1886 int debugger_called
= 0;
1887 int debugger_considered
= 0;
1889 /* t is used by handlers for all conditions, set up by C code. */
1890 if (EQ (handlers
, Qt
))
1893 /* Don't run the debugger for a memory-full error.
1894 (There is no room in memory to do that!) */
1896 debugger_considered
= 1;
1898 /* error is used similarly, but means print an error message
1899 and run the debugger if that is enabled. */
1900 if (EQ (handlers
, Qerror
)
1901 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1902 there is a handler. */
1904 if (!NILP (sig
) && wants_debugger (Vstack_trace_on_error
, conditions
))
1906 max_lisp_eval_depth
+= 15;
1911 internal_with_output_to_temp_buffer
1913 (Lisp_Object (*) (Lisp_Object
)) Fbacktrace
,
1916 max_lisp_eval_depth
-= 15;
1919 if (!debugger_considered
)
1921 debugger_considered
= 1;
1922 debugger_called
= maybe_call_debugger (conditions
, sig
, data
);
1925 /* If there is no handler, return saying whether we ran the debugger. */
1926 if (EQ (handlers
, Qerror
))
1928 if (debugger_called
)
1934 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1936 Lisp_Object handler
, condit
;
1939 if (!CONSP (handler
))
1941 condit
= Fcar (handler
);
1942 /* Handle a single condition name in handler HANDLER. */
1943 if (SYMBOLP (condit
))
1945 tem
= Fmemq (Fcar (handler
), conditions
);
1949 /* Handle a list of condition names in handler HANDLER. */
1950 else if (CONSP (condit
))
1953 for (tail
= condit
; CONSP (tail
); tail
= XCDR (tail
))
1955 tem
= Fmemq (Fcar (tail
), conditions
);
1958 /* This handler is going to apply.
1959 Does it allow the debugger to run first? */
1960 if (! debugger_considered
&& !NILP (Fmemq (Qdebug
, condit
)))
1961 maybe_call_debugger (conditions
, sig
, data
);
1971 /* dump an error message; called like printf */
1975 error (m
, a1
, a2
, a3
)
1995 int used
= doprnt (buffer
, size
, m
, m
+ mlen
, 3, args
);
2000 buffer
= (char *) xrealloc (buffer
, size
);
2003 buffer
= (char *) xmalloc (size
);
2008 string
= build_string (buffer
);
2012 xsignal1 (Qerror
, string
);
2015 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
2016 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
2017 This means it contains a description for how to read arguments to give it.
2018 The value is nil for an invalid function or a symbol with no function
2021 Interactively callable functions include strings and vectors (treated
2022 as keyboard macros), lambda-expressions that contain a top-level call
2023 to `interactive', autoload definitions made by `autoload' with non-nil
2024 fourth argument, and some of the built-in functions of Lisp.
2026 Also, a symbol satisfies `commandp' if its function definition does so.
2028 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
2029 then strings and vectors are not accepted. */)
2030 (function
, for_call_interactively
)
2031 Lisp_Object function
, for_call_interactively
;
2033 register Lisp_Object fun
;
2034 register Lisp_Object funcar
;
2035 Lisp_Object if_prop
= Qnil
;
2039 fun
= indirect_function (fun
); /* Check cycles. */
2040 if (NILP (fun
) || EQ (fun
, Qunbound
))
2043 /* Check an `interactive-form' property if present, analogous to the
2044 function-documentation property. */
2046 while (SYMBOLP (fun
))
2048 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
2051 fun
= Fsymbol_function (fun
);
2054 /* Emacs primitives are interactive if their DEFUN specifies an
2055 interactive spec. */
2057 return XSUBR (fun
)->intspec
? Qt
: if_prop
;
2059 /* Bytecode objects are interactive if they are long enough to
2060 have an element whose index is COMPILED_INTERACTIVE, which is
2061 where the interactive spec is stored. */
2062 else if (COMPILEDP (fun
))
2063 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
2066 /* Strings and vectors are keyboard macros. */
2067 if (STRINGP (fun
) || VECTORP (fun
))
2068 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
2070 /* Lists may represent commands. */
2073 funcar
= XCAR (fun
);
2074 if (EQ (funcar
, Qlambda
))
2075 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
2076 if (EQ (funcar
, Qautoload
))
2077 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
2082 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
2083 doc
: /* Define FUNCTION to autoload from FILE.
2084 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
2085 Third arg DOCSTRING is documentation for the function.
2086 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
2087 Fifth arg TYPE indicates the type of the object:
2088 nil or omitted says FUNCTION is a function,
2089 `keymap' says FUNCTION is really a keymap, and
2090 `macro' or t says FUNCTION is really a macro.
2091 Third through fifth args give info about the real definition.
2092 They default to nil.
2093 If FUNCTION is already defined other than as an autoload,
2094 this does nothing and returns nil. */)
2095 (function
, file
, docstring
, interactive
, type
)
2096 Lisp_Object function
, file
, docstring
, interactive
, type
;
2098 Lisp_Object args
[4];
2100 CHECK_SYMBOL (function
);
2101 CHECK_STRING (file
);
2103 /* If function is defined and not as an autoload, don't override */
2104 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
2105 && !(CONSP (XSYMBOL (function
)->function
)
2106 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
2109 if (NILP (Vpurify_flag
))
2110 /* Only add entries after dumping, because the ones before are
2111 not useful and else we get loads of them from the loaddefs.el. */
2112 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
2114 /* We don't want the docstring in purespace (instead,
2115 Snarf-documentation should (hopefully) overwrite it). */
2116 docstring
= make_number (0);
2117 return Ffset (function
,
2118 Fpurecopy (list5 (Qautoload
, file
, docstring
,
2119 interactive
, type
)));
2123 un_autoload (oldqueue
)
2124 Lisp_Object oldqueue
;
2126 register Lisp_Object queue
, first
, second
;
2128 /* Queue to unwind is current value of Vautoload_queue.
2129 oldqueue is the shadowed value to leave in Vautoload_queue. */
2130 queue
= Vautoload_queue
;
2131 Vautoload_queue
= oldqueue
;
2132 while (CONSP (queue
))
2134 first
= XCAR (queue
);
2135 second
= Fcdr (first
);
2136 first
= Fcar (first
);
2137 if (EQ (first
, make_number (0)))
2140 Ffset (first
, second
);
2141 queue
= XCDR (queue
);
2146 /* Load an autoloaded function.
2147 FUNNAME is the symbol which is the function's name.
2148 FUNDEF is the autoload definition (a list). */
2151 do_autoload (fundef
, funname
)
2152 Lisp_Object fundef
, funname
;
2154 int count
= SPECPDL_INDEX ();
2156 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2158 /* This is to make sure that loadup.el gives a clear picture
2159 of what files are preloaded and when. */
2160 if (! NILP (Vpurify_flag
))
2161 error ("Attempt to autoload %s while preparing to dump",
2162 SDATA (SYMBOL_NAME (funname
)));
2165 CHECK_SYMBOL (funname
);
2166 GCPRO3 (fun
, funname
, fundef
);
2168 /* Preserve the match data. */
2169 record_unwind_save_match_data ();
2171 /* If autoloading gets an error (which includes the error of failing
2172 to define the function being called), we use Vautoload_queue
2173 to undo function definitions and `provide' calls made by
2174 the function. We do this in the specific case of autoloading
2175 because autoloading is not an explicit request "load this file",
2176 but rather a request to "call this function".
2178 The value saved here is to be restored into Vautoload_queue. */
2179 record_unwind_protect (un_autoload
, Vautoload_queue
);
2180 Vautoload_queue
= Qt
;
2181 Fload (Fcar (Fcdr (fundef
)), Qnil
, Qt
, Qnil
, Qt
);
2183 /* Once loading finishes, don't undo it. */
2184 Vautoload_queue
= Qt
;
2185 unbind_to (count
, Qnil
);
2187 fun
= Findirect_function (fun
, Qnil
);
2189 if (!NILP (Fequal (fun
, fundef
)))
2190 error ("Autoloading failed to define function %s",
2191 SDATA (SYMBOL_NAME (funname
)));
2196 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
2197 doc
: /* Evaluate FORM and return its value. */)
2201 Lisp_Object fun
, val
, original_fun
, original_args
;
2203 struct backtrace backtrace
;
2204 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2206 if (handling_signal
)
2210 return Fsymbol_value (form
);
2215 if ((consing_since_gc
> gc_cons_threshold
2216 && consing_since_gc
> gc_relative_threshold
)
2218 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2221 Fgarbage_collect ();
2225 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2227 if (max_lisp_eval_depth
< 100)
2228 max_lisp_eval_depth
= 100;
2229 if (lisp_eval_depth
> max_lisp_eval_depth
)
2230 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2233 original_fun
= Fcar (form
);
2234 original_args
= Fcdr (form
);
2236 backtrace
.next
= backtrace_list
;
2237 backtrace_list
= &backtrace
;
2238 backtrace
.function
= &original_fun
; /* This also protects them from gc */
2239 backtrace
.args
= &original_args
;
2240 backtrace
.nargs
= UNEVALLED
;
2241 backtrace
.evalargs
= 1;
2242 backtrace
.debug_on_exit
= 0;
2244 if (debug_on_next_call
)
2245 do_debug_on_call (Qt
);
2247 /* At this point, only original_fun and original_args
2248 have values that will be used below */
2251 /* Optimize for no indirection. */
2253 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2254 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2255 fun
= indirect_function (fun
);
2259 Lisp_Object numargs
;
2260 Lisp_Object argvals
[8];
2261 Lisp_Object args_left
;
2262 register int i
, maxargs
;
2264 args_left
= original_args
;
2265 numargs
= Flength (args_left
);
2269 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
2270 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2271 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2273 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2275 backtrace
.evalargs
= 0;
2276 val
= (*XSUBR (fun
)->function
) (args_left
);
2280 if (XSUBR (fun
)->max_args
== MANY
)
2282 /* Pass a vector of evaluated arguments */
2284 register int argnum
= 0;
2286 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2288 GCPRO3 (args_left
, fun
, fun
);
2292 while (!NILP (args_left
))
2294 vals
[argnum
++] = Feval (Fcar (args_left
));
2295 args_left
= Fcdr (args_left
);
2296 gcpro3
.nvars
= argnum
;
2299 backtrace
.args
= vals
;
2300 backtrace
.nargs
= XINT (numargs
);
2302 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
2307 GCPRO3 (args_left
, fun
, fun
);
2308 gcpro3
.var
= argvals
;
2311 maxargs
= XSUBR (fun
)->max_args
;
2312 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
2314 argvals
[i
] = Feval (Fcar (args_left
));
2320 backtrace
.args
= argvals
;
2321 backtrace
.nargs
= XINT (numargs
);
2326 val
= (*XSUBR (fun
)->function
) ();
2329 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
2332 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
2335 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2339 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2340 argvals
[2], argvals
[3]);
2343 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2344 argvals
[3], argvals
[4]);
2347 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2348 argvals
[3], argvals
[4], argvals
[5]);
2351 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2352 argvals
[3], argvals
[4], argvals
[5],
2357 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2358 argvals
[3], argvals
[4], argvals
[5],
2359 argvals
[6], argvals
[7]);
2363 /* Someone has created a subr that takes more arguments than
2364 is supported by this code. We need to either rewrite the
2365 subr to use a different argument protocol, or add more
2366 cases to this switch. */
2370 if (COMPILEDP (fun
))
2371 val
= apply_lambda (fun
, original_args
, 1);
2374 if (EQ (fun
, Qunbound
))
2375 xsignal1 (Qvoid_function
, original_fun
);
2377 xsignal1 (Qinvalid_function
, original_fun
);
2378 funcar
= XCAR (fun
);
2379 if (!SYMBOLP (funcar
))
2380 xsignal1 (Qinvalid_function
, original_fun
);
2381 if (EQ (funcar
, Qautoload
))
2383 do_autoload (fun
, original_fun
);
2386 if (EQ (funcar
, Qmacro
))
2387 val
= Feval (apply1 (Fcdr (fun
), original_args
));
2388 else if (EQ (funcar
, Qlambda
))
2389 val
= apply_lambda (fun
, original_args
, 1);
2391 xsignal1 (Qinvalid_function
, original_fun
);
2397 if (backtrace
.debug_on_exit
)
2398 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2399 backtrace_list
= backtrace
.next
;
2404 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
2405 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2406 Then return the value FUNCTION returns.
2407 Thus, (apply '+ 1 2 '(3 4)) returns 10.
2408 usage: (apply FUNCTION &rest ARGUMENTS) */)
2413 register int i
, numargs
;
2414 register Lisp_Object spread_arg
;
2415 register Lisp_Object
*funcall_args
;
2417 struct gcpro gcpro1
;
2421 spread_arg
= args
[nargs
- 1];
2422 CHECK_LIST (spread_arg
);
2424 numargs
= XINT (Flength (spread_arg
));
2427 return Ffuncall (nargs
- 1, args
);
2428 else if (numargs
== 1)
2430 args
[nargs
- 1] = XCAR (spread_arg
);
2431 return Ffuncall (nargs
, args
);
2434 numargs
+= nargs
- 2;
2436 /* Optimize for no indirection. */
2437 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2438 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2439 fun
= indirect_function (fun
);
2440 if (EQ (fun
, Qunbound
))
2442 /* Let funcall get the error */
2449 if (numargs
< XSUBR (fun
)->min_args
2450 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2451 goto funcall
; /* Let funcall get the error */
2452 else if (XSUBR (fun
)->max_args
> numargs
)
2454 /* Avoid making funcall cons up a yet another new vector of arguments
2455 by explicitly supplying nil's for optional values */
2456 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
2457 * sizeof (Lisp_Object
));
2458 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2459 funcall_args
[++i
] = Qnil
;
2460 GCPRO1 (*funcall_args
);
2461 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2465 /* We add 1 to numargs because funcall_args includes the
2466 function itself as well as its arguments. */
2469 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
2470 * sizeof (Lisp_Object
));
2471 GCPRO1 (*funcall_args
);
2472 gcpro1
.nvars
= 1 + numargs
;
2475 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
2476 /* Spread the last arg we got. Its first element goes in
2477 the slot that it used to occupy, hence this value of I. */
2479 while (!NILP (spread_arg
))
2481 funcall_args
[i
++] = XCAR (spread_arg
);
2482 spread_arg
= XCDR (spread_arg
);
2485 /* By convention, the caller needs to gcpro Ffuncall's args. */
2486 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
2489 /* Run hook variables in various ways. */
2491 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
2492 static Lisp_Object run_hook_with_args
P_ ((int, Lisp_Object
*,
2493 enum run_hooks_condition
));
2495 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2496 doc
: /* Run each hook in HOOKS.
2497 Each argument should be a symbol, a hook variable.
2498 These symbols are processed in the order specified.
2499 If a hook symbol has a non-nil value, that value may be a function
2500 or a list of functions to be called to run the hook.
2501 If the value is a function, it is called with no arguments.
2502 If it is a list, the elements are called, in order, with no arguments.
2504 Major modes should not use this function directly to run their mode
2505 hook; they should use `run-mode-hooks' instead.
2507 Do not use `make-local-variable' to make a hook variable buffer-local.
2508 Instead, use `add-hook' and specify t for the LOCAL argument.
2509 usage: (run-hooks &rest HOOKS) */)
2514 Lisp_Object hook
[1];
2517 for (i
= 0; i
< nargs
; i
++)
2520 run_hook_with_args (1, hook
, to_completion
);
2526 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2527 Srun_hook_with_args
, 1, MANY
, 0,
2528 doc
: /* Run HOOK with the specified arguments ARGS.
2529 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2530 value, that value may be a function or a list of functions to be
2531 called to run the hook. If the value is a function, it is called with
2532 the given arguments and its return value is returned. If it is a list
2533 of functions, those functions are called, in order,
2534 with the given arguments ARGS.
2535 It is best not to depend on the value returned by `run-hook-with-args',
2538 Do not use `make-local-variable' to make a hook variable buffer-local.
2539 Instead, use `add-hook' and specify t for the LOCAL argument.
2540 usage: (run-hook-with-args HOOK &rest ARGS) */)
2545 return run_hook_with_args (nargs
, args
, to_completion
);
2548 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2549 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2550 doc
: /* Run HOOK with the specified arguments ARGS.
2551 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2552 value, that value may be a function or a list of functions to be
2553 called to run the hook. If the value is a function, it is called with
2554 the given arguments and its return value is returned.
2555 If it is a list of functions, those functions are called, in order,
2556 with the given arguments ARGS, until one of them
2557 returns a non-nil value. Then we return that value.
2558 However, if they all return nil, we return nil.
2560 Do not use `make-local-variable' to make a hook variable buffer-local.
2561 Instead, use `add-hook' and specify t for the LOCAL argument.
2562 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2567 return run_hook_with_args (nargs
, args
, until_success
);
2570 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2571 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2572 doc
: /* Run HOOK with the specified arguments ARGS.
2573 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2574 value, that value may be a function or a list of functions to be
2575 called to run the hook. If the value is a function, it is called with
2576 the given arguments and its return value is returned.
2577 If it is a list of functions, those functions are called, in order,
2578 with the given arguments ARGS, until one of them returns nil.
2579 Then we return nil. However, if they all return non-nil, we return non-nil.
2581 Do not use `make-local-variable' to make a hook variable buffer-local.
2582 Instead, use `add-hook' and specify t for the LOCAL argument.
2583 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2588 return run_hook_with_args (nargs
, args
, until_failure
);
2591 /* ARGS[0] should be a hook symbol.
2592 Call each of the functions in the hook value, passing each of them
2593 as arguments all the rest of ARGS (all NARGS - 1 elements).
2594 COND specifies a condition to test after each call
2595 to decide whether to stop.
2596 The caller (or its caller, etc) must gcpro all of ARGS,
2597 except that it isn't necessary to gcpro ARGS[0]. */
2600 run_hook_with_args (nargs
, args
, cond
)
2603 enum run_hooks_condition cond
;
2605 Lisp_Object sym
, val
, ret
;
2606 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2608 /* If we are dying or still initializing,
2609 don't do anything--it would probably crash if we tried. */
2610 if (NILP (Vrun_hooks
))
2614 val
= find_symbol_value (sym
);
2615 ret
= (cond
== until_failure
? Qt
: Qnil
);
2617 if (EQ (val
, Qunbound
) || NILP (val
))
2619 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2622 return Ffuncall (nargs
, args
);
2626 Lisp_Object globals
= Qnil
;
2627 GCPRO3 (sym
, val
, globals
);
2630 CONSP (val
) && ((cond
== to_completion
)
2631 || (cond
== until_success
? NILP (ret
)
2635 if (EQ (XCAR (val
), Qt
))
2637 /* t indicates this hook has a local binding;
2638 it means to run the global binding too. */
2639 globals
= Fdefault_value (sym
);
2640 if (NILP (globals
)) continue;
2642 if (!CONSP (globals
) || EQ (XCAR (globals
), Qlambda
))
2645 ret
= Ffuncall (nargs
, args
);
2650 CONSP (globals
) && ((cond
== to_completion
)
2651 || (cond
== until_success
? NILP (ret
)
2653 globals
= XCDR (globals
))
2655 args
[0] = XCAR (globals
);
2656 /* In a global value, t should not occur. If it does, we
2657 must ignore it to avoid an endless loop. */
2658 if (!EQ (args
[0], Qt
))
2659 ret
= Ffuncall (nargs
, args
);
2665 args
[0] = XCAR (val
);
2666 ret
= Ffuncall (nargs
, args
);
2675 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2676 present value of that symbol.
2677 Call each element of FUNLIST,
2678 passing each of them the rest of ARGS.
2679 The caller (or its caller, etc) must gcpro all of ARGS,
2680 except that it isn't necessary to gcpro ARGS[0]. */
2683 run_hook_list_with_args (funlist
, nargs
, args
)
2684 Lisp_Object funlist
;
2690 Lisp_Object globals
;
2691 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2695 GCPRO3 (sym
, val
, globals
);
2697 for (val
= funlist
; CONSP (val
); val
= XCDR (val
))
2699 if (EQ (XCAR (val
), Qt
))
2701 /* t indicates this hook has a local binding;
2702 it means to run the global binding too. */
2704 for (globals
= Fdefault_value (sym
);
2706 globals
= XCDR (globals
))
2708 args
[0] = XCAR (globals
);
2709 /* In a global value, t should not occur. If it does, we
2710 must ignore it to avoid an endless loop. */
2711 if (!EQ (args
[0], Qt
))
2712 Ffuncall (nargs
, args
);
2717 args
[0] = XCAR (val
);
2718 Ffuncall (nargs
, args
);
2725 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2728 run_hook_with_args_2 (hook
, arg1
, arg2
)
2729 Lisp_Object hook
, arg1
, arg2
;
2731 Lisp_Object temp
[3];
2736 Frun_hook_with_args (3, temp
);
2739 /* Apply fn to arg */
2742 Lisp_Object fn
, arg
;
2744 struct gcpro gcpro1
;
2748 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2752 Lisp_Object args
[2];
2756 RETURN_UNGCPRO (Fapply (2, args
));
2758 #else /* not NO_ARG_ARRAY */
2759 RETURN_UNGCPRO (Fapply (2, &fn
));
2760 #endif /* not NO_ARG_ARRAY */
2763 /* Call function fn on no arguments */
2768 struct gcpro gcpro1
;
2771 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2774 /* Call function fn with 1 argument arg1 */
2778 Lisp_Object fn
, arg1
;
2780 struct gcpro gcpro1
;
2782 Lisp_Object args
[2];
2788 RETURN_UNGCPRO (Ffuncall (2, args
));
2789 #else /* not NO_ARG_ARRAY */
2792 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2793 #endif /* not NO_ARG_ARRAY */
2796 /* Call function fn with 2 arguments arg1, arg2 */
2799 call2 (fn
, arg1
, arg2
)
2800 Lisp_Object fn
, arg1
, arg2
;
2802 struct gcpro gcpro1
;
2804 Lisp_Object args
[3];
2810 RETURN_UNGCPRO (Ffuncall (3, args
));
2811 #else /* not NO_ARG_ARRAY */
2814 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2815 #endif /* not NO_ARG_ARRAY */
2818 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2821 call3 (fn
, arg1
, arg2
, arg3
)
2822 Lisp_Object fn
, arg1
, arg2
, arg3
;
2824 struct gcpro gcpro1
;
2826 Lisp_Object args
[4];
2833 RETURN_UNGCPRO (Ffuncall (4, args
));
2834 #else /* not NO_ARG_ARRAY */
2837 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2838 #endif /* not NO_ARG_ARRAY */
2841 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2844 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2845 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2847 struct gcpro gcpro1
;
2849 Lisp_Object args
[5];
2857 RETURN_UNGCPRO (Ffuncall (5, args
));
2858 #else /* not NO_ARG_ARRAY */
2861 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2862 #endif /* not NO_ARG_ARRAY */
2865 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2868 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2869 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2871 struct gcpro gcpro1
;
2873 Lisp_Object args
[6];
2882 RETURN_UNGCPRO (Ffuncall (6, args
));
2883 #else /* not NO_ARG_ARRAY */
2886 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2887 #endif /* not NO_ARG_ARRAY */
2890 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2893 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2894 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2896 struct gcpro gcpro1
;
2898 Lisp_Object args
[7];
2908 RETURN_UNGCPRO (Ffuncall (7, args
));
2909 #else /* not NO_ARG_ARRAY */
2912 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2913 #endif /* not NO_ARG_ARRAY */
2916 /* The caller should GCPRO all the elements of ARGS. */
2918 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2919 doc
: /* Call first argument as a function, passing remaining arguments to it.
2920 Return the value that function returns.
2921 Thus, (funcall 'cons 'x 'y) returns (x . y).
2922 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2927 Lisp_Object fun
, original_fun
;
2929 int numargs
= nargs
- 1;
2930 Lisp_Object lisp_numargs
;
2932 struct backtrace backtrace
;
2933 register Lisp_Object
*internal_args
;
2937 if ((consing_since_gc
> gc_cons_threshold
2938 && consing_since_gc
> gc_relative_threshold
)
2940 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2941 Fgarbage_collect ();
2943 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2945 if (max_lisp_eval_depth
< 100)
2946 max_lisp_eval_depth
= 100;
2947 if (lisp_eval_depth
> max_lisp_eval_depth
)
2948 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2951 backtrace
.next
= backtrace_list
;
2952 backtrace_list
= &backtrace
;
2953 backtrace
.function
= &args
[0];
2954 backtrace
.args
= &args
[1];
2955 backtrace
.nargs
= nargs
- 1;
2956 backtrace
.evalargs
= 0;
2957 backtrace
.debug_on_exit
= 0;
2959 if (debug_on_next_call
)
2960 do_debug_on_call (Qlambda
);
2964 original_fun
= args
[0];
2968 /* Optimize for no indirection. */
2970 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2971 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2972 fun
= indirect_function (fun
);
2976 if (numargs
< XSUBR (fun
)->min_args
2977 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2979 XSETFASTINT (lisp_numargs
, numargs
);
2980 xsignal2 (Qwrong_number_of_arguments
, original_fun
, lisp_numargs
);
2983 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2984 xsignal1 (Qinvalid_function
, original_fun
);
2986 if (XSUBR (fun
)->max_args
== MANY
)
2988 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
2992 if (XSUBR (fun
)->max_args
> numargs
)
2994 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2995 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
2996 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2997 internal_args
[i
] = Qnil
;
3000 internal_args
= args
+ 1;
3001 switch (XSUBR (fun
)->max_args
)
3004 val
= (*XSUBR (fun
)->function
) ();
3007 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
3010 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1]);
3013 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3017 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3018 internal_args
[2], internal_args
[3]);
3021 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3022 internal_args
[2], internal_args
[3],
3026 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3027 internal_args
[2], internal_args
[3],
3028 internal_args
[4], internal_args
[5]);
3031 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3032 internal_args
[2], internal_args
[3],
3033 internal_args
[4], internal_args
[5],
3038 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3039 internal_args
[2], internal_args
[3],
3040 internal_args
[4], internal_args
[5],
3041 internal_args
[6], internal_args
[7]);
3046 /* If a subr takes more than 8 arguments without using MANY
3047 or UNEVALLED, we need to extend this function to support it.
3048 Until this is done, there is no way to call the function. */
3052 if (COMPILEDP (fun
))
3053 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3056 if (EQ (fun
, Qunbound
))
3057 xsignal1 (Qvoid_function
, original_fun
);
3059 xsignal1 (Qinvalid_function
, original_fun
);
3060 funcar
= XCAR (fun
);
3061 if (!SYMBOLP (funcar
))
3062 xsignal1 (Qinvalid_function
, original_fun
);
3063 if (EQ (funcar
, Qlambda
))
3064 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3065 else if (EQ (funcar
, Qautoload
))
3067 do_autoload (fun
, original_fun
);
3072 xsignal1 (Qinvalid_function
, original_fun
);
3077 if (backtrace
.debug_on_exit
)
3078 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
3079 backtrace_list
= backtrace
.next
;
3084 apply_lambda (fun
, args
, eval_flag
)
3085 Lisp_Object fun
, args
;
3088 Lisp_Object args_left
;
3089 Lisp_Object numargs
;
3090 register Lisp_Object
*arg_vector
;
3091 struct gcpro gcpro1
, gcpro2
, gcpro3
;
3093 register Lisp_Object tem
;
3095 numargs
= Flength (args
);
3096 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
3099 GCPRO3 (*arg_vector
, args_left
, fun
);
3102 for (i
= 0; i
< XINT (numargs
);)
3104 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
3105 if (eval_flag
) tem
= Feval (tem
);
3106 arg_vector
[i
++] = tem
;
3114 backtrace_list
->args
= arg_vector
;
3115 backtrace_list
->nargs
= i
;
3117 backtrace_list
->evalargs
= 0;
3118 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
3120 /* Do the debug-on-exit now, while arg_vector still exists. */
3121 if (backtrace_list
->debug_on_exit
)
3122 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
3123 /* Don't do it again when we return to eval. */
3124 backtrace_list
->debug_on_exit
= 0;
3128 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
3129 and return the result of evaluation.
3130 FUN must be either a lambda-expression or a compiled-code object. */
3133 funcall_lambda (fun
, nargs
, arg_vector
)
3136 register Lisp_Object
*arg_vector
;
3138 Lisp_Object val
, syms_left
, next
;
3139 int count
= SPECPDL_INDEX ();
3140 int i
, optional
, rest
;
3144 syms_left
= XCDR (fun
);
3145 if (CONSP (syms_left
))
3146 syms_left
= XCAR (syms_left
);
3148 xsignal1 (Qinvalid_function
, fun
);
3150 else if (COMPILEDP (fun
))
3151 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3155 i
= optional
= rest
= 0;
3156 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3160 next
= XCAR (syms_left
);
3161 if (!SYMBOLP (next
))
3162 xsignal1 (Qinvalid_function
, fun
);
3164 if (EQ (next
, Qand_rest
))
3166 else if (EQ (next
, Qand_optional
))
3170 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
3174 specbind (next
, arg_vector
[i
++]);
3176 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3178 specbind (next
, Qnil
);
3181 if (!NILP (syms_left
))
3182 xsignal1 (Qinvalid_function
, fun
);
3184 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3187 val
= Fprogn (XCDR (XCDR (fun
)));
3190 /* If we have not actually read the bytecode string
3191 and constants vector yet, fetch them from the file. */
3192 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3193 Ffetch_bytecode (fun
);
3194 val
= Fbyte_code (AREF (fun
, COMPILED_BYTECODE
),
3195 AREF (fun
, COMPILED_CONSTANTS
),
3196 AREF (fun
, COMPILED_STACK_DEPTH
));
3199 return unbind_to (count
, val
);
3202 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3204 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3210 if (COMPILEDP (object
) && CONSP (AREF (object
, COMPILED_BYTECODE
)))
3212 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3215 tem
= AREF (object
, COMPILED_BYTECODE
);
3216 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3217 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3219 error ("Invalid byte code");
3221 ASET (object
, COMPILED_BYTECODE
, XCAR (tem
));
3222 ASET (object
, COMPILED_CONSTANTS
, XCDR (tem
));
3230 register int count
= SPECPDL_INDEX ();
3231 if (specpdl_size
>= max_specpdl_size
)
3233 if (max_specpdl_size
< 400)
3234 max_specpdl_size
= 400;
3235 if (specpdl_size
>= max_specpdl_size
)
3236 signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil
);
3239 if (specpdl_size
> max_specpdl_size
)
3240 specpdl_size
= max_specpdl_size
;
3241 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
3242 specpdl_ptr
= specpdl
+ count
;
3246 specbind (symbol
, value
)
3247 Lisp_Object symbol
, value
;
3249 Lisp_Object valcontents
;
3251 CHECK_SYMBOL (symbol
);
3252 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3255 /* The most common case is that of a non-constant symbol with a
3256 trivial value. Make that as fast as we can. */
3257 valcontents
= SYMBOL_VALUE (symbol
);
3258 if (!MISCP (valcontents
) && !SYMBOL_CONSTANT_P (symbol
))
3261 = ensure_thread_local (&indirect_variable (XSYMBOL (symbol
))->value
);
3262 specpdl_ptr
->symbol
= symbol
;
3263 /* We know VALCONTENTS is equivalent to the CDR, but we save the
3264 CDR in case it is the thread-local mark. */
3265 specpdl_ptr
->old_value
= XCDR (cons
);
3266 specpdl_ptr
->func
= NULL
;
3268 XSETCDR (cons
, value
);
3272 Lisp_Object ovalue
= find_symbol_value (symbol
);
3273 specpdl_ptr
->func
= 0;
3274 specpdl_ptr
->old_value
= ovalue
;
3276 valcontents
= XSYMBOL (symbol
)->value
;
3278 if (BUFFER_LOCAL_VALUEP (valcontents
)
3279 || BUFFER_OBJFWDP (valcontents
))
3281 Lisp_Object where
, self_buffer
;
3283 self_buffer
= Fcurrent_buffer ();
3285 /* For a local variable, record both the symbol and which
3286 buffer's or frame's value we are saving. */
3287 if (!NILP (Flocal_variable_p (symbol
, Qnil
)))
3288 where
= self_buffer
;
3289 else if (BUFFER_LOCAL_VALUEP (valcontents
)
3290 && BLOCAL_FOUND_FOR_FRAME (XBUFFER_LOCAL_VALUE (valcontents
)))
3291 where
= BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
));
3295 /* We're not using the `unused' slot in the specbinding
3296 structure because this would mean we have to do more
3297 work for simple variables. */
3298 specpdl_ptr
->symbol
= Fcons (symbol
, Fcons (where
, self_buffer
));
3300 /* If SYMBOL is a per-buffer variable which doesn't have a
3301 buffer-local value here, make the `let' change the global
3302 value by changing the value of SYMBOL in all buffers not
3303 having their own value. This is consistent with what
3304 happens with other buffer-local variables. */
3306 && BUFFER_OBJFWDP (valcontents
))
3309 Fset_default (symbol
, value
);
3314 specpdl_ptr
->symbol
= symbol
;
3318 if (BUFFER_OBJFWDP (ovalue) || KBOARD_OBJFWDP (ovalue))
3319 store_symval_forwarding (symbol, ovalue, value, NULL);
3321 but ovalue comes from find_symbol_value which should never return
3322 such an internal value. */
3323 eassert (!(BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
)));
3324 set_internal (symbol
, value
, 0, 1);
3329 record_unwind_protect (function
, arg
)
3330 Lisp_Object (*function
) P_ ((Lisp_Object
));
3333 eassert (!handling_signal
);
3335 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3337 specpdl_ptr
->func
= function
;
3338 specpdl_ptr
->symbol
= Qnil
;
3339 specpdl_ptr
->old_value
= arg
;
3344 unbind_to (count
, value
)
3348 Lisp_Object quitf
= Vquit_flag
;
3349 struct gcpro gcpro1
, gcpro2
;
3351 GCPRO2 (value
, quitf
);
3354 while (specpdl_ptr
!= specpdl
+ count
)
3356 /* Copy the binding, and decrement specpdl_ptr, before we do
3357 the work to unbind it. We decrement first
3358 so that an error in unbinding won't try to unbind
3359 the same entry again, and we copy the binding first
3360 in case more bindings are made during some of the code we run. */
3362 struct specbinding this_binding
;
3363 this_binding
= *--specpdl_ptr
;
3365 if (this_binding
.func
!= 0)
3366 (*this_binding
.func
) (this_binding
.old_value
);
3367 /* If the symbol is a list, it is really (SYMBOL WHERE
3368 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3369 frame. If WHERE is a buffer or frame, this indicates we
3370 bound a variable that had a buffer-local or frame-local
3371 binding. WHERE nil means that the variable had the default
3372 value when it was bound. CURRENT-BUFFER is the buffer that
3373 was current when the variable was bound. */
3374 else if (CONSP (this_binding
.symbol
))
3376 Lisp_Object symbol
, where
;
3378 symbol
= XCAR (this_binding
.symbol
);
3379 where
= XCAR (XCDR (this_binding
.symbol
));
3382 Fset_default (symbol
, this_binding
.old_value
);
3383 else if (BUFFERP (where
))
3384 set_internal (symbol
, this_binding
.old_value
, XBUFFER (where
), 1);
3386 set_internal (symbol
, this_binding
.old_value
, NULL
, 1);
3390 /* If variable has a trivial value (no forwarding), we can
3391 just set it. No need to check for constant symbols here,
3392 since that was already done by specbind. */
3393 if (!MISCP (SYMBOL_VALUE (this_binding
.symbol
)))
3394 SET_SYMBOL_VALUE (this_binding
.symbol
, this_binding
.old_value
);
3397 if (EQ (this_binding
.old_value
, Qthread_local_mark
))
3398 remove_thread_local (&indirect_variable (XSYMBOL (this_binding
.symbol
))->value
);
3400 set_internal (this_binding
.symbol
, this_binding
.old_value
, 0, 1);
3405 if (NILP (Vquit_flag
) && !NILP (quitf
))
3412 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3413 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3414 The debugger is entered when that frame exits, if the flag is non-nil. */)
3416 Lisp_Object level
, flag
;
3418 register struct backtrace
*backlist
= backtrace_list
;
3421 CHECK_NUMBER (level
);
3423 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
3425 backlist
= backlist
->next
;
3429 backlist
->debug_on_exit
= !NILP (flag
);
3434 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3435 doc
: /* Print a trace of Lisp function calls currently active.
3436 Output stream used is value of `standard-output'. */)
3439 register struct backtrace
*backlist
= backtrace_list
;
3443 struct gcpro gcpro1
;
3445 XSETFASTINT (Vprint_level
, 3);
3452 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
3453 if (backlist
->nargs
== UNEVALLED
)
3455 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
3456 write_string ("\n", -1);
3460 tem
= *backlist
->function
;
3461 Fprin1 (tem
, Qnil
); /* This can QUIT */
3462 write_string ("(", -1);
3463 if (backlist
->nargs
== MANY
)
3465 for (tail
= *backlist
->args
, i
= 0;
3467 tail
= Fcdr (tail
), i
++)
3469 if (i
) write_string (" ", -1);
3470 Fprin1 (Fcar (tail
), Qnil
);
3475 for (i
= 0; i
< backlist
->nargs
; i
++)
3477 if (i
) write_string (" ", -1);
3478 Fprin1 (backlist
->args
[i
], Qnil
);
3481 write_string (")\n", -1);
3483 backlist
= backlist
->next
;
3486 Vprint_level
= Qnil
;
3491 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, NULL
,
3492 doc
: /* Return the function and arguments NFRAMES up from current execution point.
3493 If that frame has not evaluated the arguments yet (or is a special form),
3494 the value is (nil FUNCTION ARG-FORMS...).
3495 If that frame has evaluated its arguments and called its function already,
3496 the value is (t FUNCTION ARG-VALUES...).
3497 A &rest arg is represented as the tail of the list ARG-VALUES.
3498 FUNCTION is whatever was supplied as car of evaluated list,
3499 or a lambda expression for macro calls.
3500 If NFRAMES is more than the number of frames, the value is nil. */)
3502 Lisp_Object nframes
;
3504 register struct backtrace
*backlist
= backtrace_list
;
3508 CHECK_NATNUM (nframes
);
3510 /* Find the frame requested. */
3511 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3512 backlist
= backlist
->next
;
3516 if (backlist
->nargs
== UNEVALLED
)
3517 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3520 if (backlist
->nargs
== MANY
)
3521 tem
= *backlist
->args
;
3523 tem
= Flist (backlist
->nargs
, backlist
->args
);
3525 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3531 mark_backtrace (struct backtrace
*backlist
)
3535 for (; backlist
; backlist
= backlist
->next
)
3537 mark_object (*backlist
->function
);
3539 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3542 i
= backlist
->nargs
- 1;
3544 mark_object (backlist
->args
[i
]);
3551 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
3552 doc
: /* *Limit on number of Lisp variable bindings and `unwind-protect's.
3553 If Lisp code tries to increase the total number past this amount,
3554 an error is signaled.
3555 You can safely use a value considerably larger than the default value,
3556 if that proves inconveniently small. However, if you increase it too far,
3557 Emacs could run out of memory trying to make the stack bigger. */);
3559 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
3560 doc
: /* *Limit on depth in `eval', `apply' and `funcall' before error.
3562 This limit serves to catch infinite recursions for you before they cause
3563 actual stack overflow in C, which would be fatal for Emacs.
3564 You can safely make it considerably larger than its default value,
3565 if that proves inconveniently small. However, if you increase it too far,
3566 Emacs could overflow the real C stack, and crash. */);
3568 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
3569 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3570 If the value is t, that means do an ordinary quit.
3571 If the value equals `throw-on-input', that means quit by throwing
3572 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3573 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3574 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3577 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
3578 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3579 Note that `quit-flag' will still be set by typing C-g,
3580 so a quit will be signaled as soon as `inhibit-quit' is nil.
3581 To prevent this happening, set `quit-flag' to nil
3582 before making `inhibit-quit' nil. */);
3583 Vinhibit_quit
= Qnil
;
3585 Qinhibit_quit
= intern_c_string ("inhibit-quit");
3586 staticpro (&Qinhibit_quit
);
3588 Qautoload
= intern_c_string ("autoload");
3589 staticpro (&Qautoload
);
3591 Qdebug_on_error
= intern_c_string ("debug-on-error");
3592 staticpro (&Qdebug_on_error
);
3594 Qmacro
= intern_c_string ("macro");
3595 staticpro (&Qmacro
);
3597 Qdeclare
= intern_c_string ("declare");
3598 staticpro (&Qdeclare
);
3600 /* Note that the process handling also uses Qexit, but we don't want
3601 to staticpro it twice, so we just do it here. */
3602 Qexit
= intern_c_string ("exit");
3605 Qinteractive
= intern_c_string ("interactive");
3606 staticpro (&Qinteractive
);
3608 Qcommandp
= intern_c_string ("commandp");
3609 staticpro (&Qcommandp
);
3611 Qdefun
= intern_c_string ("defun");
3612 staticpro (&Qdefun
);
3614 Qand_rest
= intern_c_string ("&rest");
3615 staticpro (&Qand_rest
);
3617 Qand_optional
= intern_c_string ("&optional");
3618 staticpro (&Qand_optional
);
3620 Qdebug
= intern_c_string ("debug");
3621 staticpro (&Qdebug
);
3623 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
3624 doc
: /* *Non-nil means errors display a backtrace buffer.
3625 More precisely, this happens for any error that is handled
3626 by the editor command loop.
3627 If the value is a list, an error only means to display a backtrace
3628 if one of its condition symbols appears in the list. */);
3629 Vstack_trace_on_error
= Qnil
;
3631 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
3632 doc
: /* *Non-nil means enter debugger if an error is signaled.
3633 Does not apply to errors handled by `condition-case' or those
3634 matched by `debug-ignored-errors'.
3635 If the value is a list, an error only means to enter the debugger
3636 if one of its condition symbols appears in the list.
3637 When you evaluate an expression interactively, this variable
3638 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3639 The command `toggle-debug-on-error' toggles this.
3640 See also the variable `debug-on-quit'. */);
3641 Vdebug_on_error
= Qnil
;
3643 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
3644 doc
: /* *List of errors for which the debugger should not be called.
3645 Each element may be a condition-name or a regexp that matches error messages.
3646 If any element applies to a given error, that error skips the debugger
3647 and just returns to top level.
3648 This overrides the variable `debug-on-error'.
3649 It does not apply to errors handled by `condition-case'. */);
3650 Vdebug_ignored_errors
= Qnil
;
3652 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
3653 doc
: /* *Non-nil means enter debugger if quit is signaled (C-g, for example).
3654 Does not apply if quit is handled by a `condition-case'. */);
3657 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
3658 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3660 DEFVAR_BOOL ("debugger-may-continue", &debugger_may_continue
,
3661 doc
: /* Non-nil means debugger may continue execution.
3662 This is nil when the debugger is called under circumstances where it
3663 might not be safe to continue. */);
3664 debugger_may_continue
= 1;
3666 DEFVAR_LISP ("debugger", &Vdebugger
,
3667 doc
: /* Function to call to invoke debugger.
3668 If due to frame exit, args are `exit' and the value being returned;
3669 this function's value will be returned instead of that.
3670 If due to error, args are `error' and a list of the args to `signal'.
3671 If due to `apply' or `funcall' entry, one arg, `lambda'.
3672 If due to `eval' entry, one arg, t. */);
3675 DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function
,
3676 doc
: /* If non-nil, this is a function for `signal' to call.
3677 It receives the same arguments that `signal' was given.
3678 The Edebug package uses this to regain control. */);
3679 Vsignal_hook_function
= Qnil
;
3681 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal
,
3682 doc
: /* *Non-nil means call the debugger regardless of condition handlers.
3683 Note that `debug-on-error', `debug-on-quit' and friends
3684 still determine whether to handle the particular condition. */);
3685 Vdebug_on_signal
= Qnil
;
3687 DEFVAR_LISP ("macro-declaration-function", &Vmacro_declaration_function
,
3688 doc
: /* Function to process declarations in a macro definition.
3689 The function will be called with two args MACRO and DECL.
3690 MACRO is the name of the macro being defined.
3691 DECL is a list `(declare ...)' containing the declarations.
3692 The value the function returns is not used. */);
3693 Vmacro_declaration_function
= Qnil
;
3695 Vrun_hooks
= intern_c_string ("run-hooks");
3696 staticpro (&Vrun_hooks
);
3698 staticpro (&Vautoload_queue
);
3699 Vautoload_queue
= Qnil
;
3700 staticpro (&Vsignaling_function
);
3701 Vsignaling_function
= Qnil
;
3712 defsubr (&Sfunction
);
3714 defsubr (&Sdefmacro
);
3716 defsubr (&Sdefvaralias
);
3717 defsubr (&Sdefconst
);
3718 defsubr (&Suser_variable_p
);
3722 defsubr (&Smacroexpand
);
3725 defsubr (&Sunwind_protect
);
3726 defsubr (&Scondition_case
);
3728 defsubr (&Sinteractive_p
);
3729 defsubr (&Scalled_interactively_p
);
3730 defsubr (&Scommandp
);
3731 defsubr (&Sautoload
);
3734 defsubr (&Sfuncall
);
3735 defsubr (&Srun_hooks
);
3736 defsubr (&Srun_hook_with_args
);
3737 defsubr (&Srun_hook_with_args_until_success
);
3738 defsubr (&Srun_hook_with_args_until_failure
);
3739 defsubr (&Sfetch_bytecode
);
3740 defsubr (&Sbacktrace_debug
);
3741 defsubr (&Sbacktrace
);
3742 defsubr (&Sbacktrace_frame
);
3745 /* arch-tag: 014a07aa-33ab-4a8f-a3d2-ee8a4a9ff7fb
3746 (do not change this comment) */