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. */
50 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
51 Lisp_Object Qinhibit_quit
, impl_Vinhibit_quit
, impl_Vquit_flag
;
52 Lisp_Object Qand_rest
, Qand_optional
;
53 Lisp_Object Qdebug_on_error
;
56 extern Lisp_Object Qinteractive_form
;
58 /* This holds either the symbol `run-hooks' or nil.
59 It is nil at an early stage of startup, and when Emacs
62 Lisp_Object Vrun_hooks
;
64 /* Non-nil means record all fset's and provide's, to be undone
65 if the file being autoloaded is not fully loaded.
66 They are recorded by being consed onto the front of Vautoload_queue:
67 (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide. */
69 Lisp_Object Vautoload_queue
;
71 /* Maximum size allowed for specpdl allocation */
73 EMACS_INT max_specpdl_size
;
75 /* Maximum allowed depth in Lisp evaluations and function calls. */
77 EMACS_INT max_lisp_eval_depth
;
79 /* Nonzero means enter debugger before next function call */
81 int debug_on_next_call
;
83 /* Non-zero means debugger may continue. This is zero when the
84 debugger is called during redisplay, where it might not be safe to
85 continue the interrupted redisplay. */
87 int debugger_may_continue
;
89 /* List of conditions (non-nil atom means all) which cause a backtrace
90 if an error is handled by the command loop's error handler. */
92 Lisp_Object impl_Vstack_trace_on_error
;
94 /* List of conditions (non-nil atom means all) which enter the debugger
95 if an error is handled by the command loop's error handler. */
97 Lisp_Object impl_Vdebug_on_error
;
99 /* List of conditions and regexps specifying error messages which
100 do not enter the debugger even if Vdebug_on_error says they should. */
102 Lisp_Object impl_Vdebug_ignored_errors
;
104 /* Non-nil means call the debugger even if the error will be handled. */
106 Lisp_Object impl_Vdebug_on_signal
;
108 /* Hook for edebug to use. */
110 Lisp_Object impl_Vsignal_hook_function
;
112 /* Nonzero means enter debugger if a quit signal
113 is handled by the command loop's error handler. */
117 /* The value of num_nonmacro_input_events as of the last time we
118 started to enter the debugger. If we decide to enter the debugger
119 again when this is still equal to num_nonmacro_input_events, then we
120 know that the debugger itself has an error, and we should just
121 signal the error instead of entering an infinite loop of debugger
124 int when_entered_debugger
;
126 Lisp_Object impl_Vdebugger
;
128 /* The function from which the last `signal' was called. Set in
131 Lisp_Object Vsignaling_function
;
133 /* Set to non-zero while processing X events. Checked in Feval to
134 make sure the Lisp interpreter isn't called from a signal handler,
135 which is unsafe because the interpreter isn't reentrant. */
139 /* Function to process declarations in defmacro forms. */
141 Lisp_Object impl_Vmacro_declaration_function
;
143 extern Lisp_Object Qrisky_local_variable
;
145 extern Lisp_Object Qfunction
;
147 static Lisp_Object funcall_lambda
P_ ((Lisp_Object
, int, Lisp_Object
*));
148 static void unwind_to_catch
P_ ((struct catchtag
*, Lisp_Object
)) NO_RETURN
;
151 /* "gcc -O3" enables automatic function inlining, which optimizes out
152 the arguments for the invocations of these functions, whereas they
153 expect these values on the stack. */
154 Lisp_Object
apply1 () __attribute__((noinline
));
155 Lisp_Object
call2 () __attribute__((noinline
));
162 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
163 specpdl_ptr
= specpdl
;
164 /* Don't forget to update docs (lispref node "Local Variables"). */
165 max_specpdl_size
= 1000;
166 max_lisp_eval_depth
= 500;
174 specpdl_ptr
= specpdl
;
179 debug_on_next_call
= 0;
184 /* This is less than the initial value of num_nonmacro_input_events. */
185 when_entered_debugger
= -1;
189 mark_catchlist (struct catchtag
*catch)
191 for (; catch; catch = catch->next
)
193 mark_object (catch->tag
);
194 mark_object (catch->val
);
198 /* unwind-protect function used by call_debugger. */
201 restore_stack_limits (data
)
204 max_specpdl_size
= XINT (XCAR (data
));
205 max_lisp_eval_depth
= XINT (XCDR (data
));
209 /* Call the Lisp debugger, giving it argument ARG. */
215 int debug_while_redisplaying
;
216 int count
= SPECPDL_INDEX ();
218 int old_max
= max_specpdl_size
;
220 /* Temporarily bump up the stack limits,
221 so the debugger won't run out of stack. */
223 max_specpdl_size
+= 1;
224 record_unwind_protect (restore_stack_limits
,
225 Fcons (make_number (old_max
),
226 make_number (max_lisp_eval_depth
)));
227 max_specpdl_size
= old_max
;
229 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
230 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
232 if (SPECPDL_INDEX () + 100 > max_specpdl_size
)
233 max_specpdl_size
= SPECPDL_INDEX () + 100;
235 #ifdef HAVE_WINDOW_SYSTEM
236 if (display_hourglass_p
)
240 debug_on_next_call
= 0;
241 when_entered_debugger
= num_nonmacro_input_events
;
243 /* Resetting redisplaying_p to 0 makes sure that debug output is
244 displayed if the debugger is invoked during redisplay. */
245 debug_while_redisplaying
= redisplaying_p
;
247 specbind (intern ("debugger-may-continue"),
248 debug_while_redisplaying
? Qnil
: Qt
);
249 specbind (Qinhibit_redisplay
, Qnil
);
250 specbind (Qdebug_on_error
, Qnil
);
252 #if 0 /* Binding this prevents execution of Lisp code during
253 redisplay, which necessarily leads to display problems. */
254 specbind (Qinhibit_eval_during_redisplay
, Qt
);
257 val
= apply1 (Vdebugger
, arg
);
259 /* Interrupting redisplay and resuming it later is not safe under
260 all circumstances. So, when the debugger returns, abort the
261 interrupted redisplay by going back to the top-level. */
262 if (debug_while_redisplaying
)
265 return unbind_to (count
, val
);
269 do_debug_on_call (code
)
272 debug_on_next_call
= 0;
273 backtrace_list
->debug_on_exit
= 1;
274 call_debugger (Fcons (code
, Qnil
));
277 /* NOTE!!! Every function that can call EVAL must protect its args
278 and temporaries from garbage collection while it needs them.
279 The definition of `For' shows what you have to do. */
281 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
282 doc
: /* Eval args until one of them yields non-nil, then return that value.
283 The remaining args are not evalled at all.
284 If all args return nil, return nil.
285 usage: (or CONDITIONS...) */)
289 register Lisp_Object val
= Qnil
;
296 val
= Feval (XCAR (args
));
306 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
307 doc
: /* Eval args until one of them yields nil, then return nil.
308 The remaining args are not evalled at all.
309 If no arg yields nil, return the last arg's value.
310 usage: (and CONDITIONS...) */)
314 register Lisp_Object val
= Qt
;
321 val
= Feval (XCAR (args
));
331 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
332 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
333 Returns the value of THEN or the value of the last of the ELSE's.
334 THEN must be one expression, but ELSE... can be zero or more expressions.
335 If COND yields nil, and there are no ELSE's, the value is nil.
336 usage: (if COND THEN ELSE...) */)
340 register Lisp_Object cond
;
344 cond
= Feval (Fcar (args
));
348 return Feval (Fcar (Fcdr (args
)));
349 return Fprogn (Fcdr (Fcdr (args
)));
352 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
353 doc
: /* Try each clause until one succeeds.
354 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
355 and, if the value is non-nil, this clause succeeds:
356 then the expressions in BODY are evaluated and the last one's
357 value is the value of the cond-form.
358 If no clause succeeds, cond returns nil.
359 If a clause has one element, as in (CONDITION),
360 CONDITION's value if non-nil is returned from the cond-form.
361 usage: (cond CLAUSES...) */)
365 register Lisp_Object clause
, val
;
372 clause
= Fcar (args
);
373 val
= Feval (Fcar (clause
));
376 if (!EQ (XCDR (clause
), Qnil
))
377 val
= Fprogn (XCDR (clause
));
387 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
388 doc
: /* Eval BODY forms sequentially and return value of last one.
389 usage: (progn BODY...) */)
393 register Lisp_Object val
= Qnil
;
400 val
= Feval (XCAR (args
));
408 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
409 doc
: /* Eval FIRST and BODY sequentially; return value from FIRST.
410 The value of FIRST is saved during the evaluation of the remaining args,
411 whose values are discarded.
412 usage: (prog1 FIRST BODY...) */)
417 register Lisp_Object args_left
;
418 struct gcpro gcpro1
, gcpro2
;
419 register int argnum
= 0;
431 val
= Feval (Fcar (args_left
));
433 Feval (Fcar (args_left
));
434 args_left
= Fcdr (args_left
);
436 while (!NILP(args_left
));
442 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
443 doc
: /* Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
444 The value of FORM2 is saved during the evaluation of the
445 remaining args, whose values are discarded.
446 usage: (prog2 FORM1 FORM2 BODY...) */)
451 register Lisp_Object args_left
;
452 struct gcpro gcpro1
, gcpro2
;
453 register int argnum
= -1;
467 val
= Feval (Fcar (args_left
));
469 Feval (Fcar (args_left
));
470 args_left
= Fcdr (args_left
);
472 while (!NILP (args_left
));
478 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
479 doc
: /* Set each SYM to the value of its VAL.
480 The symbols SYM are variables; they are literal (not evaluated).
481 The values VAL are expressions; they are evaluated.
482 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
483 The second VAL is not computed until after the first SYM is set, and so on;
484 each VAL can use the new value of variables set earlier in the `setq'.
485 The return value of the `setq' form is the value of the last VAL.
486 usage: (setq [SYM VAL]...) */)
490 register Lisp_Object args_left
;
491 register Lisp_Object val
, sym
;
502 val
= Feval (Fcar (Fcdr (args_left
)));
503 sym
= Fcar (args_left
);
505 args_left
= Fcdr (Fcdr (args_left
));
507 while (!NILP(args_left
));
513 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
514 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
515 usage: (quote ARG) */)
519 if (!NILP (Fcdr (args
)))
520 xsignal2 (Qwrong_number_of_arguments
, Qquote
, Flength (args
));
524 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
525 doc
: /* Like `quote', but preferred for objects which are functions.
526 In byte compilation, `function' causes its argument to be compiled.
527 `quote' cannot do that.
528 usage: (function ARG) */)
532 if (!NILP (Fcdr (args
)))
533 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
538 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
539 doc
: /* Return t if the containing function was run directly by user input.
540 This means that the function was called with `call-interactively'
541 \(which includes being called as the binding of a key)
542 and input is currently coming from the keyboard (not a keyboard macro),
543 and Emacs is not running in batch mode (`noninteractive' is nil).
545 The only known proper use of `interactive-p' is in deciding whether to
546 display a helpful message, or how to display it. If you're thinking
547 of using it for any other purpose, it is quite likely that you're
548 making a mistake. Think: what do you want to do when the command is
549 called from a keyboard macro?
551 To test whether your function was called with `call-interactively',
552 either (i) add an extra optional argument and give it an `interactive'
553 spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
554 use `called-interactively-p'. */)
557 return (INTERACTIVE
&& interactive_p (1)) ? Qt
: Qnil
;
561 DEFUN ("called-interactively-p", Fcalled_interactively_p
, Scalled_interactively_p
, 0, 1, 0,
562 doc
: /* Return t if the containing function was called by `call-interactively'.
563 If KIND is `interactive', then only return t if the call was made
564 interactively by the user, i.e. not in `noninteractive' mode nor
565 when `executing-kbd-macro'.
566 If KIND is `any', on the other hand, it will return t for any kind of
567 interactive call, including being called as the binding of a key, or
568 from a keyboard macro, or in `noninteractive' mode.
570 The only known proper use of `interactive' for KIND is in deciding
571 whether to display a helpful message, or how to display it. If you're
572 thinking of using it for any other purpose, it is quite likely that
573 you're making a mistake. Think: what do you want to do when the
574 command is called from a keyboard macro?
576 This function is meant for implementing advice and other
577 function-modifying features. Instead of using this, it is sometimes
578 cleaner to give your function an extra optional argument whose
579 `interactive' spec specifies non-nil unconditionally (\"p\" is a good
580 way to do this), or via (not (or executing-kbd-macro noninteractive)). */)
584 return ((INTERACTIVE
|| !EQ (kind
, intern ("interactive")))
585 && interactive_p (1)) ? Qt
: Qnil
;
589 /* Return 1 if function in which this appears was called using
592 EXCLUDE_SUBRS_P non-zero means always return 0 if the function
593 called is a built-in. */
596 interactive_p (exclude_subrs_p
)
599 struct backtrace
*btp
;
602 btp
= backtrace_list
;
604 /* If this isn't a byte-compiled function, there may be a frame at
605 the top for Finteractive_p. If so, skip it. */
606 fun
= Findirect_function (*btp
->function
, Qnil
);
607 if (SUBRP (fun
) && (XSUBR (fun
) == &Sinteractive_p
608 || XSUBR (fun
) == &Scalled_interactively_p
))
611 /* If we're running an Emacs 18-style byte-compiled function, there
612 may be a frame for Fbytecode at the top level. In any version of
613 Emacs there can be Fbytecode frames for subexpressions evaluated
614 inside catch and condition-case. Skip past them.
616 If this isn't a byte-compiled function, then we may now be
617 looking at several frames for special forms. Skip past them. */
619 && (EQ (*btp
->function
, Qbytecode
)
620 || btp
->nargs
== UNEVALLED
))
623 /* btp now points at the frame of the innermost function that isn't
624 a special form, ignoring frames for Finteractive_p and/or
625 Fbytecode at the top. If this frame is for a built-in function
626 (such as load or eval-region) return nil. */
627 fun
= Findirect_function (*btp
->function
, Qnil
);
628 if (exclude_subrs_p
&& SUBRP (fun
))
631 /* btp points to the frame of a Lisp function that called interactive-p.
632 Return t if that function was called interactively. */
633 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
639 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
640 doc
: /* Define NAME as a function.
641 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
642 See also the function `interactive'.
643 usage: (defun NAME ARGLIST [DOCSTRING] BODY...) */)
647 register Lisp_Object fn_name
;
648 register Lisp_Object defn
;
650 fn_name
= Fcar (args
);
651 CHECK_SYMBOL (fn_name
);
652 defn
= Fcons (Qlambda
, Fcdr (args
));
653 if (!NILP (Vpurify_flag
))
654 defn
= Fpurecopy (defn
);
655 if (CONSP (XSYMBOL (fn_name
)->function
)
656 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
657 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
658 Ffset (fn_name
, defn
);
659 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
663 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
664 doc
: /* Define NAME as a macro.
665 The actual definition looks like
666 (macro lambda ARGLIST [DOCSTRING] [DECL] BODY...).
667 When the macro is called, as in (NAME ARGS...),
668 the function (lambda ARGLIST BODY...) is applied to
669 the list ARGS... as it appears in the expression,
670 and the result should be a form to be evaluated instead of the original.
672 DECL is a declaration, optional, which can specify how to indent
673 calls to this macro, how Edebug should handle it, and which argument
674 should be treated as documentation. It looks like this:
676 The elements can look like this:
678 Set NAME's `lisp-indent-function' property to INDENT.
681 Set NAME's `edebug-form-spec' property to DEBUG. (This is
682 equivalent to writing a `def-edebug-spec' for the macro.)
685 Set NAME's `doc-string-elt' property to ELT.
687 usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */)
691 register Lisp_Object fn_name
;
692 register Lisp_Object defn
;
693 Lisp_Object lambda_list
, doc
, tail
;
695 fn_name
= Fcar (args
);
696 CHECK_SYMBOL (fn_name
);
697 lambda_list
= Fcar (Fcdr (args
));
698 tail
= Fcdr (Fcdr (args
));
701 if (STRINGP (Fcar (tail
)))
707 while (CONSP (Fcar (tail
))
708 && EQ (Fcar (Fcar (tail
)), Qdeclare
))
710 if (!NILP (Vmacro_declaration_function
))
714 call2 (Vmacro_declaration_function
, fn_name
, Fcar (tail
));
722 tail
= Fcons (lambda_list
, tail
);
724 tail
= Fcons (lambda_list
, Fcons (doc
, tail
));
725 defn
= Fcons (Qmacro
, Fcons (Qlambda
, tail
));
727 if (!NILP (Vpurify_flag
))
728 defn
= Fpurecopy (defn
);
729 if (CONSP (XSYMBOL (fn_name
)->function
)
730 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
731 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
732 Ffset (fn_name
, defn
);
733 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
738 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
739 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
740 Aliased variables always have the same value; setting one sets the other.
741 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
742 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
743 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
744 itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
745 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
746 The return value is BASE-VARIABLE. */)
747 (new_alias
, base_variable
, docstring
)
748 Lisp_Object new_alias
, base_variable
, docstring
;
750 struct Lisp_Symbol
*sym
;
752 CHECK_SYMBOL (new_alias
);
753 CHECK_SYMBOL (base_variable
);
755 if (SYMBOL_CONSTANT_P (new_alias
))
756 error ("Cannot make a constant an alias");
758 sym
= XSYMBOL (new_alias
);
759 /* http://lists.gnu.org/archive/html/emacs-devel/2008-04/msg00834.html
760 If n_a is bound, but b_v is not, set the value of b_v to n_a.
761 This is for the sake of define-obsolete-variable-alias and user
763 if (NILP (Fboundp (base_variable
)) && !NILP (Fboundp (new_alias
)))
764 XSYMBOL(base_variable
)->value
= sym
->value
;
765 sym
->indirect_variable
= 1;
766 sym
->value
= base_variable
;
767 sym
->constant
= SYMBOL_CONSTANT_P (base_variable
);
768 LOADHIST_ATTACH (new_alias
);
769 if (!NILP (docstring
))
770 Fput (new_alias
, Qvariable_documentation
, docstring
);
772 Fput (new_alias
, Qvariable_documentation
, Qnil
);
774 return base_variable
;
778 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
779 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
780 You are not required to define a variable in order to use it,
781 but the definition can supply documentation and an initial value
782 in a way that tags can recognize.
784 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.
785 If SYMBOL is buffer-local, its default value is what is set;
786 buffer-local values are not affected.
787 INITVALUE and DOCSTRING are optional.
788 If DOCSTRING starts with *, this variable is identified as a user option.
789 This means that M-x set-variable recognizes it.
790 See also `user-variable-p'.
791 If INITVALUE is missing, SYMBOL's value is not set.
793 If SYMBOL has a local binding, then this form affects the local
794 binding. This is usually not what you want. Thus, if you need to
795 load a file defining variables, with this form or with `defconst' or
796 `defcustom', you should always load that file _outside_ any bindings
797 for these variables. \(`defconst' and `defcustom' behave similarly in
799 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
803 register Lisp_Object sym
, tem
, tail
;
807 if (!NILP (Fcdr (Fcdr (tail
))))
808 error ("Too many arguments");
810 tem
= Fdefault_boundp (sym
);
813 if (SYMBOL_CONSTANT_P (sym
))
815 /* For upward compatibility, allow (defvar :foo (quote :foo)). */
816 Lisp_Object tem
= Fcar (tail
);
818 && EQ (XCAR (tem
), Qquote
)
819 && CONSP (XCDR (tem
))
820 && EQ (XCAR (XCDR (tem
)), sym
)))
821 error ("Constant symbol `%s' specified in defvar",
822 SDATA (SYMBOL_NAME (sym
)));
826 Fset_default (sym
, Feval (Fcar (tail
)));
828 { /* Check if there is really a global binding rather than just a let
829 binding that shadows the global unboundness of the var. */
830 volatile struct specbinding
*pdl
= specpdl_ptr
;
831 while (--pdl
>= specpdl
)
833 if (EQ (pdl
->symbol
, sym
) && !pdl
->func
834 && EQ (pdl
->old_value
, Qunbound
))
836 message_with_string ("Warning: defvar ignored because %s is let-bound",
837 SYMBOL_NAME (sym
), 1);
846 if (!NILP (Vpurify_flag
))
847 tem
= Fpurecopy (tem
);
848 Fput (sym
, Qvariable_documentation
, tem
);
850 LOADHIST_ATTACH (sym
);
853 /* Simple (defvar <var>) should not count as a definition at all.
854 It could get in the way of other definitions, and unloading this
855 package could try to make the variable unbound. */
861 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
862 doc
: /* Define SYMBOL as a constant variable.
863 The intent is that neither programs nor users should ever change this value.
864 Always sets the value of SYMBOL to the result of evalling INITVALUE.
865 If SYMBOL is buffer-local, its default value is what is set;
866 buffer-local values are not affected.
867 DOCSTRING is optional.
869 If SYMBOL has a local binding, then this form sets the local binding's
870 value. However, you should normally not make local bindings for
871 variables defined with this form.
872 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
876 register Lisp_Object sym
, tem
;
879 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
880 error ("Too many arguments");
882 tem
= Feval (Fcar (Fcdr (args
)));
883 if (!NILP (Vpurify_flag
))
884 tem
= Fpurecopy (tem
);
885 Fset_default (sym
, tem
);
886 tem
= Fcar (Fcdr (Fcdr (args
)));
889 if (!NILP (Vpurify_flag
))
890 tem
= Fpurecopy (tem
);
891 Fput (sym
, Qvariable_documentation
, tem
);
893 Fput (sym
, Qrisky_local_variable
, Qt
);
894 LOADHIST_ATTACH (sym
);
898 /* Error handler used in Fuser_variable_p. */
900 user_variable_p_eh (ignore
)
907 lisp_indirect_variable (Lisp_Object sym
)
909 XSETSYMBOL (sym
, indirect_variable (XSYMBOL (sym
)));
913 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
914 doc
: /* Return t if VARIABLE is intended to be set and modified by users.
915 \(The alternative is a variable used internally in a Lisp program.)
916 A variable is a user variable if
917 \(1) the first character of its documentation is `*', or
918 \(2) it is customizable (its property list contains a non-nil value
919 of `standard-value' or `custom-autoload'), or
920 \(3) it is an alias for another user variable.
921 Return nil if VARIABLE is an alias and there is a loop in the
922 chain of symbols. */)
924 Lisp_Object variable
;
926 Lisp_Object documentation
;
928 if (!SYMBOLP (variable
))
931 /* If indirect and there's an alias loop, don't check anything else. */
932 if (XSYMBOL (variable
)->indirect_variable
933 && NILP (internal_condition_case_1 (lisp_indirect_variable
, variable
,
934 Qt
, user_variable_p_eh
)))
939 documentation
= Fget (variable
, Qvariable_documentation
);
940 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
942 if (STRINGP (documentation
)
943 && ((unsigned char) SREF (documentation
, 0) == '*'))
945 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
946 if (CONSP (documentation
)
947 && STRINGP (XCAR (documentation
))
948 && INTEGERP (XCDR (documentation
))
949 && XINT (XCDR (documentation
)) < 0)
951 /* Customizable? See `custom-variable-p'. */
952 if ((!NILP (Fget (variable
, intern ("standard-value"))))
953 || (!NILP (Fget (variable
, intern ("custom-autoload")))))
956 if (!XSYMBOL (variable
)->indirect_variable
)
959 /* An indirect variable? Let's follow the chain. */
960 variable
= XSYMBOL (variable
)->value
;
964 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
965 doc
: /* Bind variables according to VARLIST then eval BODY.
966 The value of the last form in BODY is returned.
967 Each element of VARLIST is a symbol (which is bound to nil)
968 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
969 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
970 usage: (let* VARLIST BODY...) */)
974 Lisp_Object varlist
, val
, elt
;
975 int count
= SPECPDL_INDEX ();
976 struct gcpro gcpro1
, gcpro2
, gcpro3
;
978 GCPRO3 (args
, elt
, varlist
);
980 varlist
= Fcar (args
);
981 while (!NILP (varlist
))
984 elt
= Fcar (varlist
);
986 specbind (elt
, Qnil
);
987 else if (! NILP (Fcdr (Fcdr (elt
))))
988 signal_error ("`let' bindings can have only one value-form", elt
);
991 val
= Feval (Fcar (Fcdr (elt
)));
992 specbind (Fcar (elt
), val
);
994 varlist
= Fcdr (varlist
);
997 val
= Fprogn (Fcdr (args
));
998 return unbind_to (count
, val
);
1001 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
1002 doc
: /* Bind variables according to VARLIST then eval BODY.
1003 The value of the last form in BODY is returned.
1004 Each element of VARLIST is a symbol (which is bound to nil)
1005 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
1006 All the VALUEFORMs are evalled before any symbols are bound.
1007 usage: (let VARLIST BODY...) */)
1011 Lisp_Object
*temps
, tem
;
1012 register Lisp_Object elt
, varlist
;
1013 int count
= SPECPDL_INDEX ();
1014 register int argnum
;
1015 struct gcpro gcpro1
, gcpro2
;
1017 varlist
= Fcar (args
);
1019 /* Make space to hold the values to give the bound variables */
1020 elt
= Flength (varlist
);
1021 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
1023 /* Compute the values and store them in `temps' */
1025 GCPRO2 (args
, *temps
);
1028 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
1031 elt
= XCAR (varlist
);
1033 temps
[argnum
++] = Qnil
;
1034 else if (! NILP (Fcdr (Fcdr (elt
))))
1035 signal_error ("`let' bindings can have only one value-form", elt
);
1037 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
1038 gcpro2
.nvars
= argnum
;
1042 varlist
= Fcar (args
);
1043 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
1045 elt
= XCAR (varlist
);
1046 tem
= temps
[argnum
++];
1048 specbind (elt
, tem
);
1050 specbind (Fcar (elt
), tem
);
1053 elt
= Fprogn (Fcdr (args
));
1054 return unbind_to (count
, elt
);
1057 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
1058 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
1059 The order of execution is thus TEST, BODY, TEST, BODY and so on
1060 until TEST returns nil.
1061 usage: (while TEST BODY...) */)
1065 Lisp_Object test
, body
;
1066 struct gcpro gcpro1
, gcpro2
;
1068 GCPRO2 (test
, body
);
1072 while (!NILP (Feval (test
)))
1082 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
1083 doc
: /* Return result of expanding macros at top level of FORM.
1084 If FORM is not a macro call, it is returned unchanged.
1085 Otherwise, the macro is expanded and the expansion is considered
1086 in place of FORM. When a non-macro-call results, it is returned.
1088 The second optional arg ENVIRONMENT specifies an environment of macro
1089 definitions to shadow the loaded ones for use in file byte-compilation. */)
1092 Lisp_Object environment
;
1094 /* With cleanups from Hallvard Furuseth. */
1095 register Lisp_Object expander
, sym
, def
, tem
;
1099 /* Come back here each time we expand a macro call,
1100 in case it expands into another macro call. */
1103 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1104 def
= sym
= XCAR (form
);
1106 /* Trace symbols aliases to other symbols
1107 until we get a symbol that is not an alias. */
1108 while (SYMBOLP (def
))
1112 tem
= Fassq (sym
, environment
);
1115 def
= XSYMBOL (sym
)->function
;
1116 if (!EQ (def
, Qunbound
))
1121 /* Right now TEM is the result from SYM in ENVIRONMENT,
1122 and if TEM is nil then DEF is SYM's function definition. */
1125 /* SYM is not mentioned in ENVIRONMENT.
1126 Look at its function definition. */
1127 if (EQ (def
, Qunbound
) || !CONSP (def
))
1128 /* Not defined or definition not suitable */
1130 if (EQ (XCAR (def
), Qautoload
))
1132 /* Autoloading function: will it be a macro when loaded? */
1133 tem
= Fnth (make_number (4), def
);
1134 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
1135 /* Yes, load it and try again. */
1137 struct gcpro gcpro1
;
1139 do_autoload (def
, sym
);
1146 else if (!EQ (XCAR (def
), Qmacro
))
1148 else expander
= XCDR (def
);
1152 expander
= XCDR (tem
);
1153 if (NILP (expander
))
1156 form
= apply1 (expander
, XCDR (form
));
1161 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1162 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1163 TAG is evalled to get the tag to use; it must not be nil.
1165 Then the BODY is executed.
1166 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
1167 If no throw happens, `catch' returns the value of the last BODY form.
1168 If a throw happens, it specifies the value to return from `catch'.
1169 usage: (catch TAG BODY...) */)
1173 register Lisp_Object tag
;
1174 struct gcpro gcpro1
;
1177 tag
= Feval (Fcar (args
));
1179 return internal_catch (tag
, Fprogn
, Fcdr (args
));
1182 /* Set up a catch, then call C function FUNC on argument ARG.
1183 FUNC should return a Lisp_Object.
1184 This is how catches are done from within C code. */
1187 internal_catch (tag
, func
, arg
)
1189 Lisp_Object (*func
) ();
1192 /* This structure is made part of the chain `catchlist'. */
1195 /* Fill in the components of c, and put it on the list. */
1199 c
.backlist
= backtrace_list
;
1200 c
.m_handlerlist
= handlerlist
;
1201 c
.m_lisp_eval_depth
= lisp_eval_depth
;
1202 c
.pdlcount
= SPECPDL_INDEX ();
1203 c
.poll_suppress_count
= poll_suppress_count
;
1204 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1205 c
.gcpro
= gcprolist
;
1206 c
.byte_stack
= byte_stack_list
;
1210 if (! _setjmp (c
.jmp
))
1211 c
.val
= (*func
) (arg
);
1213 /* Throw works by a longjmp that comes right here. */
1218 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1219 jump to that CATCH, returning VALUE as the value of that catch.
1221 This is the guts Fthrow and Fsignal; they differ only in the way
1222 they choose the catch tag to throw to. A catch tag for a
1223 condition-case form has a TAG of Qnil.
1225 Before each catch is discarded, unbind all special bindings and
1226 execute all unwind-protect clauses made above that catch. Unwind
1227 the handler stack as we go, so that the proper handlers are in
1228 effect for each unwind-protect clause we run. At the end, restore
1229 some static info saved in CATCH, and longjmp to the location
1232 This is used for correct unwinding in Fthrow and Fsignal. */
1235 unwind_to_catch (catch, value
)
1236 struct catchtag
*catch;
1239 register int last_time
;
1241 /* Save the value in the tag. */
1244 /* Restore certain special C variables. */
1245 set_poll_suppress_count (catch->poll_suppress_count
);
1246 UNBLOCK_INPUT_TO (catch->interrupt_input_blocked
);
1247 handling_signal
= 0;
1252 last_time
= catchlist
== catch;
1254 /* Unwind the specpdl stack, and then restore the proper set of
1256 unbind_to (catchlist
->pdlcount
, Qnil
);
1257 handlerlist
= catchlist
->m_handlerlist
;
1258 catchlist
= catchlist
->next
;
1260 while (! last_time
);
1263 /* If x_catch_errors was done, turn it off now.
1264 (First we give unbind_to a chance to do that.) */
1265 #if 0 /* This would disable x_catch_errors after x_connection_closed.
1266 * The catch must remain in effect during that delicate
1267 * state. --lorentey */
1268 x_fully_uncatch_errors ();
1272 byte_stack_list
= catch->byte_stack
;
1273 gcprolist
= catch->gcpro
;
1276 gcpro_level
= gcprolist
->level
+ 1;
1280 backtrace_list
= catch->backlist
;
1281 lisp_eval_depth
= catch->m_lisp_eval_depth
;
1283 _longjmp (catch->jmp
, 1);
1286 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1287 doc
: /* Throw to the catch for TAG and return VALUE from it.
1288 Both TAG and VALUE are evalled. */)
1290 register Lisp_Object tag
, value
;
1292 register struct catchtag
*c
;
1295 for (c
= catchlist
; c
; c
= c
->next
)
1297 if (EQ (c
->tag
, tag
))
1298 unwind_to_catch (c
, value
);
1300 xsignal2 (Qno_catch
, tag
, value
);
1304 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1305 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1306 If BODYFORM completes normally, its value is returned
1307 after executing the UNWINDFORMS.
1308 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1309 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1314 int count
= SPECPDL_INDEX ();
1316 record_unwind_protect (Fprogn
, Fcdr (args
));
1317 val
= Feval (Fcar (args
));
1318 return unbind_to (count
, val
);
1321 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1322 doc
: /* Regain control when an error is signaled.
1323 Executes BODYFORM and returns its value if no error happens.
1324 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1325 where the BODY is made of Lisp expressions.
1327 A handler is applicable to an error
1328 if CONDITION-NAME is one of the error's condition names.
1329 If an error happens, the first applicable handler is run.
1331 The car of a handler may be a list of condition names
1332 instead of a single condition name. Then it handles all of them.
1334 When a handler handles an error, control returns to the `condition-case'
1335 and it executes the handler's BODY...
1336 with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
1337 (If VAR is nil, the handler can't access that information.)
1338 Then the value of the last BODY form is returned from the `condition-case'
1341 See also the function `signal' for more info.
1342 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1346 register Lisp_Object bodyform
, handlers
;
1347 volatile Lisp_Object var
;
1350 bodyform
= Fcar (Fcdr (args
));
1351 handlers
= Fcdr (Fcdr (args
));
1353 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1356 /* Like Fcondition_case, but the args are separate
1357 rather than passed in a list. Used by Fbyte_code. */
1360 internal_lisp_condition_case (var
, bodyform
, handlers
)
1361 volatile Lisp_Object var
;
1362 Lisp_Object bodyform
, handlers
;
1370 for (val
= handlers
; CONSP (val
); val
= XCDR (val
))
1376 && (SYMBOLP (XCAR (tem
))
1377 || CONSP (XCAR (tem
))))))
1378 error ("Invalid condition handler", tem
);
1383 c
.backlist
= backtrace_list
;
1384 c
.m_handlerlist
= handlerlist
;
1385 c
.m_lisp_eval_depth
= lisp_eval_depth
;
1386 c
.pdlcount
= SPECPDL_INDEX ();
1387 c
.poll_suppress_count
= poll_suppress_count
;
1388 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1389 c
.gcpro
= gcprolist
;
1390 c
.byte_stack
= byte_stack_list
;
1391 if (_setjmp (c
.jmp
))
1394 specbind (h
.var
, c
.val
);
1395 val
= Fprogn (Fcdr (h
.chosen_clause
));
1397 /* Note that this just undoes the binding of h.var; whoever
1398 longjumped to us unwound the stack to c.pdlcount before
1400 unbind_to (c
.pdlcount
, Qnil
);
1407 h
.handler
= handlers
;
1408 h
.next
= handlerlist
;
1412 val
= Feval (bodyform
);
1414 handlerlist
= h
.next
;
1418 /* Call the function BFUN with no arguments, catching errors within it
1419 according to HANDLERS. If there is an error, call HFUN with
1420 one argument which is the data that describes the error:
1423 HANDLERS can be a list of conditions to catch.
1424 If HANDLERS is Qt, catch all errors.
1425 If HANDLERS is Qerror, catch all errors
1426 but allow the debugger to run if that is enabled. */
1429 internal_condition_case (bfun
, handlers
, hfun
)
1430 Lisp_Object (*bfun
) ();
1431 Lisp_Object handlers
;
1432 Lisp_Object (*hfun
) ();
1438 /* Since Fsignal will close off all calls to x_catch_errors,
1439 we will get the wrong results if some are not closed now. */
1441 if (x_catching_errors ())
1447 c
.backlist
= backtrace_list
;
1448 c
.m_handlerlist
= handlerlist
;
1449 c
.m_lisp_eval_depth
= lisp_eval_depth
;
1450 c
.pdlcount
= SPECPDL_INDEX ();
1451 c
.poll_suppress_count
= poll_suppress_count
;
1452 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1453 c
.gcpro
= gcprolist
;
1454 c
.byte_stack
= byte_stack_list
;
1455 if (_setjmp (c
.jmp
))
1457 return (*hfun
) (c
.val
);
1461 h
.handler
= handlers
;
1463 h
.next
= handlerlist
;
1469 handlerlist
= h
.next
;
1473 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1476 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1477 Lisp_Object (*bfun
) ();
1479 Lisp_Object handlers
;
1480 Lisp_Object (*hfun
) ();
1486 /* Since Fsignal will close off all calls to x_catch_errors,
1487 we will get the wrong results if some are not closed now. */
1489 if (x_catching_errors ())
1495 c
.backlist
= backtrace_list
;
1496 c
.m_handlerlist
= handlerlist
;
1497 c
.m_lisp_eval_depth
= lisp_eval_depth
;
1498 c
.pdlcount
= SPECPDL_INDEX ();
1499 c
.poll_suppress_count
= poll_suppress_count
;
1500 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1501 c
.gcpro
= gcprolist
;
1502 c
.byte_stack
= byte_stack_list
;
1503 if (_setjmp (c
.jmp
))
1505 return (*hfun
) (c
.val
);
1509 h
.handler
= handlers
;
1511 h
.next
= handlerlist
;
1515 val
= (*bfun
) (arg
);
1517 handlerlist
= h
.next
;
1522 /* Like internal_condition_case but call BFUN with NARGS as first,
1523 and ARGS as second argument. */
1526 internal_condition_case_2 (bfun
, nargs
, args
, handlers
, hfun
)
1527 Lisp_Object (*bfun
) ();
1530 Lisp_Object handlers
;
1531 Lisp_Object (*hfun
) ();
1537 /* Since Fsignal will close off all calls to x_catch_errors,
1538 we will get the wrong results if some are not closed now. */
1540 if (x_catching_errors ())
1546 c
.backlist
= backtrace_list
;
1547 c
.m_handlerlist
= handlerlist
;
1548 c
.m_lisp_eval_depth
= lisp_eval_depth
;
1549 c
.pdlcount
= SPECPDL_INDEX ();
1550 c
.poll_suppress_count
= poll_suppress_count
;
1551 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1552 c
.gcpro
= gcprolist
;
1553 c
.byte_stack
= byte_stack_list
;
1554 if (_setjmp (c
.jmp
))
1556 return (*hfun
) (c
.val
);
1560 h
.handler
= handlers
;
1562 h
.next
= handlerlist
;
1566 val
= (*bfun
) (nargs
, args
);
1568 handlerlist
= h
.next
;
1573 static Lisp_Object find_handler_clause
P_ ((Lisp_Object
, Lisp_Object
,
1574 Lisp_Object
, Lisp_Object
));
1576 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1577 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1578 This function does not return.
1580 An error symbol is a symbol with an `error-conditions' property
1581 that is a list of condition names.
1582 A handler for any of those names will get to handle this signal.
1583 The symbol `error' should normally be one of them.
1585 DATA should be a list. Its elements are printed as part of the error message.
1586 See Info anchor `(elisp)Definition of signal' for some details on how this
1587 error message is constructed.
1588 If the signal is handled, DATA is made available to the handler.
1589 See also the function `condition-case'. */)
1590 (error_symbol
, data
)
1591 Lisp_Object error_symbol
, data
;
1593 /* When memory is full, ERROR-SYMBOL is nil,
1594 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1595 That is a special case--don't do this in other situations. */
1596 register struct handler
*allhandlers
= handlerlist
;
1597 Lisp_Object conditions
;
1598 extern int gc_in_progress
;
1599 extern int waiting_for_input
;
1601 Lisp_Object real_error_symbol
;
1602 struct backtrace
*bp
;
1604 immediate_quit
= handling_signal
= 0;
1606 /* How handle waiting_for_input? -- giuseppe*/
1607 if (gc_in_progress
/*|| waiting_for_input*/)
1610 if (NILP (error_symbol
))
1611 real_error_symbol
= Fcar (data
);
1613 real_error_symbol
= error_symbol
;
1615 #if 0 /* rms: I don't know why this was here,
1616 but it is surely wrong for an error that is handled. */
1617 #ifdef HAVE_WINDOW_SYSTEM
1618 if (display_hourglass_p
)
1619 cancel_hourglass ();
1623 /* This hook is used by edebug. */
1624 if (! NILP (Vsignal_hook_function
)
1625 && ! NILP (error_symbol
))
1627 /* Edebug takes care of restoring these variables when it exits. */
1628 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1629 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1631 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1632 max_specpdl_size
= SPECPDL_INDEX () + 40;
1634 call2 (Vsignal_hook_function
, error_symbol
, data
);
1637 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1639 /* Remember from where signal was called. Skip over the frame for
1640 `signal' itself. If a frame for `error' follows, skip that,
1641 too. Don't do this when ERROR_SYMBOL is nil, because that
1642 is a memory-full error. */
1643 Vsignaling_function
= Qnil
;
1644 if (backtrace_list
&& !NILP (error_symbol
))
1646 bp
= backtrace_list
->next
;
1647 if (bp
&& bp
->function
&& EQ (*bp
->function
, Qerror
))
1649 if (bp
&& bp
->function
)
1650 Vsignaling_function
= *bp
->function
;
1653 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1655 register Lisp_Object clause
;
1657 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1658 error_symbol
, data
);
1660 if (EQ (clause
, Qlambda
))
1662 /* We can't return values to code which signaled an error, but we
1663 can continue code which has signaled a quit. */
1664 if (EQ (real_error_symbol
, Qquit
))
1667 error ("Cannot return from the debugger in an error");
1672 Lisp_Object unwind_data
;
1673 struct handler
*h
= handlerlist
;
1675 handlerlist
= allhandlers
;
1677 if (NILP (error_symbol
))
1680 unwind_data
= Fcons (error_symbol
, data
);
1681 h
->chosen_clause
= clause
;
1682 unwind_to_catch (h
->tag
, unwind_data
);
1686 handlerlist
= allhandlers
;
1687 /* If no handler is present now, try to run the debugger,
1688 and if that fails, throw to top level. */
1689 find_handler_clause (Qerror
, conditions
, error_symbol
, data
);
1691 Fthrow (Qtop_level
, Qt
);
1693 if (! NILP (error_symbol
))
1694 data
= Fcons (error_symbol
, data
);
1696 string
= Ferror_message_string (data
);
1697 fatal ("%s", SDATA (string
), 0);
1700 /* Internal version of Fsignal that never returns.
1701 Used for anything but Qquit (which can return from Fsignal). */
1704 xsignal (error_symbol
, data
)
1705 Lisp_Object error_symbol
, data
;
1707 Fsignal (error_symbol
, data
);
1711 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1714 xsignal0 (error_symbol
)
1715 Lisp_Object error_symbol
;
1717 xsignal (error_symbol
, Qnil
);
1721 xsignal1 (error_symbol
, arg
)
1722 Lisp_Object error_symbol
, arg
;
1724 xsignal (error_symbol
, list1 (arg
));
1728 xsignal2 (error_symbol
, arg1
, arg2
)
1729 Lisp_Object error_symbol
, arg1
, arg2
;
1731 xsignal (error_symbol
, list2 (arg1
, arg2
));
1735 xsignal3 (error_symbol
, arg1
, arg2
, arg3
)
1736 Lisp_Object error_symbol
, arg1
, arg2
, arg3
;
1738 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1741 /* Signal `error' with message S, and additional arg ARG.
1742 If ARG is not a genuine list, make it a one-element list. */
1745 signal_error (s
, arg
)
1749 Lisp_Object tortoise
, hare
;
1751 hare
= tortoise
= arg
;
1752 while (CONSP (hare
))
1759 tortoise
= XCDR (tortoise
);
1761 if (EQ (hare
, tortoise
))
1766 arg
= Fcons (arg
, Qnil
); /* Make it a list. */
1768 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1772 /* Return nonzero if LIST is a non-nil atom or
1773 a list containing one of CONDITIONS. */
1776 wants_debugger (list
, conditions
)
1777 Lisp_Object list
, conditions
;
1784 while (CONSP (conditions
))
1786 Lisp_Object
this, tail
;
1787 this = XCAR (conditions
);
1788 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1789 if (EQ (XCAR (tail
), this))
1791 conditions
= XCDR (conditions
);
1796 /* Return 1 if an error with condition-symbols CONDITIONS,
1797 and described by SIGNAL-DATA, should skip the debugger
1798 according to debugger-ignored-errors. */
1801 skip_debugger (conditions
, data
)
1802 Lisp_Object conditions
, data
;
1805 int first_string
= 1;
1806 Lisp_Object error_message
;
1808 error_message
= Qnil
;
1809 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1811 if (STRINGP (XCAR (tail
)))
1815 error_message
= Ferror_message_string (data
);
1819 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1824 Lisp_Object contail
;
1826 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1827 if (EQ (XCAR (tail
), XCAR (contail
)))
1835 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1836 SIG and DATA describe the signal, as in find_handler_clause. */
1839 maybe_call_debugger (conditions
, sig
, data
)
1840 Lisp_Object conditions
, sig
, data
;
1842 Lisp_Object combined_data
;
1844 combined_data
= Fcons (sig
, data
);
1847 /* Don't try to run the debugger with interrupts blocked.
1848 The editing loop would return anyway. */
1850 /* Does user want to enter debugger for this kind of error? */
1853 : wants_debugger (Vdebug_on_error
, conditions
))
1854 && ! skip_debugger (conditions
, combined_data
)
1855 /* rms: what's this for? */
1856 && when_entered_debugger
< num_nonmacro_input_events
)
1858 call_debugger (Fcons (Qerror
, Fcons (combined_data
, Qnil
)));
1865 /* Value of Qlambda means we have called debugger and user has continued.
1866 There are two ways to pass SIG and DATA:
1867 = SIG is the error symbol, and DATA is the rest of the data.
1868 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1869 This is for memory-full errors only.
1871 We need to increase max_specpdl_size temporarily around
1872 anything we do that can push on the specpdl, so as not to get
1873 a second error here in case we're handling specpdl overflow. */
1876 find_handler_clause (handlers
, conditions
, sig
, data
)
1877 Lisp_Object handlers
, conditions
, sig
, data
;
1879 register Lisp_Object h
;
1880 register Lisp_Object tem
;
1881 int debugger_called
= 0;
1882 int debugger_considered
= 0;
1884 /* t is used by handlers for all conditions, set up by C code. */
1885 if (EQ (handlers
, Qt
))
1888 /* Don't run the debugger for a memory-full error.
1889 (There is no room in memory to do that!) */
1891 debugger_considered
= 1;
1893 /* error is used similarly, but means print an error message
1894 and run the debugger if that is enabled. */
1895 if (EQ (handlers
, Qerror
)
1896 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1897 there is a handler. */
1899 if (!NILP (sig
) && wants_debugger (Vstack_trace_on_error
, conditions
))
1901 max_lisp_eval_depth
+= 15;
1906 internal_with_output_to_temp_buffer
1908 (Lisp_Object (*) (Lisp_Object
)) Fbacktrace
,
1911 max_lisp_eval_depth
-= 15;
1914 if (!debugger_considered
)
1916 debugger_considered
= 1;
1917 debugger_called
= maybe_call_debugger (conditions
, sig
, data
);
1920 /* If there is no handler, return saying whether we ran the debugger. */
1921 if (EQ (handlers
, Qerror
))
1923 if (debugger_called
)
1929 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1931 Lisp_Object handler
, condit
;
1934 if (!CONSP (handler
))
1936 condit
= Fcar (handler
);
1937 /* Handle a single condition name in handler HANDLER. */
1938 if (SYMBOLP (condit
))
1940 tem
= Fmemq (Fcar (handler
), conditions
);
1944 /* Handle a list of condition names in handler HANDLER. */
1945 else if (CONSP (condit
))
1948 for (tail
= condit
; CONSP (tail
); tail
= XCDR (tail
))
1950 tem
= Fmemq (Fcar (tail
), conditions
);
1953 /* This handler is going to apply.
1954 Does it allow the debugger to run first? */
1955 if (! debugger_considered
&& !NILP (Fmemq (Qdebug
, condit
)))
1956 maybe_call_debugger (conditions
, sig
, data
);
1966 /* dump an error message; called like printf */
1970 error (m
, a1
, a2
, a3
)
1990 int used
= doprnt (buffer
, size
, m
, m
+ mlen
, 3, args
);
1995 buffer
= (char *) xrealloc (buffer
, size
);
1998 buffer
= (char *) xmalloc (size
);
2003 string
= build_string (buffer
);
2007 xsignal1 (Qerror
, string
);
2010 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
2011 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
2012 This means it contains a description for how to read arguments to give it.
2013 The value is nil for an invalid function or a symbol with no function
2016 Interactively callable functions include strings and vectors (treated
2017 as keyboard macros), lambda-expressions that contain a top-level call
2018 to `interactive', autoload definitions made by `autoload' with non-nil
2019 fourth argument, and some of the built-in functions of Lisp.
2021 Also, a symbol satisfies `commandp' if its function definition does so.
2023 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
2024 then strings and vectors are not accepted. */)
2025 (function
, for_call_interactively
)
2026 Lisp_Object function
, for_call_interactively
;
2028 register Lisp_Object fun
;
2029 register Lisp_Object funcar
;
2030 Lisp_Object if_prop
= Qnil
;
2034 fun
= indirect_function (fun
); /* Check cycles. */
2035 if (NILP (fun
) || EQ (fun
, Qunbound
))
2038 /* Check an `interactive-form' property if present, analogous to the
2039 function-documentation property. */
2041 while (SYMBOLP (fun
))
2043 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
2046 fun
= Fsymbol_function (fun
);
2049 /* Emacs primitives are interactive if their DEFUN specifies an
2050 interactive spec. */
2052 return XSUBR (fun
)->intspec
? Qt
: if_prop
;
2054 /* Bytecode objects are interactive if they are long enough to
2055 have an element whose index is COMPILED_INTERACTIVE, which is
2056 where the interactive spec is stored. */
2057 else if (COMPILEDP (fun
))
2058 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
2061 /* Strings and vectors are keyboard macros. */
2062 if (STRINGP (fun
) || VECTORP (fun
))
2063 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
2065 /* Lists may represent commands. */
2068 funcar
= XCAR (fun
);
2069 if (EQ (funcar
, Qlambda
))
2070 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
2071 if (EQ (funcar
, Qautoload
))
2072 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
2077 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
2078 doc
: /* Define FUNCTION to autoload from FILE.
2079 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
2080 Third arg DOCSTRING is documentation for the function.
2081 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
2082 Fifth arg TYPE indicates the type of the object:
2083 nil or omitted says FUNCTION is a function,
2084 `keymap' says FUNCTION is really a keymap, and
2085 `macro' or t says FUNCTION is really a macro.
2086 Third through fifth args give info about the real definition.
2087 They default to nil.
2088 If FUNCTION is already defined other than as an autoload,
2089 this does nothing and returns nil. */)
2090 (function
, file
, docstring
, interactive
, type
)
2091 Lisp_Object function
, file
, docstring
, interactive
, type
;
2093 Lisp_Object args
[4];
2095 CHECK_SYMBOL (function
);
2096 CHECK_STRING (file
);
2098 /* If function is defined and not as an autoload, don't override */
2099 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
2100 && !(CONSP (XSYMBOL (function
)->function
)
2101 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
2104 if (NILP (Vpurify_flag
))
2105 /* Only add entries after dumping, because the ones before are
2106 not useful and else we get loads of them from the loaddefs.el. */
2107 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
2109 /* We don't want the docstring in purespace (instead,
2110 Snarf-documentation should (hopefully) overwrite it). */
2111 docstring
= make_number (0);
2112 return Ffset (function
,
2113 Fpurecopy (list5 (Qautoload
, file
, docstring
,
2114 interactive
, type
)));
2118 un_autoload (oldqueue
)
2119 Lisp_Object oldqueue
;
2121 register Lisp_Object queue
, first
, second
;
2123 /* Queue to unwind is current value of Vautoload_queue.
2124 oldqueue is the shadowed value to leave in Vautoload_queue. */
2125 queue
= Vautoload_queue
;
2126 Vautoload_queue
= oldqueue
;
2127 while (CONSP (queue
))
2129 first
= XCAR (queue
);
2130 second
= Fcdr (first
);
2131 first
= Fcar (first
);
2132 if (EQ (first
, make_number (0)))
2135 Ffset (first
, second
);
2136 queue
= XCDR (queue
);
2141 /* Load an autoloaded function.
2142 FUNNAME is the symbol which is the function's name.
2143 FUNDEF is the autoload definition (a list). */
2146 do_autoload (fundef
, funname
)
2147 Lisp_Object fundef
, funname
;
2149 int count
= SPECPDL_INDEX ();
2151 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2153 /* This is to make sure that loadup.el gives a clear picture
2154 of what files are preloaded and when. */
2155 if (! NILP (Vpurify_flag
))
2156 error ("Attempt to autoload %s while preparing to dump",
2157 SDATA (SYMBOL_NAME (funname
)));
2160 CHECK_SYMBOL (funname
);
2161 GCPRO3 (fun
, funname
, fundef
);
2163 /* Preserve the match data. */
2164 record_unwind_save_match_data ();
2166 /* If autoloading gets an error (which includes the error of failing
2167 to define the function being called), we use Vautoload_queue
2168 to undo function definitions and `provide' calls made by
2169 the function. We do this in the specific case of autoloading
2170 because autoloading is not an explicit request "load this file",
2171 but rather a request to "call this function".
2173 The value saved here is to be restored into Vautoload_queue. */
2174 record_unwind_protect (un_autoload
, Vautoload_queue
);
2175 Vautoload_queue
= Qt
;
2176 Fload (Fcar (Fcdr (fundef
)), Qnil
, Qt
, Qnil
, Qt
);
2178 /* Once loading finishes, don't undo it. */
2179 Vautoload_queue
= Qt
;
2180 unbind_to (count
, Qnil
);
2182 fun
= Findirect_function (fun
, Qnil
);
2184 if (!NILP (Fequal (fun
, fundef
)))
2185 error ("Autoloading failed to define function %s",
2186 SDATA (SYMBOL_NAME (funname
)));
2191 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
2192 doc
: /* Evaluate FORM and return its value. */)
2196 Lisp_Object fun
, val
, original_fun
, original_args
;
2198 struct backtrace backtrace
;
2199 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2201 if (handling_signal
)
2205 return Fsymbol_value (form
);
2210 if ((consing_since_gc
> gc_cons_threshold
2211 && consing_since_gc
> gc_relative_threshold
)
2213 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2216 Fgarbage_collect ();
2220 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2222 if (max_lisp_eval_depth
< 100)
2223 max_lisp_eval_depth
= 100;
2224 if (lisp_eval_depth
> max_lisp_eval_depth
)
2225 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2228 original_fun
= Fcar (form
);
2229 original_args
= Fcdr (form
);
2231 backtrace
.next
= backtrace_list
;
2232 backtrace_list
= &backtrace
;
2233 backtrace
.function
= &original_fun
; /* This also protects them from gc */
2234 backtrace
.args
= &original_args
;
2235 backtrace
.nargs
= UNEVALLED
;
2236 backtrace
.evalargs
= 1;
2237 backtrace
.debug_on_exit
= 0;
2239 if (debug_on_next_call
)
2240 do_debug_on_call (Qt
);
2242 /* At this point, only original_fun and original_args
2243 have values that will be used below */
2246 /* Optimize for no indirection. */
2248 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2249 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2250 fun
= indirect_function (fun
);
2254 Lisp_Object numargs
;
2255 Lisp_Object argvals
[8];
2256 Lisp_Object args_left
;
2257 register int i
, maxargs
;
2259 args_left
= original_args
;
2260 numargs
= Flength (args_left
);
2264 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
2265 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2266 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2268 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2270 backtrace
.evalargs
= 0;
2271 val
= (*XSUBR (fun
)->function
) (args_left
);
2275 if (XSUBR (fun
)->max_args
== MANY
)
2277 /* Pass a vector of evaluated arguments */
2279 register int argnum
= 0;
2281 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2283 GCPRO3 (args_left
, fun
, fun
);
2287 while (!NILP (args_left
))
2289 vals
[argnum
++] = Feval (Fcar (args_left
));
2290 args_left
= Fcdr (args_left
);
2291 gcpro3
.nvars
= argnum
;
2294 backtrace
.args
= vals
;
2295 backtrace
.nargs
= XINT (numargs
);
2297 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
2302 GCPRO3 (args_left
, fun
, fun
);
2303 gcpro3
.var
= argvals
;
2306 maxargs
= XSUBR (fun
)->max_args
;
2307 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
2309 argvals
[i
] = Feval (Fcar (args_left
));
2315 backtrace
.args
= argvals
;
2316 backtrace
.nargs
= XINT (numargs
);
2321 val
= (*XSUBR (fun
)->function
) ();
2324 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
2327 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
2330 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2334 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2335 argvals
[2], argvals
[3]);
2338 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2339 argvals
[3], argvals
[4]);
2342 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2343 argvals
[3], argvals
[4], argvals
[5]);
2346 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2347 argvals
[3], argvals
[4], argvals
[5],
2352 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2353 argvals
[3], argvals
[4], argvals
[5],
2354 argvals
[6], argvals
[7]);
2358 /* Someone has created a subr that takes more arguments than
2359 is supported by this code. We need to either rewrite the
2360 subr to use a different argument protocol, or add more
2361 cases to this switch. */
2365 if (COMPILEDP (fun
))
2366 val
= apply_lambda (fun
, original_args
, 1);
2369 if (EQ (fun
, Qunbound
))
2370 xsignal1 (Qvoid_function
, original_fun
);
2372 xsignal1 (Qinvalid_function
, original_fun
);
2373 funcar
= XCAR (fun
);
2374 if (!SYMBOLP (funcar
))
2375 xsignal1 (Qinvalid_function
, original_fun
);
2376 if (EQ (funcar
, Qautoload
))
2378 do_autoload (fun
, original_fun
);
2381 if (EQ (funcar
, Qmacro
))
2382 val
= Feval (apply1 (Fcdr (fun
), original_args
));
2383 else if (EQ (funcar
, Qlambda
))
2384 val
= apply_lambda (fun
, original_args
, 1);
2386 xsignal1 (Qinvalid_function
, original_fun
);
2392 if (backtrace
.debug_on_exit
)
2393 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2394 backtrace_list
= backtrace
.next
;
2399 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
2400 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2401 Then return the value FUNCTION returns.
2402 Thus, (apply '+ 1 2 '(3 4)) returns 10.
2403 usage: (apply FUNCTION &rest ARGUMENTS) */)
2408 register int i
, numargs
;
2409 register Lisp_Object spread_arg
;
2410 register Lisp_Object
*funcall_args
;
2412 struct gcpro gcpro1
;
2416 spread_arg
= args
[nargs
- 1];
2417 CHECK_LIST (spread_arg
);
2419 numargs
= XINT (Flength (spread_arg
));
2422 return Ffuncall (nargs
- 1, args
);
2423 else if (numargs
== 1)
2425 args
[nargs
- 1] = XCAR (spread_arg
);
2426 return Ffuncall (nargs
, args
);
2429 numargs
+= nargs
- 2;
2431 /* Optimize for no indirection. */
2432 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2433 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2434 fun
= indirect_function (fun
);
2435 if (EQ (fun
, Qunbound
))
2437 /* Let funcall get the error */
2444 if (numargs
< XSUBR (fun
)->min_args
2445 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2446 goto funcall
; /* Let funcall get the error */
2447 else if (XSUBR (fun
)->max_args
> numargs
)
2449 /* Avoid making funcall cons up a yet another new vector of arguments
2450 by explicitly supplying nil's for optional values */
2451 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
2452 * sizeof (Lisp_Object
));
2453 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2454 funcall_args
[++i
] = Qnil
;
2455 GCPRO1 (*funcall_args
);
2456 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2460 /* We add 1 to numargs because funcall_args includes the
2461 function itself as well as its arguments. */
2464 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
2465 * sizeof (Lisp_Object
));
2466 GCPRO1 (*funcall_args
);
2467 gcpro1
.nvars
= 1 + numargs
;
2470 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
2471 /* Spread the last arg we got. Its first element goes in
2472 the slot that it used to occupy, hence this value of I. */
2474 while (!NILP (spread_arg
))
2476 funcall_args
[i
++] = XCAR (spread_arg
);
2477 spread_arg
= XCDR (spread_arg
);
2480 /* By convention, the caller needs to gcpro Ffuncall's args. */
2481 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
2484 /* Run hook variables in various ways. */
2486 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
2487 static Lisp_Object run_hook_with_args
P_ ((int, Lisp_Object
*,
2488 enum run_hooks_condition
));
2490 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2491 doc
: /* Run each hook in HOOKS.
2492 Each argument should be a symbol, a hook variable.
2493 These symbols are processed in the order specified.
2494 If a hook symbol has a non-nil value, that value may be a function
2495 or a list of functions to be called to run the hook.
2496 If the value is a function, it is called with no arguments.
2497 If it is a list, the elements are called, in order, with no arguments.
2499 Major modes should not use this function directly to run their mode
2500 hook; they should use `run-mode-hooks' instead.
2502 Do not use `make-local-variable' to make a hook variable buffer-local.
2503 Instead, use `add-hook' and specify t for the LOCAL argument.
2504 usage: (run-hooks &rest HOOKS) */)
2509 Lisp_Object hook
[1];
2512 for (i
= 0; i
< nargs
; i
++)
2515 run_hook_with_args (1, hook
, to_completion
);
2521 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2522 Srun_hook_with_args
, 1, MANY
, 0,
2523 doc
: /* Run HOOK with the specified arguments ARGS.
2524 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2525 value, that value may be a function or a list of functions to be
2526 called to run the hook. If the value is a function, it is called with
2527 the given arguments and its return value is returned. If it is a list
2528 of functions, those functions are called, in order,
2529 with the given arguments ARGS.
2530 It is best not to depend on the value returned by `run-hook-with-args',
2533 Do not use `make-local-variable' to make a hook variable buffer-local.
2534 Instead, use `add-hook' and specify t for the LOCAL argument.
2535 usage: (run-hook-with-args HOOK &rest ARGS) */)
2540 return run_hook_with_args (nargs
, args
, to_completion
);
2543 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2544 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2545 doc
: /* Run HOOK with the specified arguments ARGS.
2546 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2547 value, that value may be a function or a list of functions to be
2548 called to run the hook. If the value is a function, it is called with
2549 the given arguments and its return value is returned.
2550 If it is a list of functions, those functions are called, in order,
2551 with the given arguments ARGS, until one of them
2552 returns a non-nil value. Then we return that value.
2553 However, if they all return nil, we return nil.
2555 Do not use `make-local-variable' to make a hook variable buffer-local.
2556 Instead, use `add-hook' and specify t for the LOCAL argument.
2557 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2562 return run_hook_with_args (nargs
, args
, until_success
);
2565 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2566 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2567 doc
: /* Run HOOK with the specified arguments ARGS.
2568 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2569 value, that value may be a function or a list of functions to be
2570 called to run the hook. If the value is a function, it is called with
2571 the given arguments and its return value is returned.
2572 If it is a list of functions, those functions are called, in order,
2573 with the given arguments ARGS, until one of them returns nil.
2574 Then we return nil. However, if they all return non-nil, we return non-nil.
2576 Do not use `make-local-variable' to make a hook variable buffer-local.
2577 Instead, use `add-hook' and specify t for the LOCAL argument.
2578 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2583 return run_hook_with_args (nargs
, args
, until_failure
);
2586 /* ARGS[0] should be a hook symbol.
2587 Call each of the functions in the hook value, passing each of them
2588 as arguments all the rest of ARGS (all NARGS - 1 elements).
2589 COND specifies a condition to test after each call
2590 to decide whether to stop.
2591 The caller (or its caller, etc) must gcpro all of ARGS,
2592 except that it isn't necessary to gcpro ARGS[0]. */
2595 run_hook_with_args (nargs
, args
, cond
)
2598 enum run_hooks_condition cond
;
2600 Lisp_Object sym
, val
, ret
;
2601 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2603 /* If we are dying or still initializing,
2604 don't do anything--it would probably crash if we tried. */
2605 if (NILP (Vrun_hooks
))
2609 val
= find_symbol_value (sym
);
2610 ret
= (cond
== until_failure
? Qt
: Qnil
);
2612 if (EQ (val
, Qunbound
) || NILP (val
))
2614 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2617 return Ffuncall (nargs
, args
);
2621 Lisp_Object globals
= Qnil
;
2622 GCPRO3 (sym
, val
, globals
);
2625 CONSP (val
) && ((cond
== to_completion
)
2626 || (cond
== until_success
? NILP (ret
)
2630 if (EQ (XCAR (val
), Qt
))
2632 /* t indicates this hook has a local binding;
2633 it means to run the global binding too. */
2634 globals
= Fdefault_value (sym
);
2635 if (NILP (globals
)) continue;
2637 if (!CONSP (globals
) || EQ (XCAR (globals
), Qlambda
))
2640 ret
= Ffuncall (nargs
, args
);
2645 CONSP (globals
) && ((cond
== to_completion
)
2646 || (cond
== until_success
? NILP (ret
)
2648 globals
= XCDR (globals
))
2650 args
[0] = XCAR (globals
);
2651 /* In a global value, t should not occur. If it does, we
2652 must ignore it to avoid an endless loop. */
2653 if (!EQ (args
[0], Qt
))
2654 ret
= Ffuncall (nargs
, args
);
2660 args
[0] = XCAR (val
);
2661 ret
= Ffuncall (nargs
, args
);
2670 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2671 present value of that symbol.
2672 Call each element of FUNLIST,
2673 passing each of them the rest of ARGS.
2674 The caller (or its caller, etc) must gcpro all of ARGS,
2675 except that it isn't necessary to gcpro ARGS[0]. */
2678 run_hook_list_with_args (funlist
, nargs
, args
)
2679 Lisp_Object funlist
;
2685 Lisp_Object globals
;
2686 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2690 GCPRO3 (sym
, val
, globals
);
2692 for (val
= funlist
; CONSP (val
); val
= XCDR (val
))
2694 if (EQ (XCAR (val
), Qt
))
2696 /* t indicates this hook has a local binding;
2697 it means to run the global binding too. */
2699 for (globals
= Fdefault_value (sym
);
2701 globals
= XCDR (globals
))
2703 args
[0] = XCAR (globals
);
2704 /* In a global value, t should not occur. If it does, we
2705 must ignore it to avoid an endless loop. */
2706 if (!EQ (args
[0], Qt
))
2707 Ffuncall (nargs
, args
);
2712 args
[0] = XCAR (val
);
2713 Ffuncall (nargs
, args
);
2720 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2723 run_hook_with_args_2 (hook
, arg1
, arg2
)
2724 Lisp_Object hook
, arg1
, arg2
;
2726 Lisp_Object temp
[3];
2731 Frun_hook_with_args (3, temp
);
2734 /* Apply fn to arg */
2737 Lisp_Object fn
, arg
;
2739 struct gcpro gcpro1
;
2743 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2747 Lisp_Object args
[2];
2751 RETURN_UNGCPRO (Fapply (2, args
));
2753 #else /* not NO_ARG_ARRAY */
2754 RETURN_UNGCPRO (Fapply (2, &fn
));
2755 #endif /* not NO_ARG_ARRAY */
2758 /* Call function fn on no arguments */
2763 struct gcpro gcpro1
;
2766 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2769 /* Call function fn with 1 argument arg1 */
2773 Lisp_Object fn
, arg1
;
2775 struct gcpro gcpro1
;
2777 Lisp_Object args
[2];
2783 RETURN_UNGCPRO (Ffuncall (2, args
));
2784 #else /* not NO_ARG_ARRAY */
2787 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2788 #endif /* not NO_ARG_ARRAY */
2791 /* Call function fn with 2 arguments arg1, arg2 */
2794 call2 (fn
, arg1
, arg2
)
2795 Lisp_Object fn
, arg1
, arg2
;
2797 struct gcpro gcpro1
;
2799 Lisp_Object args
[3];
2805 RETURN_UNGCPRO (Ffuncall (3, args
));
2806 #else /* not NO_ARG_ARRAY */
2809 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2810 #endif /* not NO_ARG_ARRAY */
2813 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2816 call3 (fn
, arg1
, arg2
, arg3
)
2817 Lisp_Object fn
, arg1
, arg2
, arg3
;
2819 struct gcpro gcpro1
;
2821 Lisp_Object args
[4];
2828 RETURN_UNGCPRO (Ffuncall (4, args
));
2829 #else /* not NO_ARG_ARRAY */
2832 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2833 #endif /* not NO_ARG_ARRAY */
2836 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2839 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2840 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2842 struct gcpro gcpro1
;
2844 Lisp_Object args
[5];
2852 RETURN_UNGCPRO (Ffuncall (5, args
));
2853 #else /* not NO_ARG_ARRAY */
2856 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2857 #endif /* not NO_ARG_ARRAY */
2860 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2863 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2864 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2866 struct gcpro gcpro1
;
2868 Lisp_Object args
[6];
2877 RETURN_UNGCPRO (Ffuncall (6, args
));
2878 #else /* not NO_ARG_ARRAY */
2881 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2882 #endif /* not NO_ARG_ARRAY */
2885 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2888 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2889 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2891 struct gcpro gcpro1
;
2893 Lisp_Object args
[7];
2903 RETURN_UNGCPRO (Ffuncall (7, args
));
2904 #else /* not NO_ARG_ARRAY */
2907 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2908 #endif /* not NO_ARG_ARRAY */
2911 /* The caller should GCPRO all the elements of ARGS. */
2913 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2914 doc
: /* Call first argument as a function, passing remaining arguments to it.
2915 Return the value that function returns.
2916 Thus, (funcall 'cons 'x 'y) returns (x . y).
2917 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2922 Lisp_Object fun
, original_fun
;
2924 int numargs
= nargs
- 1;
2925 Lisp_Object lisp_numargs
;
2927 struct backtrace backtrace
;
2928 register Lisp_Object
*internal_args
;
2932 if ((consing_since_gc
> gc_cons_threshold
2933 && consing_since_gc
> gc_relative_threshold
)
2935 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2936 Fgarbage_collect ();
2938 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2940 if (max_lisp_eval_depth
< 100)
2941 max_lisp_eval_depth
= 100;
2942 if (lisp_eval_depth
> max_lisp_eval_depth
)
2943 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2946 backtrace
.next
= backtrace_list
;
2947 backtrace_list
= &backtrace
;
2948 backtrace
.function
= &args
[0];
2949 backtrace
.args
= &args
[1];
2950 backtrace
.nargs
= nargs
- 1;
2951 backtrace
.evalargs
= 0;
2952 backtrace
.debug_on_exit
= 0;
2954 if (debug_on_next_call
)
2955 do_debug_on_call (Qlambda
);
2959 original_fun
= args
[0];
2963 /* Optimize for no indirection. */
2965 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2966 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2967 fun
= indirect_function (fun
);
2971 if (numargs
< XSUBR (fun
)->min_args
2972 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2974 XSETFASTINT (lisp_numargs
, numargs
);
2975 xsignal2 (Qwrong_number_of_arguments
, original_fun
, lisp_numargs
);
2978 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2979 xsignal1 (Qinvalid_function
, original_fun
);
2981 if (XSUBR (fun
)->max_args
== MANY
)
2983 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
2987 if (XSUBR (fun
)->max_args
> numargs
)
2989 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2990 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
2991 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2992 internal_args
[i
] = Qnil
;
2995 internal_args
= args
+ 1;
2996 switch (XSUBR (fun
)->max_args
)
2999 val
= (*XSUBR (fun
)->function
) ();
3002 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
3005 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1]);
3008 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3012 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3013 internal_args
[2], internal_args
[3]);
3016 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3017 internal_args
[2], internal_args
[3],
3021 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3022 internal_args
[2], internal_args
[3],
3023 internal_args
[4], internal_args
[5]);
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],
3033 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3034 internal_args
[2], internal_args
[3],
3035 internal_args
[4], internal_args
[5],
3036 internal_args
[6], internal_args
[7]);
3041 /* If a subr takes more than 8 arguments without using MANY
3042 or UNEVALLED, we need to extend this function to support it.
3043 Until this is done, there is no way to call the function. */
3047 if (COMPILEDP (fun
))
3048 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3051 if (EQ (fun
, Qunbound
))
3052 xsignal1 (Qvoid_function
, original_fun
);
3054 xsignal1 (Qinvalid_function
, original_fun
);
3055 funcar
= XCAR (fun
);
3056 if (!SYMBOLP (funcar
))
3057 xsignal1 (Qinvalid_function
, original_fun
);
3058 if (EQ (funcar
, Qlambda
))
3059 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3060 else if (EQ (funcar
, Qautoload
))
3062 do_autoload (fun
, original_fun
);
3067 xsignal1 (Qinvalid_function
, original_fun
);
3072 if (backtrace
.debug_on_exit
)
3073 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
3074 backtrace_list
= backtrace
.next
;
3079 apply_lambda (fun
, args
, eval_flag
)
3080 Lisp_Object fun
, args
;
3083 Lisp_Object args_left
;
3084 Lisp_Object numargs
;
3085 register Lisp_Object
*arg_vector
;
3086 struct gcpro gcpro1
, gcpro2
, gcpro3
;
3088 register Lisp_Object tem
;
3090 numargs
= Flength (args
);
3091 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
3094 GCPRO3 (*arg_vector
, args_left
, fun
);
3097 for (i
= 0; i
< XINT (numargs
);)
3099 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
3100 if (eval_flag
) tem
= Feval (tem
);
3101 arg_vector
[i
++] = tem
;
3109 backtrace_list
->args
= arg_vector
;
3110 backtrace_list
->nargs
= i
;
3112 backtrace_list
->evalargs
= 0;
3113 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
3115 /* Do the debug-on-exit now, while arg_vector still exists. */
3116 if (backtrace_list
->debug_on_exit
)
3117 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
3118 /* Don't do it again when we return to eval. */
3119 backtrace_list
->debug_on_exit
= 0;
3123 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
3124 and return the result of evaluation.
3125 FUN must be either a lambda-expression or a compiled-code object. */
3128 funcall_lambda (fun
, nargs
, arg_vector
)
3131 register Lisp_Object
*arg_vector
;
3133 Lisp_Object val
, syms_left
, next
;
3134 int count
= SPECPDL_INDEX ();
3135 int i
, optional
, rest
;
3139 syms_left
= XCDR (fun
);
3140 if (CONSP (syms_left
))
3141 syms_left
= XCAR (syms_left
);
3143 xsignal1 (Qinvalid_function
, fun
);
3145 else if (COMPILEDP (fun
))
3146 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3150 i
= optional
= rest
= 0;
3151 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3155 next
= XCAR (syms_left
);
3156 if (!SYMBOLP (next
))
3157 xsignal1 (Qinvalid_function
, fun
);
3159 if (EQ (next
, Qand_rest
))
3161 else if (EQ (next
, Qand_optional
))
3165 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
3169 specbind (next
, arg_vector
[i
++]);
3171 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3173 specbind (next
, Qnil
);
3176 if (!NILP (syms_left
))
3177 xsignal1 (Qinvalid_function
, fun
);
3179 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3182 val
= Fprogn (XCDR (XCDR (fun
)));
3185 /* If we have not actually read the bytecode string
3186 and constants vector yet, fetch them from the file. */
3187 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3188 Ffetch_bytecode (fun
);
3189 val
= Fbyte_code (AREF (fun
, COMPILED_BYTECODE
),
3190 AREF (fun
, COMPILED_CONSTANTS
),
3191 AREF (fun
, COMPILED_STACK_DEPTH
));
3194 return unbind_to (count
, val
);
3197 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3199 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3205 if (COMPILEDP (object
) && CONSP (AREF (object
, COMPILED_BYTECODE
)))
3207 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3210 tem
= AREF (object
, COMPILED_BYTECODE
);
3211 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3212 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3214 error ("Invalid byte code");
3216 ASET (object
, COMPILED_BYTECODE
, XCAR (tem
));
3217 ASET (object
, COMPILED_CONSTANTS
, XCDR (tem
));
3225 register int count
= SPECPDL_INDEX ();
3226 if (specpdl_size
>= max_specpdl_size
)
3228 if (max_specpdl_size
< 400)
3229 max_specpdl_size
= 400;
3230 if (specpdl_size
>= max_specpdl_size
)
3231 signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil
);
3234 if (specpdl_size
> max_specpdl_size
)
3235 specpdl_size
= max_specpdl_size
;
3236 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
3237 specpdl_ptr
= specpdl
+ count
;
3241 specbind (symbol
, value
)
3242 Lisp_Object symbol
, value
;
3244 Lisp_Object valcontents
;
3246 CHECK_SYMBOL (symbol
);
3247 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3250 /* The most common case is that of a non-constant symbol with a
3251 trivial value. Make that as fast as we can. */
3252 valcontents
= SYMBOL_VALUE (symbol
);
3253 if (!MISCP (valcontents
) && !SYMBOL_CONSTANT_P (symbol
))
3256 = ensure_thread_local (&indirect_variable (XSYMBOL (symbol
))->value
);
3257 specpdl_ptr
->symbol
= symbol
;
3258 /* We know VALCONTENTS is equivalent to the CDR, but we save the
3259 CDR in case it is the thread-local mark. */
3260 specpdl_ptr
->old_value
= XCDR (cons
);
3261 specpdl_ptr
->func
= NULL
;
3263 XSETCDR (cons
, value
);
3267 Lisp_Object ovalue
= find_symbol_value (symbol
);
3268 specpdl_ptr
->func
= 0;
3269 specpdl_ptr
->old_value
= ovalue
;
3271 valcontents
= XSYMBOL (symbol
)->value
;
3273 if (BUFFER_LOCAL_VALUEP (valcontents
)
3274 || BUFFER_OBJFWDP (valcontents
))
3276 Lisp_Object where
, self_buffer
;
3278 self_buffer
= Fcurrent_buffer ();
3280 /* For a local variable, record both the symbol and which
3281 buffer's or frame's value we are saving. */
3282 if (!NILP (Flocal_variable_p (symbol
, Qnil
)))
3283 where
= self_buffer
;
3284 else if (BUFFER_LOCAL_VALUEP (valcontents
)
3285 && BLOCAL_FOUND_FOR_FRAME (XBUFFER_LOCAL_VALUE (valcontents
)))
3286 where
= BLOCAL_FRAME (XBUFFER_LOCAL_VALUE (valcontents
));
3290 /* We're not using the `unused' slot in the specbinding
3291 structure because this would mean we have to do more
3292 work for simple variables. */
3293 specpdl_ptr
->symbol
= Fcons (symbol
, Fcons (where
, self_buffer
));
3295 /* If SYMBOL is a per-buffer variable which doesn't have a
3296 buffer-local value here, make the `let' change the global
3297 value by changing the value of SYMBOL in all buffers not
3298 having their own value. This is consistent with what
3299 happens with other buffer-local variables. */
3301 && BUFFER_OBJFWDP (valcontents
))
3304 Fset_default (symbol
, value
);
3309 specpdl_ptr
->symbol
= symbol
;
3313 if (BUFFER_OBJFWDP (ovalue) || KBOARD_OBJFWDP (ovalue))
3314 store_symval_forwarding (symbol, ovalue, value, NULL);
3316 but ovalue comes from find_symbol_value which should never return
3317 such an internal value. */
3318 eassert (!(BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
)));
3319 set_internal (symbol
, value
, 0, 1);
3324 record_unwind_protect (function
, arg
)
3325 Lisp_Object (*function
) P_ ((Lisp_Object
));
3328 eassert (!handling_signal
);
3330 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3332 specpdl_ptr
->func
= function
;
3333 specpdl_ptr
->symbol
= Qnil
;
3334 specpdl_ptr
->old_value
= arg
;
3339 unbind_to (count
, value
)
3343 Lisp_Object quitf
= Vquit_flag
;
3344 struct gcpro gcpro1
, gcpro2
;
3346 GCPRO2 (value
, quitf
);
3349 while (specpdl_ptr
!= specpdl
+ count
)
3351 /* Copy the binding, and decrement specpdl_ptr, before we do
3352 the work to unbind it. We decrement first
3353 so that an error in unbinding won't try to unbind
3354 the same entry again, and we copy the binding first
3355 in case more bindings are made during some of the code we run. */
3357 struct specbinding this_binding
;
3358 this_binding
= *--specpdl_ptr
;
3360 if (this_binding
.func
!= 0)
3361 (*this_binding
.func
) (this_binding
.old_value
);
3362 /* If the symbol is a list, it is really (SYMBOL WHERE
3363 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3364 frame. If WHERE is a buffer or frame, this indicates we
3365 bound a variable that had a buffer-local or frame-local
3366 binding. WHERE nil means that the variable had the default
3367 value when it was bound. CURRENT-BUFFER is the buffer that
3368 was current when the variable was bound. */
3369 else if (CONSP (this_binding
.symbol
))
3371 Lisp_Object symbol
, where
;
3373 symbol
= XCAR (this_binding
.symbol
);
3374 where
= XCAR (XCDR (this_binding
.symbol
));
3377 Fset_default (symbol
, this_binding
.old_value
);
3378 else if (BUFFERP (where
))
3379 set_internal (symbol
, this_binding
.old_value
, XBUFFER (where
), 1);
3381 set_internal (symbol
, this_binding
.old_value
, NULL
, 1);
3385 /* If variable has a trivial value (no forwarding), we can
3386 just set it. No need to check for constant symbols here,
3387 since that was already done by specbind. */
3388 if (!MISCP (SYMBOL_VALUE (this_binding
.symbol
)))
3389 SET_SYMBOL_VALUE (this_binding
.symbol
, this_binding
.old_value
);
3392 if (EQ (this_binding
.old_value
, Qthread_local_mark
))
3393 remove_thread_local (&indirect_variable (XSYMBOL (this_binding
.symbol
))->value
);
3395 set_internal (this_binding
.symbol
, this_binding
.old_value
, 0, 1);
3400 if (NILP (Vquit_flag
) && !NILP (quitf
))
3407 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3408 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3409 The debugger is entered when that frame exits, if the flag is non-nil. */)
3411 Lisp_Object level
, flag
;
3413 register struct backtrace
*backlist
= backtrace_list
;
3416 CHECK_NUMBER (level
);
3418 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
3420 backlist
= backlist
->next
;
3424 backlist
->debug_on_exit
= !NILP (flag
);
3429 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3430 doc
: /* Print a trace of Lisp function calls currently active.
3431 Output stream used is value of `standard-output'. */)
3434 register struct backtrace
*backlist
= backtrace_list
;
3438 struct gcpro gcpro1
;
3440 XSETFASTINT (Vprint_level
, 3);
3447 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
3448 if (backlist
->nargs
== UNEVALLED
)
3450 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
3451 write_string ("\n", -1);
3455 tem
= *backlist
->function
;
3456 Fprin1 (tem
, Qnil
); /* This can QUIT */
3457 write_string ("(", -1);
3458 if (backlist
->nargs
== MANY
)
3460 for (tail
= *backlist
->args
, i
= 0;
3462 tail
= Fcdr (tail
), i
++)
3464 if (i
) write_string (" ", -1);
3465 Fprin1 (Fcar (tail
), Qnil
);
3470 for (i
= 0; i
< backlist
->nargs
; i
++)
3472 if (i
) write_string (" ", -1);
3473 Fprin1 (backlist
->args
[i
], Qnil
);
3476 write_string (")\n", -1);
3478 backlist
= backlist
->next
;
3481 Vprint_level
= Qnil
;
3486 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, NULL
,
3487 doc
: /* Return the function and arguments NFRAMES up from current execution point.
3488 If that frame has not evaluated the arguments yet (or is a special form),
3489 the value is (nil FUNCTION ARG-FORMS...).
3490 If that frame has evaluated its arguments and called its function already,
3491 the value is (t FUNCTION ARG-VALUES...).
3492 A &rest arg is represented as the tail of the list ARG-VALUES.
3493 FUNCTION is whatever was supplied as car of evaluated list,
3494 or a lambda expression for macro calls.
3495 If NFRAMES is more than the number of frames, the value is nil. */)
3497 Lisp_Object nframes
;
3499 register struct backtrace
*backlist
= backtrace_list
;
3503 CHECK_NATNUM (nframes
);
3505 /* Find the frame requested. */
3506 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3507 backlist
= backlist
->next
;
3511 if (backlist
->nargs
== UNEVALLED
)
3512 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3515 if (backlist
->nargs
== MANY
)
3516 tem
= *backlist
->args
;
3518 tem
= Flist (backlist
->nargs
, backlist
->args
);
3520 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3526 mark_backtrace (struct backtrace
*backlist
)
3530 for (; backlist
; backlist
= backlist
->next
)
3532 mark_object (*backlist
->function
);
3534 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3537 i
= backlist
->nargs
- 1;
3539 mark_object (backlist
->args
[i
]);
3546 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
3547 doc
: /* *Limit on number of Lisp variable bindings and `unwind-protect's.
3548 If Lisp code tries to increase the total number past this amount,
3549 an error is signaled.
3550 You can safely use a value considerably larger than the default value,
3551 if that proves inconveniently small. However, if you increase it too far,
3552 Emacs could run out of memory trying to make the stack bigger. */);
3554 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
3555 doc
: /* *Limit on depth in `eval', `apply' and `funcall' before error.
3557 This limit serves to catch infinite recursions for you before they cause
3558 actual stack overflow in C, which would be fatal for Emacs.
3559 You can safely make it considerably larger than its default value,
3560 if that proves inconveniently small. However, if you increase it too far,
3561 Emacs could overflow the real C stack, and crash. */);
3563 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
3564 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3565 If the value is t, that means do an ordinary quit.
3566 If the value equals `throw-on-input', that means quit by throwing
3567 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3568 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3569 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3572 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
3573 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3574 Note that `quit-flag' will still be set by typing C-g,
3575 so a quit will be signaled as soon as `inhibit-quit' is nil.
3576 To prevent this happening, set `quit-flag' to nil
3577 before making `inhibit-quit' nil. */);
3578 Vinhibit_quit
= Qnil
;
3580 Qinhibit_quit
= intern_c_string ("inhibit-quit");
3581 staticpro (&Qinhibit_quit
);
3583 Qautoload
= intern_c_string ("autoload");
3584 staticpro (&Qautoload
);
3586 Qdebug_on_error
= intern_c_string ("debug-on-error");
3587 staticpro (&Qdebug_on_error
);
3589 Qmacro
= intern_c_string ("macro");
3590 staticpro (&Qmacro
);
3592 Qdeclare
= intern_c_string ("declare");
3593 staticpro (&Qdeclare
);
3595 /* Note that the process handling also uses Qexit, but we don't want
3596 to staticpro it twice, so we just do it here. */
3597 Qexit
= intern_c_string ("exit");
3600 Qinteractive
= intern_c_string ("interactive");
3601 staticpro (&Qinteractive
);
3603 Qcommandp
= intern_c_string ("commandp");
3604 staticpro (&Qcommandp
);
3606 Qdefun
= intern_c_string ("defun");
3607 staticpro (&Qdefun
);
3609 Qand_rest
= intern_c_string ("&rest");
3610 staticpro (&Qand_rest
);
3612 Qand_optional
= intern_c_string ("&optional");
3613 staticpro (&Qand_optional
);
3615 Qdebug
= intern_c_string ("debug");
3616 staticpro (&Qdebug
);
3618 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
3619 doc
: /* *Non-nil means errors display a backtrace buffer.
3620 More precisely, this happens for any error that is handled
3621 by the editor command loop.
3622 If the value is a list, an error only means to display a backtrace
3623 if one of its condition symbols appears in the list. */);
3624 Vstack_trace_on_error
= Qnil
;
3626 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
3627 doc
: /* *Non-nil means enter debugger if an error is signaled.
3628 Does not apply to errors handled by `condition-case' or those
3629 matched by `debug-ignored-errors'.
3630 If the value is a list, an error only means to enter the debugger
3631 if one of its condition symbols appears in the list.
3632 When you evaluate an expression interactively, this variable
3633 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3634 The command `toggle-debug-on-error' toggles this.
3635 See also the variable `debug-on-quit'. */);
3636 Vdebug_on_error
= Qnil
;
3638 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
3639 doc
: /* *List of errors for which the debugger should not be called.
3640 Each element may be a condition-name or a regexp that matches error messages.
3641 If any element applies to a given error, that error skips the debugger
3642 and just returns to top level.
3643 This overrides the variable `debug-on-error'.
3644 It does not apply to errors handled by `condition-case'. */);
3645 Vdebug_ignored_errors
= Qnil
;
3647 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
3648 doc
: /* *Non-nil means enter debugger if quit is signaled (C-g, for example).
3649 Does not apply if quit is handled by a `condition-case'. */);
3652 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
3653 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3655 DEFVAR_BOOL ("debugger-may-continue", &debugger_may_continue
,
3656 doc
: /* Non-nil means debugger may continue execution.
3657 This is nil when the debugger is called under circumstances where it
3658 might not be safe to continue. */);
3659 debugger_may_continue
= 1;
3661 DEFVAR_LISP ("debugger", &Vdebugger
,
3662 doc
: /* Function to call to invoke debugger.
3663 If due to frame exit, args are `exit' and the value being returned;
3664 this function's value will be returned instead of that.
3665 If due to error, args are `error' and a list of the args to `signal'.
3666 If due to `apply' or `funcall' entry, one arg, `lambda'.
3667 If due to `eval' entry, one arg, t. */);
3670 DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function
,
3671 doc
: /* If non-nil, this is a function for `signal' to call.
3672 It receives the same arguments that `signal' was given.
3673 The Edebug package uses this to regain control. */);
3674 Vsignal_hook_function
= Qnil
;
3676 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal
,
3677 doc
: /* *Non-nil means call the debugger regardless of condition handlers.
3678 Note that `debug-on-error', `debug-on-quit' and friends
3679 still determine whether to handle the particular condition. */);
3680 Vdebug_on_signal
= Qnil
;
3682 DEFVAR_LISP ("macro-declaration-function", &Vmacro_declaration_function
,
3683 doc
: /* Function to process declarations in a macro definition.
3684 The function will be called with two args MACRO and DECL.
3685 MACRO is the name of the macro being defined.
3686 DECL is a list `(declare ...)' containing the declarations.
3687 The value the function returns is not used. */);
3688 Vmacro_declaration_function
= Qnil
;
3690 Vrun_hooks
= intern_c_string ("run-hooks");
3691 staticpro (&Vrun_hooks
);
3693 staticpro (&Vautoload_queue
);
3694 Vautoload_queue
= Qnil
;
3695 staticpro (&Vsignaling_function
);
3696 Vsignaling_function
= Qnil
;
3707 defsubr (&Sfunction
);
3709 defsubr (&Sdefmacro
);
3711 defsubr (&Sdefvaralias
);
3712 defsubr (&Sdefconst
);
3713 defsubr (&Suser_variable_p
);
3717 defsubr (&Smacroexpand
);
3720 defsubr (&Sunwind_protect
);
3721 defsubr (&Scondition_case
);
3723 defsubr (&Sinteractive_p
);
3724 defsubr (&Scalled_interactively_p
);
3725 defsubr (&Scommandp
);
3726 defsubr (&Sautoload
);
3729 defsubr (&Sfuncall
);
3730 defsubr (&Srun_hooks
);
3731 defsubr (&Srun_hook_with_args
);
3732 defsubr (&Srun_hook_with_args_until_success
);
3733 defsubr (&Srun_hook_with_args_until_failure
);
3734 defsubr (&Sfetch_bytecode
);
3735 defsubr (&Sbacktrace_debug
);
3736 defsubr (&Sbacktrace
);
3737 defsubr (&Sbacktrace_frame
);
3740 /* arch-tag: 014a07aa-33ab-4a8f-a3d2-ee8a4a9ff7fb
3741 (do not change this comment) */