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 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
20 Boston, MA 02110-1301, USA. */
25 #include "blockinput.h"
28 #include "dispextern.h"
35 /* This definition is duplicated in alloc.c and keyboard.c */
36 /* Putting it in lisp.h makes cc bomb out! */
40 struct backtrace
*next
;
41 Lisp_Object
*function
;
42 Lisp_Object
*args
; /* Points to vector of args. */
43 int nargs
; /* Length of vector.
44 If nargs is UNEVALLED, args points to slot holding
45 list of unevalled args */
47 /* Nonzero means call value of debugger when done with this operation. */
51 struct backtrace
*backtrace_list
;
53 /* This structure helps implement the `catch' and `throw' control
54 structure. A struct catchtag contains all the information needed
55 to restore the state of the interpreter after a non-local jump.
57 Handlers for error conditions (represented by `struct handler'
58 structures) just point to a catch tag to do the cleanup required
61 catchtag structures are chained together in the C calling stack;
62 the `next' member points to the next outer catchtag.
64 A call like (throw TAG VAL) searches for a catchtag whose `tag'
65 member is TAG, and then unbinds to it. The `val' member is used to
66 hold VAL while the stack is unwound; `val' is returned as the value
69 All the other members are concerned with restoring the interpreter
76 struct catchtag
*next
;
79 struct backtrace
*backlist
;
80 struct handler
*handlerlist
;
83 int poll_suppress_count
;
84 int interrupt_input_blocked
;
85 struct byte_stack
*byte_stack
;
88 struct catchtag
*catchlist
;
91 /* Count levels of GCPRO to detect failure to UNGCPRO. */
95 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
96 Lisp_Object Qinhibit_quit
, Vinhibit_quit
, Vquit_flag
;
97 Lisp_Object Qand_rest
, Qand_optional
;
98 Lisp_Object Qdebug_on_error
;
102 /* This holds either the symbol `run-hooks' or nil.
103 It is nil at an early stage of startup, and when Emacs
106 Lisp_Object Vrun_hooks
;
108 /* Non-nil means record all fset's and provide's, to be undone
109 if the file being autoloaded is not fully loaded.
110 They are recorded by being consed onto the front of Vautoload_queue:
111 (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide. */
113 Lisp_Object Vautoload_queue
;
115 /* Current number of specbindings allocated in specpdl. */
119 /* Pointer to beginning of specpdl. */
121 struct specbinding
*specpdl
;
123 /* Pointer to first unused element in specpdl. */
125 struct specbinding
*specpdl_ptr
;
127 /* Maximum size allowed for specpdl allocation */
129 EMACS_INT max_specpdl_size
;
131 /* Depth in Lisp evaluations and function calls. */
135 /* Maximum allowed depth in Lisp evaluations and function calls. */
137 EMACS_INT max_lisp_eval_depth
;
139 /* Nonzero means enter debugger before next function call */
141 int debug_on_next_call
;
143 /* Non-zero means debugger may continue. This is zero when the
144 debugger is called during redisplay, where it might not be safe to
145 continue the interrupted redisplay. */
147 int debugger_may_continue
;
149 /* List of conditions (non-nil atom means all) which cause a backtrace
150 if an error is handled by the command loop's error handler. */
152 Lisp_Object Vstack_trace_on_error
;
154 /* List of conditions (non-nil atom means all) which enter the debugger
155 if an error is handled by the command loop's error handler. */
157 Lisp_Object Vdebug_on_error
;
159 /* List of conditions and regexps specifying error messages which
160 do not enter the debugger even if Vdebug_on_error says they should. */
162 Lisp_Object Vdebug_ignored_errors
;
164 /* Non-nil means call the debugger even if the error will be handled. */
166 Lisp_Object Vdebug_on_signal
;
168 /* Hook for edebug to use. */
170 Lisp_Object Vsignal_hook_function
;
172 /* Nonzero means enter debugger if a quit signal
173 is handled by the command loop's error handler. */
177 /* The value of num_nonmacro_input_events as of the last time we
178 started to enter the debugger. If we decide to enter the debugger
179 again when this is still equal to num_nonmacro_input_events, then we
180 know that the debugger itself has an error, and we should just
181 signal the error instead of entering an infinite loop of debugger
184 int when_entered_debugger
;
186 Lisp_Object Vdebugger
;
188 /* The function from which the last `signal' was called. Set in
191 Lisp_Object Vsignaling_function
;
193 /* Set to non-zero while processing X events. Checked in Feval to
194 make sure the Lisp interpreter isn't called from a signal handler,
195 which is unsafe because the interpreter isn't reentrant. */
199 /* Function to process declarations in defmacro forms. */
201 Lisp_Object Vmacro_declaration_function
;
203 extern Lisp_Object Qrisky_local_variable
;
205 extern Lisp_Object Qfunction
;
207 static Lisp_Object funcall_lambda
P_ ((Lisp_Object
, int, Lisp_Object
*));
208 static void unwind_to_catch
P_ ((struct catchtag
*, Lisp_Object
)) NO_RETURN
;
211 /* "gcc -O3" enables automatic function inlining, which optimizes out
212 the arguments for the invocations of these functions, whereas they
213 expect these values on the stack. */
214 Lisp_Object
apply1 () __attribute__((noinline
));
215 Lisp_Object
call2 () __attribute__((noinline
));
222 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
223 specpdl_ptr
= specpdl
;
224 /* Don't forget to update docs (lispref node "Local Variables"). */
225 max_specpdl_size
= 1000;
226 max_lisp_eval_depth
= 400;
234 specpdl_ptr
= specpdl
;
239 debug_on_next_call
= 0;
244 /* This is less than the initial value of num_nonmacro_input_events. */
245 when_entered_debugger
= -1;
248 /* unwind-protect function used by call_debugger. */
251 restore_stack_limits (data
)
254 max_specpdl_size
= XINT (XCAR (data
));
255 max_lisp_eval_depth
= XINT (XCDR (data
));
259 /* Call the Lisp debugger, giving it argument ARG. */
265 int debug_while_redisplaying
;
266 int count
= SPECPDL_INDEX ();
268 int old_max
= max_specpdl_size
;
270 /* Temporarily bump up the stack limits,
271 so the debugger won't run out of stack. */
273 max_specpdl_size
+= 1;
274 record_unwind_protect (restore_stack_limits
,
275 Fcons (make_number (old_max
),
276 make_number (max_lisp_eval_depth
)));
277 max_specpdl_size
= old_max
;
279 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
280 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
282 if (SPECPDL_INDEX () + 100 > max_specpdl_size
)
283 max_specpdl_size
= SPECPDL_INDEX () + 100;
285 #ifdef HAVE_X_WINDOWS
286 if (display_hourglass_p
)
290 debug_on_next_call
= 0;
291 when_entered_debugger
= num_nonmacro_input_events
;
293 /* Resetting redisplaying_p to 0 makes sure that debug output is
294 displayed if the debugger is invoked during redisplay. */
295 debug_while_redisplaying
= redisplaying_p
;
297 specbind (intern ("debugger-may-continue"),
298 debug_while_redisplaying
? Qnil
: Qt
);
299 specbind (Qinhibit_redisplay
, Qnil
);
300 specbind (Qdebug_on_error
, Qnil
);
302 #if 0 /* Binding this prevents execution of Lisp code during
303 redisplay, which necessarily leads to display problems. */
304 specbind (Qinhibit_eval_during_redisplay
, Qt
);
307 val
= apply1 (Vdebugger
, arg
);
309 /* Interrupting redisplay and resuming it later is not safe under
310 all circumstances. So, when the debugger returns, abort the
311 interrupted redisplay by going back to the top-level. */
312 if (debug_while_redisplaying
)
315 return unbind_to (count
, val
);
319 do_debug_on_call (code
)
322 debug_on_next_call
= 0;
323 backtrace_list
->debug_on_exit
= 1;
324 call_debugger (Fcons (code
, Qnil
));
327 /* NOTE!!! Every function that can call EVAL must protect its args
328 and temporaries from garbage collection while it needs them.
329 The definition of `For' shows what you have to do. */
331 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
332 doc
: /* Eval args until one of them yields non-nil, then return that value.
333 The remaining args are not evalled at all.
334 If all args return nil, return nil.
335 usage: (or CONDITIONS...) */)
339 register Lisp_Object val
= Qnil
;
346 val
= Feval (XCAR (args
));
356 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
357 doc
: /* Eval args until one of them yields nil, then return nil.
358 The remaining args are not evalled at all.
359 If no arg yields nil, return the last arg's value.
360 usage: (and CONDITIONS...) */)
364 register Lisp_Object val
= Qt
;
371 val
= Feval (XCAR (args
));
381 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
382 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
383 Returns the value of THEN or the value of the last of the ELSE's.
384 THEN must be one expression, but ELSE... can be zero or more expressions.
385 If COND yields nil, and there are no ELSE's, the value is nil.
386 usage: (if COND THEN ELSE...) */)
390 register Lisp_Object cond
;
394 cond
= Feval (Fcar (args
));
398 return Feval (Fcar (Fcdr (args
)));
399 return Fprogn (Fcdr (Fcdr (args
)));
402 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
403 doc
: /* Try each clause until one succeeds.
404 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
405 and, if the value is non-nil, this clause succeeds:
406 then the expressions in BODY are evaluated and the last one's
407 value is the value of the cond-form.
408 If no clause succeeds, cond returns nil.
409 If a clause has one element, as in (CONDITION),
410 CONDITION's value if non-nil is returned from the cond-form.
411 usage: (cond CLAUSES...) */)
415 register Lisp_Object clause
, val
;
422 clause
= Fcar (args
);
423 val
= Feval (Fcar (clause
));
426 if (!EQ (XCDR (clause
), Qnil
))
427 val
= Fprogn (XCDR (clause
));
437 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
438 doc
: /* Eval BODY forms sequentially and return value of last one.
439 usage: (progn BODY...) */)
443 register Lisp_Object val
= Qnil
;
450 val
= Feval (XCAR (args
));
458 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
459 doc
: /* Eval FIRST and BODY sequentially; value from FIRST.
460 The value of FIRST is saved during the evaluation of the remaining args,
461 whose values are discarded.
462 usage: (prog1 FIRST BODY...) */)
467 register Lisp_Object args_left
;
468 struct gcpro gcpro1
, gcpro2
;
469 register int argnum
= 0;
481 val
= Feval (Fcar (args_left
));
483 Feval (Fcar (args_left
));
484 args_left
= Fcdr (args_left
);
486 while (!NILP(args_left
));
492 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
493 doc
: /* Eval FORM1, FORM2 and BODY sequentially; value from FORM2.
494 The value of FORM2 is saved during the evaluation of the
495 remaining args, whose values are discarded.
496 usage: (prog2 FORM1 FORM2 BODY...) */)
501 register Lisp_Object args_left
;
502 struct gcpro gcpro1
, gcpro2
;
503 register int argnum
= -1;
517 val
= Feval (Fcar (args_left
));
519 Feval (Fcar (args_left
));
520 args_left
= Fcdr (args_left
);
522 while (!NILP (args_left
));
528 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
529 doc
: /* Set each SYM to the value of its VAL.
530 The symbols SYM are variables; they are literal (not evaluated).
531 The values VAL are expressions; they are evaluated.
532 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
533 The second VAL is not computed until after the first SYM is set, and so on;
534 each VAL can use the new value of variables set earlier in the `setq'.
535 The return value of the `setq' form is the value of the last VAL.
536 usage: (setq [SYM VAL]...) */)
540 register Lisp_Object args_left
;
541 register Lisp_Object val
, sym
;
552 val
= Feval (Fcar (Fcdr (args_left
)));
553 sym
= Fcar (args_left
);
555 args_left
= Fcdr (Fcdr (args_left
));
557 while (!NILP(args_left
));
563 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
564 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
565 usage: (quote ARG) */)
569 if (!NILP (Fcdr (args
)))
570 xsignal2 (Qwrong_number_of_arguments
, Qquote
, Flength (args
));
574 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
575 doc
: /* Like `quote', but preferred for objects which are functions.
576 In byte compilation, `function' causes its argument to be compiled.
577 `quote' cannot do that.
578 usage: (function ARG) */)
582 if (!NILP (Fcdr (args
)))
583 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
588 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
589 doc
: /* Return t if the function was run directly by user input.
590 This means that the function was called with `call-interactively'
591 \(which includes being called as the binding of a key)
592 and input is currently coming from the keyboard (not in keyboard macro),
593 and Emacs is not running in batch mode (`noninteractive' is nil).
595 The only known proper use of `interactive-p' is in deciding whether to
596 display a helpful message, or how to display it. If you're thinking
597 of using it for any other purpose, it is quite likely that you're
598 making a mistake. Think: what do you want to do when the command is
599 called from a keyboard macro?
601 If you want to test whether your function was called with
602 `call-interactively', the way to do that is by adding an extra
603 optional argument, and making the `interactive' spec specify non-nil
604 unconditionally for that argument. (`p' is a good way to do this.) */)
607 return (INTERACTIVE
&& interactive_p (1)) ? Qt
: Qnil
;
611 DEFUN ("called-interactively-p", Fcalled_interactively_p
, Scalled_interactively_p
, 0, 0, 0,
612 doc
: /* Return t if the function using this was called with `call-interactively'.
613 This is used for implementing advice and other function-modifying
616 The cleanest way to test whether your function was called with
617 `call-interactively' is by adding an extra optional argument,
618 and making the `interactive' spec specify non-nil unconditionally
619 for that argument. (`p' is a good way to do this.) */)
622 return interactive_p (1) ? Qt
: Qnil
;
626 /* Return 1 if function in which this appears was called using
629 EXCLUDE_SUBRS_P non-zero means always return 0 if the function
630 called is a built-in. */
633 interactive_p (exclude_subrs_p
)
636 struct backtrace
*btp
;
639 btp
= backtrace_list
;
641 /* If this isn't a byte-compiled function, there may be a frame at
642 the top for Finteractive_p. If so, skip it. */
643 fun
= Findirect_function (*btp
->function
, Qnil
);
644 if (SUBRP (fun
) && (XSUBR (fun
) == &Sinteractive_p
645 || XSUBR (fun
) == &Scalled_interactively_p
))
648 /* If we're running an Emacs 18-style byte-compiled function, there
649 may be a frame for Fbytecode at the top level. In any version of
650 Emacs there can be Fbytecode frames for subexpressions evaluated
651 inside catch and condition-case. Skip past them.
653 If this isn't a byte-compiled function, then we may now be
654 looking at several frames for special forms. Skip past them. */
656 && (EQ (*btp
->function
, Qbytecode
)
657 || btp
->nargs
== UNEVALLED
))
660 /* btp now points at the frame of the innermost function that isn't
661 a special form, ignoring frames for Finteractive_p and/or
662 Fbytecode at the top. If this frame is for a built-in function
663 (such as load or eval-region) return nil. */
664 fun
= Findirect_function (*btp
->function
, Qnil
);
665 if (exclude_subrs_p
&& SUBRP (fun
))
668 /* btp points to the frame of a Lisp function that called interactive-p.
669 Return t if that function was called interactively. */
670 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
676 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
677 doc
: /* Define NAME as a function.
678 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
679 See also the function `interactive'.
680 usage: (defun NAME ARGLIST [DOCSTRING] BODY...) */)
684 register Lisp_Object fn_name
;
685 register Lisp_Object defn
;
687 fn_name
= Fcar (args
);
688 CHECK_SYMBOL (fn_name
);
689 defn
= Fcons (Qlambda
, Fcdr (args
));
690 if (!NILP (Vpurify_flag
))
691 defn
= Fpurecopy (defn
);
692 if (CONSP (XSYMBOL (fn_name
)->function
)
693 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
694 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
695 Ffset (fn_name
, defn
);
696 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
700 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
701 doc
: /* Define NAME as a macro.
702 The actual definition looks like
703 (macro lambda ARGLIST [DOCSTRING] [DECL] BODY...).
704 When the macro is called, as in (NAME ARGS...),
705 the function (lambda ARGLIST BODY...) is applied to
706 the list ARGS... as it appears in the expression,
707 and the result should be a form to be evaluated instead of the original.
709 DECL is a declaration, optional, which can specify how to indent
710 calls to this macro and how Edebug should handle it. It looks like this:
712 The elements can look like this:
714 Set NAME's `lisp-indent-function' property to INDENT.
717 Set NAME's `edebug-form-spec' property to DEBUG. (This is
718 equivalent to writing a `def-edebug-spec' for the macro.)
719 usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */)
723 register Lisp_Object fn_name
;
724 register Lisp_Object defn
;
725 Lisp_Object lambda_list
, doc
, tail
;
727 fn_name
= Fcar (args
);
728 CHECK_SYMBOL (fn_name
);
729 lambda_list
= Fcar (Fcdr (args
));
730 tail
= Fcdr (Fcdr (args
));
733 if (STRINGP (Fcar (tail
)))
739 while (CONSP (Fcar (tail
))
740 && EQ (Fcar (Fcar (tail
)), Qdeclare
))
742 if (!NILP (Vmacro_declaration_function
))
746 call2 (Vmacro_declaration_function
, fn_name
, Fcar (tail
));
754 tail
= Fcons (lambda_list
, tail
);
756 tail
= Fcons (lambda_list
, Fcons (doc
, tail
));
757 defn
= Fcons (Qmacro
, Fcons (Qlambda
, tail
));
759 if (!NILP (Vpurify_flag
))
760 defn
= Fpurecopy (defn
);
761 if (CONSP (XSYMBOL (fn_name
)->function
)
762 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
763 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
764 Ffset (fn_name
, defn
);
765 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
770 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
771 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
772 Aliased variables always have the same value; setting one sets the other.
773 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
774 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
775 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
777 The return value is BASE-VARIABLE. */)
778 (new_alias
, base_variable
, docstring
)
779 Lisp_Object new_alias
, base_variable
, docstring
;
781 struct Lisp_Symbol
*sym
;
783 CHECK_SYMBOL (new_alias
);
784 CHECK_SYMBOL (base_variable
);
786 if (SYMBOL_CONSTANT_P (new_alias
))
787 error ("Cannot make a constant an alias");
789 sym
= XSYMBOL (new_alias
);
790 sym
->indirect_variable
= 1;
791 sym
->value
= base_variable
;
792 sym
->constant
= SYMBOL_CONSTANT_P (base_variable
);
793 LOADHIST_ATTACH (new_alias
);
794 if (!NILP (docstring
))
795 Fput (new_alias
, Qvariable_documentation
, docstring
);
797 Fput (new_alias
, Qvariable_documentation
, Qnil
);
799 return base_variable
;
803 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
804 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
805 You are not required to define a variable in order to use it,
806 but the definition can supply documentation and an initial value
807 in a way that tags can recognize.
809 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.
810 If SYMBOL is buffer-local, its default value is what is set;
811 buffer-local values are not affected.
812 INITVALUE and DOCSTRING are optional.
813 If DOCSTRING starts with *, this variable is identified as a user option.
814 This means that M-x set-variable recognizes it.
815 See also `user-variable-p'.
816 If INITVALUE is missing, SYMBOL's value is not set.
818 If SYMBOL has a local binding, then this form affects the local
819 binding. This is usually not what you want. Thus, if you need to
820 load a file defining variables, with this form or with `defconst' or
821 `defcustom', you should always load that file _outside_ any bindings
822 for these variables. \(`defconst' and `defcustom' behave similarly in
824 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
828 register Lisp_Object sym
, tem
, tail
;
832 if (!NILP (Fcdr (Fcdr (tail
))))
833 error ("Too many arguments");
835 tem
= Fdefault_boundp (sym
);
838 if (SYMBOL_CONSTANT_P (sym
))
840 /* For upward compatibility, allow (defvar :foo (quote :foo)). */
841 Lisp_Object tem
= Fcar (tail
);
843 && EQ (XCAR (tem
), Qquote
)
844 && CONSP (XCDR (tem
))
845 && EQ (XCAR (XCDR (tem
)), sym
)))
846 error ("Constant symbol `%s' specified in defvar",
847 SDATA (SYMBOL_NAME (sym
)));
851 Fset_default (sym
, Feval (Fcar (tail
)));
853 { /* Check if there is really a global binding rather than just a let
854 binding that shadows the global unboundness of the var. */
855 volatile struct specbinding
*pdl
= specpdl_ptr
;
856 while (--pdl
>= specpdl
)
858 if (EQ (pdl
->symbol
, sym
) && !pdl
->func
859 && EQ (pdl
->old_value
, Qunbound
))
861 message_with_string ("Warning: defvar ignored because %s is let-bound",
862 SYMBOL_NAME (sym
), 1);
871 if (!NILP (Vpurify_flag
))
872 tem
= Fpurecopy (tem
);
873 Fput (sym
, Qvariable_documentation
, tem
);
875 LOADHIST_ATTACH (sym
);
878 /* Simple (defvar <var>) should not count as a definition at all.
879 It could get in the way of other definitions, and unloading this
880 package could try to make the variable unbound. */
886 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
887 doc
: /* Define SYMBOL as a constant variable.
888 The intent is that neither programs nor users should ever change this value.
889 Always sets the value of SYMBOL to the result of evalling INITVALUE.
890 If SYMBOL is buffer-local, its default value is what is set;
891 buffer-local values are not affected.
892 DOCSTRING is optional.
894 If SYMBOL has a local binding, then this form sets the local binding's
895 value. However, you should normally not make local bindings for
896 variables defined with this form.
897 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
901 register Lisp_Object sym
, tem
;
904 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
905 error ("Too many arguments");
907 tem
= Feval (Fcar (Fcdr (args
)));
908 if (!NILP (Vpurify_flag
))
909 tem
= Fpurecopy (tem
);
910 Fset_default (sym
, tem
);
911 tem
= Fcar (Fcdr (Fcdr (args
)));
914 if (!NILP (Vpurify_flag
))
915 tem
= Fpurecopy (tem
);
916 Fput (sym
, Qvariable_documentation
, tem
);
918 Fput (sym
, Qrisky_local_variable
, Qt
);
919 LOADHIST_ATTACH (sym
);
923 /* Error handler used in Fuser_variable_p. */
925 user_variable_p_eh (ignore
)
931 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
932 doc
: /* Return t if VARIABLE is intended to be set and modified by users.
933 \(The alternative is a variable used internally in a Lisp program.)
934 A variable is a user variable if
935 \(1) the first character of its documentation is `*', or
936 \(2) it is customizable (its property list contains a non-nil value
937 of `standard-value' or `custom-autoload'), or
938 \(3) it is an alias for another user variable.
939 Return nil if VARIABLE is an alias and there is a loop in the
940 chain of symbols. */)
942 Lisp_Object variable
;
944 Lisp_Object documentation
;
946 if (!SYMBOLP (variable
))
949 /* If indirect and there's an alias loop, don't check anything else. */
950 if (XSYMBOL (variable
)->indirect_variable
951 && NILP (internal_condition_case_1 (indirect_variable
, variable
,
952 Qt
, user_variable_p_eh
)))
957 documentation
= Fget (variable
, Qvariable_documentation
);
958 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
960 if (STRINGP (documentation
)
961 && ((unsigned char) SREF (documentation
, 0) == '*'))
963 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
964 if (CONSP (documentation
)
965 && STRINGP (XCAR (documentation
))
966 && INTEGERP (XCDR (documentation
))
967 && XINT (XCDR (documentation
)) < 0)
969 /* Customizable? See `custom-variable-p'. */
970 if ((!NILP (Fget (variable
, intern ("standard-value"))))
971 || (!NILP (Fget (variable
, intern ("custom-autoload")))))
974 if (!XSYMBOL (variable
)->indirect_variable
)
977 /* An indirect variable? Let's follow the chain. */
978 variable
= XSYMBOL (variable
)->value
;
982 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
983 doc
: /* Bind variables according to VARLIST then eval BODY.
984 The value of the last form in BODY is returned.
985 Each element of VARLIST is a symbol (which is bound to nil)
986 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
987 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
988 usage: (let* VARLIST BODY...) */)
992 Lisp_Object varlist
, val
, elt
;
993 int count
= SPECPDL_INDEX ();
994 struct gcpro gcpro1
, gcpro2
, gcpro3
;
996 GCPRO3 (args
, elt
, varlist
);
998 varlist
= Fcar (args
);
999 while (!NILP (varlist
))
1002 elt
= Fcar (varlist
);
1004 specbind (elt
, Qnil
);
1005 else if (! NILP (Fcdr (Fcdr (elt
))))
1006 signal_error ("`let' bindings can have only one value-form", elt
);
1009 val
= Feval (Fcar (Fcdr (elt
)));
1010 specbind (Fcar (elt
), val
);
1012 varlist
= Fcdr (varlist
);
1015 val
= Fprogn (Fcdr (args
));
1016 return unbind_to (count
, val
);
1019 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
1020 doc
: /* Bind variables according to VARLIST then eval BODY.
1021 The value of the last form in BODY is returned.
1022 Each element of VARLIST is a symbol (which is bound to nil)
1023 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
1024 All the VALUEFORMs are evalled before any symbols are bound.
1025 usage: (let VARLIST BODY...) */)
1029 Lisp_Object
*temps
, tem
;
1030 register Lisp_Object elt
, varlist
;
1031 int count
= SPECPDL_INDEX ();
1032 register int argnum
;
1033 struct gcpro gcpro1
, gcpro2
;
1035 varlist
= Fcar (args
);
1037 /* Make space to hold the values to give the bound variables */
1038 elt
= Flength (varlist
);
1039 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
1041 /* Compute the values and store them in `temps' */
1043 GCPRO2 (args
, *temps
);
1046 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
1049 elt
= Fcar (varlist
);
1051 temps
[argnum
++] = Qnil
;
1052 else if (! NILP (Fcdr (Fcdr (elt
))))
1053 signal_error ("`let' bindings can have only one value-form", elt
);
1055 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
1056 gcpro2
.nvars
= argnum
;
1060 varlist
= Fcar (args
);
1061 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
1063 elt
= Fcar (varlist
);
1064 tem
= temps
[argnum
++];
1066 specbind (elt
, tem
);
1068 specbind (Fcar (elt
), tem
);
1071 elt
= Fprogn (Fcdr (args
));
1072 return unbind_to (count
, elt
);
1075 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
1076 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
1077 The order of execution is thus TEST, BODY, TEST, BODY and so on
1078 until TEST returns nil.
1079 usage: (while TEST BODY...) */)
1083 Lisp_Object test
, body
;
1084 struct gcpro gcpro1
, gcpro2
;
1086 GCPRO2 (test
, body
);
1090 while (!NILP (Feval (test
)))
1100 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
1101 doc
: /* Return result of expanding macros at top level of FORM.
1102 If FORM is not a macro call, it is returned unchanged.
1103 Otherwise, the macro is expanded and the expansion is considered
1104 in place of FORM. When a non-macro-call results, it is returned.
1106 The second optional arg ENVIRONMENT specifies an environment of macro
1107 definitions to shadow the loaded ones for use in file byte-compilation. */)
1110 Lisp_Object environment
;
1112 /* With cleanups from Hallvard Furuseth. */
1113 register Lisp_Object expander
, sym
, def
, tem
;
1117 /* Come back here each time we expand a macro call,
1118 in case it expands into another macro call. */
1121 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1122 def
= sym
= XCAR (form
);
1124 /* Trace symbols aliases to other symbols
1125 until we get a symbol that is not an alias. */
1126 while (SYMBOLP (def
))
1130 tem
= Fassq (sym
, environment
);
1133 def
= XSYMBOL (sym
)->function
;
1134 if (!EQ (def
, Qunbound
))
1139 /* Right now TEM is the result from SYM in ENVIRONMENT,
1140 and if TEM is nil then DEF is SYM's function definition. */
1143 /* SYM is not mentioned in ENVIRONMENT.
1144 Look at its function definition. */
1145 if (EQ (def
, Qunbound
) || !CONSP (def
))
1146 /* Not defined or definition not suitable */
1148 if (EQ (XCAR (def
), Qautoload
))
1150 /* Autoloading function: will it be a macro when loaded? */
1151 tem
= Fnth (make_number (4), def
);
1152 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
1153 /* Yes, load it and try again. */
1155 struct gcpro gcpro1
;
1157 do_autoload (def
, sym
);
1164 else if (!EQ (XCAR (def
), Qmacro
))
1166 else expander
= XCDR (def
);
1170 expander
= XCDR (tem
);
1171 if (NILP (expander
))
1174 form
= apply1 (expander
, XCDR (form
));
1179 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1180 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1181 TAG is evalled to get the tag to use; it must not be nil.
1183 Then the BODY is executed.
1184 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
1185 If no throw happens, `catch' returns the value of the last BODY form.
1186 If a throw happens, it specifies the value to return from `catch'.
1187 usage: (catch TAG BODY...) */)
1191 register Lisp_Object tag
;
1192 struct gcpro gcpro1
;
1195 tag
= Feval (Fcar (args
));
1197 return internal_catch (tag
, Fprogn
, Fcdr (args
));
1200 /* Set up a catch, then call C function FUNC on argument ARG.
1201 FUNC should return a Lisp_Object.
1202 This is how catches are done from within C code. */
1205 internal_catch (tag
, func
, arg
)
1207 Lisp_Object (*func
) ();
1210 /* This structure is made part of the chain `catchlist'. */
1213 /* Fill in the components of c, and put it on the list. */
1217 c
.backlist
= backtrace_list
;
1218 c
.handlerlist
= handlerlist
;
1219 c
.lisp_eval_depth
= lisp_eval_depth
;
1220 c
.pdlcount
= SPECPDL_INDEX ();
1221 c
.poll_suppress_count
= poll_suppress_count
;
1222 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1223 c
.gcpro
= gcprolist
;
1224 c
.byte_stack
= byte_stack_list
;
1228 if (! _setjmp (c
.jmp
))
1229 c
.val
= (*func
) (arg
);
1231 /* Throw works by a longjmp that comes right here. */
1236 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1237 jump to that CATCH, returning VALUE as the value of that catch.
1239 This is the guts Fthrow and Fsignal; they differ only in the way
1240 they choose the catch tag to throw to. A catch tag for a
1241 condition-case form has a TAG of Qnil.
1243 Before each catch is discarded, unbind all special bindings and
1244 execute all unwind-protect clauses made above that catch. Unwind
1245 the handler stack as we go, so that the proper handlers are in
1246 effect for each unwind-protect clause we run. At the end, restore
1247 some static info saved in CATCH, and longjmp to the location
1250 This is used for correct unwinding in Fthrow and Fsignal. */
1253 unwind_to_catch (catch, value
)
1254 struct catchtag
*catch;
1257 register int last_time
;
1259 /* Save the value in the tag. */
1262 /* Restore certain special C variables. */
1263 set_poll_suppress_count (catch->poll_suppress_count
);
1264 UNBLOCK_INPUT_TO (catch->interrupt_input_blocked
);
1265 handling_signal
= 0;
1270 last_time
= catchlist
== catch;
1272 /* Unwind the specpdl stack, and then restore the proper set of
1274 unbind_to (catchlist
->pdlcount
, Qnil
);
1275 handlerlist
= catchlist
->handlerlist
;
1276 catchlist
= catchlist
->next
;
1278 while (! last_time
);
1281 /* If x_catch_errors was done, turn it off now.
1282 (First we give unbind_to a chance to do that.) */
1283 x_fully_uncatch_errors ();
1286 byte_stack_list
= catch->byte_stack
;
1287 gcprolist
= catch->gcpro
;
1290 gcpro_level
= gcprolist
->level
+ 1;
1294 backtrace_list
= catch->backlist
;
1295 lisp_eval_depth
= catch->lisp_eval_depth
;
1297 _longjmp (catch->jmp
, 1);
1300 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1301 doc
: /* Throw to the catch for TAG and return VALUE from it.
1302 Both TAG and VALUE are evalled. */)
1304 register Lisp_Object tag
, value
;
1306 register struct catchtag
*c
;
1309 for (c
= catchlist
; c
; c
= c
->next
)
1311 if (EQ (c
->tag
, tag
))
1312 unwind_to_catch (c
, value
);
1314 xsignal2 (Qno_catch
, tag
, value
);
1318 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1319 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1320 If BODYFORM completes normally, its value is returned
1321 after executing the UNWINDFORMS.
1322 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1323 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1328 int count
= SPECPDL_INDEX ();
1330 record_unwind_protect (Fprogn
, Fcdr (args
));
1331 val
= Feval (Fcar (args
));
1332 return unbind_to (count
, val
);
1335 /* Chain of condition handlers currently in effect.
1336 The elements of this chain are contained in the stack frames
1337 of Fcondition_case and internal_condition_case.
1338 When an error is signaled (by calling Fsignal, below),
1339 this chain is searched for an element that applies. */
1341 struct handler
*handlerlist
;
1343 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1344 doc
: /* Regain control when an error is signaled.
1345 Executes BODYFORM and returns its value if no error happens.
1346 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1347 where the BODY is made of Lisp expressions.
1349 A handler is applicable to an error
1350 if CONDITION-NAME is one of the error's condition names.
1351 If an error happens, the first applicable handler is run.
1353 The car of a handler may be a list of condition names
1354 instead of a single condition name.
1356 When a handler handles an error,
1357 control returns to the condition-case and the handler BODY... is executed
1358 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).
1359 VAR may be nil; then you do not get access to the signal information.
1361 The value of the last BODY form is returned from the condition-case.
1362 See also the function `signal' for more info.
1363 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1367 register Lisp_Object bodyform
, handlers
;
1368 volatile Lisp_Object var
;
1371 bodyform
= Fcar (Fcdr (args
));
1372 handlers
= Fcdr (Fcdr (args
));
1374 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1377 /* Like Fcondition_case, but the args are separate
1378 rather than passed in a list. Used by Fbyte_code. */
1381 internal_lisp_condition_case (var
, bodyform
, handlers
)
1382 volatile Lisp_Object var
;
1383 Lisp_Object bodyform
, handlers
;
1391 for (val
= handlers
; CONSP (val
); val
= XCDR (val
))
1397 && (SYMBOLP (XCAR (tem
))
1398 || CONSP (XCAR (tem
))))))
1399 error ("Invalid condition handler", tem
);
1404 c
.backlist
= backtrace_list
;
1405 c
.handlerlist
= handlerlist
;
1406 c
.lisp_eval_depth
= lisp_eval_depth
;
1407 c
.pdlcount
= SPECPDL_INDEX ();
1408 c
.poll_suppress_count
= poll_suppress_count
;
1409 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1410 c
.gcpro
= gcprolist
;
1411 c
.byte_stack
= byte_stack_list
;
1412 if (_setjmp (c
.jmp
))
1415 specbind (h
.var
, c
.val
);
1416 val
= Fprogn (Fcdr (h
.chosen_clause
));
1418 /* Note that this just undoes the binding of h.var; whoever
1419 longjumped to us unwound the stack to c.pdlcount before
1421 unbind_to (c
.pdlcount
, Qnil
);
1428 h
.handler
= handlers
;
1429 h
.next
= handlerlist
;
1433 val
= Feval (bodyform
);
1435 handlerlist
= h
.next
;
1439 /* Call the function BFUN with no arguments, catching errors within it
1440 according to HANDLERS. If there is an error, call HFUN with
1441 one argument which is the data that describes the error:
1444 HANDLERS can be a list of conditions to catch.
1445 If HANDLERS is Qt, catch all errors.
1446 If HANDLERS is Qerror, catch all errors
1447 but allow the debugger to run if that is enabled. */
1450 internal_condition_case (bfun
, handlers
, hfun
)
1451 Lisp_Object (*bfun
) ();
1452 Lisp_Object handlers
;
1453 Lisp_Object (*hfun
) ();
1459 /* Since Fsignal will close off all calls to x_catch_errors,
1460 we will get the wrong results if some are not closed now. */
1462 if (x_catching_errors ())
1468 c
.backlist
= backtrace_list
;
1469 c
.handlerlist
= handlerlist
;
1470 c
.lisp_eval_depth
= lisp_eval_depth
;
1471 c
.pdlcount
= SPECPDL_INDEX ();
1472 c
.poll_suppress_count
= poll_suppress_count
;
1473 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1474 c
.gcpro
= gcprolist
;
1475 c
.byte_stack
= byte_stack_list
;
1476 if (_setjmp (c
.jmp
))
1478 return (*hfun
) (c
.val
);
1482 h
.handler
= handlers
;
1484 h
.next
= handlerlist
;
1490 handlerlist
= h
.next
;
1494 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1497 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1498 Lisp_Object (*bfun
) ();
1500 Lisp_Object handlers
;
1501 Lisp_Object (*hfun
) ();
1507 /* Since Fsignal will close off all calls to x_catch_errors,
1508 we will get the wrong results if some are not closed now. */
1510 if (x_catching_errors ())
1516 c
.backlist
= backtrace_list
;
1517 c
.handlerlist
= handlerlist
;
1518 c
.lisp_eval_depth
= lisp_eval_depth
;
1519 c
.pdlcount
= SPECPDL_INDEX ();
1520 c
.poll_suppress_count
= poll_suppress_count
;
1521 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1522 c
.gcpro
= gcprolist
;
1523 c
.byte_stack
= byte_stack_list
;
1524 if (_setjmp (c
.jmp
))
1526 return (*hfun
) (c
.val
);
1530 h
.handler
= handlers
;
1532 h
.next
= handlerlist
;
1536 val
= (*bfun
) (arg
);
1538 handlerlist
= h
.next
;
1543 /* Like internal_condition_case but call BFUN with NARGS as first,
1544 and ARGS as second argument. */
1547 internal_condition_case_2 (bfun
, nargs
, args
, handlers
, hfun
)
1548 Lisp_Object (*bfun
) ();
1551 Lisp_Object handlers
;
1552 Lisp_Object (*hfun
) ();
1558 /* Since Fsignal will close off all calls to x_catch_errors,
1559 we will get the wrong results if some are not closed now. */
1561 if (x_catching_errors ())
1567 c
.backlist
= backtrace_list
;
1568 c
.handlerlist
= handlerlist
;
1569 c
.lisp_eval_depth
= lisp_eval_depth
;
1570 c
.pdlcount
= SPECPDL_INDEX ();
1571 c
.poll_suppress_count
= poll_suppress_count
;
1572 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1573 c
.gcpro
= gcprolist
;
1574 c
.byte_stack
= byte_stack_list
;
1575 if (_setjmp (c
.jmp
))
1577 return (*hfun
) (c
.val
);
1581 h
.handler
= handlers
;
1583 h
.next
= handlerlist
;
1587 val
= (*bfun
) (nargs
, args
);
1589 handlerlist
= h
.next
;
1594 static Lisp_Object find_handler_clause
P_ ((Lisp_Object
, Lisp_Object
,
1595 Lisp_Object
, Lisp_Object
));
1597 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1598 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1599 This function does not return.
1601 An error symbol is a symbol with an `error-conditions' property
1602 that is a list of condition names.
1603 A handler for any of those names will get to handle this signal.
1604 The symbol `error' should normally be one of them.
1606 DATA should be a list. Its elements are printed as part of the error message.
1607 See Info anchor `(elisp)Definition of signal' for some details on how this
1608 error message is constructed.
1609 If the signal is handled, DATA is made available to the handler.
1610 See also the function `condition-case'. */)
1611 (error_symbol
, data
)
1612 Lisp_Object error_symbol
, data
;
1614 /* When memory is full, ERROR-SYMBOL is nil,
1615 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1616 That is a special case--don't do this in other situations. */
1617 register struct handler
*allhandlers
= handlerlist
;
1618 Lisp_Object conditions
;
1619 extern int gc_in_progress
;
1620 extern int waiting_for_input
;
1622 Lisp_Object real_error_symbol
;
1623 struct backtrace
*bp
;
1625 immediate_quit
= handling_signal
= 0;
1627 if (gc_in_progress
|| waiting_for_input
)
1630 if (NILP (error_symbol
))
1631 real_error_symbol
= Fcar (data
);
1633 real_error_symbol
= error_symbol
;
1635 #if 0 /* rms: I don't know why this was here,
1636 but it is surely wrong for an error that is handled. */
1637 #ifdef HAVE_X_WINDOWS
1638 if (display_hourglass_p
)
1639 cancel_hourglass ();
1643 /* This hook is used by edebug. */
1644 if (! NILP (Vsignal_hook_function
)
1645 && ! NILP (error_symbol
))
1647 /* Edebug takes care of restoring these variables when it exits. */
1648 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1649 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1651 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1652 max_specpdl_size
= SPECPDL_INDEX () + 40;
1654 call2 (Vsignal_hook_function
, error_symbol
, data
);
1657 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1659 /* Remember from where signal was called. Skip over the frame for
1660 `signal' itself. If a frame for `error' follows, skip that,
1661 too. Don't do this when ERROR_SYMBOL is nil, because that
1662 is a memory-full error. */
1663 Vsignaling_function
= Qnil
;
1664 if (backtrace_list
&& !NILP (error_symbol
))
1666 bp
= backtrace_list
->next
;
1667 if (bp
&& bp
->function
&& EQ (*bp
->function
, Qerror
))
1669 if (bp
&& bp
->function
)
1670 Vsignaling_function
= *bp
->function
;
1673 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1675 register Lisp_Object clause
;
1677 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1678 error_symbol
, data
);
1680 if (EQ (clause
, Qlambda
))
1682 /* We can't return values to code which signaled an error, but we
1683 can continue code which has signaled a quit. */
1684 if (EQ (real_error_symbol
, Qquit
))
1687 error ("Cannot return from the debugger in an error");
1692 Lisp_Object unwind_data
;
1693 struct handler
*h
= handlerlist
;
1695 handlerlist
= allhandlers
;
1697 if (NILP (error_symbol
))
1700 unwind_data
= Fcons (error_symbol
, data
);
1701 h
->chosen_clause
= clause
;
1702 unwind_to_catch (h
->tag
, unwind_data
);
1706 handlerlist
= allhandlers
;
1707 /* If no handler is present now, try to run the debugger,
1708 and if that fails, throw to top level. */
1709 find_handler_clause (Qerror
, conditions
, error_symbol
, data
);
1711 Fthrow (Qtop_level
, Qt
);
1713 if (! NILP (error_symbol
))
1714 data
= Fcons (error_symbol
, data
);
1716 string
= Ferror_message_string (data
);
1717 fatal ("%s", SDATA (string
), 0);
1720 /* Internal version of Fsignal that never returns.
1721 Used for anything but Qquit (which can return from Fsignal). */
1724 xsignal (error_symbol
, data
)
1725 Lisp_Object error_symbol
, data
;
1727 Fsignal (error_symbol
, data
);
1731 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1734 xsignal0 (error_symbol
)
1735 Lisp_Object error_symbol
;
1737 xsignal (error_symbol
, Qnil
);
1741 xsignal1 (error_symbol
, arg
)
1742 Lisp_Object error_symbol
, arg
;
1744 xsignal (error_symbol
, list1 (arg
));
1748 xsignal2 (error_symbol
, arg1
, arg2
)
1749 Lisp_Object error_symbol
, arg1
, arg2
;
1751 xsignal (error_symbol
, list2 (arg1
, arg2
));
1755 xsignal3 (error_symbol
, arg1
, arg2
, arg3
)
1756 Lisp_Object error_symbol
, arg1
, arg2
, arg3
;
1758 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1761 /* Signal `error' with message S, and additional arg ARG.
1762 If ARG is not a genuine list, make it a one-element list. */
1765 signal_error (s
, arg
)
1769 Lisp_Object tortoise
, hare
;
1771 hare
= tortoise
= arg
;
1772 while (CONSP (hare
))
1779 tortoise
= XCDR (tortoise
);
1781 if (EQ (hare
, tortoise
))
1786 arg
= Fcons (arg
, Qnil
); /* Make it a list. */
1788 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1792 /* Return nonzero if LIST is a non-nil atom or
1793 a list containing one of CONDITIONS. */
1796 wants_debugger (list
, conditions
)
1797 Lisp_Object list
, conditions
;
1804 while (CONSP (conditions
))
1806 Lisp_Object
this, tail
;
1807 this = XCAR (conditions
);
1808 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1809 if (EQ (XCAR (tail
), this))
1811 conditions
= XCDR (conditions
);
1816 /* Return 1 if an error with condition-symbols CONDITIONS,
1817 and described by SIGNAL-DATA, should skip the debugger
1818 according to debugger-ignored-errors. */
1821 skip_debugger (conditions
, data
)
1822 Lisp_Object conditions
, data
;
1825 int first_string
= 1;
1826 Lisp_Object error_message
;
1828 error_message
= Qnil
;
1829 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1831 if (STRINGP (XCAR (tail
)))
1835 error_message
= Ferror_message_string (data
);
1839 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1844 Lisp_Object contail
;
1846 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1847 if (EQ (XCAR (tail
), XCAR (contail
)))
1855 /* Value of Qlambda means we have called debugger and user has continued.
1856 There are two ways to pass SIG and DATA:
1857 = SIG is the error symbol, and DATA is the rest of the data.
1858 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1859 This is for memory-full errors only.
1861 We need to increase max_specpdl_size temporarily around
1862 anything we do that can push on the specpdl, so as not to get
1863 a second error here in case we're handling specpdl overflow. */
1866 find_handler_clause (handlers
, conditions
, sig
, data
)
1867 Lisp_Object handlers
, conditions
, sig
, data
;
1869 register Lisp_Object h
;
1870 register Lisp_Object tem
;
1871 int debugger_called
= 0;
1872 int debugger_considered
= 0;
1874 /* t is used by handlers for all conditions, set up by C code. */
1875 if (EQ (handlers
, Qt
))
1878 /* Don't run the debugger for a memory-full error.
1879 (There is no room in memory to do that!) */
1881 debugger_considered
= 1;
1883 /* error is used similarly, but means print an error message
1884 and run the debugger if that is enabled. */
1885 if (EQ (handlers
, Qerror
)
1886 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1887 there is a handler. */
1889 if (!NILP (sig
) && wants_debugger (Vstack_trace_on_error
, conditions
))
1893 internal_with_output_to_temp_buffer ("*Backtrace*",
1894 (Lisp_Object (*) (Lisp_Object
)) Fbacktrace
,
1897 internal_with_output_to_temp_buffer ("*Backtrace*",
1903 if (!debugger_considered
)
1905 debugger_considered
= 1;
1906 debugger_called
= maybe_call_debugger (conditions
, sig
, data
);
1909 /* If there is no handler, return saying whether we ran the debugger. */
1910 if (EQ (handlers
, Qerror
))
1912 if (debugger_called
)
1918 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1920 Lisp_Object handler
, condit
;
1923 if (!CONSP (handler
))
1925 condit
= Fcar (handler
);
1926 /* Handle a single condition name in handler HANDLER. */
1927 if (SYMBOLP (condit
))
1929 tem
= Fmemq (Fcar (handler
), conditions
);
1933 /* Handle a list of condition names in handler HANDLER. */
1934 else if (CONSP (condit
))
1937 for (tail
= condit
; CONSP (tail
); tail
= XCDR (tail
))
1939 tem
= Fmemq (Fcar (tail
), conditions
);
1942 /* This handler is going to apply.
1943 Does it allow the debugger to run first? */
1944 if (! debugger_considered
&& !NILP (Fmemq (Qdebug
, condit
)))
1945 maybe_call_debugger (conditions
, sig
, data
);
1955 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1956 SIG and DATA describe the signal, as in find_handler_clause. */
1959 maybe_call_debugger (conditions
, sig
, data
)
1960 Lisp_Object conditions
, sig
, data
;
1962 Lisp_Object combined_data
;
1964 combined_data
= Fcons (sig
, data
);
1967 /* Don't try to run the debugger with interrupts blocked.
1968 The editing loop would return anyway. */
1970 /* Does user wants to enter debugger for this kind of error? */
1973 : wants_debugger (Vdebug_on_error
, conditions
))
1974 && ! skip_debugger (conditions
, combined_data
)
1975 /* rms: what's this for? */
1976 && when_entered_debugger
< num_nonmacro_input_events
)
1978 call_debugger (Fcons (Qerror
, Fcons (combined_data
, Qnil
)));
1985 /* dump an error message; called like printf */
1989 error (m
, a1
, a2
, a3
)
2009 int used
= doprnt (buffer
, size
, m
, m
+ mlen
, 3, args
);
2014 buffer
= (char *) xrealloc (buffer
, size
);
2017 buffer
= (char *) xmalloc (size
);
2022 string
= build_string (buffer
);
2026 xsignal1 (Qerror
, string
);
2029 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
2030 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
2031 This means it contains a description for how to read arguments to give it.
2032 The value is nil for an invalid function or a symbol with no function
2035 Interactively callable functions include strings and vectors (treated
2036 as keyboard macros), lambda-expressions that contain a top-level call
2037 to `interactive', autoload definitions made by `autoload' with non-nil
2038 fourth argument, and some of the built-in functions of Lisp.
2040 Also, a symbol satisfies `commandp' if its function definition does so.
2042 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
2043 then strings and vectors are not accepted. */)
2044 (function
, for_call_interactively
)
2045 Lisp_Object function
, for_call_interactively
;
2047 register Lisp_Object fun
;
2048 register Lisp_Object funcar
;
2049 Lisp_Object if_prop
= Qnil
;
2053 fun
= indirect_function (fun
); /* Check cycles. */
2054 if (NILP (fun
) || EQ (fun
, Qunbound
))
2057 /* Check an `interactive-form' property if present, analogous to the
2058 function-documentation property. */
2060 while (SYMBOLP (fun
))
2062 Lisp_Object tmp
= Fget (fun
, intern ("interactive-form"));
2065 fun
= Fsymbol_function (fun
);
2068 /* Emacs primitives are interactive if their DEFUN specifies an
2069 interactive spec. */
2071 return XSUBR (fun
)->prompt
? Qt
: if_prop
;
2073 /* Bytecode objects are interactive if they are long enough to
2074 have an element whose index is COMPILED_INTERACTIVE, which is
2075 where the interactive spec is stored. */
2076 else if (COMPILEDP (fun
))
2077 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
2080 /* Strings and vectors are keyboard macros. */
2081 if (STRINGP (fun
) || VECTORP (fun
))
2082 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
2084 /* Lists may represent commands. */
2087 funcar
= XCAR (fun
);
2088 if (EQ (funcar
, Qlambda
))
2089 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
2090 if (EQ (funcar
, Qautoload
))
2091 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
2097 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
2098 doc
: /* Define FUNCTION to autoload from FILE.
2099 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
2100 Third arg DOCSTRING is documentation for the function.
2101 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
2102 Fifth arg TYPE indicates the type of the object:
2103 nil or omitted says FUNCTION is a function,
2104 `keymap' says FUNCTION is really a keymap, and
2105 `macro' or t says FUNCTION is really a macro.
2106 Third through fifth args give info about the real definition.
2107 They default to nil.
2108 If FUNCTION is already defined other than as an autoload,
2109 this does nothing and returns nil. */)
2110 (function
, file
, docstring
, interactive
, type
)
2111 Lisp_Object function
, file
, docstring
, interactive
, type
;
2114 Lisp_Object args
[4];
2117 CHECK_SYMBOL (function
);
2118 CHECK_STRING (file
);
2120 /* If function is defined and not as an autoload, don't override */
2121 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
2122 && !(CONSP (XSYMBOL (function
)->function
)
2123 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
2126 if (NILP (Vpurify_flag
))
2127 /* Only add entries after dumping, because the ones before are
2128 not useful and else we get loads of them from the loaddefs.el. */
2129 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
2133 args
[1] = docstring
;
2134 args
[2] = interactive
;
2137 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
2138 #else /* NO_ARG_ARRAY */
2139 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
2140 #endif /* not NO_ARG_ARRAY */
2144 un_autoload (oldqueue
)
2145 Lisp_Object oldqueue
;
2147 register Lisp_Object queue
, first
, second
;
2149 /* Queue to unwind is current value of Vautoload_queue.
2150 oldqueue is the shadowed value to leave in Vautoload_queue. */
2151 queue
= Vautoload_queue
;
2152 Vautoload_queue
= oldqueue
;
2153 while (CONSP (queue
))
2155 first
= XCAR (queue
);
2156 second
= Fcdr (first
);
2157 first
= Fcar (first
);
2158 if (EQ (first
, make_number (0)))
2161 Ffset (first
, second
);
2162 queue
= XCDR (queue
);
2167 /* Load an autoloaded function.
2168 FUNNAME is the symbol which is the function's name.
2169 FUNDEF is the autoload definition (a list). */
2172 do_autoload (fundef
, funname
)
2173 Lisp_Object fundef
, funname
;
2175 int count
= SPECPDL_INDEX ();
2176 Lisp_Object fun
, queue
, first
, second
;
2177 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2179 /* This is to make sure that loadup.el gives a clear picture
2180 of what files are preloaded and when. */
2181 if (! NILP (Vpurify_flag
))
2182 error ("Attempt to autoload %s while preparing to dump",
2183 SDATA (SYMBOL_NAME (funname
)));
2186 CHECK_SYMBOL (funname
);
2187 GCPRO3 (fun
, funname
, fundef
);
2189 /* Preserve the match data. */
2190 record_unwind_save_match_data ();
2192 /* Value saved here is to be restored into Vautoload_queue. */
2193 record_unwind_protect (un_autoload
, Vautoload_queue
);
2194 Vautoload_queue
= Qt
;
2195 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
, Qt
);
2197 /* Save the old autoloads, in case we ever do an unload. */
2198 queue
= Vautoload_queue
;
2199 while (CONSP (queue
))
2201 first
= XCAR (queue
);
2202 second
= Fcdr (first
);
2203 first
= Fcar (first
);
2205 if (SYMBOLP (first
) && CONSP (second
) && EQ (XCAR (second
), Qautoload
))
2206 Fput (first
, Qautoload
, (XCDR (second
)));
2208 queue
= XCDR (queue
);
2211 /* Once loading finishes, don't undo it. */
2212 Vautoload_queue
= Qt
;
2213 unbind_to (count
, Qnil
);
2215 fun
= Findirect_function (fun
, Qnil
);
2217 if (!NILP (Fequal (fun
, fundef
)))
2218 error ("Autoloading failed to define function %s",
2219 SDATA (SYMBOL_NAME (funname
)));
2224 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
2225 doc
: /* Evaluate FORM and return its value. */)
2229 Lisp_Object fun
, val
, original_fun
, original_args
;
2231 struct backtrace backtrace
;
2232 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2234 if (handling_signal
)
2238 return Fsymbol_value (form
);
2243 if ((consing_since_gc
> gc_cons_threshold
2244 && consing_since_gc
> gc_relative_threshold
)
2246 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2249 Fgarbage_collect ();
2253 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2255 if (max_lisp_eval_depth
< 100)
2256 max_lisp_eval_depth
= 100;
2257 if (lisp_eval_depth
> max_lisp_eval_depth
)
2258 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2261 original_fun
= Fcar (form
);
2262 original_args
= Fcdr (form
);
2264 backtrace
.next
= backtrace_list
;
2265 backtrace_list
= &backtrace
;
2266 backtrace
.function
= &original_fun
; /* This also protects them from gc */
2267 backtrace
.args
= &original_args
;
2268 backtrace
.nargs
= UNEVALLED
;
2269 backtrace
.evalargs
= 1;
2270 backtrace
.debug_on_exit
= 0;
2272 if (debug_on_next_call
)
2273 do_debug_on_call (Qt
);
2275 /* At this point, only original_fun and original_args
2276 have values that will be used below */
2279 /* Optimize for no indirection. */
2281 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2282 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2283 fun
= indirect_function (fun
);
2287 Lisp_Object numargs
;
2288 Lisp_Object argvals
[8];
2289 Lisp_Object args_left
;
2290 register int i
, maxargs
;
2292 args_left
= original_args
;
2293 numargs
= Flength (args_left
);
2297 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
2298 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2299 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2301 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2303 backtrace
.evalargs
= 0;
2304 val
= (*XSUBR (fun
)->function
) (args_left
);
2308 if (XSUBR (fun
)->max_args
== MANY
)
2310 /* Pass a vector of evaluated arguments */
2312 register int argnum
= 0;
2314 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2316 GCPRO3 (args_left
, fun
, fun
);
2320 while (!NILP (args_left
))
2322 vals
[argnum
++] = Feval (Fcar (args_left
));
2323 args_left
= Fcdr (args_left
);
2324 gcpro3
.nvars
= argnum
;
2327 backtrace
.args
= vals
;
2328 backtrace
.nargs
= XINT (numargs
);
2330 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
2335 GCPRO3 (args_left
, fun
, fun
);
2336 gcpro3
.var
= argvals
;
2339 maxargs
= XSUBR (fun
)->max_args
;
2340 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
2342 argvals
[i
] = Feval (Fcar (args_left
));
2348 backtrace
.args
= argvals
;
2349 backtrace
.nargs
= XINT (numargs
);
2354 val
= (*XSUBR (fun
)->function
) ();
2357 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
2360 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
2363 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2367 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2368 argvals
[2], argvals
[3]);
2371 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2372 argvals
[3], argvals
[4]);
2375 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2376 argvals
[3], argvals
[4], argvals
[5]);
2379 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2380 argvals
[3], argvals
[4], argvals
[5],
2385 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2386 argvals
[3], argvals
[4], argvals
[5],
2387 argvals
[6], argvals
[7]);
2391 /* Someone has created a subr that takes more arguments than
2392 is supported by this code. We need to either rewrite the
2393 subr to use a different argument protocol, or add more
2394 cases to this switch. */
2398 if (COMPILEDP (fun
))
2399 val
= apply_lambda (fun
, original_args
, 1);
2402 if (EQ (fun
, Qunbound
))
2403 xsignal1 (Qvoid_function
, original_fun
);
2405 xsignal1 (Qinvalid_function
, original_fun
);
2406 funcar
= XCAR (fun
);
2407 if (!SYMBOLP (funcar
))
2408 xsignal1 (Qinvalid_function
, original_fun
);
2409 if (EQ (funcar
, Qautoload
))
2411 do_autoload (fun
, original_fun
);
2414 if (EQ (funcar
, Qmacro
))
2415 val
= Feval (apply1 (Fcdr (fun
), original_args
));
2416 else if (EQ (funcar
, Qlambda
))
2417 val
= apply_lambda (fun
, original_args
, 1);
2419 xsignal1 (Qinvalid_function
, original_fun
);
2425 if (backtrace
.debug_on_exit
)
2426 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2427 backtrace_list
= backtrace
.next
;
2432 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
2433 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2434 Then return the value FUNCTION returns.
2435 Thus, (apply '+ 1 2 '(3 4)) returns 10.
2436 usage: (apply FUNCTION &rest ARGUMENTS) */)
2441 register int i
, numargs
;
2442 register Lisp_Object spread_arg
;
2443 register Lisp_Object
*funcall_args
;
2445 struct gcpro gcpro1
;
2449 spread_arg
= args
[nargs
- 1];
2450 CHECK_LIST (spread_arg
);
2452 numargs
= XINT (Flength (spread_arg
));
2455 return Ffuncall (nargs
- 1, args
);
2456 else if (numargs
== 1)
2458 args
[nargs
- 1] = XCAR (spread_arg
);
2459 return Ffuncall (nargs
, args
);
2462 numargs
+= nargs
- 2;
2464 /* Optimize for no indirection. */
2465 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2466 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2467 fun
= indirect_function (fun
);
2468 if (EQ (fun
, Qunbound
))
2470 /* Let funcall get the error */
2477 if (numargs
< XSUBR (fun
)->min_args
2478 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2479 goto funcall
; /* Let funcall get the error */
2480 else if (XSUBR (fun
)->max_args
> numargs
)
2482 /* Avoid making funcall cons up a yet another new vector of arguments
2483 by explicitly supplying nil's for optional values */
2484 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
2485 * sizeof (Lisp_Object
));
2486 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2487 funcall_args
[++i
] = Qnil
;
2488 GCPRO1 (*funcall_args
);
2489 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2493 /* We add 1 to numargs because funcall_args includes the
2494 function itself as well as its arguments. */
2497 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
2498 * sizeof (Lisp_Object
));
2499 GCPRO1 (*funcall_args
);
2500 gcpro1
.nvars
= 1 + numargs
;
2503 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
2504 /* Spread the last arg we got. Its first element goes in
2505 the slot that it used to occupy, hence this value of I. */
2507 while (!NILP (spread_arg
))
2509 funcall_args
[i
++] = XCAR (spread_arg
);
2510 spread_arg
= XCDR (spread_arg
);
2513 /* By convention, the caller needs to gcpro Ffuncall's args. */
2514 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
2517 /* Run hook variables in various ways. */
2519 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
2520 static Lisp_Object run_hook_with_args
P_ ((int, Lisp_Object
*,
2521 enum run_hooks_condition
));
2523 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2524 doc
: /* Run each hook in HOOKS.
2525 Each argument should be a symbol, a hook variable.
2526 These symbols are processed in the order specified.
2527 If a hook symbol has a non-nil value, that value may be a function
2528 or a list of functions to be called to run the hook.
2529 If the value is a function, it is called with no arguments.
2530 If it is a list, the elements are called, in order, with no arguments.
2532 Major modes should not use this function directly to run their mode
2533 hook; they should use `run-mode-hooks' instead.
2535 Do not use `make-local-variable' to make a hook variable buffer-local.
2536 Instead, use `add-hook' and specify t for the LOCAL argument.
2537 usage: (run-hooks &rest HOOKS) */)
2542 Lisp_Object hook
[1];
2545 for (i
= 0; i
< nargs
; i
++)
2548 run_hook_with_args (1, hook
, to_completion
);
2554 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2555 Srun_hook_with_args
, 1, MANY
, 0,
2556 doc
: /* Run HOOK with the specified arguments ARGS.
2557 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2558 value, that value may be a function or a list of functions to be
2559 called to run the hook. If the value is a function, it is called with
2560 the given arguments and its return value is returned. If it is a list
2561 of functions, those functions are called, in order,
2562 with the given arguments ARGS.
2563 It is best not to depend on the value returned by `run-hook-with-args',
2566 Do not use `make-local-variable' to make a hook variable buffer-local.
2567 Instead, use `add-hook' and specify t for the LOCAL argument.
2568 usage: (run-hook-with-args HOOK &rest ARGS) */)
2573 return run_hook_with_args (nargs
, args
, to_completion
);
2576 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2577 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2578 doc
: /* Run HOOK with the specified arguments ARGS.
2579 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2580 value, that value may be a function or a list of functions to be
2581 called to run the hook. If the value is a function, it is called with
2582 the given arguments and its return value is returned.
2583 If it is a list of functions, those functions are called, in order,
2584 with the given arguments ARGS, until one of them
2585 returns a non-nil value. Then we return that value.
2586 However, if they all return nil, we return nil.
2588 Do not use `make-local-variable' to make a hook variable buffer-local.
2589 Instead, use `add-hook' and specify t for the LOCAL argument.
2590 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2595 return run_hook_with_args (nargs
, args
, until_success
);
2598 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2599 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2600 doc
: /* Run HOOK with the specified arguments ARGS.
2601 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2602 value, that value may be a function or a list of functions to be
2603 called to run the hook. If the value is a function, it is called with
2604 the given arguments and its return value is returned.
2605 If it is a list of functions, those functions are called, in order,
2606 with the given arguments ARGS, until one of them returns nil.
2607 Then we return nil. However, if they all return non-nil, we return non-nil.
2609 Do not use `make-local-variable' to make a hook variable buffer-local.
2610 Instead, use `add-hook' and specify t for the LOCAL argument.
2611 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2616 return run_hook_with_args (nargs
, args
, until_failure
);
2619 /* ARGS[0] should be a hook symbol.
2620 Call each of the functions in the hook value, passing each of them
2621 as arguments all the rest of ARGS (all NARGS - 1 elements).
2622 COND specifies a condition to test after each call
2623 to decide whether to stop.
2624 The caller (or its caller, etc) must gcpro all of ARGS,
2625 except that it isn't necessary to gcpro ARGS[0]. */
2628 run_hook_with_args (nargs
, args
, cond
)
2631 enum run_hooks_condition cond
;
2633 Lisp_Object sym
, val
, ret
;
2634 Lisp_Object globals
;
2635 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2637 /* If we are dying or still initializing,
2638 don't do anything--it would probably crash if we tried. */
2639 if (NILP (Vrun_hooks
))
2643 val
= find_symbol_value (sym
);
2644 ret
= (cond
== until_failure
? Qt
: Qnil
);
2646 if (EQ (val
, Qunbound
) || NILP (val
))
2648 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2651 return Ffuncall (nargs
, args
);
2656 GCPRO3 (sym
, val
, globals
);
2659 CONSP (val
) && ((cond
== to_completion
)
2660 || (cond
== until_success
? NILP (ret
)
2664 if (EQ (XCAR (val
), Qt
))
2666 /* t indicates this hook has a local binding;
2667 it means to run the global binding too. */
2669 for (globals
= Fdefault_value (sym
);
2670 CONSP (globals
) && ((cond
== to_completion
)
2671 || (cond
== until_success
? NILP (ret
)
2673 globals
= XCDR (globals
))
2675 args
[0] = XCAR (globals
);
2676 /* In a global value, t should not occur. If it does, we
2677 must ignore it to avoid an endless loop. */
2678 if (!EQ (args
[0], Qt
))
2679 ret
= Ffuncall (nargs
, args
);
2684 args
[0] = XCAR (val
);
2685 ret
= Ffuncall (nargs
, args
);
2694 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2695 present value of that symbol.
2696 Call each element of FUNLIST,
2697 passing each of them the rest of ARGS.
2698 The caller (or its caller, etc) must gcpro all of ARGS,
2699 except that it isn't necessary to gcpro ARGS[0]. */
2702 run_hook_list_with_args (funlist
, nargs
, args
)
2703 Lisp_Object funlist
;
2709 Lisp_Object globals
;
2710 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2714 GCPRO3 (sym
, val
, globals
);
2716 for (val
= funlist
; CONSP (val
); val
= XCDR (val
))
2718 if (EQ (XCAR (val
), Qt
))
2720 /* t indicates this hook has a local binding;
2721 it means to run the global binding too. */
2723 for (globals
= Fdefault_value (sym
);
2725 globals
= XCDR (globals
))
2727 args
[0] = XCAR (globals
);
2728 /* In a global value, t should not occur. If it does, we
2729 must ignore it to avoid an endless loop. */
2730 if (!EQ (args
[0], Qt
))
2731 Ffuncall (nargs
, args
);
2736 args
[0] = XCAR (val
);
2737 Ffuncall (nargs
, args
);
2744 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2747 run_hook_with_args_2 (hook
, arg1
, arg2
)
2748 Lisp_Object hook
, arg1
, arg2
;
2750 Lisp_Object temp
[3];
2755 Frun_hook_with_args (3, temp
);
2758 /* Apply fn to arg */
2761 Lisp_Object fn
, arg
;
2763 struct gcpro gcpro1
;
2767 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2771 Lisp_Object args
[2];
2775 RETURN_UNGCPRO (Fapply (2, args
));
2777 #else /* not NO_ARG_ARRAY */
2778 RETURN_UNGCPRO (Fapply (2, &fn
));
2779 #endif /* not NO_ARG_ARRAY */
2782 /* Call function fn on no arguments */
2787 struct gcpro gcpro1
;
2790 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2793 /* Call function fn with 1 argument arg1 */
2797 Lisp_Object fn
, arg1
;
2799 struct gcpro gcpro1
;
2801 Lisp_Object args
[2];
2807 RETURN_UNGCPRO (Ffuncall (2, args
));
2808 #else /* not NO_ARG_ARRAY */
2811 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2812 #endif /* not NO_ARG_ARRAY */
2815 /* Call function fn with 2 arguments arg1, arg2 */
2818 call2 (fn
, arg1
, arg2
)
2819 Lisp_Object fn
, arg1
, arg2
;
2821 struct gcpro gcpro1
;
2823 Lisp_Object args
[3];
2829 RETURN_UNGCPRO (Ffuncall (3, args
));
2830 #else /* not NO_ARG_ARRAY */
2833 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2834 #endif /* not NO_ARG_ARRAY */
2837 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2840 call3 (fn
, arg1
, arg2
, arg3
)
2841 Lisp_Object fn
, arg1
, arg2
, arg3
;
2843 struct gcpro gcpro1
;
2845 Lisp_Object args
[4];
2852 RETURN_UNGCPRO (Ffuncall (4, args
));
2853 #else /* not NO_ARG_ARRAY */
2856 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2857 #endif /* not NO_ARG_ARRAY */
2860 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2863 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2864 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2866 struct gcpro gcpro1
;
2868 Lisp_Object args
[5];
2876 RETURN_UNGCPRO (Ffuncall (5, args
));
2877 #else /* not NO_ARG_ARRAY */
2880 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2881 #endif /* not NO_ARG_ARRAY */
2884 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2887 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2888 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2890 struct gcpro gcpro1
;
2892 Lisp_Object args
[6];
2901 RETURN_UNGCPRO (Ffuncall (6, args
));
2902 #else /* not NO_ARG_ARRAY */
2905 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2906 #endif /* not NO_ARG_ARRAY */
2909 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2912 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2913 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2915 struct gcpro gcpro1
;
2917 Lisp_Object args
[7];
2927 RETURN_UNGCPRO (Ffuncall (7, args
));
2928 #else /* not NO_ARG_ARRAY */
2931 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2932 #endif /* not NO_ARG_ARRAY */
2935 /* The caller should GCPRO all the elements of ARGS. */
2937 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2938 doc
: /* Call first argument as a function, passing remaining arguments to it.
2939 Return the value that function returns.
2940 Thus, (funcall 'cons 'x 'y) returns (x . y).
2941 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2946 Lisp_Object fun
, original_fun
;
2948 int numargs
= nargs
- 1;
2949 Lisp_Object lisp_numargs
;
2951 struct backtrace backtrace
;
2952 register Lisp_Object
*internal_args
;
2956 if ((consing_since_gc
> gc_cons_threshold
2957 && consing_since_gc
> gc_relative_threshold
)
2959 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2960 Fgarbage_collect ();
2962 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2964 if (max_lisp_eval_depth
< 100)
2965 max_lisp_eval_depth
= 100;
2966 if (lisp_eval_depth
> max_lisp_eval_depth
)
2967 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2970 backtrace
.next
= backtrace_list
;
2971 backtrace_list
= &backtrace
;
2972 backtrace
.function
= &args
[0];
2973 backtrace
.args
= &args
[1];
2974 backtrace
.nargs
= nargs
- 1;
2975 backtrace
.evalargs
= 0;
2976 backtrace
.debug_on_exit
= 0;
2978 if (debug_on_next_call
)
2979 do_debug_on_call (Qlambda
);
2983 original_fun
= args
[0];
2987 /* Optimize for no indirection. */
2989 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2990 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2991 fun
= indirect_function (fun
);
2995 if (numargs
< XSUBR (fun
)->min_args
2996 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2998 XSETFASTINT (lisp_numargs
, numargs
);
2999 xsignal2 (Qwrong_number_of_arguments
, original_fun
, lisp_numargs
);
3002 if (XSUBR (fun
)->max_args
== UNEVALLED
)
3003 xsignal1 (Qinvalid_function
, original_fun
);
3005 if (XSUBR (fun
)->max_args
== MANY
)
3007 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
3011 if (XSUBR (fun
)->max_args
> numargs
)
3013 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
3014 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
3015 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
3016 internal_args
[i
] = Qnil
;
3019 internal_args
= args
+ 1;
3020 switch (XSUBR (fun
)->max_args
)
3023 val
= (*XSUBR (fun
)->function
) ();
3026 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
3029 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1]);
3032 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3036 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3037 internal_args
[2], internal_args
[3]);
3040 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3041 internal_args
[2], internal_args
[3],
3045 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3046 internal_args
[2], internal_args
[3],
3047 internal_args
[4], internal_args
[5]);
3050 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3051 internal_args
[2], internal_args
[3],
3052 internal_args
[4], internal_args
[5],
3057 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3058 internal_args
[2], internal_args
[3],
3059 internal_args
[4], internal_args
[5],
3060 internal_args
[6], internal_args
[7]);
3065 /* If a subr takes more than 8 arguments without using MANY
3066 or UNEVALLED, we need to extend this function to support it.
3067 Until this is done, there is no way to call the function. */
3071 if (COMPILEDP (fun
))
3072 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3075 if (EQ (fun
, Qunbound
))
3076 xsignal1 (Qvoid_function
, original_fun
);
3078 xsignal1 (Qinvalid_function
, original_fun
);
3079 funcar
= XCAR (fun
);
3080 if (!SYMBOLP (funcar
))
3081 xsignal1 (Qinvalid_function
, original_fun
);
3082 if (EQ (funcar
, Qlambda
))
3083 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3084 else if (EQ (funcar
, Qautoload
))
3086 do_autoload (fun
, original_fun
);
3091 xsignal1 (Qinvalid_function
, original_fun
);
3096 if (backtrace
.debug_on_exit
)
3097 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
3098 backtrace_list
= backtrace
.next
;
3103 apply_lambda (fun
, args
, eval_flag
)
3104 Lisp_Object fun
, args
;
3107 Lisp_Object args_left
;
3108 Lisp_Object numargs
;
3109 register Lisp_Object
*arg_vector
;
3110 struct gcpro gcpro1
, gcpro2
, gcpro3
;
3112 register Lisp_Object tem
;
3114 numargs
= Flength (args
);
3115 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
3118 GCPRO3 (*arg_vector
, args_left
, fun
);
3121 for (i
= 0; i
< XINT (numargs
);)
3123 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
3124 if (eval_flag
) tem
= Feval (tem
);
3125 arg_vector
[i
++] = tem
;
3133 backtrace_list
->args
= arg_vector
;
3134 backtrace_list
->nargs
= i
;
3136 backtrace_list
->evalargs
= 0;
3137 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
3139 /* Do the debug-on-exit now, while arg_vector still exists. */
3140 if (backtrace_list
->debug_on_exit
)
3141 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
3142 /* Don't do it again when we return to eval. */
3143 backtrace_list
->debug_on_exit
= 0;
3147 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
3148 and return the result of evaluation.
3149 FUN must be either a lambda-expression or a compiled-code object. */
3152 funcall_lambda (fun
, nargs
, arg_vector
)
3155 register Lisp_Object
*arg_vector
;
3157 Lisp_Object val
, syms_left
, next
;
3158 int count
= SPECPDL_INDEX ();
3159 int i
, optional
, rest
;
3163 syms_left
= XCDR (fun
);
3164 if (CONSP (syms_left
))
3165 syms_left
= XCAR (syms_left
);
3167 xsignal1 (Qinvalid_function
, fun
);
3169 else if (COMPILEDP (fun
))
3170 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3174 i
= optional
= rest
= 0;
3175 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3179 next
= XCAR (syms_left
);
3180 if (!SYMBOLP (next
))
3181 xsignal1 (Qinvalid_function
, fun
);
3183 if (EQ (next
, Qand_rest
))
3185 else if (EQ (next
, Qand_optional
))
3189 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
3193 specbind (next
, arg_vector
[i
++]);
3195 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3197 specbind (next
, Qnil
);
3200 if (!NILP (syms_left
))
3201 xsignal1 (Qinvalid_function
, fun
);
3203 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3206 val
= Fprogn (XCDR (XCDR (fun
)));
3209 /* If we have not actually read the bytecode string
3210 and constants vector yet, fetch them from the file. */
3211 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3212 Ffetch_bytecode (fun
);
3213 val
= Fbyte_code (AREF (fun
, COMPILED_BYTECODE
),
3214 AREF (fun
, COMPILED_CONSTANTS
),
3215 AREF (fun
, COMPILED_STACK_DEPTH
));
3218 return unbind_to (count
, val
);
3221 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3223 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3229 if (COMPILEDP (object
) && CONSP (AREF (object
, COMPILED_BYTECODE
)))
3231 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3234 tem
= AREF (object
, COMPILED_BYTECODE
);
3235 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3236 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3238 error ("Invalid byte code");
3240 AREF (object
, COMPILED_BYTECODE
) = XCAR (tem
);
3241 AREF (object
, COMPILED_CONSTANTS
) = XCDR (tem
);
3249 register int count
= SPECPDL_INDEX ();
3250 if (specpdl_size
>= max_specpdl_size
)
3252 if (max_specpdl_size
< 400)
3253 max_specpdl_size
= 400;
3254 if (specpdl_size
>= max_specpdl_size
)
3255 signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil
);
3258 if (specpdl_size
> max_specpdl_size
)
3259 specpdl_size
= max_specpdl_size
;
3260 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
3261 specpdl_ptr
= specpdl
+ count
;
3265 specbind (symbol
, value
)
3266 Lisp_Object symbol
, value
;
3269 Lisp_Object valcontents
;
3271 CHECK_SYMBOL (symbol
);
3272 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3275 /* The most common case is that of a non-constant symbol with a
3276 trivial value. Make that as fast as we can. */
3277 valcontents
= SYMBOL_VALUE (symbol
);
3278 if (!MISCP (valcontents
) && !SYMBOL_CONSTANT_P (symbol
))
3280 specpdl_ptr
->symbol
= symbol
;
3281 specpdl_ptr
->old_value
= valcontents
;
3282 specpdl_ptr
->func
= NULL
;
3284 SET_SYMBOL_VALUE (symbol
, value
);
3288 Lisp_Object valcontents
;
3290 ovalue
= find_symbol_value (symbol
);
3291 specpdl_ptr
->func
= 0;
3292 specpdl_ptr
->old_value
= ovalue
;
3294 valcontents
= XSYMBOL (symbol
)->value
;
3296 if (BUFFER_LOCAL_VALUEP (valcontents
)
3297 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
3298 || BUFFER_OBJFWDP (valcontents
))
3300 Lisp_Object where
, current_buffer
;
3302 current_buffer
= Fcurrent_buffer ();
3304 /* For a local variable, record both the symbol and which
3305 buffer's or frame's value we are saving. */
3306 if (!NILP (Flocal_variable_p (symbol
, Qnil
)))
3307 where
= current_buffer
;
3308 else if (!BUFFER_OBJFWDP (valcontents
)
3309 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
3310 where
= XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
3314 /* We're not using the `unused' slot in the specbinding
3315 structure because this would mean we have to do more
3316 work for simple variables. */
3317 specpdl_ptr
->symbol
= Fcons (symbol
, Fcons (where
, current_buffer
));
3319 /* If SYMBOL is a per-buffer variable which doesn't have a
3320 buffer-local value here, make the `let' change the global
3321 value by changing the value of SYMBOL in all buffers not
3322 having their own value. This is consistent with what
3323 happens with other buffer-local variables. */
3325 && BUFFER_OBJFWDP (valcontents
))
3328 Fset_default (symbol
, value
);
3333 specpdl_ptr
->symbol
= symbol
;
3336 if (BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
))
3337 store_symval_forwarding (symbol
, ovalue
, value
, NULL
);
3339 set_internal (symbol
, value
, 0, 1);
3344 record_unwind_protect (function
, arg
)
3345 Lisp_Object (*function
) P_ ((Lisp_Object
));
3348 eassert (!handling_signal
);
3350 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3352 specpdl_ptr
->func
= function
;
3353 specpdl_ptr
->symbol
= Qnil
;
3354 specpdl_ptr
->old_value
= arg
;
3359 unbind_to (count
, value
)
3363 Lisp_Object quitf
= Vquit_flag
;
3364 struct gcpro gcpro1
, gcpro2
;
3366 GCPRO2 (value
, quitf
);
3369 while (specpdl_ptr
!= specpdl
+ count
)
3371 /* Copy the binding, and decrement specpdl_ptr, before we do
3372 the work to unbind it. We decrement first
3373 so that an error in unbinding won't try to unbind
3374 the same entry again, and we copy the binding first
3375 in case more bindings are made during some of the code we run. */
3377 struct specbinding this_binding
;
3378 this_binding
= *--specpdl_ptr
;
3380 if (this_binding
.func
!= 0)
3381 (*this_binding
.func
) (this_binding
.old_value
);
3382 /* If the symbol is a list, it is really (SYMBOL WHERE
3383 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3384 frame. If WHERE is a buffer or frame, this indicates we
3385 bound a variable that had a buffer-local or frame-local
3386 binding. WHERE nil means that the variable had the default
3387 value when it was bound. CURRENT-BUFFER is the buffer that
3388 was current when the variable was bound. */
3389 else if (CONSP (this_binding
.symbol
))
3391 Lisp_Object symbol
, where
;
3393 symbol
= XCAR (this_binding
.symbol
);
3394 where
= XCAR (XCDR (this_binding
.symbol
));
3397 Fset_default (symbol
, this_binding
.old_value
);
3398 else if (BUFFERP (where
))
3399 set_internal (symbol
, this_binding
.old_value
, XBUFFER (where
), 1);
3401 set_internal (symbol
, this_binding
.old_value
, NULL
, 1);
3405 /* If variable has a trivial value (no forwarding), we can
3406 just set it. No need to check for constant symbols here,
3407 since that was already done by specbind. */
3408 if (!MISCP (SYMBOL_VALUE (this_binding
.symbol
)))
3409 SET_SYMBOL_VALUE (this_binding
.symbol
, this_binding
.old_value
);
3411 set_internal (this_binding
.symbol
, this_binding
.old_value
, 0, 1);
3415 if (NILP (Vquit_flag
) && !NILP (quitf
))
3422 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3423 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3424 The debugger is entered when that frame exits, if the flag is non-nil. */)
3426 Lisp_Object level
, flag
;
3428 register struct backtrace
*backlist
= backtrace_list
;
3431 CHECK_NUMBER (level
);
3433 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
3435 backlist
= backlist
->next
;
3439 backlist
->debug_on_exit
= !NILP (flag
);
3444 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3445 doc
: /* Print a trace of Lisp function calls currently active.
3446 Output stream used is value of `standard-output'. */)
3449 register struct backtrace
*backlist
= backtrace_list
;
3453 extern Lisp_Object Vprint_level
;
3454 struct gcpro gcpro1
;
3456 XSETFASTINT (Vprint_level
, 3);
3463 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
3464 if (backlist
->nargs
== UNEVALLED
)
3466 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
3467 write_string ("\n", -1);
3471 tem
= *backlist
->function
;
3472 Fprin1 (tem
, Qnil
); /* This can QUIT */
3473 write_string ("(", -1);
3474 if (backlist
->nargs
== MANY
)
3476 for (tail
= *backlist
->args
, i
= 0;
3478 tail
= Fcdr (tail
), i
++)
3480 if (i
) write_string (" ", -1);
3481 Fprin1 (Fcar (tail
), Qnil
);
3486 for (i
= 0; i
< backlist
->nargs
; i
++)
3488 if (i
) write_string (" ", -1);
3489 Fprin1 (backlist
->args
[i
], Qnil
);
3492 write_string (")\n", -1);
3494 backlist
= backlist
->next
;
3497 Vprint_level
= Qnil
;
3502 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, NULL
,
3503 doc
: /* Return the function and arguments NFRAMES up from current execution point.
3504 If that frame has not evaluated the arguments yet (or is a special form),
3505 the value is (nil FUNCTION ARG-FORMS...).
3506 If that frame has evaluated its arguments and called its function already,
3507 the value is (t FUNCTION ARG-VALUES...).
3508 A &rest arg is represented as the tail of the list ARG-VALUES.
3509 FUNCTION is whatever was supplied as car of evaluated list,
3510 or a lambda expression for macro calls.
3511 If NFRAMES is more than the number of frames, the value is nil. */)
3513 Lisp_Object nframes
;
3515 register struct backtrace
*backlist
= backtrace_list
;
3519 CHECK_NATNUM (nframes
);
3521 /* Find the frame requested. */
3522 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3523 backlist
= backlist
->next
;
3527 if (backlist
->nargs
== UNEVALLED
)
3528 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3531 if (backlist
->nargs
== MANY
)
3532 tem
= *backlist
->args
;
3534 tem
= Flist (backlist
->nargs
, backlist
->args
);
3536 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3544 register struct backtrace
*backlist
;
3547 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3549 mark_object (*backlist
->function
);
3551 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3554 i
= backlist
->nargs
- 1;
3556 mark_object (backlist
->args
[i
]);
3563 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
3564 doc
: /* *Limit on number of Lisp variable bindings and `unwind-protect's.
3565 If Lisp code tries to increase the total number past this amount,
3566 an error is signaled.
3567 You can safely use a value considerably larger than the default value,
3568 if that proves inconveniently small. However, if you increase it too far,
3569 Emacs could run out of memory trying to make the stack bigger. */);
3571 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
3572 doc
: /* *Limit on depth in `eval', `apply' and `funcall' before error.
3574 This limit serves to catch infinite recursions for you before they cause
3575 actual stack overflow in C, which would be fatal for Emacs.
3576 You can safely make it considerably larger than its default value,
3577 if that proves inconveniently small. However, if you increase it too far,
3578 Emacs could overflow the real C stack, and crash. */);
3580 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
3581 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3582 If the value is t, that means do an ordinary quit.
3583 If the value equals `throw-on-input', that means quit by throwing
3584 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3585 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3586 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3589 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
3590 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3591 Note that `quit-flag' will still be set by typing C-g,
3592 so a quit will be signaled as soon as `inhibit-quit' is nil.
3593 To prevent this happening, set `quit-flag' to nil
3594 before making `inhibit-quit' nil. */);
3595 Vinhibit_quit
= Qnil
;
3597 Qinhibit_quit
= intern ("inhibit-quit");
3598 staticpro (&Qinhibit_quit
);
3600 Qautoload
= intern ("autoload");
3601 staticpro (&Qautoload
);
3603 Qdebug_on_error
= intern ("debug-on-error");
3604 staticpro (&Qdebug_on_error
);
3606 Qmacro
= intern ("macro");
3607 staticpro (&Qmacro
);
3609 Qdeclare
= intern ("declare");
3610 staticpro (&Qdeclare
);
3612 /* Note that the process handling also uses Qexit, but we don't want
3613 to staticpro it twice, so we just do it here. */
3614 Qexit
= intern ("exit");
3617 Qinteractive
= intern ("interactive");
3618 staticpro (&Qinteractive
);
3620 Qcommandp
= intern ("commandp");
3621 staticpro (&Qcommandp
);
3623 Qdefun
= intern ("defun");
3624 staticpro (&Qdefun
);
3626 Qand_rest
= intern ("&rest");
3627 staticpro (&Qand_rest
);
3629 Qand_optional
= intern ("&optional");
3630 staticpro (&Qand_optional
);
3632 Qdebug
= intern ("debug");
3633 staticpro (&Qdebug
);
3635 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
3636 doc
: /* *Non-nil means errors display a backtrace buffer.
3637 More precisely, this happens for any error that is handled
3638 by the editor command loop.
3639 If the value is a list, an error only means to display a backtrace
3640 if one of its condition symbols appears in the list. */);
3641 Vstack_trace_on_error
= Qnil
;
3643 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
3644 doc
: /* *Non-nil means enter debugger if an error is signaled.
3645 Does not apply to errors handled by `condition-case' or those
3646 matched by `debug-ignored-errors'.
3647 If the value is a list, an error only means to enter the debugger
3648 if one of its condition symbols appears in the list.
3649 When you evaluate an expression interactively, this variable
3650 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3651 See also variable `debug-on-quit'. */);
3652 Vdebug_on_error
= Qnil
;
3654 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
3655 doc
: /* *List of errors for which the debugger should not be called.
3656 Each element may be a condition-name or a regexp that matches error messages.
3657 If any element applies to a given error, that error skips the debugger
3658 and just returns to top level.
3659 This overrides the variable `debug-on-error'.
3660 It does not apply to errors handled by `condition-case'. */);
3661 Vdebug_ignored_errors
= Qnil
;
3663 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
3664 doc
: /* *Non-nil means enter debugger if quit is signaled (C-g, for example).
3665 Does not apply if quit is handled by a `condition-case'. */);
3668 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
3669 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3671 DEFVAR_BOOL ("debugger-may-continue", &debugger_may_continue
,
3672 doc
: /* Non-nil means debugger may continue execution.
3673 This is nil when the debugger is called under circumstances where it
3674 might not be safe to continue. */);
3675 debugger_may_continue
= 1;
3677 DEFVAR_LISP ("debugger", &Vdebugger
,
3678 doc
: /* Function to call to invoke debugger.
3679 If due to frame exit, args are `exit' and the value being returned;
3680 this function's value will be returned instead of that.
3681 If due to error, args are `error' and a list of the args to `signal'.
3682 If due to `apply' or `funcall' entry, one arg, `lambda'.
3683 If due to `eval' entry, one arg, t. */);
3686 DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function
,
3687 doc
: /* If non-nil, this is a function for `signal' to call.
3688 It receives the same arguments that `signal' was given.
3689 The Edebug package uses this to regain control. */);
3690 Vsignal_hook_function
= Qnil
;
3692 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal
,
3693 doc
: /* *Non-nil means call the debugger regardless of condition handlers.
3694 Note that `debug-on-error', `debug-on-quit' and friends
3695 still determine whether to handle the particular condition. */);
3696 Vdebug_on_signal
= Qnil
;
3698 DEFVAR_LISP ("macro-declaration-function", &Vmacro_declaration_function
,
3699 doc
: /* Function to process declarations in a macro definition.
3700 The function will be called with two args MACRO and DECL.
3701 MACRO is the name of the macro being defined.
3702 DECL is a list `(declare ...)' containing the declarations.
3703 The value the function returns is not used. */);
3704 Vmacro_declaration_function
= Qnil
;
3706 Vrun_hooks
= intern ("run-hooks");
3707 staticpro (&Vrun_hooks
);
3709 staticpro (&Vautoload_queue
);
3710 Vautoload_queue
= Qnil
;
3711 staticpro (&Vsignaling_function
);
3712 Vsignaling_function
= Qnil
;
3723 defsubr (&Sfunction
);
3725 defsubr (&Sdefmacro
);
3727 defsubr (&Sdefvaralias
);
3728 defsubr (&Sdefconst
);
3729 defsubr (&Suser_variable_p
);
3733 defsubr (&Smacroexpand
);
3736 defsubr (&Sunwind_protect
);
3737 defsubr (&Scondition_case
);
3739 defsubr (&Sinteractive_p
);
3740 defsubr (&Scalled_interactively_p
);
3741 defsubr (&Scommandp
);
3742 defsubr (&Sautoload
);
3745 defsubr (&Sfuncall
);
3746 defsubr (&Srun_hooks
);
3747 defsubr (&Srun_hook_with_args
);
3748 defsubr (&Srun_hook_with_args_until_success
);
3749 defsubr (&Srun_hook_with_args_until_failure
);
3750 defsubr (&Sfetch_bytecode
);
3751 defsubr (&Sbacktrace_debug
);
3752 defsubr (&Sbacktrace
);
3753 defsubr (&Sbacktrace_frame
);
3756 /* arch-tag: 014a07aa-33ab-4a8f-a3d2-ee8a4a9ff7fb
3757 (do not change this comment) */