1 /* Evaluator for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1999, 2000, 2001,
3 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
4 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
25 #include "blockinput.h"
28 #include "dispextern.h"
34 /* This definition is duplicated in alloc.c and keyboard.c */
35 /* Putting it in lisp.h makes cc bomb out! */
39 struct backtrace
*next
;
40 Lisp_Object
*function
;
41 Lisp_Object
*args
; /* Points to vector of args. */
42 int nargs
; /* Length of vector.
43 If nargs is UNEVALLED, args points to slot holding
44 list of unevalled args */
46 /* Nonzero means call value of debugger when done with this operation. */
50 struct backtrace
*backtrace_list
;
52 struct catchtag
*catchlist
;
55 /* Count levels of GCPRO to detect failure to UNGCPRO. */
59 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
60 Lisp_Object Qinhibit_quit
, Vinhibit_quit
, Vquit_flag
;
61 Lisp_Object Qand_rest
, Qand_optional
;
62 Lisp_Object Qdebug_on_error
;
65 extern Lisp_Object Qinteractive_form
;
67 /* This holds either the symbol `run-hooks' or nil.
68 It is nil at an early stage of startup, and when Emacs
71 Lisp_Object Vrun_hooks
;
73 /* Non-nil means record all fset's and provide's, to be undone
74 if the file being autoloaded is not fully loaded.
75 They are recorded by being consed onto the front of Vautoload_queue:
76 (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide. */
78 Lisp_Object Vautoload_queue
;
80 /* Current number of specbindings allocated in specpdl. */
84 /* Pointer to beginning of specpdl. */
86 struct specbinding
*specpdl
;
88 /* Pointer to first unused element in specpdl. */
90 struct specbinding
*specpdl_ptr
;
92 /* Maximum size allowed for specpdl allocation */
94 EMACS_INT max_specpdl_size
;
96 /* Depth in Lisp evaluations and function calls. */
100 /* Maximum allowed depth in Lisp evaluations and function calls. */
102 EMACS_INT max_lisp_eval_depth
;
104 /* Nonzero means enter debugger before next function call */
106 int debug_on_next_call
;
108 /* Non-zero means debugger may continue. This is zero when the
109 debugger is called during redisplay, where it might not be safe to
110 continue the interrupted redisplay. */
112 int debugger_may_continue
;
114 /* List of conditions (non-nil atom means all) which cause a backtrace
115 if an error is handled by the command loop's error handler. */
117 Lisp_Object Vstack_trace_on_error
;
119 /* List of conditions (non-nil atom means all) which enter the debugger
120 if an error is handled by the command loop's error handler. */
122 Lisp_Object Vdebug_on_error
;
124 /* List of conditions and regexps specifying error messages which
125 do not enter the debugger even if Vdebug_on_error says they should. */
127 Lisp_Object Vdebug_ignored_errors
;
129 /* Non-nil means call the debugger even if the error will be handled. */
131 Lisp_Object Vdebug_on_signal
;
133 /* Hook for edebug to use. */
135 Lisp_Object Vsignal_hook_function
;
137 /* Nonzero means enter debugger if a quit signal
138 is handled by the command loop's error handler. */
142 /* The value of num_nonmacro_input_events as of the last time we
143 started to enter the debugger. If we decide to enter the debugger
144 again when this is still equal to num_nonmacro_input_events, then we
145 know that the debugger itself has an error, and we should just
146 signal the error instead of entering an infinite loop of debugger
149 int when_entered_debugger
;
151 Lisp_Object Vdebugger
;
153 /* The function from which the last `signal' was called. Set in
156 Lisp_Object Vsignaling_function
;
158 /* Set to non-zero while processing X events. Checked in Feval to
159 make sure the Lisp interpreter isn't called from a signal handler,
160 which is unsafe because the interpreter isn't reentrant. */
164 /* Function to process declarations in defmacro forms. */
166 Lisp_Object Vmacro_declaration_function
;
168 extern Lisp_Object Qrisky_local_variable
;
170 extern Lisp_Object Qfunction
;
172 static Lisp_Object funcall_lambda
P_ ((Lisp_Object
, int, Lisp_Object
*));
173 static void unwind_to_catch
P_ ((struct catchtag
*, Lisp_Object
)) NO_RETURN
;
176 /* "gcc -O3" enables automatic function inlining, which optimizes out
177 the arguments for the invocations of these functions, whereas they
178 expect these values on the stack. */
179 Lisp_Object
apply1 () __attribute__((noinline
));
180 Lisp_Object
call2 () __attribute__((noinline
));
187 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
188 specpdl_ptr
= specpdl
;
189 /* Don't forget to update docs (lispref node "Local Variables"). */
190 max_specpdl_size
= 1000;
191 max_lisp_eval_depth
= 500;
199 specpdl_ptr
= specpdl
;
204 debug_on_next_call
= 0;
209 /* This is less than the initial value of num_nonmacro_input_events. */
210 when_entered_debugger
= -1;
213 /* unwind-protect function used by call_debugger. */
216 restore_stack_limits (data
)
219 max_specpdl_size
= XINT (XCAR (data
));
220 max_lisp_eval_depth
= XINT (XCDR (data
));
224 /* Call the Lisp debugger, giving it argument ARG. */
230 int debug_while_redisplaying
;
231 int count
= SPECPDL_INDEX ();
233 int old_max
= max_specpdl_size
;
235 /* Temporarily bump up the stack limits,
236 so the debugger won't run out of stack. */
238 max_specpdl_size
+= 1;
239 record_unwind_protect (restore_stack_limits
,
240 Fcons (make_number (old_max
),
241 make_number (max_lisp_eval_depth
)));
242 max_specpdl_size
= old_max
;
244 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
245 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
247 if (SPECPDL_INDEX () + 100 > max_specpdl_size
)
248 max_specpdl_size
= SPECPDL_INDEX () + 100;
250 #ifdef HAVE_WINDOW_SYSTEM
251 if (display_hourglass_p
)
255 debug_on_next_call
= 0;
256 when_entered_debugger
= num_nonmacro_input_events
;
258 /* Resetting redisplaying_p to 0 makes sure that debug output is
259 displayed if the debugger is invoked during redisplay. */
260 debug_while_redisplaying
= redisplaying_p
;
262 specbind (intern ("debugger-may-continue"),
263 debug_while_redisplaying
? Qnil
: Qt
);
264 specbind (Qinhibit_redisplay
, Qnil
);
265 specbind (Qdebug_on_error
, Qnil
);
267 #if 0 /* Binding this prevents execution of Lisp code during
268 redisplay, which necessarily leads to display problems. */
269 specbind (Qinhibit_eval_during_redisplay
, Qt
);
272 val
= apply1 (Vdebugger
, arg
);
274 /* Interrupting redisplay and resuming it later is not safe under
275 all circumstances. So, when the debugger returns, abort the
276 interrupted redisplay by going back to the top-level. */
277 if (debug_while_redisplaying
)
280 return unbind_to (count
, val
);
284 do_debug_on_call (code
)
287 debug_on_next_call
= 0;
288 backtrace_list
->debug_on_exit
= 1;
289 call_debugger (Fcons (code
, Qnil
));
292 /* NOTE!!! Every function that can call EVAL must protect its args
293 and temporaries from garbage collection while it needs them.
294 The definition of `For' shows what you have to do. */
296 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
297 doc
: /* Eval args until one of them yields non-nil, then return that value.
298 The remaining args are not evalled at all.
299 If all args return nil, return nil.
300 usage: (or CONDITIONS...) */)
304 register Lisp_Object val
= Qnil
;
311 val
= Feval (XCAR (args
));
321 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
322 doc
: /* Eval args until one of them yields nil, then return nil.
323 The remaining args are not evalled at all.
324 If no arg yields nil, return the last arg's value.
325 usage: (and CONDITIONS...) */)
329 register Lisp_Object val
= Qt
;
336 val
= Feval (XCAR (args
));
346 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
347 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
348 Returns the value of THEN or the value of the last of the ELSE's.
349 THEN must be one expression, but ELSE... can be zero or more expressions.
350 If COND yields nil, and there are no ELSE's, the value is nil.
351 usage: (if COND THEN ELSE...) */)
355 register Lisp_Object cond
;
359 cond
= Feval (Fcar (args
));
363 return Feval (Fcar (Fcdr (args
)));
364 return Fprogn (Fcdr (Fcdr (args
)));
367 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
368 doc
: /* Try each clause until one succeeds.
369 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
370 and, if the value is non-nil, this clause succeeds:
371 then the expressions in BODY are evaluated and the last one's
372 value is the value of the cond-form.
373 If no clause succeeds, cond returns nil.
374 If a clause has one element, as in (CONDITION),
375 CONDITION's value if non-nil is returned from the cond-form.
376 usage: (cond CLAUSES...) */)
380 register Lisp_Object clause
, val
;
387 clause
= Fcar (args
);
388 val
= Feval (Fcar (clause
));
391 if (!EQ (XCDR (clause
), Qnil
))
392 val
= Fprogn (XCDR (clause
));
402 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
403 doc
: /* Eval BODY forms sequentially and return value of last one.
404 usage: (progn BODY...) */)
408 register Lisp_Object val
= Qnil
;
415 val
= Feval (XCAR (args
));
423 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
424 doc
: /* Eval FIRST and BODY sequentially; return value from FIRST.
425 The value of FIRST is saved during the evaluation of the remaining args,
426 whose values are discarded.
427 usage: (prog1 FIRST BODY...) */)
432 register Lisp_Object args_left
;
433 struct gcpro gcpro1
, gcpro2
;
434 register int argnum
= 0;
446 val
= Feval (Fcar (args_left
));
448 Feval (Fcar (args_left
));
449 args_left
= Fcdr (args_left
);
451 while (!NILP(args_left
));
457 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
458 doc
: /* Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
459 The value of FORM2 is saved during the evaluation of the
460 remaining args, whose values are discarded.
461 usage: (prog2 FORM1 FORM2 BODY...) */)
466 register Lisp_Object args_left
;
467 struct gcpro gcpro1
, gcpro2
;
468 register int argnum
= -1;
482 val
= Feval (Fcar (args_left
));
484 Feval (Fcar (args_left
));
485 args_left
= Fcdr (args_left
);
487 while (!NILP (args_left
));
493 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
494 doc
: /* Set each SYM to the value of its VAL.
495 The symbols SYM are variables; they are literal (not evaluated).
496 The values VAL are expressions; they are evaluated.
497 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
498 The second VAL is not computed until after the first SYM is set, and so on;
499 each VAL can use the new value of variables set earlier in the `setq'.
500 The return value of the `setq' form is the value of the last VAL.
501 usage: (setq [SYM VAL]...) */)
505 register Lisp_Object args_left
;
506 register Lisp_Object val
, sym
;
517 val
= Feval (Fcar (Fcdr (args_left
)));
518 sym
= Fcar (args_left
);
520 args_left
= Fcdr (Fcdr (args_left
));
522 while (!NILP(args_left
));
528 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
529 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
530 usage: (quote ARG) */)
534 if (!NILP (Fcdr (args
)))
535 xsignal2 (Qwrong_number_of_arguments
, Qquote
, Flength (args
));
539 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
540 doc
: /* Like `quote', but preferred for objects which are functions.
541 In byte compilation, `function' causes its argument to be compiled.
542 `quote' cannot do that.
543 usage: (function ARG) */)
547 if (!NILP (Fcdr (args
)))
548 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
553 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
554 doc
: /* Return t if the containing function was run directly by user input.
555 This means that the function was called with `call-interactively'
556 \(which includes being called as the binding of a key)
557 and input is currently coming from the keyboard (not a keyboard macro),
558 and Emacs is not running in batch mode (`noninteractive' is nil).
560 The only known proper use of `interactive-p' is in deciding whether to
561 display a helpful message, or how to display it. If you're thinking
562 of using it for any other purpose, it is quite likely that you're
563 making a mistake. Think: what do you want to do when the command is
564 called from a keyboard macro?
566 To test whether your function was called with `call-interactively',
567 either (i) add an extra optional argument and give it an `interactive'
568 spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
569 use `called-interactively-p'. */)
572 return (INTERACTIVE
&& interactive_p (1)) ? Qt
: Qnil
;
576 DEFUN ("called-interactively-p", Fcalled_interactively_p
, Scalled_interactively_p
, 0, 1, 0,
577 doc
: /* Return t if the containing function was called by `call-interactively'.
578 If KIND is `interactive', then only return t if the call was made
579 interactively by the user, i.e. not in `noninteractive' mode nor
580 when `executing-kbd-macro'.
581 If KIND is `any', on the other hand, it will return t for any kind of
582 interactive call, including being called as the binding of a key, or
583 from a keyboard macro, or in `noninteractive' mode.
585 The only known proper use of `interactive' for KIND is in deciding
586 whether to display a helpful message, or how to display it. If you're
587 thinking of using it for any other purpose, it is quite likely that
588 you're making a mistake. Think: what do you want to do when the
589 command is called from a keyboard macro?
591 This function is meant for implementing advice and other
592 function-modifying features. Instead of using this, it is sometimes
593 cleaner to give your function an extra optional argument whose
594 `interactive' spec specifies non-nil unconditionally (\"p\" is a good
595 way to do this), or via (not (or executing-kbd-macro noninteractive)). */)
599 return ((INTERACTIVE
|| !EQ (kind
, intern ("interactive")))
600 && interactive_p (1)) ? Qt
: Qnil
;
604 /* Return 1 if function in which this appears was called using
607 EXCLUDE_SUBRS_P non-zero means always return 0 if the function
608 called is a built-in. */
611 interactive_p (exclude_subrs_p
)
614 struct backtrace
*btp
;
617 btp
= backtrace_list
;
619 /* If this isn't a byte-compiled function, there may be a frame at
620 the top for Finteractive_p. If so, skip it. */
621 fun
= Findirect_function (*btp
->function
, Qnil
);
622 if (SUBRP (fun
) && (XSUBR (fun
) == &Sinteractive_p
623 || XSUBR (fun
) == &Scalled_interactively_p
))
626 /* If we're running an Emacs 18-style byte-compiled function, there
627 may be a frame for Fbytecode at the top level. In any version of
628 Emacs there can be Fbytecode frames for subexpressions evaluated
629 inside catch and condition-case. Skip past them.
631 If this isn't a byte-compiled function, then we may now be
632 looking at several frames for special forms. Skip past them. */
634 && (EQ (*btp
->function
, Qbytecode
)
635 || btp
->nargs
== UNEVALLED
))
638 /* btp now points at the frame of the innermost function that isn't
639 a special form, ignoring frames for Finteractive_p and/or
640 Fbytecode at the top. If this frame is for a built-in function
641 (such as load or eval-region) return nil. */
642 fun
= Findirect_function (*btp
->function
, Qnil
);
643 if (exclude_subrs_p
&& SUBRP (fun
))
646 /* btp points to the frame of a Lisp function that called interactive-p.
647 Return t if that function was called interactively. */
648 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
654 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
655 doc
: /* Define NAME as a function.
656 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
657 See also the function `interactive'.
658 usage: (defun NAME ARGLIST [DOCSTRING] BODY...) */)
662 register Lisp_Object fn_name
;
663 register Lisp_Object defn
;
665 fn_name
= Fcar (args
);
666 CHECK_SYMBOL (fn_name
);
667 defn
= Fcons (Qlambda
, Fcdr (args
));
668 if (!NILP (Vpurify_flag
))
669 defn
= Fpurecopy (defn
);
670 if (CONSP (XSYMBOL (fn_name
)->function
)
671 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
672 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
673 Ffset (fn_name
, defn
);
674 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
678 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
679 doc
: /* Define NAME as a macro.
680 The actual definition looks like
681 (macro lambda ARGLIST [DOCSTRING] [DECL] BODY...).
682 When the macro is called, as in (NAME ARGS...),
683 the function (lambda ARGLIST BODY...) is applied to
684 the list ARGS... as it appears in the expression,
685 and the result should be a form to be evaluated instead of the original.
687 DECL is a declaration, optional, which can specify how to indent
688 calls to this macro, how Edebug should handle it, and which argument
689 should be treated as documentation. It looks like this:
691 The elements can look like this:
693 Set NAME's `lisp-indent-function' property to INDENT.
696 Set NAME's `edebug-form-spec' property to DEBUG. (This is
697 equivalent to writing a `def-edebug-spec' for the macro.)
700 Set NAME's `doc-string-elt' property to ELT.
702 usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */)
706 register Lisp_Object fn_name
;
707 register Lisp_Object defn
;
708 Lisp_Object lambda_list
, doc
, tail
;
710 fn_name
= Fcar (args
);
711 CHECK_SYMBOL (fn_name
);
712 lambda_list
= Fcar (Fcdr (args
));
713 tail
= Fcdr (Fcdr (args
));
716 if (STRINGP (Fcar (tail
)))
722 while (CONSP (Fcar (tail
))
723 && EQ (Fcar (Fcar (tail
)), Qdeclare
))
725 if (!NILP (Vmacro_declaration_function
))
729 call2 (Vmacro_declaration_function
, fn_name
, Fcar (tail
));
737 tail
= Fcons (lambda_list
, tail
);
739 tail
= Fcons (lambda_list
, Fcons (doc
, tail
));
740 defn
= Fcons (Qmacro
, Fcons (Qlambda
, tail
));
742 if (!NILP (Vpurify_flag
))
743 defn
= Fpurecopy (defn
);
744 if (CONSP (XSYMBOL (fn_name
)->function
)
745 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
746 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
747 Ffset (fn_name
, defn
);
748 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
753 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
754 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
755 Aliased variables always have the same value; setting one sets the other.
756 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
757 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
758 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
759 itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
760 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
761 The return value is BASE-VARIABLE. */)
762 (new_alias
, base_variable
, docstring
)
763 Lisp_Object new_alias
, base_variable
, docstring
;
765 struct Lisp_Symbol
*sym
;
767 CHECK_SYMBOL (new_alias
);
768 CHECK_SYMBOL (base_variable
);
770 sym
= XSYMBOL (new_alias
);
773 if (sym
->redirect
== SYMBOL_VARALIAS
)
774 sym
->constant
= 0; /* Reset. */
777 error ("Cannot make a constant an alias");
779 switch (sym
->redirect
)
781 case SYMBOL_FORWARDED
:
782 error ("Cannot make an internal variable an alias");
783 case SYMBOL_LOCALIZED
:
784 error ("Don't know how to make a localized variable an alias");
787 /* http://lists.gnu.org/archive/html/emacs-devel/2008-04/msg00834.html
788 If n_a is bound, but b_v is not, set the value of b_v to n_a,
789 so that old-code that affects n_a before the aliasing is setup
791 if (NILP (Fboundp (base_variable
)))
792 set_internal (base_variable
, find_symbol_value (new_alias
), NULL
, 1);
795 struct specbinding
*p
;
797 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
800 CONSP (p
->symbol
) ? XCAR (p
->symbol
) : p
->symbol
)))
801 error ("Don't know how to make a let-bound variable an alias");
804 sym
->redirect
= SYMBOL_VARALIAS
;
805 SET_SYMBOL_ALIAS (sym
, XSYMBOL (base_variable
));
806 sym
->constant
= SYMBOL_CONSTANT_P (base_variable
);
807 LOADHIST_ATTACH (new_alias
);
808 /* Even if docstring is nil: remove old docstring. */
809 Fput (new_alias
, Qvariable_documentation
, docstring
);
811 return base_variable
;
815 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
816 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
817 You are not required to define a variable in order to use it,
818 but the definition can supply documentation and an initial value
819 in a way that tags can recognize.
821 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.
822 If SYMBOL is buffer-local, its default value is what is set;
823 buffer-local values are not affected.
824 INITVALUE and DOCSTRING are optional.
825 If DOCSTRING starts with *, this variable is identified as a user option.
826 This means that M-x set-variable recognizes it.
827 See also `user-variable-p'.
828 If INITVALUE is missing, SYMBOL's value is not set.
830 If SYMBOL has a local binding, then this form affects the local
831 binding. This is usually not what you want. Thus, if you need to
832 load a file defining variables, with this form or with `defconst' or
833 `defcustom', you should always load that file _outside_ any bindings
834 for these variables. \(`defconst' and `defcustom' behave similarly in
836 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
840 register Lisp_Object sym
, tem
, tail
;
844 if (!NILP (Fcdr (Fcdr (tail
))))
845 error ("Too many arguments");
847 tem
= Fdefault_boundp (sym
);
850 if (SYMBOL_CONSTANT_P (sym
))
852 /* For upward compatibility, allow (defvar :foo (quote :foo)). */
853 Lisp_Object tem
= Fcar (tail
);
855 && EQ (XCAR (tem
), Qquote
)
856 && CONSP (XCDR (tem
))
857 && EQ (XCAR (XCDR (tem
)), sym
)))
858 error ("Constant symbol `%s' specified in defvar",
859 SDATA (SYMBOL_NAME (sym
)));
863 Fset_default (sym
, Feval (Fcar (tail
)));
865 { /* Check if there is really a global binding rather than just a let
866 binding that shadows the global unboundness of the var. */
867 volatile struct specbinding
*pdl
= specpdl_ptr
;
868 while (--pdl
>= specpdl
)
870 if (EQ (pdl
->symbol
, sym
) && !pdl
->func
871 && EQ (pdl
->old_value
, Qunbound
))
873 message_with_string ("Warning: defvar ignored because %s is let-bound",
874 SYMBOL_NAME (sym
), 1);
883 if (!NILP (Vpurify_flag
))
884 tem
= Fpurecopy (tem
);
885 Fput (sym
, Qvariable_documentation
, tem
);
887 LOADHIST_ATTACH (sym
);
890 /* Simple (defvar <var>) should not count as a definition at all.
891 It could get in the way of other definitions, and unloading this
892 package could try to make the variable unbound. */
898 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
899 doc
: /* Define SYMBOL as a constant variable.
900 The intent is that neither programs nor users should ever change this value.
901 Always sets the value of SYMBOL to the result of evalling INITVALUE.
902 If SYMBOL is buffer-local, its default value is what is set;
903 buffer-local values are not affected.
904 DOCSTRING is optional.
906 If SYMBOL has a local binding, then this form sets the local binding's
907 value. However, you should normally not make local bindings for
908 variables defined with this form.
909 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
913 register Lisp_Object sym
, tem
;
916 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
917 error ("Too many arguments");
919 tem
= Feval (Fcar (Fcdr (args
)));
920 if (!NILP (Vpurify_flag
))
921 tem
= Fpurecopy (tem
);
922 Fset_default (sym
, tem
);
923 tem
= Fcar (Fcdr (Fcdr (args
)));
926 if (!NILP (Vpurify_flag
))
927 tem
= Fpurecopy (tem
);
928 Fput (sym
, Qvariable_documentation
, tem
);
930 Fput (sym
, Qrisky_local_variable
, Qt
);
931 LOADHIST_ATTACH (sym
);
935 /* Error handler used in Fuser_variable_p. */
937 user_variable_p_eh (ignore
)
944 lisp_indirect_variable (Lisp_Object sym
)
946 XSETSYMBOL (sym
, indirect_variable (XSYMBOL (sym
)));
950 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
951 doc
: /* Return t if VARIABLE is intended to be set and modified by users.
952 \(The alternative is a variable used internally in a Lisp program.)
953 A variable is a user variable if
954 \(1) the first character of its documentation is `*', or
955 \(2) it is customizable (its property list contains a non-nil value
956 of `standard-value' or `custom-autoload'), or
957 \(3) it is an alias for another user variable.
958 Return nil if VARIABLE is an alias and there is a loop in the
959 chain of symbols. */)
961 Lisp_Object variable
;
963 Lisp_Object documentation
;
965 if (!SYMBOLP (variable
))
968 /* If indirect and there's an alias loop, don't check anything else. */
969 if (XSYMBOL (variable
)->redirect
== SYMBOL_VARALIAS
970 && NILP (internal_condition_case_1 (lisp_indirect_variable
, variable
,
971 Qt
, user_variable_p_eh
)))
976 documentation
= Fget (variable
, Qvariable_documentation
);
977 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
979 if (STRINGP (documentation
)
980 && ((unsigned char) SREF (documentation
, 0) == '*'))
982 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
983 if (CONSP (documentation
)
984 && STRINGP (XCAR (documentation
))
985 && INTEGERP (XCDR (documentation
))
986 && XINT (XCDR (documentation
)) < 0)
988 /* Customizable? See `custom-variable-p'. */
989 if ((!NILP (Fget (variable
, intern ("standard-value"))))
990 || (!NILP (Fget (variable
, intern ("custom-autoload")))))
993 if (!(XSYMBOL (variable
)->redirect
== SYMBOL_VARALIAS
))
996 /* An indirect variable? Let's follow the chain. */
997 XSETSYMBOL (variable
, SYMBOL_ALIAS (XSYMBOL (variable
)));
1001 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
1002 doc
: /* Bind variables according to VARLIST then eval BODY.
1003 The value of the last form in BODY is returned.
1004 Each element of VARLIST is a symbol (which is bound to nil)
1005 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
1006 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
1007 usage: (let* VARLIST BODY...) */)
1011 Lisp_Object varlist
, val
, elt
;
1012 int count
= SPECPDL_INDEX ();
1013 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1015 GCPRO3 (args
, elt
, varlist
);
1017 varlist
= Fcar (args
);
1018 while (!NILP (varlist
))
1021 elt
= Fcar (varlist
);
1023 specbind (elt
, Qnil
);
1024 else if (! NILP (Fcdr (Fcdr (elt
))))
1025 signal_error ("`let' bindings can have only one value-form", elt
);
1028 val
= Feval (Fcar (Fcdr (elt
)));
1029 specbind (Fcar (elt
), val
);
1031 varlist
= Fcdr (varlist
);
1034 val
= Fprogn (Fcdr (args
));
1035 return unbind_to (count
, val
);
1038 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
1039 doc
: /* Bind variables according to VARLIST then eval BODY.
1040 The value of the last form in BODY is returned.
1041 Each element of VARLIST is a symbol (which is bound to nil)
1042 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
1043 All the VALUEFORMs are evalled before any symbols are bound.
1044 usage: (let VARLIST BODY...) */)
1048 Lisp_Object
*temps
, tem
;
1049 register Lisp_Object elt
, varlist
;
1050 int count
= SPECPDL_INDEX ();
1051 register int argnum
;
1052 struct gcpro gcpro1
, gcpro2
;
1054 varlist
= Fcar (args
);
1056 /* Make space to hold the values to give the bound variables */
1057 elt
= Flength (varlist
);
1058 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
1060 /* Compute the values and store them in `temps' */
1062 GCPRO2 (args
, *temps
);
1065 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
1068 elt
= XCAR (varlist
);
1070 temps
[argnum
++] = Qnil
;
1071 else if (! NILP (Fcdr (Fcdr (elt
))))
1072 signal_error ("`let' bindings can have only one value-form", elt
);
1074 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
1075 gcpro2
.nvars
= argnum
;
1079 varlist
= Fcar (args
);
1080 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
1082 elt
= XCAR (varlist
);
1083 tem
= temps
[argnum
++];
1085 specbind (elt
, tem
);
1087 specbind (Fcar (elt
), tem
);
1090 elt
= Fprogn (Fcdr (args
));
1091 return unbind_to (count
, elt
);
1094 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
1095 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
1096 The order of execution is thus TEST, BODY, TEST, BODY and so on
1097 until TEST returns nil.
1098 usage: (while TEST BODY...) */)
1102 Lisp_Object test
, body
;
1103 struct gcpro gcpro1
, gcpro2
;
1105 GCPRO2 (test
, body
);
1109 while (!NILP (Feval (test
)))
1119 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
1120 doc
: /* Return result of expanding macros at top level of FORM.
1121 If FORM is not a macro call, it is returned unchanged.
1122 Otherwise, the macro is expanded and the expansion is considered
1123 in place of FORM. When a non-macro-call results, it is returned.
1125 The second optional arg ENVIRONMENT specifies an environment of macro
1126 definitions to shadow the loaded ones for use in file byte-compilation. */)
1129 Lisp_Object environment
;
1131 /* With cleanups from Hallvard Furuseth. */
1132 register Lisp_Object expander
, sym
, def
, tem
;
1136 /* Come back here each time we expand a macro call,
1137 in case it expands into another macro call. */
1140 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1141 def
= sym
= XCAR (form
);
1143 /* Trace symbols aliases to other symbols
1144 until we get a symbol that is not an alias. */
1145 while (SYMBOLP (def
))
1149 tem
= Fassq (sym
, environment
);
1152 def
= XSYMBOL (sym
)->function
;
1153 if (!EQ (def
, Qunbound
))
1158 /* Right now TEM is the result from SYM in ENVIRONMENT,
1159 and if TEM is nil then DEF is SYM's function definition. */
1162 /* SYM is not mentioned in ENVIRONMENT.
1163 Look at its function definition. */
1164 if (EQ (def
, Qunbound
) || !CONSP (def
))
1165 /* Not defined or definition not suitable */
1167 if (EQ (XCAR (def
), Qautoload
))
1169 /* Autoloading function: will it be a macro when loaded? */
1170 tem
= Fnth (make_number (4), def
);
1171 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
1172 /* Yes, load it and try again. */
1174 struct gcpro gcpro1
;
1176 do_autoload (def
, sym
);
1183 else if (!EQ (XCAR (def
), Qmacro
))
1185 else expander
= XCDR (def
);
1189 expander
= XCDR (tem
);
1190 if (NILP (expander
))
1193 form
= apply1 (expander
, XCDR (form
));
1198 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1199 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1200 TAG is evalled to get the tag to use; it must not be nil.
1202 Then the BODY is executed.
1203 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
1204 If no throw happens, `catch' returns the value of the last BODY form.
1205 If a throw happens, it specifies the value to return from `catch'.
1206 usage: (catch TAG BODY...) */)
1210 register Lisp_Object tag
;
1211 struct gcpro gcpro1
;
1214 tag
= Feval (Fcar (args
));
1216 return internal_catch (tag
, Fprogn
, Fcdr (args
));
1219 /* Set up a catch, then call C function FUNC on argument ARG.
1220 FUNC should return a Lisp_Object.
1221 This is how catches are done from within C code. */
1224 internal_catch (tag
, func
, arg
)
1226 Lisp_Object (*func
) ();
1229 /* This structure is made part of the chain `catchlist'. */
1232 /* Fill in the components of c, and put it on the list. */
1236 c
.backlist
= backtrace_list
;
1237 c
.handlerlist
= handlerlist
;
1238 c
.lisp_eval_depth
= lisp_eval_depth
;
1239 c
.pdlcount
= SPECPDL_INDEX ();
1240 c
.poll_suppress_count
= poll_suppress_count
;
1241 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1242 c
.gcpro
= gcprolist
;
1243 c
.byte_stack
= byte_stack_list
;
1247 if (! _setjmp (c
.jmp
))
1248 c
.val
= (*func
) (arg
);
1250 /* Throw works by a longjmp that comes right here. */
1255 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1256 jump to that CATCH, returning VALUE as the value of that catch.
1258 This is the guts Fthrow and Fsignal; they differ only in the way
1259 they choose the catch tag to throw to. A catch tag for a
1260 condition-case form has a TAG of Qnil.
1262 Before each catch is discarded, unbind all special bindings and
1263 execute all unwind-protect clauses made above that catch. Unwind
1264 the handler stack as we go, so that the proper handlers are in
1265 effect for each unwind-protect clause we run. At the end, restore
1266 some static info saved in CATCH, and longjmp to the location
1269 This is used for correct unwinding in Fthrow and Fsignal. */
1272 unwind_to_catch (catch, value
)
1273 struct catchtag
*catch;
1276 register int last_time
;
1278 /* Save the value in the tag. */
1281 /* Restore certain special C variables. */
1282 set_poll_suppress_count (catch->poll_suppress_count
);
1283 UNBLOCK_INPUT_TO (catch->interrupt_input_blocked
);
1284 handling_signal
= 0;
1289 last_time
= catchlist
== catch;
1291 /* Unwind the specpdl stack, and then restore the proper set of
1293 unbind_to (catchlist
->pdlcount
, Qnil
);
1294 handlerlist
= catchlist
->handlerlist
;
1295 catchlist
= catchlist
->next
;
1297 while (! last_time
);
1300 /* If x_catch_errors was done, turn it off now.
1301 (First we give unbind_to a chance to do that.) */
1302 #if 0 /* This would disable x_catch_errors after x_connection_closed.
1303 * The catch must remain in effect during that delicate
1304 * state. --lorentey */
1305 x_fully_uncatch_errors ();
1309 byte_stack_list
= catch->byte_stack
;
1310 gcprolist
= catch->gcpro
;
1313 gcpro_level
= gcprolist
->level
+ 1;
1317 backtrace_list
= catch->backlist
;
1318 lisp_eval_depth
= catch->lisp_eval_depth
;
1320 _longjmp (catch->jmp
, 1);
1323 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1324 doc
: /* Throw to the catch for TAG and return VALUE from it.
1325 Both TAG and VALUE are evalled. */)
1327 register Lisp_Object tag
, value
;
1329 register struct catchtag
*c
;
1332 for (c
= catchlist
; c
; c
= c
->next
)
1334 if (EQ (c
->tag
, tag
))
1335 unwind_to_catch (c
, value
);
1337 xsignal2 (Qno_catch
, tag
, value
);
1341 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1342 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1343 If BODYFORM completes normally, its value is returned
1344 after executing the UNWINDFORMS.
1345 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1346 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1351 int count
= SPECPDL_INDEX ();
1353 record_unwind_protect (Fprogn
, Fcdr (args
));
1354 val
= Feval (Fcar (args
));
1355 return unbind_to (count
, val
);
1358 /* Chain of condition handlers currently in effect.
1359 The elements of this chain are contained in the stack frames
1360 of Fcondition_case and internal_condition_case.
1361 When an error is signaled (by calling Fsignal, below),
1362 this chain is searched for an element that applies. */
1364 struct handler
*handlerlist
;
1366 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1367 doc
: /* Regain control when an error is signaled.
1368 Executes BODYFORM and returns its value if no error happens.
1369 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1370 where the BODY is made of Lisp expressions.
1372 A handler is applicable to an error
1373 if CONDITION-NAME is one of the error's condition names.
1374 If an error happens, the first applicable handler is run.
1376 The car of a handler may be a list of condition names
1377 instead of a single condition name. Then it handles all of them.
1379 When a handler handles an error, control returns to the `condition-case'
1380 and it executes the handler's BODY...
1381 with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
1382 (If VAR is nil, the handler can't access that information.)
1383 Then the value of the last BODY form is returned from the `condition-case'
1386 See also the function `signal' for more info.
1387 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1391 register Lisp_Object bodyform
, handlers
;
1392 volatile Lisp_Object var
;
1395 bodyform
= Fcar (Fcdr (args
));
1396 handlers
= Fcdr (Fcdr (args
));
1398 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1401 /* Like Fcondition_case, but the args are separate
1402 rather than passed in a list. Used by Fbyte_code. */
1405 internal_lisp_condition_case (var
, bodyform
, handlers
)
1406 volatile Lisp_Object var
;
1407 Lisp_Object bodyform
, handlers
;
1415 for (val
= handlers
; CONSP (val
); val
= XCDR (val
))
1421 && (SYMBOLP (XCAR (tem
))
1422 || CONSP (XCAR (tem
))))))
1423 error ("Invalid condition handler", tem
);
1428 c
.backlist
= backtrace_list
;
1429 c
.handlerlist
= handlerlist
;
1430 c
.lisp_eval_depth
= lisp_eval_depth
;
1431 c
.pdlcount
= SPECPDL_INDEX ();
1432 c
.poll_suppress_count
= poll_suppress_count
;
1433 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1434 c
.gcpro
= gcprolist
;
1435 c
.byte_stack
= byte_stack_list
;
1436 if (_setjmp (c
.jmp
))
1439 specbind (h
.var
, c
.val
);
1440 val
= Fprogn (Fcdr (h
.chosen_clause
));
1442 /* Note that this just undoes the binding of h.var; whoever
1443 longjumped to us unwound the stack to c.pdlcount before
1445 unbind_to (c
.pdlcount
, Qnil
);
1452 h
.handler
= handlers
;
1453 h
.next
= handlerlist
;
1457 val
= Feval (bodyform
);
1459 handlerlist
= h
.next
;
1463 /* Call the function BFUN with no arguments, catching errors within it
1464 according to HANDLERS. If there is an error, call HFUN with
1465 one argument which is the data that describes the error:
1468 HANDLERS can be a list of conditions to catch.
1469 If HANDLERS is Qt, catch all errors.
1470 If HANDLERS is Qerror, catch all errors
1471 but allow the debugger to run if that is enabled. */
1474 internal_condition_case (bfun
, handlers
, hfun
)
1475 Lisp_Object (*bfun
) ();
1476 Lisp_Object handlers
;
1477 Lisp_Object (*hfun
) ();
1483 /* Since Fsignal will close off all calls to x_catch_errors,
1484 we will get the wrong results if some are not closed now. */
1486 if (x_catching_errors ())
1492 c
.backlist
= backtrace_list
;
1493 c
.handlerlist
= handlerlist
;
1494 c
.lisp_eval_depth
= lisp_eval_depth
;
1495 c
.pdlcount
= SPECPDL_INDEX ();
1496 c
.poll_suppress_count
= poll_suppress_count
;
1497 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1498 c
.gcpro
= gcprolist
;
1499 c
.byte_stack
= byte_stack_list
;
1500 if (_setjmp (c
.jmp
))
1502 return (*hfun
) (c
.val
);
1506 h
.handler
= handlers
;
1508 h
.next
= handlerlist
;
1514 handlerlist
= h
.next
;
1518 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1521 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1522 Lisp_Object (*bfun
) ();
1524 Lisp_Object handlers
;
1525 Lisp_Object (*hfun
) ();
1531 /* Since Fsignal will close off all calls to x_catch_errors,
1532 we will get the wrong results if some are not closed now. */
1534 if (x_catching_errors ())
1540 c
.backlist
= backtrace_list
;
1541 c
.handlerlist
= handlerlist
;
1542 c
.lisp_eval_depth
= lisp_eval_depth
;
1543 c
.pdlcount
= SPECPDL_INDEX ();
1544 c
.poll_suppress_count
= poll_suppress_count
;
1545 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1546 c
.gcpro
= gcprolist
;
1547 c
.byte_stack
= byte_stack_list
;
1548 if (_setjmp (c
.jmp
))
1550 return (*hfun
) (c
.val
);
1554 h
.handler
= handlers
;
1556 h
.next
= handlerlist
;
1560 val
= (*bfun
) (arg
);
1562 handlerlist
= h
.next
;
1567 /* Like internal_condition_case but call BFUN with NARGS as first,
1568 and ARGS as second argument. */
1571 internal_condition_case_2 (bfun
, nargs
, args
, handlers
, hfun
)
1572 Lisp_Object (*bfun
) ();
1575 Lisp_Object handlers
;
1576 Lisp_Object (*hfun
) ();
1582 /* Since Fsignal will close off all calls to x_catch_errors,
1583 we will get the wrong results if some are not closed now. */
1585 if (x_catching_errors ())
1591 c
.backlist
= backtrace_list
;
1592 c
.handlerlist
= handlerlist
;
1593 c
.lisp_eval_depth
= lisp_eval_depth
;
1594 c
.pdlcount
= SPECPDL_INDEX ();
1595 c
.poll_suppress_count
= poll_suppress_count
;
1596 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1597 c
.gcpro
= gcprolist
;
1598 c
.byte_stack
= byte_stack_list
;
1599 if (_setjmp (c
.jmp
))
1601 return (*hfun
) (c
.val
);
1605 h
.handler
= handlers
;
1607 h
.next
= handlerlist
;
1611 val
= (*bfun
) (nargs
, args
);
1613 handlerlist
= h
.next
;
1618 static Lisp_Object find_handler_clause
P_ ((Lisp_Object
, Lisp_Object
,
1619 Lisp_Object
, Lisp_Object
));
1621 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1622 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1623 This function does not return.
1625 An error symbol is a symbol with an `error-conditions' property
1626 that is a list of condition names.
1627 A handler for any of those names will get to handle this signal.
1628 The symbol `error' should normally be one of them.
1630 DATA should be a list. Its elements are printed as part of the error message.
1631 See Info anchor `(elisp)Definition of signal' for some details on how this
1632 error message is constructed.
1633 If the signal is handled, DATA is made available to the handler.
1634 See also the function `condition-case'. */)
1635 (error_symbol
, data
)
1636 Lisp_Object error_symbol
, data
;
1638 /* When memory is full, ERROR-SYMBOL is nil,
1639 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1640 That is a special case--don't do this in other situations. */
1641 register struct handler
*allhandlers
= handlerlist
;
1642 Lisp_Object conditions
;
1643 extern int gc_in_progress
;
1644 extern int waiting_for_input
;
1646 Lisp_Object real_error_symbol
;
1647 struct backtrace
*bp
;
1649 immediate_quit
= handling_signal
= 0;
1651 if (gc_in_progress
|| waiting_for_input
)
1654 if (NILP (error_symbol
))
1655 real_error_symbol
= Fcar (data
);
1657 real_error_symbol
= error_symbol
;
1659 #if 0 /* rms: I don't know why this was here,
1660 but it is surely wrong for an error that is handled. */
1661 #ifdef HAVE_WINDOW_SYSTEM
1662 if (display_hourglass_p
)
1663 cancel_hourglass ();
1667 /* This hook is used by edebug. */
1668 if (! NILP (Vsignal_hook_function
)
1669 && ! NILP (error_symbol
))
1671 /* Edebug takes care of restoring these variables when it exits. */
1672 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1673 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1675 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1676 max_specpdl_size
= SPECPDL_INDEX () + 40;
1678 call2 (Vsignal_hook_function
, error_symbol
, data
);
1681 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1683 /* Remember from where signal was called. Skip over the frame for
1684 `signal' itself. If a frame for `error' follows, skip that,
1685 too. Don't do this when ERROR_SYMBOL is nil, because that
1686 is a memory-full error. */
1687 Vsignaling_function
= Qnil
;
1688 if (backtrace_list
&& !NILP (error_symbol
))
1690 bp
= backtrace_list
->next
;
1691 if (bp
&& bp
->function
&& EQ (*bp
->function
, Qerror
))
1693 if (bp
&& bp
->function
)
1694 Vsignaling_function
= *bp
->function
;
1697 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1699 register Lisp_Object clause
;
1701 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1702 error_symbol
, data
);
1704 if (EQ (clause
, Qlambda
))
1706 /* We can't return values to code which signaled an error, but we
1707 can continue code which has signaled a quit. */
1708 if (EQ (real_error_symbol
, Qquit
))
1711 error ("Cannot return from the debugger in an error");
1716 Lisp_Object unwind_data
;
1717 struct handler
*h
= handlerlist
;
1719 handlerlist
= allhandlers
;
1721 if (NILP (error_symbol
))
1724 unwind_data
= Fcons (error_symbol
, data
);
1725 h
->chosen_clause
= clause
;
1726 unwind_to_catch (h
->tag
, unwind_data
);
1730 handlerlist
= allhandlers
;
1731 /* If no handler is present now, try to run the debugger,
1732 and if that fails, throw to top level. */
1733 find_handler_clause (Qerror
, conditions
, error_symbol
, data
);
1735 Fthrow (Qtop_level
, Qt
);
1737 if (! NILP (error_symbol
))
1738 data
= Fcons (error_symbol
, data
);
1740 string
= Ferror_message_string (data
);
1741 fatal ("%s", SDATA (string
), 0);
1744 /* Internal version of Fsignal that never returns.
1745 Used for anything but Qquit (which can return from Fsignal). */
1748 xsignal (error_symbol
, data
)
1749 Lisp_Object error_symbol
, data
;
1751 Fsignal (error_symbol
, data
);
1755 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1758 xsignal0 (error_symbol
)
1759 Lisp_Object error_symbol
;
1761 xsignal (error_symbol
, Qnil
);
1765 xsignal1 (error_symbol
, arg
)
1766 Lisp_Object error_symbol
, arg
;
1768 xsignal (error_symbol
, list1 (arg
));
1772 xsignal2 (error_symbol
, arg1
, arg2
)
1773 Lisp_Object error_symbol
, arg1
, arg2
;
1775 xsignal (error_symbol
, list2 (arg1
, arg2
));
1779 xsignal3 (error_symbol
, arg1
, arg2
, arg3
)
1780 Lisp_Object error_symbol
, arg1
, arg2
, arg3
;
1782 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1785 /* Signal `error' with message S, and additional arg ARG.
1786 If ARG is not a genuine list, make it a one-element list. */
1789 signal_error (s
, arg
)
1793 Lisp_Object tortoise
, hare
;
1795 hare
= tortoise
= arg
;
1796 while (CONSP (hare
))
1803 tortoise
= XCDR (tortoise
);
1805 if (EQ (hare
, tortoise
))
1810 arg
= Fcons (arg
, Qnil
); /* Make it a list. */
1812 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1816 /* Return nonzero if LIST is a non-nil atom or
1817 a list containing one of CONDITIONS. */
1820 wants_debugger (list
, conditions
)
1821 Lisp_Object list
, conditions
;
1828 while (CONSP (conditions
))
1830 Lisp_Object
this, tail
;
1831 this = XCAR (conditions
);
1832 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1833 if (EQ (XCAR (tail
), this))
1835 conditions
= XCDR (conditions
);
1840 /* Return 1 if an error with condition-symbols CONDITIONS,
1841 and described by SIGNAL-DATA, should skip the debugger
1842 according to debugger-ignored-errors. */
1845 skip_debugger (conditions
, data
)
1846 Lisp_Object conditions
, data
;
1849 int first_string
= 1;
1850 Lisp_Object error_message
;
1852 error_message
= Qnil
;
1853 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1855 if (STRINGP (XCAR (tail
)))
1859 error_message
= Ferror_message_string (data
);
1863 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1868 Lisp_Object contail
;
1870 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1871 if (EQ (XCAR (tail
), XCAR (contail
)))
1879 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1880 SIG and DATA describe the signal, as in find_handler_clause. */
1883 maybe_call_debugger (conditions
, sig
, data
)
1884 Lisp_Object conditions
, sig
, data
;
1886 Lisp_Object combined_data
;
1888 combined_data
= Fcons (sig
, data
);
1891 /* Don't try to run the debugger with interrupts blocked.
1892 The editing loop would return anyway. */
1894 /* Does user want to enter debugger for this kind of error? */
1897 : wants_debugger (Vdebug_on_error
, conditions
))
1898 && ! skip_debugger (conditions
, combined_data
)
1899 /* rms: what's this for? */
1900 && when_entered_debugger
< num_nonmacro_input_events
)
1902 call_debugger (Fcons (Qerror
, Fcons (combined_data
, Qnil
)));
1909 /* Value of Qlambda means we have called debugger and user has continued.
1910 There are two ways to pass SIG and DATA:
1911 = SIG is the error symbol, and DATA is the rest of the data.
1912 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1913 This is for memory-full errors only.
1915 We need to increase max_specpdl_size temporarily around
1916 anything we do that can push on the specpdl, so as not to get
1917 a second error here in case we're handling specpdl overflow. */
1920 find_handler_clause (handlers
, conditions
, sig
, data
)
1921 Lisp_Object handlers
, conditions
, sig
, data
;
1923 register Lisp_Object h
;
1924 register Lisp_Object tem
;
1925 int debugger_called
= 0;
1926 int debugger_considered
= 0;
1928 /* t is used by handlers for all conditions, set up by C code. */
1929 if (EQ (handlers
, Qt
))
1932 /* Don't run the debugger for a memory-full error.
1933 (There is no room in memory to do that!) */
1935 debugger_considered
= 1;
1937 /* error is used similarly, but means print an error message
1938 and run the debugger if that is enabled. */
1939 if (EQ (handlers
, Qerror
)
1940 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1941 there is a handler. */
1943 if (!NILP (sig
) && wants_debugger (Vstack_trace_on_error
, conditions
))
1945 max_lisp_eval_depth
+= 15;
1950 internal_with_output_to_temp_buffer
1952 (Lisp_Object (*) (Lisp_Object
)) Fbacktrace
,
1955 max_lisp_eval_depth
-= 15;
1958 if (!debugger_considered
)
1960 debugger_considered
= 1;
1961 debugger_called
= maybe_call_debugger (conditions
, sig
, data
);
1964 /* If there is no handler, return saying whether we ran the debugger. */
1965 if (EQ (handlers
, Qerror
))
1967 if (debugger_called
)
1973 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1975 Lisp_Object handler
, condit
;
1978 if (!CONSP (handler
))
1980 condit
= Fcar (handler
);
1981 /* Handle a single condition name in handler HANDLER. */
1982 if (SYMBOLP (condit
))
1984 tem
= Fmemq (Fcar (handler
), conditions
);
1988 /* Handle a list of condition names in handler HANDLER. */
1989 else if (CONSP (condit
))
1992 for (tail
= condit
; CONSP (tail
); tail
= XCDR (tail
))
1994 tem
= Fmemq (Fcar (tail
), conditions
);
1997 /* This handler is going to apply.
1998 Does it allow the debugger to run first? */
1999 if (! debugger_considered
&& !NILP (Fmemq (Qdebug
, condit
)))
2000 maybe_call_debugger (conditions
, sig
, data
);
2010 /* dump an error message; called like printf */
2014 error (m
, a1
, a2
, a3
)
2034 int used
= doprnt (buffer
, size
, m
, m
+ mlen
, 3, args
);
2039 buffer
= (char *) xrealloc (buffer
, size
);
2042 buffer
= (char *) xmalloc (size
);
2047 string
= build_string (buffer
);
2051 xsignal1 (Qerror
, string
);
2054 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
2055 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
2056 This means it contains a description for how to read arguments to give it.
2057 The value is nil for an invalid function or a symbol with no function
2060 Interactively callable functions include strings and vectors (treated
2061 as keyboard macros), lambda-expressions that contain a top-level call
2062 to `interactive', autoload definitions made by `autoload' with non-nil
2063 fourth argument, and some of the built-in functions of Lisp.
2065 Also, a symbol satisfies `commandp' if its function definition does so.
2067 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
2068 then strings and vectors are not accepted. */)
2069 (function
, for_call_interactively
)
2070 Lisp_Object function
, for_call_interactively
;
2072 register Lisp_Object fun
;
2073 register Lisp_Object funcar
;
2074 Lisp_Object if_prop
= Qnil
;
2078 fun
= indirect_function (fun
); /* Check cycles. */
2079 if (NILP (fun
) || EQ (fun
, Qunbound
))
2082 /* Check an `interactive-form' property if present, analogous to the
2083 function-documentation property. */
2085 while (SYMBOLP (fun
))
2087 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
2090 fun
= Fsymbol_function (fun
);
2093 /* Emacs primitives are interactive if their DEFUN specifies an
2094 interactive spec. */
2096 return XSUBR (fun
)->intspec
? Qt
: if_prop
;
2098 /* Bytecode objects are interactive if they are long enough to
2099 have an element whose index is COMPILED_INTERACTIVE, which is
2100 where the interactive spec is stored. */
2101 else if (COMPILEDP (fun
))
2102 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
2105 /* Strings and vectors are keyboard macros. */
2106 if (STRINGP (fun
) || VECTORP (fun
))
2107 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
2109 /* Lists may represent commands. */
2112 funcar
= XCAR (fun
);
2113 if (EQ (funcar
, Qlambda
))
2114 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
2115 if (EQ (funcar
, Qautoload
))
2116 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
2121 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
2122 doc
: /* Define FUNCTION to autoload from FILE.
2123 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
2124 Third arg DOCSTRING is documentation for the function.
2125 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
2126 Fifth arg TYPE indicates the type of the object:
2127 nil or omitted says FUNCTION is a function,
2128 `keymap' says FUNCTION is really a keymap, and
2129 `macro' or t says FUNCTION is really a macro.
2130 Third through fifth args give info about the real definition.
2131 They default to nil.
2132 If FUNCTION is already defined other than as an autoload,
2133 this does nothing and returns nil. */)
2134 (function
, file
, docstring
, interactive
, type
)
2135 Lisp_Object function
, file
, docstring
, interactive
, type
;
2137 Lisp_Object args
[4];
2139 CHECK_SYMBOL (function
);
2140 CHECK_STRING (file
);
2142 /* If function is defined and not as an autoload, don't override */
2143 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
2144 && !(CONSP (XSYMBOL (function
)->function
)
2145 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
2148 if (NILP (Vpurify_flag
))
2149 /* Only add entries after dumping, because the ones before are
2150 not useful and else we get loads of them from the loaddefs.el. */
2151 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
2153 /* We don't want the docstring in purespace (instead,
2154 Snarf-documentation should (hopefully) overwrite it). */
2155 docstring
= make_number (0);
2156 return Ffset (function
,
2157 Fpurecopy (list5 (Qautoload
, file
, docstring
,
2158 interactive
, type
)));
2162 un_autoload (oldqueue
)
2163 Lisp_Object oldqueue
;
2165 register Lisp_Object queue
, first
, second
;
2167 /* Queue to unwind is current value of Vautoload_queue.
2168 oldqueue is the shadowed value to leave in Vautoload_queue. */
2169 queue
= Vautoload_queue
;
2170 Vautoload_queue
= oldqueue
;
2171 while (CONSP (queue
))
2173 first
= XCAR (queue
);
2174 second
= Fcdr (first
);
2175 first
= Fcar (first
);
2176 if (EQ (first
, make_number (0)))
2179 Ffset (first
, second
);
2180 queue
= XCDR (queue
);
2185 /* Load an autoloaded function.
2186 FUNNAME is the symbol which is the function's name.
2187 FUNDEF is the autoload definition (a list). */
2190 do_autoload (fundef
, funname
)
2191 Lisp_Object fundef
, funname
;
2193 int count
= SPECPDL_INDEX ();
2195 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2197 /* This is to make sure that loadup.el gives a clear picture
2198 of what files are preloaded and when. */
2199 if (! NILP (Vpurify_flag
))
2200 error ("Attempt to autoload %s while preparing to dump",
2201 SDATA (SYMBOL_NAME (funname
)));
2204 CHECK_SYMBOL (funname
);
2205 GCPRO3 (fun
, funname
, fundef
);
2207 /* Preserve the match data. */
2208 record_unwind_save_match_data ();
2210 /* If autoloading gets an error (which includes the error of failing
2211 to define the function being called), we use Vautoload_queue
2212 to undo function definitions and `provide' calls made by
2213 the function. We do this in the specific case of autoloading
2214 because autoloading is not an explicit request "load this file",
2215 but rather a request to "call this function".
2217 The value saved here is to be restored into Vautoload_queue. */
2218 record_unwind_protect (un_autoload
, Vautoload_queue
);
2219 Vautoload_queue
= Qt
;
2220 Fload (Fcar (Fcdr (fundef
)), Qnil
, Qt
, Qnil
, Qt
);
2222 /* Once loading finishes, don't undo it. */
2223 Vautoload_queue
= Qt
;
2224 unbind_to (count
, Qnil
);
2226 fun
= Findirect_function (fun
, Qnil
);
2228 if (!NILP (Fequal (fun
, fundef
)))
2229 error ("Autoloading failed to define function %s",
2230 SDATA (SYMBOL_NAME (funname
)));
2235 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
2236 doc
: /* Evaluate FORM and return its value. */)
2240 Lisp_Object fun
, val
, original_fun
, original_args
;
2242 struct backtrace backtrace
;
2243 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2245 if (handling_signal
)
2249 return Fsymbol_value (form
);
2254 if ((consing_since_gc
> gc_cons_threshold
2255 && consing_since_gc
> gc_relative_threshold
)
2257 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2260 Fgarbage_collect ();
2264 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2266 if (max_lisp_eval_depth
< 100)
2267 max_lisp_eval_depth
= 100;
2268 if (lisp_eval_depth
> max_lisp_eval_depth
)
2269 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2272 original_fun
= Fcar (form
);
2273 original_args
= Fcdr (form
);
2275 backtrace
.next
= backtrace_list
;
2276 backtrace_list
= &backtrace
;
2277 backtrace
.function
= &original_fun
; /* This also protects them from gc */
2278 backtrace
.args
= &original_args
;
2279 backtrace
.nargs
= UNEVALLED
;
2280 backtrace
.evalargs
= 1;
2281 backtrace
.debug_on_exit
= 0;
2283 if (debug_on_next_call
)
2284 do_debug_on_call (Qt
);
2286 /* At this point, only original_fun and original_args
2287 have values that will be used below */
2290 /* Optimize for no indirection. */
2292 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2293 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2294 fun
= indirect_function (fun
);
2298 Lisp_Object numargs
;
2299 Lisp_Object argvals
[8];
2300 Lisp_Object args_left
;
2301 register int i
, maxargs
;
2303 args_left
= original_args
;
2304 numargs
= Flength (args_left
);
2308 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
2309 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2310 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2312 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2314 backtrace
.evalargs
= 0;
2315 val
= (*XSUBR (fun
)->function
) (args_left
);
2319 if (XSUBR (fun
)->max_args
== MANY
)
2321 /* Pass a vector of evaluated arguments */
2323 register int argnum
= 0;
2325 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2327 GCPRO3 (args_left
, fun
, fun
);
2331 while (!NILP (args_left
))
2333 vals
[argnum
++] = Feval (Fcar (args_left
));
2334 args_left
= Fcdr (args_left
);
2335 gcpro3
.nvars
= argnum
;
2338 backtrace
.args
= vals
;
2339 backtrace
.nargs
= XINT (numargs
);
2341 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
2346 GCPRO3 (args_left
, fun
, fun
);
2347 gcpro3
.var
= argvals
;
2350 maxargs
= XSUBR (fun
)->max_args
;
2351 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
2353 argvals
[i
] = Feval (Fcar (args_left
));
2359 backtrace
.args
= argvals
;
2360 backtrace
.nargs
= XINT (numargs
);
2365 val
= (*XSUBR (fun
)->function
) ();
2368 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
2371 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
2374 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2378 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2379 argvals
[2], argvals
[3]);
2382 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2383 argvals
[3], argvals
[4]);
2386 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2387 argvals
[3], argvals
[4], argvals
[5]);
2390 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2391 argvals
[3], argvals
[4], argvals
[5],
2396 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2397 argvals
[3], argvals
[4], argvals
[5],
2398 argvals
[6], argvals
[7]);
2402 /* Someone has created a subr that takes more arguments than
2403 is supported by this code. We need to either rewrite the
2404 subr to use a different argument protocol, or add more
2405 cases to this switch. */
2409 if (COMPILEDP (fun
))
2410 val
= apply_lambda (fun
, original_args
, 1);
2413 if (EQ (fun
, Qunbound
))
2414 xsignal1 (Qvoid_function
, original_fun
);
2416 xsignal1 (Qinvalid_function
, original_fun
);
2417 funcar
= XCAR (fun
);
2418 if (!SYMBOLP (funcar
))
2419 xsignal1 (Qinvalid_function
, original_fun
);
2420 if (EQ (funcar
, Qautoload
))
2422 do_autoload (fun
, original_fun
);
2425 if (EQ (funcar
, Qmacro
))
2426 val
= Feval (apply1 (Fcdr (fun
), original_args
));
2427 else if (EQ (funcar
, Qlambda
))
2428 val
= apply_lambda (fun
, original_args
, 1);
2430 xsignal1 (Qinvalid_function
, original_fun
);
2436 if (backtrace
.debug_on_exit
)
2437 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2438 backtrace_list
= backtrace
.next
;
2443 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
2444 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2445 Then return the value FUNCTION returns.
2446 Thus, (apply '+ 1 2 '(3 4)) returns 10.
2447 usage: (apply FUNCTION &rest ARGUMENTS) */)
2452 register int i
, numargs
;
2453 register Lisp_Object spread_arg
;
2454 register Lisp_Object
*funcall_args
;
2456 struct gcpro gcpro1
;
2460 spread_arg
= args
[nargs
- 1];
2461 CHECK_LIST (spread_arg
);
2463 numargs
= XINT (Flength (spread_arg
));
2466 return Ffuncall (nargs
- 1, args
);
2467 else if (numargs
== 1)
2469 args
[nargs
- 1] = XCAR (spread_arg
);
2470 return Ffuncall (nargs
, args
);
2473 numargs
+= nargs
- 2;
2475 /* Optimize for no indirection. */
2476 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2477 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2478 fun
= indirect_function (fun
);
2479 if (EQ (fun
, Qunbound
))
2481 /* Let funcall get the error */
2488 if (numargs
< XSUBR (fun
)->min_args
2489 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2490 goto funcall
; /* Let funcall get the error */
2491 else if (XSUBR (fun
)->max_args
> numargs
)
2493 /* Avoid making funcall cons up a yet another new vector of arguments
2494 by explicitly supplying nil's for optional values */
2495 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
2496 * sizeof (Lisp_Object
));
2497 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2498 funcall_args
[++i
] = Qnil
;
2499 GCPRO1 (*funcall_args
);
2500 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2504 /* We add 1 to numargs because funcall_args includes the
2505 function itself as well as its arguments. */
2508 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
2509 * sizeof (Lisp_Object
));
2510 GCPRO1 (*funcall_args
);
2511 gcpro1
.nvars
= 1 + numargs
;
2514 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
2515 /* Spread the last arg we got. Its first element goes in
2516 the slot that it used to occupy, hence this value of I. */
2518 while (!NILP (spread_arg
))
2520 funcall_args
[i
++] = XCAR (spread_arg
);
2521 spread_arg
= XCDR (spread_arg
);
2524 /* By convention, the caller needs to gcpro Ffuncall's args. */
2525 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
2528 /* Run hook variables in various ways. */
2530 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
2531 static Lisp_Object run_hook_with_args
P_ ((int, Lisp_Object
*,
2532 enum run_hooks_condition
));
2534 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2535 doc
: /* Run each hook in HOOKS.
2536 Each argument should be a symbol, a hook variable.
2537 These symbols are processed in the order specified.
2538 If a hook symbol has a non-nil value, that value may be a function
2539 or a list of functions to be called to run the hook.
2540 If the value is a function, it is called with no arguments.
2541 If it is a list, the elements are called, in order, with no arguments.
2543 Major modes should not use this function directly to run their mode
2544 hook; they should use `run-mode-hooks' instead.
2546 Do not use `make-local-variable' to make a hook variable buffer-local.
2547 Instead, use `add-hook' and specify t for the LOCAL argument.
2548 usage: (run-hooks &rest HOOKS) */)
2553 Lisp_Object hook
[1];
2556 for (i
= 0; i
< nargs
; i
++)
2559 run_hook_with_args (1, hook
, to_completion
);
2565 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2566 Srun_hook_with_args
, 1, MANY
, 0,
2567 doc
: /* Run HOOK with the specified arguments ARGS.
2568 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2569 value, that value may be a function or a list of functions to be
2570 called to run the hook. If the value is a function, it is called with
2571 the given arguments and its return value is returned. If it is a list
2572 of functions, those functions are called, in order,
2573 with the given arguments ARGS.
2574 It is best not to depend on the value returned by `run-hook-with-args',
2577 Do not use `make-local-variable' to make a hook variable buffer-local.
2578 Instead, use `add-hook' and specify t for the LOCAL argument.
2579 usage: (run-hook-with-args HOOK &rest ARGS) */)
2584 return run_hook_with_args (nargs
, args
, to_completion
);
2587 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2588 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2589 doc
: /* Run HOOK with the specified arguments ARGS.
2590 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2591 value, that value may be a function or a list of functions to be
2592 called to run the hook. If the value is a function, it is called with
2593 the given arguments and its return value is returned.
2594 If it is a list of functions, those functions are called, in order,
2595 with the given arguments ARGS, until one of them
2596 returns a non-nil value. Then we return that value.
2597 However, if they all return nil, we return nil.
2599 Do not use `make-local-variable' to make a hook variable buffer-local.
2600 Instead, use `add-hook' and specify t for the LOCAL argument.
2601 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2606 return run_hook_with_args (nargs
, args
, until_success
);
2609 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2610 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2611 doc
: /* Run HOOK with the specified arguments ARGS.
2612 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2613 value, that value may be a function or a list of functions to be
2614 called to run the hook. If the value is a function, it is called with
2615 the given arguments and its return value is returned.
2616 If it is a list of functions, those functions are called, in order,
2617 with the given arguments ARGS, until one of them returns nil.
2618 Then we return nil. However, if they all return non-nil, we return non-nil.
2620 Do not use `make-local-variable' to make a hook variable buffer-local.
2621 Instead, use `add-hook' and specify t for the LOCAL argument.
2622 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2627 return run_hook_with_args (nargs
, args
, until_failure
);
2630 /* ARGS[0] should be a hook symbol.
2631 Call each of the functions in the hook value, passing each of them
2632 as arguments all the rest of ARGS (all NARGS - 1 elements).
2633 COND specifies a condition to test after each call
2634 to decide whether to stop.
2635 The caller (or its caller, etc) must gcpro all of ARGS,
2636 except that it isn't necessary to gcpro ARGS[0]. */
2639 run_hook_with_args (nargs
, args
, cond
)
2642 enum run_hooks_condition cond
;
2644 Lisp_Object sym
, val
, ret
;
2645 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2647 /* If we are dying or still initializing,
2648 don't do anything--it would probably crash if we tried. */
2649 if (NILP (Vrun_hooks
))
2653 val
= find_symbol_value (sym
);
2654 ret
= (cond
== until_failure
? Qt
: Qnil
);
2656 if (EQ (val
, Qunbound
) || NILP (val
))
2658 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2661 return Ffuncall (nargs
, args
);
2665 Lisp_Object globals
= Qnil
;
2666 GCPRO3 (sym
, val
, globals
);
2669 CONSP (val
) && ((cond
== to_completion
)
2670 || (cond
== until_success
? NILP (ret
)
2674 if (EQ (XCAR (val
), Qt
))
2676 /* t indicates this hook has a local binding;
2677 it means to run the global binding too. */
2678 globals
= Fdefault_value (sym
);
2679 if (NILP (globals
)) continue;
2681 if (!CONSP (globals
) || EQ (XCAR (globals
), Qlambda
))
2684 ret
= Ffuncall (nargs
, args
);
2689 CONSP (globals
) && ((cond
== to_completion
)
2690 || (cond
== until_success
? NILP (ret
)
2692 globals
= XCDR (globals
))
2694 args
[0] = XCAR (globals
);
2695 /* In a global value, t should not occur. If it does, we
2696 must ignore it to avoid an endless loop. */
2697 if (!EQ (args
[0], Qt
))
2698 ret
= Ffuncall (nargs
, args
);
2704 args
[0] = XCAR (val
);
2705 ret
= Ffuncall (nargs
, args
);
2714 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2715 present value of that symbol.
2716 Call each element of FUNLIST,
2717 passing each of them the rest of ARGS.
2718 The caller (or its caller, etc) must gcpro all of ARGS,
2719 except that it isn't necessary to gcpro ARGS[0]. */
2722 run_hook_list_with_args (funlist
, nargs
, args
)
2723 Lisp_Object funlist
;
2729 Lisp_Object globals
;
2730 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2734 GCPRO3 (sym
, val
, globals
);
2736 for (val
= funlist
; CONSP (val
); val
= XCDR (val
))
2738 if (EQ (XCAR (val
), Qt
))
2740 /* t indicates this hook has a local binding;
2741 it means to run the global binding too. */
2743 for (globals
= Fdefault_value (sym
);
2745 globals
= XCDR (globals
))
2747 args
[0] = XCAR (globals
);
2748 /* In a global value, t should not occur. If it does, we
2749 must ignore it to avoid an endless loop. */
2750 if (!EQ (args
[0], Qt
))
2751 Ffuncall (nargs
, args
);
2756 args
[0] = XCAR (val
);
2757 Ffuncall (nargs
, args
);
2764 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2767 run_hook_with_args_2 (hook
, arg1
, arg2
)
2768 Lisp_Object hook
, arg1
, arg2
;
2770 Lisp_Object temp
[3];
2775 Frun_hook_with_args (3, temp
);
2778 /* Apply fn to arg */
2781 Lisp_Object fn
, arg
;
2783 struct gcpro gcpro1
;
2787 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2791 Lisp_Object args
[2];
2795 RETURN_UNGCPRO (Fapply (2, args
));
2797 #else /* not NO_ARG_ARRAY */
2798 RETURN_UNGCPRO (Fapply (2, &fn
));
2799 #endif /* not NO_ARG_ARRAY */
2802 /* Call function fn on no arguments */
2807 struct gcpro gcpro1
;
2810 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2813 /* Call function fn with 1 argument arg1 */
2817 Lisp_Object fn
, arg1
;
2819 struct gcpro gcpro1
;
2821 Lisp_Object args
[2];
2827 RETURN_UNGCPRO (Ffuncall (2, args
));
2828 #else /* not NO_ARG_ARRAY */
2831 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2832 #endif /* not NO_ARG_ARRAY */
2835 /* Call function fn with 2 arguments arg1, arg2 */
2838 call2 (fn
, arg1
, arg2
)
2839 Lisp_Object fn
, arg1
, arg2
;
2841 struct gcpro gcpro1
;
2843 Lisp_Object args
[3];
2849 RETURN_UNGCPRO (Ffuncall (3, args
));
2850 #else /* not NO_ARG_ARRAY */
2853 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2854 #endif /* not NO_ARG_ARRAY */
2857 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2860 call3 (fn
, arg1
, arg2
, arg3
)
2861 Lisp_Object fn
, arg1
, arg2
, arg3
;
2863 struct gcpro gcpro1
;
2865 Lisp_Object args
[4];
2872 RETURN_UNGCPRO (Ffuncall (4, args
));
2873 #else /* not NO_ARG_ARRAY */
2876 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2877 #endif /* not NO_ARG_ARRAY */
2880 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2883 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2884 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2886 struct gcpro gcpro1
;
2888 Lisp_Object args
[5];
2896 RETURN_UNGCPRO (Ffuncall (5, args
));
2897 #else /* not NO_ARG_ARRAY */
2900 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2901 #endif /* not NO_ARG_ARRAY */
2904 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2907 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2908 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2910 struct gcpro gcpro1
;
2912 Lisp_Object args
[6];
2921 RETURN_UNGCPRO (Ffuncall (6, args
));
2922 #else /* not NO_ARG_ARRAY */
2925 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2926 #endif /* not NO_ARG_ARRAY */
2929 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2932 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2933 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2935 struct gcpro gcpro1
;
2937 Lisp_Object args
[7];
2947 RETURN_UNGCPRO (Ffuncall (7, args
));
2948 #else /* not NO_ARG_ARRAY */
2951 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2952 #endif /* not NO_ARG_ARRAY */
2955 /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7 */
2958 call7 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
)
2959 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
;
2961 struct gcpro gcpro1
;
2963 Lisp_Object args
[8];
2974 RETURN_UNGCPRO (Ffuncall (8, args
));
2975 #else /* not NO_ARG_ARRAY */
2978 RETURN_UNGCPRO (Ffuncall (8, &fn
));
2979 #endif /* not NO_ARG_ARRAY */
2982 /* The caller should GCPRO all the elements of ARGS. */
2984 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2985 doc
: /* Call first argument as a function, passing remaining arguments to it.
2986 Return the value that function returns.
2987 Thus, (funcall 'cons 'x 'y) returns (x . y).
2988 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2993 Lisp_Object fun
, original_fun
;
2995 int numargs
= nargs
- 1;
2996 Lisp_Object lisp_numargs
;
2998 struct backtrace backtrace
;
2999 register Lisp_Object
*internal_args
;
3003 if ((consing_since_gc
> gc_cons_threshold
3004 && consing_since_gc
> gc_relative_threshold
)
3006 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
3007 Fgarbage_collect ();
3009 if (++lisp_eval_depth
> max_lisp_eval_depth
)
3011 if (max_lisp_eval_depth
< 100)
3012 max_lisp_eval_depth
= 100;
3013 if (lisp_eval_depth
> max_lisp_eval_depth
)
3014 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
3017 backtrace
.next
= backtrace_list
;
3018 backtrace_list
= &backtrace
;
3019 backtrace
.function
= &args
[0];
3020 backtrace
.args
= &args
[1];
3021 backtrace
.nargs
= nargs
- 1;
3022 backtrace
.evalargs
= 0;
3023 backtrace
.debug_on_exit
= 0;
3025 if (debug_on_next_call
)
3026 do_debug_on_call (Qlambda
);
3030 original_fun
= args
[0];
3034 /* Optimize for no indirection. */
3036 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
3037 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
3038 fun
= indirect_function (fun
);
3042 if (numargs
< XSUBR (fun
)->min_args
3043 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
3045 XSETFASTINT (lisp_numargs
, numargs
);
3046 xsignal2 (Qwrong_number_of_arguments
, original_fun
, lisp_numargs
);
3049 if (XSUBR (fun
)->max_args
== UNEVALLED
)
3050 xsignal1 (Qinvalid_function
, original_fun
);
3052 if (XSUBR (fun
)->max_args
== MANY
)
3054 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
3058 if (XSUBR (fun
)->max_args
> numargs
)
3060 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
3061 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
3062 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
3063 internal_args
[i
] = Qnil
;
3066 internal_args
= args
+ 1;
3067 switch (XSUBR (fun
)->max_args
)
3070 val
= (*XSUBR (fun
)->function
) ();
3073 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
3076 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1]);
3079 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3083 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3084 internal_args
[2], internal_args
[3]);
3087 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3088 internal_args
[2], internal_args
[3],
3092 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3093 internal_args
[2], internal_args
[3],
3094 internal_args
[4], internal_args
[5]);
3097 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3098 internal_args
[2], internal_args
[3],
3099 internal_args
[4], internal_args
[5],
3104 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
3105 internal_args
[2], internal_args
[3],
3106 internal_args
[4], internal_args
[5],
3107 internal_args
[6], internal_args
[7]);
3112 /* If a subr takes more than 8 arguments without using MANY
3113 or UNEVALLED, we need to extend this function to support it.
3114 Until this is done, there is no way to call the function. */
3118 if (COMPILEDP (fun
))
3119 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3122 if (EQ (fun
, Qunbound
))
3123 xsignal1 (Qvoid_function
, original_fun
);
3125 xsignal1 (Qinvalid_function
, original_fun
);
3126 funcar
= XCAR (fun
);
3127 if (!SYMBOLP (funcar
))
3128 xsignal1 (Qinvalid_function
, original_fun
);
3129 if (EQ (funcar
, Qlambda
))
3130 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3131 else if (EQ (funcar
, Qautoload
))
3133 do_autoload (fun
, original_fun
);
3138 xsignal1 (Qinvalid_function
, original_fun
);
3143 if (backtrace
.debug_on_exit
)
3144 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
3145 backtrace_list
= backtrace
.next
;
3150 apply_lambda (fun
, args
, eval_flag
)
3151 Lisp_Object fun
, args
;
3154 Lisp_Object args_left
;
3155 Lisp_Object numargs
;
3156 register Lisp_Object
*arg_vector
;
3157 struct gcpro gcpro1
, gcpro2
, gcpro3
;
3159 register Lisp_Object tem
;
3161 numargs
= Flength (args
);
3162 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
3165 GCPRO3 (*arg_vector
, args_left
, fun
);
3168 for (i
= 0; i
< XINT (numargs
);)
3170 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
3171 if (eval_flag
) tem
= Feval (tem
);
3172 arg_vector
[i
++] = tem
;
3180 backtrace_list
->args
= arg_vector
;
3181 backtrace_list
->nargs
= i
;
3183 backtrace_list
->evalargs
= 0;
3184 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
3186 /* Do the debug-on-exit now, while arg_vector still exists. */
3187 if (backtrace_list
->debug_on_exit
)
3188 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
3189 /* Don't do it again when we return to eval. */
3190 backtrace_list
->debug_on_exit
= 0;
3194 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
3195 and return the result of evaluation.
3196 FUN must be either a lambda-expression or a compiled-code object. */
3199 funcall_lambda (fun
, nargs
, arg_vector
)
3202 register Lisp_Object
*arg_vector
;
3204 Lisp_Object val
, syms_left
, next
;
3205 int count
= SPECPDL_INDEX ();
3206 int i
, optional
, rest
;
3210 syms_left
= XCDR (fun
);
3211 if (CONSP (syms_left
))
3212 syms_left
= XCAR (syms_left
);
3214 xsignal1 (Qinvalid_function
, fun
);
3216 else if (COMPILEDP (fun
))
3217 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3221 i
= optional
= rest
= 0;
3222 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3226 next
= XCAR (syms_left
);
3227 if (!SYMBOLP (next
))
3228 xsignal1 (Qinvalid_function
, fun
);
3230 if (EQ (next
, Qand_rest
))
3232 else if (EQ (next
, Qand_optional
))
3236 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
3240 specbind (next
, arg_vector
[i
++]);
3242 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3244 specbind (next
, Qnil
);
3247 if (!NILP (syms_left
))
3248 xsignal1 (Qinvalid_function
, fun
);
3250 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3253 val
= Fprogn (XCDR (XCDR (fun
)));
3256 /* If we have not actually read the bytecode string
3257 and constants vector yet, fetch them from the file. */
3258 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3259 Ffetch_bytecode (fun
);
3260 val
= Fbyte_code (AREF (fun
, COMPILED_BYTECODE
),
3261 AREF (fun
, COMPILED_CONSTANTS
),
3262 AREF (fun
, COMPILED_STACK_DEPTH
));
3265 return unbind_to (count
, val
);
3268 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3270 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3276 if (COMPILEDP (object
) && CONSP (AREF (object
, COMPILED_BYTECODE
)))
3278 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3281 tem
= AREF (object
, COMPILED_BYTECODE
);
3282 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3283 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3285 error ("Invalid byte code");
3287 ASET (object
, COMPILED_BYTECODE
, XCAR (tem
));
3288 ASET (object
, COMPILED_CONSTANTS
, XCDR (tem
));
3296 register int count
= SPECPDL_INDEX ();
3297 if (specpdl_size
>= max_specpdl_size
)
3299 if (max_specpdl_size
< 400)
3300 max_specpdl_size
= 400;
3301 if (specpdl_size
>= max_specpdl_size
)
3302 signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil
);
3305 if (specpdl_size
> max_specpdl_size
)
3306 specpdl_size
= max_specpdl_size
;
3307 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
3308 specpdl_ptr
= specpdl
+ count
;
3312 specbind (symbol
, value
)
3313 Lisp_Object symbol
, value
;
3315 struct Lisp_Symbol
*sym
;
3317 eassert (!handling_signal
);
3319 CHECK_SYMBOL (symbol
);
3320 sym
= XSYMBOL (symbol
);
3321 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3325 switch (sym
->redirect
)
3327 case SYMBOL_VARALIAS
:
3328 sym
= indirect_variable (sym
); XSETSYMBOL (symbol
, sym
); goto start
;
3329 case SYMBOL_PLAINVAL
:
3330 { /* The most common case is that of a non-constant symbol with a
3331 trivial value. Make that as fast as we can. */
3332 specpdl_ptr
->symbol
= symbol
;
3333 specpdl_ptr
->old_value
= SYMBOL_VAL (sym
);
3334 specpdl_ptr
->func
= NULL
;
3337 SET_SYMBOL_VAL (sym
, value
);
3339 set_internal (symbol
, value
, 0, 1);
3342 case SYMBOL_LOCALIZED
: case SYMBOL_FORWARDED
:
3344 Lisp_Object ovalue
= find_symbol_value (symbol
);
3345 specpdl_ptr
->func
= 0;
3346 specpdl_ptr
->old_value
= ovalue
;
3348 eassert (sym
->redirect
!= SYMBOL_LOCALIZED
3349 || (EQ (SYMBOL_BLV (sym
)->where
,
3350 SYMBOL_BLV (sym
)->frame_local
?
3351 Fselected_frame () : Fcurrent_buffer ())));
3353 if (sym
->redirect
== SYMBOL_LOCALIZED
3354 || BUFFER_OBJFWDP (SYMBOL_FWD (sym
)))
3356 Lisp_Object where
, cur_buf
= Fcurrent_buffer ();
3358 /* For a local variable, record both the symbol and which
3359 buffer's or frame's value we are saving. */
3360 if (!NILP (Flocal_variable_p (symbol
, Qnil
)))
3362 eassert (sym
->redirect
!= SYMBOL_LOCALIZED
3363 || (BLV_FOUND (SYMBOL_BLV (sym
))
3364 && EQ (cur_buf
, SYMBOL_BLV (sym
)->where
)));
3367 else if (sym
->redirect
== SYMBOL_LOCALIZED
3368 && BLV_FOUND (SYMBOL_BLV (sym
)))
3369 where
= SYMBOL_BLV (sym
)->where
;
3373 /* We're not using the `unused' slot in the specbinding
3374 structure because this would mean we have to do more
3375 work for simple variables. */
3376 /* FIXME: The third value `current_buffer' is only used in
3377 let_shadows_buffer_binding_p which is itself only used
3378 in set_internal for local_if_set. */
3379 specpdl_ptr
->symbol
= Fcons (symbol
, Fcons (where
, cur_buf
));
3381 /* If SYMBOL is a per-buffer variable which doesn't have a
3382 buffer-local value here, make the `let' change the global
3383 value by changing the value of SYMBOL in all buffers not
3384 having their own value. This is consistent with what
3385 happens with other buffer-local variables. */
3387 && sym
->redirect
== SYMBOL_FORWARDED
)
3389 eassert (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)));
3391 Fset_default (symbol
, value
);
3396 specpdl_ptr
->symbol
= symbol
;
3399 set_internal (symbol
, value
, 0, 1);
3407 record_unwind_protect (function
, arg
)
3408 Lisp_Object (*function
) P_ ((Lisp_Object
));
3411 eassert (!handling_signal
);
3413 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3415 specpdl_ptr
->func
= function
;
3416 specpdl_ptr
->symbol
= Qnil
;
3417 specpdl_ptr
->old_value
= arg
;
3422 unbind_to (count
, value
)
3426 Lisp_Object quitf
= Vquit_flag
;
3427 struct gcpro gcpro1
, gcpro2
;
3429 GCPRO2 (value
, quitf
);
3432 while (specpdl_ptr
!= specpdl
+ count
)
3434 /* Copy the binding, and decrement specpdl_ptr, before we do
3435 the work to unbind it. We decrement first
3436 so that an error in unbinding won't try to unbind
3437 the same entry again, and we copy the binding first
3438 in case more bindings are made during some of the code we run. */
3440 struct specbinding this_binding
;
3441 this_binding
= *--specpdl_ptr
;
3443 if (this_binding
.func
!= 0)
3444 (*this_binding
.func
) (this_binding
.old_value
);
3445 /* If the symbol is a list, it is really (SYMBOL WHERE
3446 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3447 frame. If WHERE is a buffer or frame, this indicates we
3448 bound a variable that had a buffer-local or frame-local
3449 binding. WHERE nil means that the variable had the default
3450 value when it was bound. CURRENT-BUFFER is the buffer that
3451 was current when the variable was bound. */
3452 else if (CONSP (this_binding
.symbol
))
3454 Lisp_Object symbol
, where
;
3456 symbol
= XCAR (this_binding
.symbol
);
3457 where
= XCAR (XCDR (this_binding
.symbol
));
3460 Fset_default (symbol
, this_binding
.old_value
);
3461 else if (BUFFERP (where
))
3462 if (!NILP (Flocal_variable_p (symbol
, where
)))
3463 set_internal (symbol
, this_binding
.old_value
, XBUFFER (where
), 1);
3464 /* else if (!NILP (Fbuffer_live_p (where)))
3465 error ("Unbinding local %s to global!", symbol); */
3469 set_internal (symbol
, this_binding
.old_value
, NULL
, 1);
3473 /* If variable has a trivial value (no forwarding), we can
3474 just set it. No need to check for constant symbols here,
3475 since that was already done by specbind. */
3476 if (XSYMBOL (this_binding
.symbol
)->redirect
== SYMBOL_PLAINVAL
)
3477 SET_SYMBOL_VAL (XSYMBOL (this_binding
.symbol
),
3478 this_binding
.old_value
);
3480 set_internal (this_binding
.symbol
, this_binding
.old_value
, 0, 1);
3484 if (NILP (Vquit_flag
) && !NILP (quitf
))
3491 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3492 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3493 The debugger is entered when that frame exits, if the flag is non-nil. */)
3495 Lisp_Object level
, flag
;
3497 register struct backtrace
*backlist
= backtrace_list
;
3500 CHECK_NUMBER (level
);
3502 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
3504 backlist
= backlist
->next
;
3508 backlist
->debug_on_exit
= !NILP (flag
);
3513 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3514 doc
: /* Print a trace of Lisp function calls currently active.
3515 Output stream used is value of `standard-output'. */)
3518 register struct backtrace
*backlist
= backtrace_list
;
3522 extern Lisp_Object Vprint_level
;
3523 struct gcpro gcpro1
;
3525 XSETFASTINT (Vprint_level
, 3);
3532 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
3533 if (backlist
->nargs
== UNEVALLED
)
3535 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
3536 write_string ("\n", -1);
3540 tem
= *backlist
->function
;
3541 Fprin1 (tem
, Qnil
); /* This can QUIT */
3542 write_string ("(", -1);
3543 if (backlist
->nargs
== MANY
)
3545 for (tail
= *backlist
->args
, i
= 0;
3547 tail
= Fcdr (tail
), i
++)
3549 if (i
) write_string (" ", -1);
3550 Fprin1 (Fcar (tail
), Qnil
);
3555 for (i
= 0; i
< backlist
->nargs
; i
++)
3557 if (i
) write_string (" ", -1);
3558 Fprin1 (backlist
->args
[i
], Qnil
);
3561 write_string (")\n", -1);
3563 backlist
= backlist
->next
;
3566 Vprint_level
= Qnil
;
3571 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, NULL
,
3572 doc
: /* Return the function and arguments NFRAMES up from current execution point.
3573 If that frame has not evaluated the arguments yet (or is a special form),
3574 the value is (nil FUNCTION ARG-FORMS...).
3575 If that frame has evaluated its arguments and called its function already,
3576 the value is (t FUNCTION ARG-VALUES...).
3577 A &rest arg is represented as the tail of the list ARG-VALUES.
3578 FUNCTION is whatever was supplied as car of evaluated list,
3579 or a lambda expression for macro calls.
3580 If NFRAMES is more than the number of frames, the value is nil. */)
3582 Lisp_Object nframes
;
3584 register struct backtrace
*backlist
= backtrace_list
;
3588 CHECK_NATNUM (nframes
);
3590 /* Find the frame requested. */
3591 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3592 backlist
= backlist
->next
;
3596 if (backlist
->nargs
== UNEVALLED
)
3597 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3600 if (backlist
->nargs
== MANY
)
3601 tem
= *backlist
->args
;
3603 tem
= Flist (backlist
->nargs
, backlist
->args
);
3605 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3613 register struct backtrace
*backlist
;
3616 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3618 mark_object (*backlist
->function
);
3620 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3623 i
= backlist
->nargs
- 1;
3625 mark_object (backlist
->args
[i
]);
3632 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
3633 doc
: /* *Limit on number of Lisp variable bindings and `unwind-protect's.
3634 If Lisp code tries to increase the total number past this amount,
3635 an error is signaled.
3636 You can safely use a value considerably larger than the default value,
3637 if that proves inconveniently small. However, if you increase it too far,
3638 Emacs could run out of memory trying to make the stack bigger. */);
3640 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
3641 doc
: /* *Limit on depth in `eval', `apply' and `funcall' before error.
3643 This limit serves to catch infinite recursions for you before they cause
3644 actual stack overflow in C, which would be fatal for Emacs.
3645 You can safely make it considerably larger than its default value,
3646 if that proves inconveniently small. However, if you increase it too far,
3647 Emacs could overflow the real C stack, and crash. */);
3649 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
3650 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3651 If the value is t, that means do an ordinary quit.
3652 If the value equals `throw-on-input', that means quit by throwing
3653 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3654 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3655 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3658 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
3659 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3660 Note that `quit-flag' will still be set by typing C-g,
3661 so a quit will be signaled as soon as `inhibit-quit' is nil.
3662 To prevent this happening, set `quit-flag' to nil
3663 before making `inhibit-quit' nil. */);
3664 Vinhibit_quit
= Qnil
;
3666 Qinhibit_quit
= intern_c_string ("inhibit-quit");
3667 staticpro (&Qinhibit_quit
);
3669 Qautoload
= intern_c_string ("autoload");
3670 staticpro (&Qautoload
);
3672 Qdebug_on_error
= intern_c_string ("debug-on-error");
3673 staticpro (&Qdebug_on_error
);
3675 Qmacro
= intern_c_string ("macro");
3676 staticpro (&Qmacro
);
3678 Qdeclare
= intern_c_string ("declare");
3679 staticpro (&Qdeclare
);
3681 /* Note that the process handling also uses Qexit, but we don't want
3682 to staticpro it twice, so we just do it here. */
3683 Qexit
= intern_c_string ("exit");
3686 Qinteractive
= intern_c_string ("interactive");
3687 staticpro (&Qinteractive
);
3689 Qcommandp
= intern_c_string ("commandp");
3690 staticpro (&Qcommandp
);
3692 Qdefun
= intern_c_string ("defun");
3693 staticpro (&Qdefun
);
3695 Qand_rest
= intern_c_string ("&rest");
3696 staticpro (&Qand_rest
);
3698 Qand_optional
= intern_c_string ("&optional");
3699 staticpro (&Qand_optional
);
3701 Qdebug
= intern_c_string ("debug");
3702 staticpro (&Qdebug
);
3704 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
3705 doc
: /* *Non-nil means errors display a backtrace buffer.
3706 More precisely, this happens for any error that is handled
3707 by the editor command loop.
3708 If the value is a list, an error only means to display a backtrace
3709 if one of its condition symbols appears in the list. */);
3710 Vstack_trace_on_error
= Qnil
;
3712 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
3713 doc
: /* *Non-nil means enter debugger if an error is signaled.
3714 Does not apply to errors handled by `condition-case' or those
3715 matched by `debug-ignored-errors'.
3716 If the value is a list, an error only means to enter the debugger
3717 if one of its condition symbols appears in the list.
3718 When you evaluate an expression interactively, this variable
3719 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3720 The command `toggle-debug-on-error' toggles this.
3721 See also the variable `debug-on-quit'. */);
3722 Vdebug_on_error
= Qnil
;
3724 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
3725 doc
: /* *List of errors for which the debugger should not be called.
3726 Each element may be a condition-name or a regexp that matches error messages.
3727 If any element applies to a given error, that error skips the debugger
3728 and just returns to top level.
3729 This overrides the variable `debug-on-error'.
3730 It does not apply to errors handled by `condition-case'. */);
3731 Vdebug_ignored_errors
= Qnil
;
3733 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
3734 doc
: /* *Non-nil means enter debugger if quit is signaled (C-g, for example).
3735 Does not apply if quit is handled by a `condition-case'. */);
3738 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
3739 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3741 DEFVAR_BOOL ("debugger-may-continue", &debugger_may_continue
,
3742 doc
: /* Non-nil means debugger may continue execution.
3743 This is nil when the debugger is called under circumstances where it
3744 might not be safe to continue. */);
3745 debugger_may_continue
= 1;
3747 DEFVAR_LISP ("debugger", &Vdebugger
,
3748 doc
: /* Function to call to invoke debugger.
3749 If due to frame exit, args are `exit' and the value being returned;
3750 this function's value will be returned instead of that.
3751 If due to error, args are `error' and a list of the args to `signal'.
3752 If due to `apply' or `funcall' entry, one arg, `lambda'.
3753 If due to `eval' entry, one arg, t. */);
3756 DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function
,
3757 doc
: /* If non-nil, this is a function for `signal' to call.
3758 It receives the same arguments that `signal' was given.
3759 The Edebug package uses this to regain control. */);
3760 Vsignal_hook_function
= Qnil
;
3762 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal
,
3763 doc
: /* *Non-nil means call the debugger regardless of condition handlers.
3764 Note that `debug-on-error', `debug-on-quit' and friends
3765 still determine whether to handle the particular condition. */);
3766 Vdebug_on_signal
= Qnil
;
3768 DEFVAR_LISP ("macro-declaration-function", &Vmacro_declaration_function
,
3769 doc
: /* Function to process declarations in a macro definition.
3770 The function will be called with two args MACRO and DECL.
3771 MACRO is the name of the macro being defined.
3772 DECL is a list `(declare ...)' containing the declarations.
3773 The value the function returns is not used. */);
3774 Vmacro_declaration_function
= Qnil
;
3776 Vrun_hooks
= intern_c_string ("run-hooks");
3777 staticpro (&Vrun_hooks
);
3779 staticpro (&Vautoload_queue
);
3780 Vautoload_queue
= Qnil
;
3781 staticpro (&Vsignaling_function
);
3782 Vsignaling_function
= Qnil
;
3793 defsubr (&Sfunction
);
3795 defsubr (&Sdefmacro
);
3797 defsubr (&Sdefvaralias
);
3798 defsubr (&Sdefconst
);
3799 defsubr (&Suser_variable_p
);
3803 defsubr (&Smacroexpand
);
3806 defsubr (&Sunwind_protect
);
3807 defsubr (&Scondition_case
);
3809 defsubr (&Sinteractive_p
);
3810 defsubr (&Scalled_interactively_p
);
3811 defsubr (&Scommandp
);
3812 defsubr (&Sautoload
);
3815 defsubr (&Sfuncall
);
3816 defsubr (&Srun_hooks
);
3817 defsubr (&Srun_hook_with_args
);
3818 defsubr (&Srun_hook_with_args_until_success
);
3819 defsubr (&Srun_hook_with_args_until_failure
);
3820 defsubr (&Sfetch_bytecode
);
3821 defsubr (&Sbacktrace_debug
);
3822 defsubr (&Sbacktrace
);
3823 defsubr (&Sbacktrace_frame
);
3826 /* arch-tag: 014a07aa-33ab-4a8f-a3d2-ee8a4a9ff7fb
3827 (do not change this comment) */