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"
29 #include "frame.h" /* For XFRAME. */
35 /* This definition is duplicated in alloc.c and keyboard.c */
36 /* Putting it in lisp.h makes cc bomb out! */
40 struct backtrace
*next
;
41 Lisp_Object
*function
;
42 Lisp_Object
*args
; /* Points to vector of args. */
43 int nargs
; /* Length of vector.
44 If nargs is UNEVALLED, args points to slot holding
45 list of unevalled args */
47 /* Nonzero means call value of debugger when done with this operation. */
51 struct backtrace
*backtrace_list
;
53 struct catchtag
*catchlist
;
56 /* Count levels of GCPRO to detect failure to UNGCPRO. */
60 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
61 Lisp_Object Qinhibit_quit
, Vinhibit_quit
, Vquit_flag
;
62 Lisp_Object Qand_rest
, Qand_optional
;
63 Lisp_Object Qdebug_on_error
;
66 extern Lisp_Object Qinteractive_form
;
68 /* This holds either the symbol `run-hooks' or nil.
69 It is nil at an early stage of startup, and when Emacs
72 Lisp_Object Vrun_hooks
;
74 /* Non-nil means record all fset's and provide's, to be undone
75 if the file being autoloaded is not fully loaded.
76 They are recorded by being consed onto the front of Vautoload_queue:
77 (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide. */
79 Lisp_Object Vautoload_queue
;
81 /* Current number of specbindings allocated in specpdl. */
85 /* Pointer to beginning of specpdl. */
87 struct specbinding
*specpdl
;
89 /* Pointer to first unused element in specpdl. */
91 struct specbinding
*specpdl_ptr
;
93 /* Maximum size allowed for specpdl allocation */
95 EMACS_INT max_specpdl_size
;
97 /* Depth in Lisp evaluations and function calls. */
101 /* Maximum allowed depth in Lisp evaluations and function calls. */
103 EMACS_INT max_lisp_eval_depth
;
105 /* Nonzero means enter debugger before next function call */
107 int debug_on_next_call
;
109 /* Non-zero means debugger may continue. This is zero when the
110 debugger is called during redisplay, where it might not be safe to
111 continue the interrupted redisplay. */
113 int debugger_may_continue
;
115 /* List of conditions (non-nil atom means all) which cause a backtrace
116 if an error is handled by the command loop's error handler. */
118 Lisp_Object Vstack_trace_on_error
;
120 /* List of conditions (non-nil atom means all) which enter the debugger
121 if an error is handled by the command loop's error handler. */
123 Lisp_Object Vdebug_on_error
;
125 /* List of conditions and regexps specifying error messages which
126 do not enter the debugger even if Vdebug_on_error says they should. */
128 Lisp_Object Vdebug_ignored_errors
;
130 /* Non-nil means call the debugger even if the error will be handled. */
132 Lisp_Object Vdebug_on_signal
;
134 /* Hook for edebug to use. */
136 Lisp_Object Vsignal_hook_function
;
138 /* Nonzero means enter debugger if a quit signal
139 is handled by the command loop's error handler. */
143 /* The value of num_nonmacro_input_events as of the last time we
144 started to enter the debugger. If we decide to enter the debugger
145 again when this is still equal to num_nonmacro_input_events, then we
146 know that the debugger itself has an error, and we should just
147 signal the error instead of entering an infinite loop of debugger
150 int when_entered_debugger
;
152 Lisp_Object Vdebugger
;
154 /* The function from which the last `signal' was called. Set in
157 Lisp_Object Vsignaling_function
;
159 /* Set to non-zero while processing X events. Checked in Feval to
160 make sure the Lisp interpreter isn't called from a signal handler,
161 which is unsafe because the interpreter isn't reentrant. */
165 /* Function to process declarations in defmacro forms. */
167 Lisp_Object Vmacro_declaration_function
;
169 extern Lisp_Object Qrisky_local_variable
;
171 extern Lisp_Object Qfunction
;
173 static Lisp_Object funcall_lambda
P_ ((Lisp_Object
, int, Lisp_Object
*));
174 static void unwind_to_catch
P_ ((struct catchtag
*, Lisp_Object
)) NO_RETURN
;
177 /* "gcc -O3" enables automatic function inlining, which optimizes out
178 the arguments for the invocations of these functions, whereas they
179 expect these values on the stack. */
180 Lisp_Object
apply1 () __attribute__((noinline
));
181 Lisp_Object
call2 () __attribute__((noinline
));
188 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
189 specpdl_ptr
= specpdl
;
190 /* Don't forget to update docs (lispref node "Local Variables"). */
191 max_specpdl_size
= 1000;
192 max_lisp_eval_depth
= 500;
200 specpdl_ptr
= specpdl
;
205 debug_on_next_call
= 0;
210 /* This is less than the initial value of num_nonmacro_input_events. */
211 when_entered_debugger
= -1;
214 /* unwind-protect function used by call_debugger. */
217 restore_stack_limits (data
)
220 max_specpdl_size
= XINT (XCAR (data
));
221 max_lisp_eval_depth
= XINT (XCDR (data
));
225 /* Call the Lisp debugger, giving it argument ARG. */
231 int debug_while_redisplaying
;
232 int count
= SPECPDL_INDEX ();
234 int old_max
= max_specpdl_size
;
236 /* Temporarily bump up the stack limits,
237 so the debugger won't run out of stack. */
239 max_specpdl_size
+= 1;
240 record_unwind_protect (restore_stack_limits
,
241 Fcons (make_number (old_max
),
242 make_number (max_lisp_eval_depth
)));
243 max_specpdl_size
= old_max
;
245 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
246 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
248 if (SPECPDL_INDEX () + 100 > max_specpdl_size
)
249 max_specpdl_size
= SPECPDL_INDEX () + 100;
251 #ifdef HAVE_WINDOW_SYSTEM
252 if (display_hourglass_p
)
256 debug_on_next_call
= 0;
257 when_entered_debugger
= num_nonmacro_input_events
;
259 /* Resetting redisplaying_p to 0 makes sure that debug output is
260 displayed if the debugger is invoked during redisplay. */
261 debug_while_redisplaying
= redisplaying_p
;
263 specbind (intern ("debugger-may-continue"),
264 debug_while_redisplaying
? Qnil
: Qt
);
265 specbind (Qinhibit_redisplay
, Qnil
);
266 specbind (Qdebug_on_error
, Qnil
);
268 #if 0 /* Binding this prevents execution of Lisp code during
269 redisplay, which necessarily leads to display problems. */
270 specbind (Qinhibit_eval_during_redisplay
, Qt
);
273 val
= apply1 (Vdebugger
, arg
);
275 /* Interrupting redisplay and resuming it later is not safe under
276 all circumstances. So, when the debugger returns, abort the
277 interrupted redisplay by going back to the top-level. */
278 if (debug_while_redisplaying
)
281 return unbind_to (count
, val
);
285 do_debug_on_call (code
)
288 debug_on_next_call
= 0;
289 backtrace_list
->debug_on_exit
= 1;
290 call_debugger (Fcons (code
, Qnil
));
293 /* NOTE!!! Every function that can call EVAL must protect its args
294 and temporaries from garbage collection while it needs them.
295 The definition of `For' shows what you have to do. */
297 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
298 doc
: /* Eval args until one of them yields non-nil, then return that value.
299 The remaining args are not evalled at all.
300 If all args return nil, return nil.
301 usage: (or CONDITIONS...) */)
305 register Lisp_Object val
= Qnil
;
312 val
= Feval (XCAR (args
));
322 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
323 doc
: /* Eval args until one of them yields nil, then return nil.
324 The remaining args are not evalled at all.
325 If no arg yields nil, return the last arg's value.
326 usage: (and CONDITIONS...) */)
330 register Lisp_Object val
= Qt
;
337 val
= Feval (XCAR (args
));
347 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
348 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
349 Returns the value of THEN or the value of the last of the ELSE's.
350 THEN must be one expression, but ELSE... can be zero or more expressions.
351 If COND yields nil, and there are no ELSE's, the value is nil.
352 usage: (if COND THEN ELSE...) */)
356 register Lisp_Object cond
;
360 cond
= Feval (Fcar (args
));
364 return Feval (Fcar (Fcdr (args
)));
365 return Fprogn (Fcdr (Fcdr (args
)));
368 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
369 doc
: /* Try each clause until one succeeds.
370 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
371 and, if the value is non-nil, this clause succeeds:
372 then the expressions in BODY are evaluated and the last one's
373 value is the value of the cond-form.
374 If no clause succeeds, cond returns nil.
375 If a clause has one element, as in (CONDITION),
376 CONDITION's value if non-nil is returned from the cond-form.
377 usage: (cond CLAUSES...) */)
381 register Lisp_Object clause
, val
;
388 clause
= Fcar (args
);
389 val
= Feval (Fcar (clause
));
392 if (!EQ (XCDR (clause
), Qnil
))
393 val
= Fprogn (XCDR (clause
));
403 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
404 doc
: /* Eval BODY forms sequentially and return value of last one.
405 usage: (progn BODY...) */)
409 register Lisp_Object val
= Qnil
;
416 val
= Feval (XCAR (args
));
424 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
425 doc
: /* Eval FIRST and BODY sequentially; return value from FIRST.
426 The value of FIRST is saved during the evaluation of the remaining args,
427 whose values are discarded.
428 usage: (prog1 FIRST BODY...) */)
433 register Lisp_Object args_left
;
434 struct gcpro gcpro1
, gcpro2
;
435 register int argnum
= 0;
447 val
= Feval (Fcar (args_left
));
449 Feval (Fcar (args_left
));
450 args_left
= Fcdr (args_left
);
452 while (!NILP(args_left
));
458 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
459 doc
: /* Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
460 The value of FORM2 is saved during the evaluation of the
461 remaining args, whose values are discarded.
462 usage: (prog2 FORM1 FORM2 BODY...) */)
467 register Lisp_Object args_left
;
468 struct gcpro gcpro1
, gcpro2
;
469 register int argnum
= -1;
483 val
= Feval (Fcar (args_left
));
485 Feval (Fcar (args_left
));
486 args_left
= Fcdr (args_left
);
488 while (!NILP (args_left
));
494 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
495 doc
: /* Set each SYM to the value of its VAL.
496 The symbols SYM are variables; they are literal (not evaluated).
497 The values VAL are expressions; they are evaluated.
498 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
499 The second VAL is not computed until after the first SYM is set, and so on;
500 each VAL can use the new value of variables set earlier in the `setq'.
501 The return value of the `setq' form is the value of the last VAL.
502 usage: (setq [SYM VAL]...) */)
506 register Lisp_Object args_left
;
507 register Lisp_Object val
, sym
;
518 val
= Feval (Fcar (Fcdr (args_left
)));
519 sym
= Fcar (args_left
);
521 args_left
= Fcdr (Fcdr (args_left
));
523 while (!NILP(args_left
));
529 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
530 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
531 usage: (quote ARG) */)
535 if (!NILP (Fcdr (args
)))
536 xsignal2 (Qwrong_number_of_arguments
, Qquote
, Flength (args
));
540 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
541 doc
: /* Like `quote', but preferred for objects which are functions.
542 In byte compilation, `function' causes its argument to be compiled.
543 `quote' cannot do that.
544 usage: (function ARG) */)
548 if (!NILP (Fcdr (args
)))
549 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
554 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
555 doc
: /* Return t if the containing function was run directly by user input.
556 This means that the function was called with `call-interactively'
557 \(which includes being called as the binding of a key)
558 and input is currently coming from the keyboard (not a keyboard macro),
559 and Emacs is not running in batch mode (`noninteractive' is nil).
561 The only known proper use of `interactive-p' is in deciding whether to
562 display a helpful message, or how to display it. If you're thinking
563 of using it for any other purpose, it is quite likely that you're
564 making a mistake. Think: what do you want to do when the command is
565 called from a keyboard macro?
567 To test whether your function was called with `call-interactively',
568 either (i) add an extra optional argument and give it an `interactive'
569 spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
570 use `called-interactively-p'. */)
573 return (INTERACTIVE
&& interactive_p (1)) ? Qt
: Qnil
;
577 DEFUN ("called-interactively-p", Fcalled_interactively_p
, Scalled_interactively_p
, 0, 1, 0,
578 doc
: /* Return t if the containing function was called by `call-interactively'.
579 If KIND is `interactive', then only return t if the call was made
580 interactively by the user, i.e. not in `noninteractive' mode nor
581 when `executing-kbd-macro'.
582 If KIND is `any', on the other hand, it will return t for any kind of
583 interactive call, including being called as the binding of a key, or
584 from a keyboard macro, or in `noninteractive' mode.
586 The only known proper use of `interactive' for KIND is in deciding
587 whether to display a helpful message, or how to display it. If you're
588 thinking of using it for any other purpose, it is quite likely that
589 you're making a mistake. Think: what do you want to do when the
590 command is called from a keyboard macro?
592 This function is meant for implementing advice and other
593 function-modifying features. Instead of using this, it is sometimes
594 cleaner to give your function an extra optional argument whose
595 `interactive' spec specifies non-nil unconditionally (\"p\" is a good
596 way to do this), or via (not (or executing-kbd-macro noninteractive)). */)
600 return ((INTERACTIVE
|| !EQ (kind
, intern ("interactive")))
601 && interactive_p (1)) ? Qt
: Qnil
;
605 /* Return 1 if function in which this appears was called using
608 EXCLUDE_SUBRS_P non-zero means always return 0 if the function
609 called is a built-in. */
612 interactive_p (exclude_subrs_p
)
615 struct backtrace
*btp
;
618 btp
= backtrace_list
;
620 /* If this isn't a byte-compiled function, there may be a frame at
621 the top for Finteractive_p. If so, skip it. */
622 fun
= Findirect_function (*btp
->function
, Qnil
);
623 if (SUBRP (fun
) && (XSUBR (fun
) == &Sinteractive_p
624 || XSUBR (fun
) == &Scalled_interactively_p
))
627 /* If we're running an Emacs 18-style byte-compiled function, there
628 may be a frame for Fbytecode at the top level. In any version of
629 Emacs there can be Fbytecode frames for subexpressions evaluated
630 inside catch and condition-case. Skip past them.
632 If this isn't a byte-compiled function, then we may now be
633 looking at several frames for special forms. Skip past them. */
635 && (EQ (*btp
->function
, Qbytecode
)
636 || btp
->nargs
== UNEVALLED
))
639 /* btp now points at the frame of the innermost function that isn't
640 a special form, ignoring frames for Finteractive_p and/or
641 Fbytecode at the top. If this frame is for a built-in function
642 (such as load or eval-region) return nil. */
643 fun
= Findirect_function (*btp
->function
, Qnil
);
644 if (exclude_subrs_p
&& SUBRP (fun
))
647 /* btp points to the frame of a Lisp function that called interactive-p.
648 Return t if that function was called interactively. */
649 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
655 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
656 doc
: /* Define NAME as a function.
657 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
658 See also the function `interactive'.
659 usage: (defun NAME ARGLIST [DOCSTRING] BODY...) */)
663 register Lisp_Object fn_name
;
664 register Lisp_Object defn
;
666 fn_name
= Fcar (args
);
667 CHECK_SYMBOL (fn_name
);
668 defn
= Fcons (Qlambda
, Fcdr (args
));
669 if (!NILP (Vpurify_flag
))
670 defn
= Fpurecopy (defn
);
671 if (CONSP (XSYMBOL (fn_name
)->function
)
672 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
673 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
674 Ffset (fn_name
, defn
);
675 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
679 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
680 doc
: /* Define NAME as a macro.
681 The actual definition looks like
682 (macro lambda ARGLIST [DOCSTRING] [DECL] BODY...).
683 When the macro is called, as in (NAME ARGS...),
684 the function (lambda ARGLIST BODY...) is applied to
685 the list ARGS... as it appears in the expression,
686 and the result should be a form to be evaluated instead of the original.
688 DECL is a declaration, optional, which can specify how to indent
689 calls to this macro, how Edebug should handle it, and which argument
690 should be treated as documentation. It looks like this:
692 The elements can look like this:
694 Set NAME's `lisp-indent-function' property to INDENT.
697 Set NAME's `edebug-form-spec' property to DEBUG. (This is
698 equivalent to writing a `def-edebug-spec' for the macro.)
701 Set NAME's `doc-string-elt' property to ELT.
703 usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */)
707 register Lisp_Object fn_name
;
708 register Lisp_Object defn
;
709 Lisp_Object lambda_list
, doc
, tail
;
711 fn_name
= Fcar (args
);
712 CHECK_SYMBOL (fn_name
);
713 lambda_list
= Fcar (Fcdr (args
));
714 tail
= Fcdr (Fcdr (args
));
717 if (STRINGP (Fcar (tail
)))
723 while (CONSP (Fcar (tail
))
724 && EQ (Fcar (Fcar (tail
)), Qdeclare
))
726 if (!NILP (Vmacro_declaration_function
))
730 call2 (Vmacro_declaration_function
, fn_name
, Fcar (tail
));
738 tail
= Fcons (lambda_list
, tail
);
740 tail
= Fcons (lambda_list
, Fcons (doc
, tail
));
741 defn
= Fcons (Qmacro
, Fcons (Qlambda
, tail
));
743 if (!NILP (Vpurify_flag
))
744 defn
= Fpurecopy (defn
);
745 if (CONSP (XSYMBOL (fn_name
)->function
)
746 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
747 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
748 Ffset (fn_name
, defn
);
749 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
754 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
755 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
756 Aliased variables always have the same value; setting one sets the other.
757 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
758 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
759 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
760 itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
761 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
762 The return value is BASE-VARIABLE. */)
763 (new_alias
, base_variable
, docstring
)
764 Lisp_Object new_alias
, base_variable
, docstring
;
766 struct Lisp_Symbol
*sym
;
768 CHECK_SYMBOL (new_alias
);
769 CHECK_SYMBOL (base_variable
);
771 sym
= XSYMBOL (new_alias
);
774 /* Not sure why, but why not? */
775 error ("Cannot make a constant an alias");
777 switch (sym
->redirect
)
779 case SYMBOL_FORWARDED
:
780 error ("Cannot make an internal variable an alias");
781 case SYMBOL_LOCALIZED
:
782 error ("Don't know how to make a localized variable an alias");
785 /* http://lists.gnu.org/archive/html/emacs-devel/2008-04/msg00834.html
786 If n_a is bound, but b_v is not, set the value of b_v to n_a,
787 so that old-code that affects n_a before the aliasing is setup
789 if (NILP (Fboundp (base_variable
)))
790 set_internal (base_variable
, find_symbol_value (new_alias
), Qnil
, 1);
793 struct specbinding
*p
;
795 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
798 CONSP (p
->symbol
) ? XCAR (p
->symbol
) : p
->symbol
)))
799 error ("Don't know how to make a let-bound variable an alias");
802 sym
->redirect
= SYMBOL_VARALIAS
;
803 SET_SYMBOL_ALIAS (sym
, XSYMBOL (base_variable
));
804 sym
->constant
= SYMBOL_CONSTANT_P (base_variable
);
805 LOADHIST_ATTACH (new_alias
);
806 /* Even if docstring is nil: remove old docstring. */
807 Fput (new_alias
, Qvariable_documentation
, docstring
);
809 return base_variable
;
813 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
814 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
815 You are not required to define a variable in order to use it,
816 but the definition can supply documentation and an initial value
817 in a way that tags can recognize.
819 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.
820 If SYMBOL is buffer-local, its default value is what is set;
821 buffer-local values are not affected.
822 INITVALUE and DOCSTRING are optional.
823 If DOCSTRING starts with *, this variable is identified as a user option.
824 This means that M-x set-variable recognizes it.
825 See also `user-variable-p'.
826 If INITVALUE is missing, SYMBOL's value is not set.
828 If SYMBOL has a local binding, then this form affects the local
829 binding. This is usually not what you want. Thus, if you need to
830 load a file defining variables, with this form or with `defconst' or
831 `defcustom', you should always load that file _outside_ any bindings
832 for these variables. \(`defconst' and `defcustom' behave similarly in
834 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
838 register Lisp_Object sym
, tem
, tail
;
842 if (!NILP (Fcdr (Fcdr (tail
))))
843 error ("Too many arguments");
845 tem
= Fdefault_boundp (sym
);
848 if (SYMBOL_CONSTANT_P (sym
))
850 /* For upward compatibility, allow (defvar :foo (quote :foo)). */
851 Lisp_Object tem
= Fcar (tail
);
853 && EQ (XCAR (tem
), Qquote
)
854 && CONSP (XCDR (tem
))
855 && EQ (XCAR (XCDR (tem
)), sym
)))
856 error ("Constant symbol `%s' specified in defvar",
857 SDATA (SYMBOL_NAME (sym
)));
861 Fset_default (sym
, Feval (Fcar (tail
)));
863 { /* Check if there is really a global binding rather than just a let
864 binding that shadows the global unboundness of the var. */
865 volatile struct specbinding
*pdl
= specpdl_ptr
;
866 while (--pdl
>= specpdl
)
868 if (EQ (pdl
->symbol
, sym
) && !pdl
->func
869 && EQ (pdl
->old_value
, Qunbound
))
871 message_with_string ("Warning: defvar ignored because %s is let-bound",
872 SYMBOL_NAME (sym
), 1);
881 if (!NILP (Vpurify_flag
))
882 tem
= Fpurecopy (tem
);
883 Fput (sym
, Qvariable_documentation
, tem
);
885 LOADHIST_ATTACH (sym
);
888 /* Simple (defvar <var>) should not count as a definition at all.
889 It could get in the way of other definitions, and unloading this
890 package could try to make the variable unbound. */
896 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
897 doc
: /* Define SYMBOL as a constant variable.
898 The intent is that neither programs nor users should ever change this value.
899 Always sets the value of SYMBOL to the result of evalling INITVALUE.
900 If SYMBOL is buffer-local, its default value is what is set;
901 buffer-local values are not affected.
902 DOCSTRING is optional.
904 If SYMBOL has a local binding, then this form sets the local binding's
905 value. However, you should normally not make local bindings for
906 variables defined with this form.
907 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
911 register Lisp_Object sym
, tem
;
914 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
915 error ("Too many arguments");
917 tem
= Feval (Fcar (Fcdr (args
)));
918 if (!NILP (Vpurify_flag
))
919 tem
= Fpurecopy (tem
);
920 Fset_default (sym
, tem
);
921 tem
= Fcar (Fcdr (Fcdr (args
)));
924 if (!NILP (Vpurify_flag
))
925 tem
= Fpurecopy (tem
);
926 Fput (sym
, Qvariable_documentation
, tem
);
928 Fput (sym
, Qrisky_local_variable
, Qt
);
929 LOADHIST_ATTACH (sym
);
933 /* Error handler used in Fuser_variable_p. */
935 user_variable_p_eh (ignore
)
942 lisp_indirect_variable (Lisp_Object sym
)
944 XSETSYMBOL (sym
, indirect_variable (XSYMBOL (sym
)));
948 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
949 doc
: /* Return t if VARIABLE is intended to be set and modified by users.
950 \(The alternative is a variable used internally in a Lisp program.)
951 A variable is a user variable if
952 \(1) the first character of its documentation is `*', or
953 \(2) it is customizable (its property list contains a non-nil value
954 of `standard-value' or `custom-autoload'), or
955 \(3) it is an alias for another user variable.
956 Return nil if VARIABLE is an alias and there is a loop in the
957 chain of symbols. */)
959 Lisp_Object variable
;
961 Lisp_Object documentation
;
963 if (!SYMBOLP (variable
))
966 /* If indirect and there's an alias loop, don't check anything else. */
967 if (XSYMBOL (variable
)->redirect
== SYMBOL_VARALIAS
968 && NILP (internal_condition_case_1 (lisp_indirect_variable
, variable
,
969 Qt
, user_variable_p_eh
)))
974 documentation
= Fget (variable
, Qvariable_documentation
);
975 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
977 if (STRINGP (documentation
)
978 && ((unsigned char) SREF (documentation
, 0) == '*'))
980 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
981 if (CONSP (documentation
)
982 && STRINGP (XCAR (documentation
))
983 && INTEGERP (XCDR (documentation
))
984 && XINT (XCDR (documentation
)) < 0)
986 /* Customizable? See `custom-variable-p'. */
987 if ((!NILP (Fget (variable
, intern ("standard-value"))))
988 || (!NILP (Fget (variable
, intern ("custom-autoload")))))
991 if (!(XSYMBOL (variable
)->redirect
== SYMBOL_VARALIAS
))
994 /* An indirect variable? Let's follow the chain. */
995 XSETSYMBOL (variable
, SYMBOL_ALIAS (XSYMBOL (variable
)));
999 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
1000 doc
: /* Bind variables according to VARLIST then eval BODY.
1001 The value of the last form in BODY is returned.
1002 Each element of VARLIST is a symbol (which is bound to nil)
1003 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
1004 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
1005 usage: (let* VARLIST BODY...) */)
1009 Lisp_Object varlist
, val
, elt
;
1010 int count
= SPECPDL_INDEX ();
1011 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1013 GCPRO3 (args
, elt
, varlist
);
1015 varlist
= Fcar (args
);
1016 while (!NILP (varlist
))
1019 elt
= Fcar (varlist
);
1021 specbind (elt
, Qnil
);
1022 else if (! NILP (Fcdr (Fcdr (elt
))))
1023 signal_error ("`let' bindings can have only one value-form", elt
);
1026 val
= Feval (Fcar (Fcdr (elt
)));
1027 specbind (Fcar (elt
), val
);
1029 varlist
= Fcdr (varlist
);
1032 val
= Fprogn (Fcdr (args
));
1033 return unbind_to (count
, val
);
1036 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
1037 doc
: /* Bind variables according to VARLIST then eval BODY.
1038 The value of the last form in BODY is returned.
1039 Each element of VARLIST is a symbol (which is bound to nil)
1040 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
1041 All the VALUEFORMs are evalled before any symbols are bound.
1042 usage: (let VARLIST BODY...) */)
1046 Lisp_Object
*temps
, tem
;
1047 register Lisp_Object elt
, varlist
;
1048 int count
= SPECPDL_INDEX ();
1049 register int argnum
;
1050 struct gcpro gcpro1
, gcpro2
;
1052 varlist
= Fcar (args
);
1054 /* Make space to hold the values to give the bound variables */
1055 elt
= Flength (varlist
);
1056 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
1058 /* Compute the values and store them in `temps' */
1060 GCPRO2 (args
, *temps
);
1063 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
1066 elt
= XCAR (varlist
);
1068 temps
[argnum
++] = Qnil
;
1069 else if (! NILP (Fcdr (Fcdr (elt
))))
1070 signal_error ("`let' bindings can have only one value-form", elt
);
1072 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
1073 gcpro2
.nvars
= argnum
;
1077 varlist
= Fcar (args
);
1078 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
1080 elt
= XCAR (varlist
);
1081 tem
= temps
[argnum
++];
1083 specbind (elt
, tem
);
1085 specbind (Fcar (elt
), tem
);
1088 elt
= Fprogn (Fcdr (args
));
1089 return unbind_to (count
, elt
);
1092 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
1093 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
1094 The order of execution is thus TEST, BODY, TEST, BODY and so on
1095 until TEST returns nil.
1096 usage: (while TEST BODY...) */)
1100 Lisp_Object test
, body
;
1101 struct gcpro gcpro1
, gcpro2
;
1103 GCPRO2 (test
, body
);
1107 while (!NILP (Feval (test
)))
1117 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
1118 doc
: /* Return result of expanding macros at top level of FORM.
1119 If FORM is not a macro call, it is returned unchanged.
1120 Otherwise, the macro is expanded and the expansion is considered
1121 in place of FORM. When a non-macro-call results, it is returned.
1123 The second optional arg ENVIRONMENT specifies an environment of macro
1124 definitions to shadow the loaded ones for use in file byte-compilation. */)
1127 Lisp_Object environment
;
1129 /* With cleanups from Hallvard Furuseth. */
1130 register Lisp_Object expander
, sym
, def
, tem
;
1134 /* Come back here each time we expand a macro call,
1135 in case it expands into another macro call. */
1138 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1139 def
= sym
= XCAR (form
);
1141 /* Trace symbols aliases to other symbols
1142 until we get a symbol that is not an alias. */
1143 while (SYMBOLP (def
))
1147 tem
= Fassq (sym
, environment
);
1150 def
= XSYMBOL (sym
)->function
;
1151 if (!EQ (def
, Qunbound
))
1156 /* Right now TEM is the result from SYM in ENVIRONMENT,
1157 and if TEM is nil then DEF is SYM's function definition. */
1160 /* SYM is not mentioned in ENVIRONMENT.
1161 Look at its function definition. */
1162 if (EQ (def
, Qunbound
) || !CONSP (def
))
1163 /* Not defined or definition not suitable */
1165 if (EQ (XCAR (def
), Qautoload
))
1167 /* Autoloading function: will it be a macro when loaded? */
1168 tem
= Fnth (make_number (4), def
);
1169 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
1170 /* Yes, load it and try again. */
1172 struct gcpro gcpro1
;
1174 do_autoload (def
, sym
);
1181 else if (!EQ (XCAR (def
), Qmacro
))
1183 else expander
= XCDR (def
);
1187 expander
= XCDR (tem
);
1188 if (NILP (expander
))
1191 form
= apply1 (expander
, XCDR (form
));
1196 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1197 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1198 TAG is evalled to get the tag to use; it must not be nil.
1200 Then the BODY is executed.
1201 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
1202 If no throw happens, `catch' returns the value of the last BODY form.
1203 If a throw happens, it specifies the value to return from `catch'.
1204 usage: (catch TAG BODY...) */)
1208 register Lisp_Object tag
;
1209 struct gcpro gcpro1
;
1212 tag
= Feval (Fcar (args
));
1214 return internal_catch (tag
, Fprogn
, Fcdr (args
));
1217 /* Set up a catch, then call C function FUNC on argument ARG.
1218 FUNC should return a Lisp_Object.
1219 This is how catches are done from within C code. */
1222 internal_catch (tag
, func
, arg
)
1224 Lisp_Object (*func
) ();
1227 /* This structure is made part of the chain `catchlist'. */
1230 /* Fill in the components of c, and put it on the list. */
1234 c
.backlist
= backtrace_list
;
1235 c
.handlerlist
= handlerlist
;
1236 c
.lisp_eval_depth
= lisp_eval_depth
;
1237 c
.pdlcount
= SPECPDL_INDEX ();
1238 c
.poll_suppress_count
= poll_suppress_count
;
1239 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1240 c
.gcpro
= gcprolist
;
1241 c
.byte_stack
= byte_stack_list
;
1245 if (! _setjmp (c
.jmp
))
1246 c
.val
= (*func
) (arg
);
1248 /* Throw works by a longjmp that comes right here. */
1253 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1254 jump to that CATCH, returning VALUE as the value of that catch.
1256 This is the guts Fthrow and Fsignal; they differ only in the way
1257 they choose the catch tag to throw to. A catch tag for a
1258 condition-case form has a TAG of Qnil.
1260 Before each catch is discarded, unbind all special bindings and
1261 execute all unwind-protect clauses made above that catch. Unwind
1262 the handler stack as we go, so that the proper handlers are in
1263 effect for each unwind-protect clause we run. At the end, restore
1264 some static info saved in CATCH, and longjmp to the location
1267 This is used for correct unwinding in Fthrow and Fsignal. */
1270 unwind_to_catch (catch, value
)
1271 struct catchtag
*catch;
1274 register int last_time
;
1276 /* Save the value in the tag. */
1279 /* Restore certain special C variables. */
1280 set_poll_suppress_count (catch->poll_suppress_count
);
1281 UNBLOCK_INPUT_TO (catch->interrupt_input_blocked
);
1282 handling_signal
= 0;
1287 last_time
= catchlist
== catch;
1289 /* Unwind the specpdl stack, and then restore the proper set of
1291 unbind_to (catchlist
->pdlcount
, Qnil
);
1292 handlerlist
= catchlist
->handlerlist
;
1293 catchlist
= catchlist
->next
;
1295 while (! last_time
);
1298 /* If x_catch_errors was done, turn it off now.
1299 (First we give unbind_to a chance to do that.) */
1300 #if 0 /* This would disable x_catch_errors after x_connection_closed.
1301 * The catch must remain in effect during that delicate
1302 * state. --lorentey */
1303 x_fully_uncatch_errors ();
1307 byte_stack_list
= catch->byte_stack
;
1308 gcprolist
= catch->gcpro
;
1311 gcpro_level
= gcprolist
->level
+ 1;
1315 backtrace_list
= catch->backlist
;
1316 lisp_eval_depth
= catch->lisp_eval_depth
;
1318 _longjmp (catch->jmp
, 1);
1321 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1322 doc
: /* Throw to the catch for TAG and return VALUE from it.
1323 Both TAG and VALUE are evalled. */)
1325 register Lisp_Object tag
, value
;
1327 register struct catchtag
*c
;
1330 for (c
= catchlist
; c
; c
= c
->next
)
1332 if (EQ (c
->tag
, tag
))
1333 unwind_to_catch (c
, value
);
1335 xsignal2 (Qno_catch
, tag
, value
);
1339 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1340 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1341 If BODYFORM completes normally, its value is returned
1342 after executing the UNWINDFORMS.
1343 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1344 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1349 int count
= SPECPDL_INDEX ();
1351 record_unwind_protect (Fprogn
, Fcdr (args
));
1352 val
= Feval (Fcar (args
));
1353 return unbind_to (count
, val
);
1356 /* Chain of condition handlers currently in effect.
1357 The elements of this chain are contained in the stack frames
1358 of Fcondition_case and internal_condition_case.
1359 When an error is signaled (by calling Fsignal, below),
1360 this chain is searched for an element that applies. */
1362 struct handler
*handlerlist
;
1364 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1365 doc
: /* Regain control when an error is signaled.
1366 Executes BODYFORM and returns its value if no error happens.
1367 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1368 where the BODY is made of Lisp expressions.
1370 A handler is applicable to an error
1371 if CONDITION-NAME is one of the error's condition names.
1372 If an error happens, the first applicable handler is run.
1374 The car of a handler may be a list of condition names
1375 instead of a single condition name. Then it handles all of them.
1377 When a handler handles an error, control returns to the `condition-case'
1378 and it executes the handler's BODY...
1379 with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
1380 (If VAR is nil, the handler can't access that information.)
1381 Then the value of the last BODY form is returned from the `condition-case'
1384 See also the function `signal' for more info.
1385 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1389 register Lisp_Object bodyform
, handlers
;
1390 volatile Lisp_Object var
;
1393 bodyform
= Fcar (Fcdr (args
));
1394 handlers
= Fcdr (Fcdr (args
));
1396 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1399 /* Like Fcondition_case, but the args are separate
1400 rather than passed in a list. Used by Fbyte_code. */
1403 internal_lisp_condition_case (var
, bodyform
, handlers
)
1404 volatile Lisp_Object var
;
1405 Lisp_Object bodyform
, handlers
;
1413 for (val
= handlers
; CONSP (val
); val
= XCDR (val
))
1419 && (SYMBOLP (XCAR (tem
))
1420 || CONSP (XCAR (tem
))))))
1421 error ("Invalid condition handler", tem
);
1426 c
.backlist
= backtrace_list
;
1427 c
.handlerlist
= handlerlist
;
1428 c
.lisp_eval_depth
= lisp_eval_depth
;
1429 c
.pdlcount
= SPECPDL_INDEX ();
1430 c
.poll_suppress_count
= poll_suppress_count
;
1431 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1432 c
.gcpro
= gcprolist
;
1433 c
.byte_stack
= byte_stack_list
;
1434 if (_setjmp (c
.jmp
))
1437 specbind (h
.var
, c
.val
);
1438 val
= Fprogn (Fcdr (h
.chosen_clause
));
1440 /* Note that this just undoes the binding of h.var; whoever
1441 longjumped to us unwound the stack to c.pdlcount before
1443 unbind_to (c
.pdlcount
, Qnil
);
1450 h
.handler
= handlers
;
1451 h
.next
= handlerlist
;
1455 val
= Feval (bodyform
);
1457 handlerlist
= h
.next
;
1461 /* Call the function BFUN with no arguments, catching errors within it
1462 according to HANDLERS. If there is an error, call HFUN with
1463 one argument which is the data that describes the error:
1466 HANDLERS can be a list of conditions to catch.
1467 If HANDLERS is Qt, catch all errors.
1468 If HANDLERS is Qerror, catch all errors
1469 but allow the debugger to run if that is enabled. */
1472 internal_condition_case (bfun
, handlers
, hfun
)
1473 Lisp_Object (*bfun
) ();
1474 Lisp_Object handlers
;
1475 Lisp_Object (*hfun
) ();
1481 /* Since Fsignal will close off all calls to x_catch_errors,
1482 we will get the wrong results if some are not closed now. */
1484 if (x_catching_errors ())
1490 c
.backlist
= backtrace_list
;
1491 c
.handlerlist
= handlerlist
;
1492 c
.lisp_eval_depth
= lisp_eval_depth
;
1493 c
.pdlcount
= SPECPDL_INDEX ();
1494 c
.poll_suppress_count
= poll_suppress_count
;
1495 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1496 c
.gcpro
= gcprolist
;
1497 c
.byte_stack
= byte_stack_list
;
1498 if (_setjmp (c
.jmp
))
1500 return (*hfun
) (c
.val
);
1504 h
.handler
= handlers
;
1506 h
.next
= handlerlist
;
1512 handlerlist
= h
.next
;
1516 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1519 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1520 Lisp_Object (*bfun
) ();
1522 Lisp_Object handlers
;
1523 Lisp_Object (*hfun
) ();
1529 /* Since Fsignal will close off all calls to x_catch_errors,
1530 we will get the wrong results if some are not closed now. */
1532 if (x_catching_errors ())
1538 c
.backlist
= backtrace_list
;
1539 c
.handlerlist
= handlerlist
;
1540 c
.lisp_eval_depth
= lisp_eval_depth
;
1541 c
.pdlcount
= SPECPDL_INDEX ();
1542 c
.poll_suppress_count
= poll_suppress_count
;
1543 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1544 c
.gcpro
= gcprolist
;
1545 c
.byte_stack
= byte_stack_list
;
1546 if (_setjmp (c
.jmp
))
1548 return (*hfun
) (c
.val
);
1552 h
.handler
= handlers
;
1554 h
.next
= handlerlist
;
1558 val
= (*bfun
) (arg
);
1560 handlerlist
= h
.next
;
1564 /* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as
1568 internal_condition_case_2 (Lisp_Object (*bfun
) (Lisp_Object
, Lisp_Object
),
1571 Lisp_Object handlers
,
1572 Lisp_Object (*hfun
) (Lisp_Object
))
1578 /* Since Fsignal will close off all calls to x_catch_errors,
1579 we will get the wrong results if some are not closed now. */
1581 if (x_catching_errors ())
1587 c
.backlist
= backtrace_list
;
1588 c
.handlerlist
= handlerlist
;
1589 c
.lisp_eval_depth
= lisp_eval_depth
;
1590 c
.pdlcount
= SPECPDL_INDEX ();
1591 c
.poll_suppress_count
= poll_suppress_count
;
1592 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1593 c
.gcpro
= gcprolist
;
1594 c
.byte_stack
= byte_stack_list
;
1595 if (_setjmp (c
.jmp
))
1597 return (*hfun
) (c
.val
);
1601 h
.handler
= handlers
;
1603 h
.next
= handlerlist
;
1607 val
= (*bfun
) (arg1
, arg2
);
1609 handlerlist
= h
.next
;
1613 /* Like internal_condition_case but call BFUN with NARGS as first,
1614 and ARGS as second argument. */
1617 internal_condition_case_n (Lisp_Object (*bfun
) (int, Lisp_Object
*),
1620 Lisp_Object handlers
,
1621 Lisp_Object (*hfun
) (Lisp_Object
))
1627 /* Since Fsignal will close off all calls to x_catch_errors,
1628 we will get the wrong results if some are not closed now. */
1630 if (x_catching_errors ())
1636 c
.backlist
= backtrace_list
;
1637 c
.handlerlist
= handlerlist
;
1638 c
.lisp_eval_depth
= lisp_eval_depth
;
1639 c
.pdlcount
= SPECPDL_INDEX ();
1640 c
.poll_suppress_count
= poll_suppress_count
;
1641 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1642 c
.gcpro
= gcprolist
;
1643 c
.byte_stack
= byte_stack_list
;
1644 if (_setjmp (c
.jmp
))
1646 return (*hfun
) (c
.val
);
1650 h
.handler
= handlers
;
1652 h
.next
= handlerlist
;
1656 val
= (*bfun
) (nargs
, args
);
1658 handlerlist
= h
.next
;
1663 static Lisp_Object find_handler_clause
P_ ((Lisp_Object
, Lisp_Object
,
1664 Lisp_Object
, Lisp_Object
));
1666 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1667 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1668 This function does not return.
1670 An error symbol is a symbol with an `error-conditions' property
1671 that is a list of condition names.
1672 A handler for any of those names will get to handle this signal.
1673 The symbol `error' should normally be one of them.
1675 DATA should be a list. Its elements are printed as part of the error message.
1676 See Info anchor `(elisp)Definition of signal' for some details on how this
1677 error message is constructed.
1678 If the signal is handled, DATA is made available to the handler.
1679 See also the function `condition-case'. */)
1680 (error_symbol
, data
)
1681 Lisp_Object error_symbol
, data
;
1683 /* When memory is full, ERROR-SYMBOL is nil,
1684 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1685 That is a special case--don't do this in other situations. */
1686 register struct handler
*allhandlers
= handlerlist
;
1687 Lisp_Object conditions
;
1688 extern int gc_in_progress
;
1689 extern int waiting_for_input
;
1691 Lisp_Object real_error_symbol
;
1692 struct backtrace
*bp
;
1694 immediate_quit
= handling_signal
= 0;
1696 if (gc_in_progress
|| waiting_for_input
)
1699 if (NILP (error_symbol
))
1700 real_error_symbol
= Fcar (data
);
1702 real_error_symbol
= error_symbol
;
1704 #if 0 /* rms: I don't know why this was here,
1705 but it is surely wrong for an error that is handled. */
1706 #ifdef HAVE_WINDOW_SYSTEM
1707 if (display_hourglass_p
)
1708 cancel_hourglass ();
1712 /* This hook is used by edebug. */
1713 if (! NILP (Vsignal_hook_function
)
1714 && ! NILP (error_symbol
))
1716 /* Edebug takes care of restoring these variables when it exits. */
1717 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1718 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1720 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1721 max_specpdl_size
= SPECPDL_INDEX () + 40;
1723 call2 (Vsignal_hook_function
, error_symbol
, data
);
1726 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1728 /* Remember from where signal was called. Skip over the frame for
1729 `signal' itself. If a frame for `error' follows, skip that,
1730 too. Don't do this when ERROR_SYMBOL is nil, because that
1731 is a memory-full error. */
1732 Vsignaling_function
= Qnil
;
1733 if (backtrace_list
&& !NILP (error_symbol
))
1735 bp
= backtrace_list
->next
;
1736 if (bp
&& bp
->function
&& EQ (*bp
->function
, Qerror
))
1738 if (bp
&& bp
->function
)
1739 Vsignaling_function
= *bp
->function
;
1742 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1744 register Lisp_Object clause
;
1746 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1747 error_symbol
, data
);
1749 if (EQ (clause
, Qlambda
))
1751 /* We can't return values to code which signaled an error, but we
1752 can continue code which has signaled a quit. */
1753 if (EQ (real_error_symbol
, Qquit
))
1756 error ("Cannot return from the debugger in an error");
1761 Lisp_Object unwind_data
;
1762 struct handler
*h
= handlerlist
;
1764 handlerlist
= allhandlers
;
1766 if (NILP (error_symbol
))
1769 unwind_data
= Fcons (error_symbol
, data
);
1770 h
->chosen_clause
= clause
;
1771 unwind_to_catch (h
->tag
, unwind_data
);
1775 handlerlist
= allhandlers
;
1776 /* If no handler is present now, try to run the debugger,
1777 and if that fails, throw to top level. */
1778 find_handler_clause (Qerror
, conditions
, error_symbol
, data
);
1780 Fthrow (Qtop_level
, Qt
);
1782 if (! NILP (error_symbol
))
1783 data
= Fcons (error_symbol
, data
);
1785 string
= Ferror_message_string (data
);
1786 fatal ("%s", SDATA (string
), 0);
1789 /* Internal version of Fsignal that never returns.
1790 Used for anything but Qquit (which can return from Fsignal). */
1793 xsignal (error_symbol
, data
)
1794 Lisp_Object error_symbol
, data
;
1796 Fsignal (error_symbol
, data
);
1800 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1803 xsignal0 (error_symbol
)
1804 Lisp_Object error_symbol
;
1806 xsignal (error_symbol
, Qnil
);
1810 xsignal1 (error_symbol
, arg
)
1811 Lisp_Object error_symbol
, arg
;
1813 xsignal (error_symbol
, list1 (arg
));
1817 xsignal2 (error_symbol
, arg1
, arg2
)
1818 Lisp_Object error_symbol
, arg1
, arg2
;
1820 xsignal (error_symbol
, list2 (arg1
, arg2
));
1824 xsignal3 (error_symbol
, arg1
, arg2
, arg3
)
1825 Lisp_Object error_symbol
, arg1
, arg2
, arg3
;
1827 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1830 /* Signal `error' with message S, and additional arg ARG.
1831 If ARG is not a genuine list, make it a one-element list. */
1834 signal_error (s
, arg
)
1838 Lisp_Object tortoise
, hare
;
1840 hare
= tortoise
= arg
;
1841 while (CONSP (hare
))
1848 tortoise
= XCDR (tortoise
);
1850 if (EQ (hare
, tortoise
))
1855 arg
= Fcons (arg
, Qnil
); /* Make it a list. */
1857 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1861 /* Return nonzero if LIST is a non-nil atom or
1862 a list containing one of CONDITIONS. */
1865 wants_debugger (list
, conditions
)
1866 Lisp_Object list
, conditions
;
1873 while (CONSP (conditions
))
1875 Lisp_Object
this, tail
;
1876 this = XCAR (conditions
);
1877 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1878 if (EQ (XCAR (tail
), this))
1880 conditions
= XCDR (conditions
);
1885 /* Return 1 if an error with condition-symbols CONDITIONS,
1886 and described by SIGNAL-DATA, should skip the debugger
1887 according to debugger-ignored-errors. */
1890 skip_debugger (conditions
, data
)
1891 Lisp_Object conditions
, data
;
1894 int first_string
= 1;
1895 Lisp_Object error_message
;
1897 error_message
= Qnil
;
1898 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1900 if (STRINGP (XCAR (tail
)))
1904 error_message
= Ferror_message_string (data
);
1908 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1913 Lisp_Object contail
;
1915 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1916 if (EQ (XCAR (tail
), XCAR (contail
)))
1924 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1925 SIG and DATA describe the signal, as in find_handler_clause. */
1928 maybe_call_debugger (conditions
, sig
, data
)
1929 Lisp_Object conditions
, sig
, data
;
1931 Lisp_Object combined_data
;
1933 combined_data
= Fcons (sig
, data
);
1936 /* Don't try to run the debugger with interrupts blocked.
1937 The editing loop would return anyway. */
1939 /* Does user want to enter debugger for this kind of error? */
1942 : wants_debugger (Vdebug_on_error
, conditions
))
1943 && ! skip_debugger (conditions
, combined_data
)
1944 /* rms: what's this for? */
1945 && when_entered_debugger
< num_nonmacro_input_events
)
1947 call_debugger (Fcons (Qerror
, Fcons (combined_data
, Qnil
)));
1954 /* Value of Qlambda means we have called debugger and user has continued.
1955 There are two ways to pass SIG and DATA:
1956 = SIG is the error symbol, and DATA is the rest of the data.
1957 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1958 This is for memory-full errors only.
1960 We need to increase max_specpdl_size temporarily around
1961 anything we do that can push on the specpdl, so as not to get
1962 a second error here in case we're handling specpdl overflow. */
1965 find_handler_clause (handlers
, conditions
, sig
, data
)
1966 Lisp_Object handlers
, conditions
, sig
, data
;
1968 register Lisp_Object h
;
1969 register Lisp_Object tem
;
1970 int debugger_called
= 0;
1971 int debugger_considered
= 0;
1973 /* t is used by handlers for all conditions, set up by C code. */
1974 if (EQ (handlers
, Qt
))
1977 /* Don't run the debugger for a memory-full error.
1978 (There is no room in memory to do that!) */
1980 debugger_considered
= 1;
1982 /* error is used similarly, but means print an error message
1983 and run the debugger if that is enabled. */
1984 if (EQ (handlers
, Qerror
)
1985 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1986 there is a handler. */
1988 if (!NILP (sig
) && wants_debugger (Vstack_trace_on_error
, conditions
))
1990 max_lisp_eval_depth
+= 15;
1995 internal_with_output_to_temp_buffer
1997 (Lisp_Object (*) (Lisp_Object
)) Fbacktrace
,
2000 max_lisp_eval_depth
-= 15;
2003 if (!debugger_considered
)
2005 debugger_considered
= 1;
2006 debugger_called
= maybe_call_debugger (conditions
, sig
, data
);
2009 /* If there is no handler, return saying whether we ran the debugger. */
2010 if (EQ (handlers
, Qerror
))
2012 if (debugger_called
)
2018 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
2020 Lisp_Object handler
, condit
;
2023 if (!CONSP (handler
))
2025 condit
= Fcar (handler
);
2026 /* Handle a single condition name in handler HANDLER. */
2027 if (SYMBOLP (condit
))
2029 tem
= Fmemq (Fcar (handler
), conditions
);
2033 /* Handle a list of condition names in handler HANDLER. */
2034 else if (CONSP (condit
))
2037 for (tail
= condit
; CONSP (tail
); tail
= XCDR (tail
))
2039 tem
= Fmemq (Fcar (tail
), conditions
);
2042 /* This handler is going to apply.
2043 Does it allow the debugger to run first? */
2044 if (! debugger_considered
&& !NILP (Fmemq (Qdebug
, condit
)))
2045 maybe_call_debugger (conditions
, sig
, data
);
2055 /* dump an error message; called like printf */
2059 error (m
, a1
, a2
, a3
)
2079 int used
= doprnt (buffer
, size
, m
, m
+ mlen
, 3, args
);
2084 buffer
= (char *) xrealloc (buffer
, size
);
2087 buffer
= (char *) xmalloc (size
);
2092 string
= build_string (buffer
);
2096 xsignal1 (Qerror
, string
);
2099 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
2100 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
2101 This means it contains a description for how to read arguments to give it.
2102 The value is nil for an invalid function or a symbol with no function
2105 Interactively callable functions include strings and vectors (treated
2106 as keyboard macros), lambda-expressions that contain a top-level call
2107 to `interactive', autoload definitions made by `autoload' with non-nil
2108 fourth argument, and some of the built-in functions of Lisp.
2110 Also, a symbol satisfies `commandp' if its function definition does so.
2112 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
2113 then strings and vectors are not accepted. */)
2114 (function
, for_call_interactively
)
2115 Lisp_Object function
, for_call_interactively
;
2117 register Lisp_Object fun
;
2118 register Lisp_Object funcar
;
2119 Lisp_Object if_prop
= Qnil
;
2123 fun
= indirect_function (fun
); /* Check cycles. */
2124 if (NILP (fun
) || EQ (fun
, Qunbound
))
2127 /* Check an `interactive-form' property if present, analogous to the
2128 function-documentation property. */
2130 while (SYMBOLP (fun
))
2132 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
2135 fun
= Fsymbol_function (fun
);
2138 /* Emacs primitives are interactive if their DEFUN specifies an
2139 interactive spec. */
2141 return XSUBR (fun
)->intspec
? Qt
: if_prop
;
2143 /* Bytecode objects are interactive if they are long enough to
2144 have an element whose index is COMPILED_INTERACTIVE, which is
2145 where the interactive spec is stored. */
2146 else if (COMPILEDP (fun
))
2147 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
2150 /* Strings and vectors are keyboard macros. */
2151 if (STRINGP (fun
) || VECTORP (fun
))
2152 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
2154 /* Lists may represent commands. */
2157 funcar
= XCAR (fun
);
2158 if (EQ (funcar
, Qlambda
))
2159 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
2160 if (EQ (funcar
, Qautoload
))
2161 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
2166 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
2167 doc
: /* Define FUNCTION to autoload from FILE.
2168 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
2169 Third arg DOCSTRING is documentation for the function.
2170 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
2171 Fifth arg TYPE indicates the type of the object:
2172 nil or omitted says FUNCTION is a function,
2173 `keymap' says FUNCTION is really a keymap, and
2174 `macro' or t says FUNCTION is really a macro.
2175 Third through fifth args give info about the real definition.
2176 They default to nil.
2177 If FUNCTION is already defined other than as an autoload,
2178 this does nothing and returns nil. */)
2179 (function
, file
, docstring
, interactive
, type
)
2180 Lisp_Object function
, file
, docstring
, interactive
, type
;
2182 CHECK_SYMBOL (function
);
2183 CHECK_STRING (file
);
2185 /* If function is defined and not as an autoload, don't override */
2186 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
2187 && !(CONSP (XSYMBOL (function
)->function
)
2188 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
2191 if (NILP (Vpurify_flag
))
2192 /* Only add entries after dumping, because the ones before are
2193 not useful and else we get loads of them from the loaddefs.el. */
2194 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
2196 /* We don't want the docstring in purespace (instead,
2197 Snarf-documentation should (hopefully) overwrite it).
2198 We used to use 0 here, but that leads to accidental sharing in
2199 purecopy's hash-consing, so we use a (hopefully) unique integer
2201 docstring
= make_number (XHASH (function
));
2202 return Ffset (function
,
2203 Fpurecopy (list5 (Qautoload
, file
, docstring
,
2204 interactive
, type
)));
2208 un_autoload (oldqueue
)
2209 Lisp_Object oldqueue
;
2211 register Lisp_Object queue
, first
, second
;
2213 /* Queue to unwind is current value of Vautoload_queue.
2214 oldqueue is the shadowed value to leave in Vautoload_queue. */
2215 queue
= Vautoload_queue
;
2216 Vautoload_queue
= oldqueue
;
2217 while (CONSP (queue
))
2219 first
= XCAR (queue
);
2220 second
= Fcdr (first
);
2221 first
= Fcar (first
);
2222 if (EQ (first
, make_number (0)))
2225 Ffset (first
, second
);
2226 queue
= XCDR (queue
);
2231 /* Load an autoloaded function.
2232 FUNNAME is the symbol which is the function's name.
2233 FUNDEF is the autoload definition (a list). */
2236 do_autoload (fundef
, funname
)
2237 Lisp_Object fundef
, funname
;
2239 int count
= SPECPDL_INDEX ();
2241 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2243 /* This is to make sure that loadup.el gives a clear picture
2244 of what files are preloaded and when. */
2245 if (! NILP (Vpurify_flag
))
2246 error ("Attempt to autoload %s while preparing to dump",
2247 SDATA (SYMBOL_NAME (funname
)));
2250 CHECK_SYMBOL (funname
);
2251 GCPRO3 (fun
, funname
, fundef
);
2253 /* Preserve the match data. */
2254 record_unwind_save_match_data ();
2256 /* If autoloading gets an error (which includes the error of failing
2257 to define the function being called), we use Vautoload_queue
2258 to undo function definitions and `provide' calls made by
2259 the function. We do this in the specific case of autoloading
2260 because autoloading is not an explicit request "load this file",
2261 but rather a request to "call this function".
2263 The value saved here is to be restored into Vautoload_queue. */
2264 record_unwind_protect (un_autoload
, Vautoload_queue
);
2265 Vautoload_queue
= Qt
;
2266 Fload (Fcar (Fcdr (fundef
)), Qnil
, Qt
, Qnil
, Qt
);
2268 /* Once loading finishes, don't undo it. */
2269 Vautoload_queue
= Qt
;
2270 unbind_to (count
, Qnil
);
2272 fun
= Findirect_function (fun
, Qnil
);
2274 if (!NILP (Fequal (fun
, fundef
)))
2275 error ("Autoloading failed to define function %s",
2276 SDATA (SYMBOL_NAME (funname
)));
2281 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
2282 doc
: /* Evaluate FORM and return its value. */)
2286 Lisp_Object fun
, val
, original_fun
, original_args
;
2288 struct backtrace backtrace
;
2289 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2291 if (handling_signal
)
2295 return Fsymbol_value (form
);
2300 if ((consing_since_gc
> gc_cons_threshold
2301 && consing_since_gc
> gc_relative_threshold
)
2303 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2306 Fgarbage_collect ();
2310 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2312 if (max_lisp_eval_depth
< 100)
2313 max_lisp_eval_depth
= 100;
2314 if (lisp_eval_depth
> max_lisp_eval_depth
)
2315 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2318 original_fun
= Fcar (form
);
2319 original_args
= Fcdr (form
);
2321 backtrace
.next
= backtrace_list
;
2322 backtrace_list
= &backtrace
;
2323 backtrace
.function
= &original_fun
; /* This also protects them from gc */
2324 backtrace
.args
= &original_args
;
2325 backtrace
.nargs
= UNEVALLED
;
2326 backtrace
.evalargs
= 1;
2327 backtrace
.debug_on_exit
= 0;
2329 if (debug_on_next_call
)
2330 do_debug_on_call (Qt
);
2332 /* At this point, only original_fun and original_args
2333 have values that will be used below */
2336 /* Optimize for no indirection. */
2338 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2339 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2340 fun
= indirect_function (fun
);
2344 Lisp_Object numargs
;
2345 Lisp_Object argvals
[8];
2346 Lisp_Object args_left
;
2347 register int i
, maxargs
;
2349 args_left
= original_args
;
2350 numargs
= Flength (args_left
);
2354 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
2355 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2356 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2358 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2360 backtrace
.evalargs
= 0;
2361 val
= (*XSUBR (fun
)->function
) (args_left
);
2365 if (XSUBR (fun
)->max_args
== MANY
)
2367 /* Pass a vector of evaluated arguments */
2369 register int argnum
= 0;
2371 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2373 GCPRO3 (args_left
, fun
, fun
);
2377 while (!NILP (args_left
))
2379 vals
[argnum
++] = Feval (Fcar (args_left
));
2380 args_left
= Fcdr (args_left
);
2381 gcpro3
.nvars
= argnum
;
2384 backtrace
.args
= vals
;
2385 backtrace
.nargs
= XINT (numargs
);
2387 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
2392 GCPRO3 (args_left
, fun
, fun
);
2393 gcpro3
.var
= argvals
;
2396 maxargs
= XSUBR (fun
)->max_args
;
2397 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
2399 argvals
[i
] = Feval (Fcar (args_left
));
2405 backtrace
.args
= argvals
;
2406 backtrace
.nargs
= XINT (numargs
);
2411 val
= (*XSUBR (fun
)->function
) ();
2414 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
2417 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
2420 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2424 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2425 argvals
[2], argvals
[3]);
2428 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2429 argvals
[3], argvals
[4]);
2432 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2433 argvals
[3], argvals
[4], argvals
[5]);
2436 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2437 argvals
[3], argvals
[4], argvals
[5],
2442 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2443 argvals
[3], argvals
[4], argvals
[5],
2444 argvals
[6], argvals
[7]);
2448 /* Someone has created a subr that takes more arguments than
2449 is supported by this code. We need to either rewrite the
2450 subr to use a different argument protocol, or add more
2451 cases to this switch. */
2455 if (COMPILEDP (fun
))
2456 val
= apply_lambda (fun
, original_args
, 1);
2459 if (EQ (fun
, Qunbound
))
2460 xsignal1 (Qvoid_function
, original_fun
);
2462 xsignal1 (Qinvalid_function
, original_fun
);
2463 funcar
= XCAR (fun
);
2464 if (!SYMBOLP (funcar
))
2465 xsignal1 (Qinvalid_function
, original_fun
);
2466 if (EQ (funcar
, Qautoload
))
2468 do_autoload (fun
, original_fun
);
2471 if (EQ (funcar
, Qmacro
))
2472 val
= Feval (apply1 (Fcdr (fun
), original_args
));
2473 else if (EQ (funcar
, Qlambda
))
2474 val
= apply_lambda (fun
, original_args
, 1);
2476 xsignal1 (Qinvalid_function
, original_fun
);
2482 if (backtrace
.debug_on_exit
)
2483 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2484 backtrace_list
= backtrace
.next
;
2489 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
2490 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2491 Then return the value FUNCTION returns.
2492 Thus, (apply '+ 1 2 '(3 4)) returns 10.
2493 usage: (apply FUNCTION &rest ARGUMENTS) */)
2498 register int i
, numargs
;
2499 register Lisp_Object spread_arg
;
2500 register Lisp_Object
*funcall_args
;
2502 struct gcpro gcpro1
;
2506 spread_arg
= args
[nargs
- 1];
2507 CHECK_LIST (spread_arg
);
2509 numargs
= XINT (Flength (spread_arg
));
2512 return Ffuncall (nargs
- 1, args
);
2513 else if (numargs
== 1)
2515 args
[nargs
- 1] = XCAR (spread_arg
);
2516 return Ffuncall (nargs
, args
);
2519 numargs
+= nargs
- 2;
2521 /* Optimize for no indirection. */
2522 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2523 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2524 fun
= indirect_function (fun
);
2525 if (EQ (fun
, Qunbound
))
2527 /* Let funcall get the error */
2534 if (numargs
< XSUBR (fun
)->min_args
2535 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2536 goto funcall
; /* Let funcall get the error */
2537 else if (XSUBR (fun
)->max_args
> numargs
)
2539 /* Avoid making funcall cons up a yet another new vector of arguments
2540 by explicitly supplying nil's for optional values */
2541 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
2542 * sizeof (Lisp_Object
));
2543 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2544 funcall_args
[++i
] = Qnil
;
2545 GCPRO1 (*funcall_args
);
2546 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2550 /* We add 1 to numargs because funcall_args includes the
2551 function itself as well as its arguments. */
2554 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
2555 * sizeof (Lisp_Object
));
2556 GCPRO1 (*funcall_args
);
2557 gcpro1
.nvars
= 1 + numargs
;
2560 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
2561 /* Spread the last arg we got. Its first element goes in
2562 the slot that it used to occupy, hence this value of I. */
2564 while (!NILP (spread_arg
))
2566 funcall_args
[i
++] = XCAR (spread_arg
);
2567 spread_arg
= XCDR (spread_arg
);
2570 /* By convention, the caller needs to gcpro Ffuncall's args. */
2571 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
2574 /* Run hook variables in various ways. */
2576 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
2577 static Lisp_Object run_hook_with_args
P_ ((int, Lisp_Object
*,
2578 enum run_hooks_condition
));
2580 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2581 doc
: /* Run each hook in HOOKS.
2582 Each argument should be a symbol, a hook variable.
2583 These symbols are processed in the order specified.
2584 If a hook symbol has a non-nil value, that value may be a function
2585 or a list of functions to be called to run the hook.
2586 If the value is a function, it is called with no arguments.
2587 If it is a list, the elements are called, in order, with no arguments.
2589 Major modes should not use this function directly to run their mode
2590 hook; they should use `run-mode-hooks' instead.
2592 Do not use `make-local-variable' to make a hook variable buffer-local.
2593 Instead, use `add-hook' and specify t for the LOCAL argument.
2594 usage: (run-hooks &rest HOOKS) */)
2599 Lisp_Object hook
[1];
2602 for (i
= 0; i
< nargs
; i
++)
2605 run_hook_with_args (1, hook
, to_completion
);
2611 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2612 Srun_hook_with_args
, 1, MANY
, 0,
2613 doc
: /* Run HOOK with the specified arguments ARGS.
2614 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2615 value, that value may be a function or a list of functions to be
2616 called to run the hook. If the value is a function, it is called with
2617 the given arguments and its return value is returned. If it is a list
2618 of functions, those functions are called, in order,
2619 with the given arguments ARGS.
2620 It is best not to depend on the value returned by `run-hook-with-args',
2623 Do not use `make-local-variable' to make a hook variable buffer-local.
2624 Instead, use `add-hook' and specify t for the LOCAL argument.
2625 usage: (run-hook-with-args HOOK &rest ARGS) */)
2630 return run_hook_with_args (nargs
, args
, to_completion
);
2633 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2634 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2635 doc
: /* Run HOOK with the specified arguments ARGS.
2636 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2637 value, that value may be a function or a list of functions to be
2638 called to run the hook. If the value is a function, it is called with
2639 the given arguments and its return value is returned.
2640 If it is a list of functions, those functions are called, in order,
2641 with the given arguments ARGS, until one of them
2642 returns a non-nil value. Then we return that value.
2643 However, if they all return nil, we return nil.
2645 Do not use `make-local-variable' to make a hook variable buffer-local.
2646 Instead, use `add-hook' and specify t for the LOCAL argument.
2647 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2652 return run_hook_with_args (nargs
, args
, until_success
);
2655 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2656 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2657 doc
: /* Run HOOK with the specified arguments ARGS.
2658 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2659 value, that value may be a function or a list of functions to be
2660 called to run the hook. If the value is a function, it is called with
2661 the given arguments and its return value is returned.
2662 If it is a list of functions, those functions are called, in order,
2663 with the given arguments ARGS, until one of them returns nil.
2664 Then we return nil. However, if they all return non-nil, we return non-nil.
2666 Do not use `make-local-variable' to make a hook variable buffer-local.
2667 Instead, use `add-hook' and specify t for the LOCAL argument.
2668 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2673 return run_hook_with_args (nargs
, args
, until_failure
);
2676 /* ARGS[0] should be a hook symbol.
2677 Call each of the functions in the hook value, passing each of them
2678 as arguments all the rest of ARGS (all NARGS - 1 elements).
2679 COND specifies a condition to test after each call
2680 to decide whether to stop.
2681 The caller (or its caller, etc) must gcpro all of ARGS,
2682 except that it isn't necessary to gcpro ARGS[0]. */
2685 run_hook_with_args (nargs
, args
, cond
)
2688 enum run_hooks_condition cond
;
2690 Lisp_Object sym
, val
, ret
;
2691 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2693 /* If we are dying or still initializing,
2694 don't do anything--it would probably crash if we tried. */
2695 if (NILP (Vrun_hooks
))
2699 val
= find_symbol_value (sym
);
2700 ret
= (cond
== until_failure
? Qt
: Qnil
);
2702 if (EQ (val
, Qunbound
) || NILP (val
))
2704 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2707 return Ffuncall (nargs
, args
);
2711 Lisp_Object globals
= Qnil
;
2712 GCPRO3 (sym
, val
, globals
);
2715 CONSP (val
) && ((cond
== to_completion
)
2716 || (cond
== until_success
? NILP (ret
)
2720 if (EQ (XCAR (val
), Qt
))
2722 /* t indicates this hook has a local binding;
2723 it means to run the global binding too. */
2724 globals
= Fdefault_value (sym
);
2725 if (NILP (globals
)) continue;
2727 if (!CONSP (globals
) || EQ (XCAR (globals
), Qlambda
))
2730 ret
= Ffuncall (nargs
, args
);
2735 CONSP (globals
) && ((cond
== to_completion
)
2736 || (cond
== until_success
? NILP (ret
)
2738 globals
= XCDR (globals
))
2740 args
[0] = XCAR (globals
);
2741 /* In a global value, t should not occur. If it does, we
2742 must ignore it to avoid an endless loop. */
2743 if (!EQ (args
[0], Qt
))
2744 ret
= Ffuncall (nargs
, args
);
2750 args
[0] = XCAR (val
);
2751 ret
= Ffuncall (nargs
, args
);
2760 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2761 present value of that symbol.
2762 Call each element of FUNLIST,
2763 passing each of them the rest of ARGS.
2764 The caller (or its caller, etc) must gcpro all of ARGS,
2765 except that it isn't necessary to gcpro ARGS[0]. */
2768 run_hook_list_with_args (funlist
, nargs
, args
)
2769 Lisp_Object funlist
;
2775 Lisp_Object globals
;
2776 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2780 GCPRO3 (sym
, val
, globals
);
2782 for (val
= funlist
; CONSP (val
); val
= XCDR (val
))
2784 if (EQ (XCAR (val
), Qt
))
2786 /* t indicates this hook has a local binding;
2787 it means to run the global binding too. */
2789 for (globals
= Fdefault_value (sym
);
2791 globals
= XCDR (globals
))
2793 args
[0] = XCAR (globals
);
2794 /* In a global value, t should not occur. If it does, we
2795 must ignore it to avoid an endless loop. */
2796 if (!EQ (args
[0], Qt
))
2797 Ffuncall (nargs
, args
);
2802 args
[0] = XCAR (val
);
2803 Ffuncall (nargs
, args
);
2810 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2813 run_hook_with_args_2 (hook
, arg1
, arg2
)
2814 Lisp_Object hook
, arg1
, arg2
;
2816 Lisp_Object temp
[3];
2821 Frun_hook_with_args (3, temp
);
2824 /* Apply fn to arg */
2827 Lisp_Object fn
, arg
;
2829 struct gcpro gcpro1
;
2833 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2836 Lisp_Object args
[2];
2840 RETURN_UNGCPRO (Fapply (2, args
));
2844 /* Call function fn on no arguments */
2849 struct gcpro gcpro1
;
2852 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2855 /* Call function fn with 1 argument arg1 */
2859 Lisp_Object fn
, arg1
;
2861 struct gcpro gcpro1
;
2862 Lisp_Object args
[2];
2868 RETURN_UNGCPRO (Ffuncall (2, args
));
2871 /* Call function fn with 2 arguments arg1, arg2 */
2874 call2 (fn
, arg1
, arg2
)
2875 Lisp_Object fn
, arg1
, arg2
;
2877 struct gcpro gcpro1
;
2878 Lisp_Object args
[3];
2884 RETURN_UNGCPRO (Ffuncall (3, args
));
2887 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2890 call3 (fn
, arg1
, arg2
, arg3
)
2891 Lisp_Object fn
, arg1
, arg2
, arg3
;
2893 struct gcpro gcpro1
;
2894 Lisp_Object args
[4];
2901 RETURN_UNGCPRO (Ffuncall (4, args
));
2904 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2907 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2908 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2910 struct gcpro gcpro1
;
2911 Lisp_Object args
[5];
2919 RETURN_UNGCPRO (Ffuncall (5, args
));
2922 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2925 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2926 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2928 struct gcpro gcpro1
;
2929 Lisp_Object args
[6];
2938 RETURN_UNGCPRO (Ffuncall (6, args
));
2941 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2944 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2945 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2947 struct gcpro gcpro1
;
2948 Lisp_Object args
[7];
2958 RETURN_UNGCPRO (Ffuncall (7, args
));
2961 /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7 */
2964 call7 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
)
2965 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
, arg7
;
2967 struct gcpro gcpro1
;
2968 Lisp_Object args
[8];
2979 RETURN_UNGCPRO (Ffuncall (8, args
));
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
, Qnil
, 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
, Qnil
, 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 /* If `where' is non-nil, reset the value in the appropriate
3462 local binding, but only if that binding still exists. */
3463 else if (BUFFERP (where
))
3466 ? !NILP (Flocal_variable_p (symbol
, where
))
3467 : !NILP (Fassq (symbol
, XFRAME (where
)->param_alist
)))
3468 set_internal (symbol
, this_binding
.old_value
, where
, 1);
3471 /* If variable has a trivial value (no forwarding), we can
3472 just set it. No need to check for constant symbols here,
3473 since that was already done by specbind. */
3474 else if (XSYMBOL (this_binding
.symbol
)->redirect
== SYMBOL_PLAINVAL
)
3475 SET_SYMBOL_VAL (XSYMBOL (this_binding
.symbol
),
3476 this_binding
.old_value
);
3478 /* NOTE: we only ever come here if make_local_foo was used for
3479 the first time on this var within this let. */
3480 Fset_default (this_binding
.symbol
, this_binding
.old_value
);
3483 if (NILP (Vquit_flag
) && !NILP (quitf
))
3490 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3491 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3492 The debugger is entered when that frame exits, if the flag is non-nil. */)
3494 Lisp_Object level
, flag
;
3496 register struct backtrace
*backlist
= backtrace_list
;
3499 CHECK_NUMBER (level
);
3501 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
3503 backlist
= backlist
->next
;
3507 backlist
->debug_on_exit
= !NILP (flag
);
3512 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3513 doc
: /* Print a trace of Lisp function calls currently active.
3514 Output stream used is value of `standard-output'. */)
3517 register struct backtrace
*backlist
= backtrace_list
;
3521 extern Lisp_Object Vprint_level
;
3522 struct gcpro gcpro1
;
3524 XSETFASTINT (Vprint_level
, 3);
3531 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
3532 if (backlist
->nargs
== UNEVALLED
)
3534 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
3535 write_string ("\n", -1);
3539 tem
= *backlist
->function
;
3540 Fprin1 (tem
, Qnil
); /* This can QUIT */
3541 write_string ("(", -1);
3542 if (backlist
->nargs
== MANY
)
3544 for (tail
= *backlist
->args
, i
= 0;
3546 tail
= Fcdr (tail
), i
++)
3548 if (i
) write_string (" ", -1);
3549 Fprin1 (Fcar (tail
), Qnil
);
3554 for (i
= 0; i
< backlist
->nargs
; i
++)
3556 if (i
) write_string (" ", -1);
3557 Fprin1 (backlist
->args
[i
], Qnil
);
3560 write_string (")\n", -1);
3562 backlist
= backlist
->next
;
3565 Vprint_level
= Qnil
;
3570 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, NULL
,
3571 doc
: /* Return the function and arguments NFRAMES up from current execution point.
3572 If that frame has not evaluated the arguments yet (or is a special form),
3573 the value is (nil FUNCTION ARG-FORMS...).
3574 If that frame has evaluated its arguments and called its function already,
3575 the value is (t FUNCTION ARG-VALUES...).
3576 A &rest arg is represented as the tail of the list ARG-VALUES.
3577 FUNCTION is whatever was supplied as car of evaluated list,
3578 or a lambda expression for macro calls.
3579 If NFRAMES is more than the number of frames, the value is nil. */)
3581 Lisp_Object nframes
;
3583 register struct backtrace
*backlist
= backtrace_list
;
3587 CHECK_NATNUM (nframes
);
3589 /* Find the frame requested. */
3590 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3591 backlist
= backlist
->next
;
3595 if (backlist
->nargs
== UNEVALLED
)
3596 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3599 if (backlist
->nargs
== MANY
)
3600 tem
= *backlist
->args
;
3602 tem
= Flist (backlist
->nargs
, backlist
->args
);
3604 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3612 register struct backtrace
*backlist
;
3615 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3617 mark_object (*backlist
->function
);
3619 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3622 i
= backlist
->nargs
- 1;
3624 mark_object (backlist
->args
[i
]);
3631 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
3632 doc
: /* *Limit on number of Lisp variable bindings and `unwind-protect's.
3633 If Lisp code tries to increase the total number past this amount,
3634 an error is signaled.
3635 You can safely use a value considerably larger than the default value,
3636 if that proves inconveniently small. However, if you increase it too far,
3637 Emacs could run out of memory trying to make the stack bigger. */);
3639 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
3640 doc
: /* *Limit on depth in `eval', `apply' and `funcall' before error.
3642 This limit serves to catch infinite recursions for you before they cause
3643 actual stack overflow in C, which would be fatal for Emacs.
3644 You can safely make it considerably larger than its default value,
3645 if that proves inconveniently small. However, if you increase it too far,
3646 Emacs could overflow the real C stack, and crash. */);
3648 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
3649 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3650 If the value is t, that means do an ordinary quit.
3651 If the value equals `throw-on-input', that means quit by throwing
3652 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3653 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3654 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3657 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
3658 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3659 Note that `quit-flag' will still be set by typing C-g,
3660 so a quit will be signaled as soon as `inhibit-quit' is nil.
3661 To prevent this happening, set `quit-flag' to nil
3662 before making `inhibit-quit' nil. */);
3663 Vinhibit_quit
= Qnil
;
3665 Qinhibit_quit
= intern_c_string ("inhibit-quit");
3666 staticpro (&Qinhibit_quit
);
3668 Qautoload
= intern_c_string ("autoload");
3669 staticpro (&Qautoload
);
3671 Qdebug_on_error
= intern_c_string ("debug-on-error");
3672 staticpro (&Qdebug_on_error
);
3674 Qmacro
= intern_c_string ("macro");
3675 staticpro (&Qmacro
);
3677 Qdeclare
= intern_c_string ("declare");
3678 staticpro (&Qdeclare
);
3680 /* Note that the process handling also uses Qexit, but we don't want
3681 to staticpro it twice, so we just do it here. */
3682 Qexit
= intern_c_string ("exit");
3685 Qinteractive
= intern_c_string ("interactive");
3686 staticpro (&Qinteractive
);
3688 Qcommandp
= intern_c_string ("commandp");
3689 staticpro (&Qcommandp
);
3691 Qdefun
= intern_c_string ("defun");
3692 staticpro (&Qdefun
);
3694 Qand_rest
= intern_c_string ("&rest");
3695 staticpro (&Qand_rest
);
3697 Qand_optional
= intern_c_string ("&optional");
3698 staticpro (&Qand_optional
);
3700 Qdebug
= intern_c_string ("debug");
3701 staticpro (&Qdebug
);
3703 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
3704 doc
: /* *Non-nil means errors display a backtrace buffer.
3705 More precisely, this happens for any error that is handled
3706 by the editor command loop.
3707 If the value is a list, an error only means to display a backtrace
3708 if one of its condition symbols appears in the list. */);
3709 Vstack_trace_on_error
= Qnil
;
3711 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
3712 doc
: /* *Non-nil means enter debugger if an error is signaled.
3713 Does not apply to errors handled by `condition-case' or those
3714 matched by `debug-ignored-errors'.
3715 If the value is a list, an error only means to enter the debugger
3716 if one of its condition symbols appears in the list.
3717 When you evaluate an expression interactively, this variable
3718 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3719 The command `toggle-debug-on-error' toggles this.
3720 See also the variable `debug-on-quit'. */);
3721 Vdebug_on_error
= Qnil
;
3723 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
3724 doc
: /* *List of errors for which the debugger should not be called.
3725 Each element may be a condition-name or a regexp that matches error messages.
3726 If any element applies to a given error, that error skips the debugger
3727 and just returns to top level.
3728 This overrides the variable `debug-on-error'.
3729 It does not apply to errors handled by `condition-case'. */);
3730 Vdebug_ignored_errors
= Qnil
;
3732 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
3733 doc
: /* *Non-nil means enter debugger if quit is signaled (C-g, for example).
3734 Does not apply if quit is handled by a `condition-case'. */);
3737 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
3738 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3740 DEFVAR_BOOL ("debugger-may-continue", &debugger_may_continue
,
3741 doc
: /* Non-nil means debugger may continue execution.
3742 This is nil when the debugger is called under circumstances where it
3743 might not be safe to continue. */);
3744 debugger_may_continue
= 1;
3746 DEFVAR_LISP ("debugger", &Vdebugger
,
3747 doc
: /* Function to call to invoke debugger.
3748 If due to frame exit, args are `exit' and the value being returned;
3749 this function's value will be returned instead of that.
3750 If due to error, args are `error' and a list of the args to `signal'.
3751 If due to `apply' or `funcall' entry, one arg, `lambda'.
3752 If due to `eval' entry, one arg, t. */);
3755 DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function
,
3756 doc
: /* If non-nil, this is a function for `signal' to call.
3757 It receives the same arguments that `signal' was given.
3758 The Edebug package uses this to regain control. */);
3759 Vsignal_hook_function
= Qnil
;
3761 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal
,
3762 doc
: /* *Non-nil means call the debugger regardless of condition handlers.
3763 Note that `debug-on-error', `debug-on-quit' and friends
3764 still determine whether to handle the particular condition. */);
3765 Vdebug_on_signal
= Qnil
;
3767 DEFVAR_LISP ("macro-declaration-function", &Vmacro_declaration_function
,
3768 doc
: /* Function to process declarations in a macro definition.
3769 The function will be called with two args MACRO and DECL.
3770 MACRO is the name of the macro being defined.
3771 DECL is a list `(declare ...)' containing the declarations.
3772 The value the function returns is not used. */);
3773 Vmacro_declaration_function
= Qnil
;
3775 Vrun_hooks
= intern_c_string ("run-hooks");
3776 staticpro (&Vrun_hooks
);
3778 staticpro (&Vautoload_queue
);
3779 Vautoload_queue
= Qnil
;
3780 staticpro (&Vsignaling_function
);
3781 Vsignaling_function
= Qnil
;
3792 defsubr (&Sfunction
);
3794 defsubr (&Sdefmacro
);
3796 defsubr (&Sdefvaralias
);
3797 defsubr (&Sdefconst
);
3798 defsubr (&Suser_variable_p
);
3802 defsubr (&Smacroexpand
);
3805 defsubr (&Sunwind_protect
);
3806 defsubr (&Scondition_case
);
3808 defsubr (&Sinteractive_p
);
3809 defsubr (&Scalled_interactively_p
);
3810 defsubr (&Scommandp
);
3811 defsubr (&Sautoload
);
3814 defsubr (&Sfuncall
);
3815 defsubr (&Srun_hooks
);
3816 defsubr (&Srun_hook_with_args
);
3817 defsubr (&Srun_hook_with_args_until_success
);
3818 defsubr (&Srun_hook_with_args_until_failure
);
3819 defsubr (&Sfetch_bytecode
);
3820 defsubr (&Sbacktrace_debug
);
3821 defsubr (&Sbacktrace
);
3822 defsubr (&Sbacktrace_frame
);
3825 /* arch-tag: 014a07aa-33ab-4a8f-a3d2-ee8a4a9ff7fb
3826 (do not change this comment) */