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 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
20 Boston, MA 02110-1301, USA. */
25 #include "blockinput.h"
28 #include "dispextern.h"
31 /* This definition is duplicated in alloc.c and keyboard.c */
32 /* Putting it in lisp.h makes cc bomb out! */
36 struct backtrace
*next
;
37 Lisp_Object
*function
;
38 Lisp_Object
*args
; /* Points to vector of args. */
39 int nargs
; /* Length of vector.
40 If nargs is UNEVALLED, args points to slot holding
41 list of unevalled args */
43 /* Nonzero means call value of debugger when done with this operation. */
47 struct backtrace
*backtrace_list
;
49 /* This structure helps implement the `catch' and `throw' control
50 structure. A struct catchtag contains all the information needed
51 to restore the state of the interpreter after a non-local jump.
53 Handlers for error conditions (represented by `struct handler'
54 structures) just point to a catch tag to do the cleanup required
57 catchtag structures are chained together in the C calling stack;
58 the `next' member points to the next outer catchtag.
60 A call like (throw TAG VAL) searches for a catchtag whose `tag'
61 member is TAG, and then unbinds to it. The `val' member is used to
62 hold VAL while the stack is unwound; `val' is returned as the value
65 All the other members are concerned with restoring the interpreter
72 struct catchtag
*next
;
75 struct backtrace
*backlist
;
76 struct handler
*handlerlist
;
79 int poll_suppress_count
;
80 int interrupt_input_blocked
;
81 struct byte_stack
*byte_stack
;
84 struct catchtag
*catchlist
;
87 /* Count levels of GCPRO to detect failure to UNGCPRO. */
91 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
92 Lisp_Object Qinhibit_quit
, Vinhibit_quit
, Vquit_flag
;
93 Lisp_Object Qand_rest
, Qand_optional
;
94 Lisp_Object Qdebug_on_error
;
97 /* This holds either the symbol `run-hooks' or nil.
98 It is nil at an early stage of startup, and when Emacs
101 Lisp_Object Vrun_hooks
;
103 /* Non-nil means record all fset's and provide's, to be undone
104 if the file being autoloaded is not fully loaded.
105 They are recorded by being consed onto the front of Vautoload_queue:
106 (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide. */
108 Lisp_Object Vautoload_queue
;
110 /* Current number of specbindings allocated in specpdl. */
114 /* Pointer to beginning of specpdl. */
116 struct specbinding
*specpdl
;
118 /* Pointer to first unused element in specpdl. */
120 struct specbinding
*specpdl_ptr
;
122 /* Maximum size allowed for specpdl allocation */
124 EMACS_INT max_specpdl_size
;
126 /* Depth in Lisp evaluations and function calls. */
130 /* Maximum allowed depth in Lisp evaluations and function calls. */
132 EMACS_INT max_lisp_eval_depth
;
134 /* Nonzero means enter debugger before next function call */
136 int debug_on_next_call
;
138 /* Non-zero means debugger may continue. This is zero when the
139 debugger is called during redisplay, where it might not be safe to
140 continue the interrupted redisplay. */
142 int debugger_may_continue
;
144 /* List of conditions (non-nil atom means all) which cause a backtrace
145 if an error is handled by the command loop's error handler. */
147 Lisp_Object Vstack_trace_on_error
;
149 /* List of conditions (non-nil atom means all) which enter the debugger
150 if an error is handled by the command loop's error handler. */
152 Lisp_Object Vdebug_on_error
;
154 /* List of conditions and regexps specifying error messages which
155 do not enter the debugger even if Vdebug_on_error says they should. */
157 Lisp_Object Vdebug_ignored_errors
;
159 /* Non-nil means call the debugger even if the error will be handled. */
161 Lisp_Object Vdebug_on_signal
;
163 /* Hook for edebug to use. */
165 Lisp_Object Vsignal_hook_function
;
167 /* Nonzero means enter debugger if a quit signal
168 is handled by the command loop's error handler. */
172 /* The value of num_nonmacro_input_events as of the last time we
173 started to enter the debugger. If we decide to enter the debugger
174 again when this is still equal to num_nonmacro_input_events, then we
175 know that the debugger itself has an error, and we should just
176 signal the error instead of entering an infinite loop of debugger
179 int when_entered_debugger
;
181 Lisp_Object Vdebugger
;
183 /* The function from which the last `signal' was called. Set in
186 Lisp_Object Vsignaling_function
;
188 /* Set to non-zero while processing X events. Checked in Feval to
189 make sure the Lisp interpreter isn't called from a signal handler,
190 which is unsafe because the interpreter isn't reentrant. */
194 /* Function to process declarations in defmacro forms. */
196 Lisp_Object Vmacro_declaration_function
;
199 static Lisp_Object funcall_lambda
P_ ((Lisp_Object
, int, Lisp_Object
*));
205 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
206 specpdl_ptr
= specpdl
;
207 max_specpdl_size
= 1000;
208 max_lisp_eval_depth
= 300;
216 specpdl_ptr
= specpdl
;
221 debug_on_next_call
= 0;
226 /* This is less than the initial value of num_nonmacro_input_events. */
227 when_entered_debugger
= -1;
230 /* unwind-protect function used by call_debugger. */
233 restore_stack_limits (data
)
236 max_specpdl_size
= XINT (XCAR (data
));
237 max_lisp_eval_depth
= XINT (XCDR (data
));
241 /* Call the Lisp debugger, giving it argument ARG. */
247 int debug_while_redisplaying
;
248 int count
= SPECPDL_INDEX ();
250 int old_max
= max_specpdl_size
;
252 /* Temporarily bump up the stack limits,
253 so the debugger won't run out of stack. */
255 max_specpdl_size
+= 1;
256 record_unwind_protect (restore_stack_limits
,
257 Fcons (make_number (old_max
),
258 make_number (max_lisp_eval_depth
)));
259 max_specpdl_size
= old_max
;
261 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
262 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
264 if (SPECPDL_INDEX () + 100 > max_specpdl_size
)
265 max_specpdl_size
= SPECPDL_INDEX () + 100;
267 #ifdef HAVE_X_WINDOWS
268 if (display_hourglass_p
)
272 debug_on_next_call
= 0;
273 when_entered_debugger
= num_nonmacro_input_events
;
275 /* Resetting redisplaying_p to 0 makes sure that debug output is
276 displayed if the debugger is invoked during redisplay. */
277 debug_while_redisplaying
= redisplaying_p
;
279 specbind (intern ("debugger-may-continue"),
280 debug_while_redisplaying
? Qnil
: Qt
);
281 specbind (Qinhibit_redisplay
, Qnil
);
282 specbind (Qdebug_on_error
, Qnil
);
284 #if 0 /* Binding this prevents execution of Lisp code during
285 redisplay, which necessarily leads to display problems. */
286 specbind (Qinhibit_eval_during_redisplay
, Qt
);
289 val
= apply1 (Vdebugger
, arg
);
291 /* Interrupting redisplay and resuming it later is not safe under
292 all circumstances. So, when the debugger returns, abort the
293 interrupted redisplay by going back to the top-level. */
294 if (debug_while_redisplaying
)
297 return unbind_to (count
, val
);
301 do_debug_on_call (code
)
304 debug_on_next_call
= 0;
305 backtrace_list
->debug_on_exit
= 1;
306 call_debugger (Fcons (code
, Qnil
));
309 /* NOTE!!! Every function that can call EVAL must protect its args
310 and temporaries from garbage collection while it needs them.
311 The definition of `For' shows what you have to do. */
313 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
314 doc
: /* Eval args until one of them yields non-nil, then return that value.
315 The remaining args are not evalled at all.
316 If all args return nil, return nil.
317 usage: (or CONDITIONS ...) */)
321 register Lisp_Object val
= Qnil
;
328 val
= Feval (XCAR (args
));
338 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
339 doc
: /* Eval args until one of them yields nil, then return nil.
340 The remaining args are not evalled at all.
341 If no arg yields nil, return the last arg's value.
342 usage: (and CONDITIONS ...) */)
346 register Lisp_Object val
= Qt
;
353 val
= Feval (XCAR (args
));
363 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
364 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
365 Returns the value of THEN or the value of the last of the ELSE's.
366 THEN must be one expression, but ELSE... can be zero or more expressions.
367 If COND yields nil, and there are no ELSE's, the value is nil.
368 usage: (if COND THEN ELSE...) */)
372 register Lisp_Object cond
;
376 cond
= Feval (Fcar (args
));
380 return Feval (Fcar (Fcdr (args
)));
381 return Fprogn (Fcdr (Fcdr (args
)));
384 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
385 doc
: /* Try each clause until one succeeds.
386 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
387 and, if the value is non-nil, this clause succeeds:
388 then the expressions in BODY are evaluated and the last one's
389 value is the value of the cond-form.
390 If no clause succeeds, cond returns nil.
391 If a clause has one element, as in (CONDITION),
392 CONDITION's value if non-nil is returned from the cond-form.
393 usage: (cond CLAUSES...) */)
397 register Lisp_Object clause
, val
;
404 clause
= Fcar (args
);
405 val
= Feval (Fcar (clause
));
408 if (!EQ (XCDR (clause
), Qnil
))
409 val
= Fprogn (XCDR (clause
));
419 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
420 doc
: /* Eval BODY forms sequentially and return value of last one.
421 usage: (progn BODY ...) */)
425 register Lisp_Object val
= Qnil
;
432 val
= Feval (XCAR (args
));
440 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
441 doc
: /* Eval FIRST and BODY sequentially; value from FIRST.
442 The value of FIRST is saved during the evaluation of the remaining args,
443 whose values are discarded.
444 usage: (prog1 FIRST BODY...) */)
449 register Lisp_Object args_left
;
450 struct gcpro gcpro1
, gcpro2
;
451 register int argnum
= 0;
463 val
= Feval (Fcar (args_left
));
465 Feval (Fcar (args_left
));
466 args_left
= Fcdr (args_left
);
468 while (!NILP(args_left
));
474 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
475 doc
: /* Eval FORM1, FORM2 and BODY sequentially; value from FORM2.
476 The value of FORM2 is saved during the evaluation of the
477 remaining args, whose values are discarded.
478 usage: (prog2 FORM1 FORM2 BODY...) */)
483 register Lisp_Object args_left
;
484 struct gcpro gcpro1
, gcpro2
;
485 register int argnum
= -1;
499 val
= Feval (Fcar (args_left
));
501 Feval (Fcar (args_left
));
502 args_left
= Fcdr (args_left
);
504 while (!NILP (args_left
));
510 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
511 doc
: /* Set each SYM to the value of its VAL.
512 The symbols SYM are variables; they are literal (not evaluated).
513 The values VAL are expressions; they are evaluated.
514 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
515 The second VAL is not computed until after the first SYM is set, and so on;
516 each VAL can use the new value of variables set earlier in the `setq'.
517 The return value of the `setq' form is the value of the last VAL.
518 usage: (setq SYM VAL SYM VAL ...) */)
522 register Lisp_Object args_left
;
523 register Lisp_Object val
, sym
;
534 val
= Feval (Fcar (Fcdr (args_left
)));
535 sym
= Fcar (args_left
);
537 args_left
= Fcdr (Fcdr (args_left
));
539 while (!NILP(args_left
));
545 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
546 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
547 usage: (quote ARG) */)
554 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
555 doc
: /* Like `quote', but preferred for objects which are functions.
556 In byte compilation, `function' causes its argument to be compiled.
557 `quote' cannot do that.
558 usage: (function ARG) */)
566 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
567 doc
: /* Return t if the function was run directly by user input.
568 This means that the function was called with `call-interactively'
569 \(which includes being called as the binding of a key)
570 and input is currently coming from the keyboard (not in keyboard macro),
571 and Emacs is not running in batch mode (`noninteractive' is nil).
573 The only known proper use of `interactive-p' is in deciding whether to
574 display a helpful message, or how to display it. If you're thinking
575 of using it for any other purpose, it is quite likely that you're
576 making a mistake. Think: what do you want to do when the command is
577 called from a keyboard macro?
579 If you want to test whether your function was called with
580 `call-interactively', the way to do that is by adding an extra
581 optional argument, and making the `interactive' spec specify non-nil
582 unconditionally for that argument. (`p' is a good way to do this.) */)
585 return (INTERACTIVE
&& interactive_p (1)) ? Qt
: Qnil
;
589 DEFUN ("called-interactively-p", Fcalled_interactively_p
, Scalled_interactively_p
, 0, 0, 0,
590 doc
: /* Return t if the function using this was called with `call-interactively'.
591 This is used for implementing advice and other function-modifying
594 The cleanest way to test whether your function was called with
595 `call-interactively' is by adding an extra optional argument,
596 and making the `interactive' spec specify non-nil unconditionally
597 for that argument. (`p' is a good way to do this.) */)
600 return interactive_p (1) ? Qt
: Qnil
;
604 /* Return 1 if function in which this appears was called using
607 EXCLUDE_SUBRS_P non-zero means always return 0 if the function
608 called is a built-in. */
611 interactive_p (exclude_subrs_p
)
614 struct backtrace
*btp
;
617 btp
= backtrace_list
;
619 /* If this isn't a byte-compiled function, there may be a frame at
620 the top for Finteractive_p. If so, skip it. */
621 fun
= Findirect_function (*btp
->function
, Qnil
);
622 if (SUBRP (fun
) && (XSUBR (fun
) == &Sinteractive_p
623 || XSUBR (fun
) == &Scalled_interactively_p
))
626 /* If we're running an Emacs 18-style byte-compiled function, there
627 may be a frame for Fbytecode at the top level. In any version of
628 Emacs there can be Fbytecode frames for subexpressions evaluated
629 inside catch and condition-case. Skip past them.
631 If this isn't a byte-compiled function, then we may now be
632 looking at several frames for special forms. Skip past them. */
634 && (EQ (*btp
->function
, Qbytecode
)
635 || btp
->nargs
== UNEVALLED
))
638 /* btp now points at the frame of the innermost function that isn't
639 a special form, ignoring frames for Finteractive_p and/or
640 Fbytecode at the top. If this frame is for a built-in function
641 (such as load or eval-region) return nil. */
642 fun
= Findirect_function (*btp
->function
, Qnil
);
643 if (exclude_subrs_p
&& SUBRP (fun
))
646 /* btp points to the frame of a Lisp function that called interactive-p.
647 Return t if that function was called interactively. */
648 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
654 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
655 doc
: /* Define NAME as a function.
656 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
657 See also the function `interactive'.
658 usage: (defun NAME ARGLIST [DOCSTRING] BODY...) */)
662 register Lisp_Object fn_name
;
663 register Lisp_Object defn
;
665 fn_name
= Fcar (args
);
666 CHECK_SYMBOL (fn_name
);
667 defn
= Fcons (Qlambda
, Fcdr (args
));
668 if (!NILP (Vpurify_flag
))
669 defn
= Fpurecopy (defn
);
670 if (CONSP (XSYMBOL (fn_name
)->function
)
671 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
672 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
673 Ffset (fn_name
, defn
);
674 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
678 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
679 doc
: /* Define NAME as a macro.
680 The actual definition looks like
681 (macro lambda ARGLIST [DOCSTRING] [DECL] BODY...).
682 When the macro is called, as in (NAME ARGS...),
683 the function (lambda ARGLIST BODY...) is applied to
684 the list ARGS... as it appears in the expression,
685 and the result should be a form to be evaluated instead of the original.
687 DECL is a declaration, optional, which can specify how to indent
688 calls to this macro and how Edebug should handle it. It looks like this:
690 The elements can look like this:
692 Set NAME's `lisp-indent-function' property to INDENT.
695 Set NAME's `edebug-form-spec' property to DEBUG. (This is
696 equivalent to writing a `def-edebug-spec' for the macro.)
697 usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */)
701 register Lisp_Object fn_name
;
702 register Lisp_Object defn
;
703 Lisp_Object lambda_list
, doc
, tail
;
705 fn_name
= Fcar (args
);
706 CHECK_SYMBOL (fn_name
);
707 lambda_list
= Fcar (Fcdr (args
));
708 tail
= Fcdr (Fcdr (args
));
711 if (STRINGP (Fcar (tail
)))
717 while (CONSP (Fcar (tail
))
718 && EQ (Fcar (Fcar (tail
)), Qdeclare
))
720 if (!NILP (Vmacro_declaration_function
))
724 call2 (Vmacro_declaration_function
, fn_name
, Fcar (tail
));
732 tail
= Fcons (lambda_list
, tail
);
734 tail
= Fcons (lambda_list
, Fcons (doc
, tail
));
735 defn
= Fcons (Qmacro
, Fcons (Qlambda
, tail
));
737 if (!NILP (Vpurify_flag
))
738 defn
= Fpurecopy (defn
);
739 if (CONSP (XSYMBOL (fn_name
)->function
)
740 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
741 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
742 Ffset (fn_name
, defn
);
743 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
748 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
749 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
750 Setting the value of NEW-ALIAS will subsequently set the value of BASE-VARIABLE,
751 and getting the value of NEW-ALIAS will return the value BASE-VARIABLE has.
752 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
753 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
754 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
756 The return value is BASE-VARIABLE. */)
757 (new_alias
, base_variable
, docstring
)
758 Lisp_Object new_alias
, base_variable
, docstring
;
760 struct Lisp_Symbol
*sym
;
762 CHECK_SYMBOL (new_alias
);
763 CHECK_SYMBOL (base_variable
);
765 if (SYMBOL_CONSTANT_P (new_alias
))
766 error ("Cannot make a constant an alias");
768 sym
= XSYMBOL (new_alias
);
769 sym
->indirect_variable
= 1;
770 sym
->value
= base_variable
;
771 sym
->constant
= SYMBOL_CONSTANT_P (base_variable
);
772 LOADHIST_ATTACH (new_alias
);
773 if (!NILP (docstring
))
774 Fput (new_alias
, Qvariable_documentation
, docstring
);
776 Fput (new_alias
, Qvariable_documentation
, Qnil
);
778 return base_variable
;
782 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
783 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
784 You are not required to define a variable in order to use it,
785 but the definition can supply documentation and an initial value
786 in a way that tags can recognize.
788 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.
789 If SYMBOL is buffer-local, its default value is what is set;
790 buffer-local values are not affected.
791 INITVALUE and DOCSTRING are optional.
792 If DOCSTRING starts with *, this variable is identified as a user option.
793 This means that M-x set-variable recognizes it.
794 See also `user-variable-p'.
795 If INITVALUE is missing, SYMBOL's value is not set.
797 If SYMBOL has a local binding, then this form affects the local
798 binding. This is usually not what you want. Thus, if you need to
799 load a file defining variables, with this form or with `defconst' or
800 `defcustom', you should always load that file _outside_ any bindings
801 for these variables. \(`defconst' and `defcustom' behave similarly in
803 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
807 register Lisp_Object sym
, tem
, tail
;
811 if (!NILP (Fcdr (Fcdr (tail
))))
812 error ("Too many arguments");
814 tem
= Fdefault_boundp (sym
);
817 if (SYMBOL_CONSTANT_P (sym
))
819 /* For upward compatibility, allow (defvar :foo (quote :foo)). */
820 Lisp_Object tem
= Fcar (tail
);
822 && EQ (XCAR (tem
), Qquote
)
823 && CONSP (XCDR (tem
))
824 && EQ (XCAR (XCDR (tem
)), sym
)))
825 error ("Constant symbol `%s' specified in defvar",
826 SDATA (SYMBOL_NAME (sym
)));
830 Fset_default (sym
, Feval (Fcar (tail
)));
832 { /* Check if there is really a global binding rather than just a let
833 binding that shadows the global unboundness of the var. */
834 volatile struct specbinding
*pdl
= specpdl_ptr
;
835 while (--pdl
>= specpdl
)
837 if (EQ (pdl
->symbol
, sym
) && !pdl
->func
838 && EQ (pdl
->old_value
, Qunbound
))
840 message_with_string ("Warning: defvar ignored because %s is let-bound",
841 SYMBOL_NAME (sym
), 1);
850 if (!NILP (Vpurify_flag
))
851 tem
= Fpurecopy (tem
);
852 Fput (sym
, Qvariable_documentation
, tem
);
854 LOADHIST_ATTACH (sym
);
857 /* Simple (defvar <var>) should not count as a definition at all.
858 It could get in the way of other definitions, and unloading this
859 package could try to make the variable unbound. */
865 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
866 doc
: /* Define SYMBOL as a constant variable.
867 The intent is that neither programs nor users should ever change this value.
868 Always sets the value of SYMBOL to the result of evalling INITVALUE.
869 If SYMBOL is buffer-local, its default value is what is set;
870 buffer-local values are not affected.
871 DOCSTRING is optional.
873 If SYMBOL has a local binding, then this form sets the local binding's
874 value. However, you should normally not make local bindings for
875 variables defined with this form.
876 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
880 register Lisp_Object sym
, tem
;
883 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
884 error ("Too many arguments");
886 tem
= Feval (Fcar (Fcdr (args
)));
887 if (!NILP (Vpurify_flag
))
888 tem
= Fpurecopy (tem
);
889 Fset_default (sym
, tem
);
890 tem
= Fcar (Fcdr (Fcdr (args
)));
893 if (!NILP (Vpurify_flag
))
894 tem
= Fpurecopy (tem
);
895 Fput (sym
, Qvariable_documentation
, tem
);
897 LOADHIST_ATTACH (sym
);
901 /* Error handler used in Fuser_variable_p. */
903 user_variable_p_eh (ignore
)
909 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
910 doc
: /* Return t if VARIABLE is intended to be set and modified by users.
911 \(The alternative is a variable used internally in a Lisp program.)
912 A variable is a user variable if
913 \(1) the first character of its documentation is `*', or
914 \(2) it is customizable (its property list contains a non-nil value
915 of `standard-value' or `custom-autoload'), or
916 \(3) it is an alias for another user variable.
917 Return nil if VARIABLE is an alias and there is a loop in the
918 chain of symbols. */)
920 Lisp_Object variable
;
922 Lisp_Object documentation
;
924 if (!SYMBOLP (variable
))
927 /* If indirect and there's an alias loop, don't check anything else. */
928 if (XSYMBOL (variable
)->indirect_variable
929 && NILP (internal_condition_case_1 (indirect_variable
, variable
,
930 Qt
, user_variable_p_eh
)))
935 documentation
= Fget (variable
, Qvariable_documentation
);
936 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
938 if (STRINGP (documentation
)
939 && ((unsigned char) SREF (documentation
, 0) == '*'))
941 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
942 if (CONSP (documentation
)
943 && STRINGP (XCAR (documentation
))
944 && INTEGERP (XCDR (documentation
))
945 && XINT (XCDR (documentation
)) < 0)
947 /* Customizable? See `custom-variable-p'. */
948 if ((!NILP (Fget (variable
, intern ("standard-value"))))
949 || (!NILP (Fget (variable
, intern ("custom-autoload")))))
952 if (!XSYMBOL (variable
)->indirect_variable
)
955 /* An indirect variable? Let's follow the chain. */
956 variable
= XSYMBOL (variable
)->value
;
960 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
961 doc
: /* Bind variables according to VARLIST then eval BODY.
962 The value of the last form in BODY is returned.
963 Each element of VARLIST is a symbol (which is bound to nil)
964 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
965 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
966 usage: (let* VARLIST BODY...) */)
970 Lisp_Object varlist
, val
, elt
;
971 int count
= SPECPDL_INDEX ();
972 struct gcpro gcpro1
, gcpro2
, gcpro3
;
974 GCPRO3 (args
, elt
, varlist
);
976 varlist
= Fcar (args
);
977 while (!NILP (varlist
))
980 elt
= Fcar (varlist
);
982 specbind (elt
, Qnil
);
983 else if (! NILP (Fcdr (Fcdr (elt
))))
985 Fcons (build_string ("`let' bindings can have only one value-form"),
989 val
= Feval (Fcar (Fcdr (elt
)));
990 specbind (Fcar (elt
), val
);
992 varlist
= Fcdr (varlist
);
995 val
= Fprogn (Fcdr (args
));
996 return unbind_to (count
, val
);
999 DEFUN ("let", Flet
, Slet
, 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 All the VALUEFORMs are evalled before any symbols are bound.
1005 usage: (let VARLIST BODY...) */)
1009 Lisp_Object
*temps
, tem
;
1010 register Lisp_Object elt
, varlist
;
1011 int count
= SPECPDL_INDEX ();
1012 register int argnum
;
1013 struct gcpro gcpro1
, gcpro2
;
1015 varlist
= Fcar (args
);
1017 /* Make space to hold the values to give the bound variables */
1018 elt
= Flength (varlist
);
1019 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
1021 /* Compute the values and store them in `temps' */
1023 GCPRO2 (args
, *temps
);
1026 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
1029 elt
= Fcar (varlist
);
1031 temps
[argnum
++] = Qnil
;
1032 else if (! NILP (Fcdr (Fcdr (elt
))))
1034 Fcons (build_string ("`let' bindings can have only one value-form"),
1037 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
1038 gcpro2
.nvars
= argnum
;
1042 varlist
= Fcar (args
);
1043 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
1045 elt
= Fcar (varlist
);
1046 tem
= temps
[argnum
++];
1048 specbind (elt
, tem
);
1050 specbind (Fcar (elt
), tem
);
1053 elt
= Fprogn (Fcdr (args
));
1054 return unbind_to (count
, elt
);
1057 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
1058 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
1059 The order of execution is thus TEST, BODY, TEST, BODY and so on
1060 until TEST returns nil.
1061 usage: (while TEST BODY...) */)
1065 Lisp_Object test
, body
;
1066 struct gcpro gcpro1
, gcpro2
;
1068 GCPRO2 (test
, body
);
1072 while (!NILP (Feval (test
)))
1082 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
1083 doc
: /* Return result of expanding macros at top level of FORM.
1084 If FORM is not a macro call, it is returned unchanged.
1085 Otherwise, the macro is expanded and the expansion is considered
1086 in place of FORM. When a non-macro-call results, it is returned.
1088 The second optional arg ENVIRONMENT specifies an environment of macro
1089 definitions to shadow the loaded ones for use in file byte-compilation. */)
1092 Lisp_Object environment
;
1094 /* With cleanups from Hallvard Furuseth. */
1095 register Lisp_Object expander
, sym
, def
, tem
;
1099 /* Come back here each time we expand a macro call,
1100 in case it expands into another macro call. */
1103 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1104 def
= sym
= XCAR (form
);
1106 /* Trace symbols aliases to other symbols
1107 until we get a symbol that is not an alias. */
1108 while (SYMBOLP (def
))
1112 tem
= Fassq (sym
, environment
);
1115 def
= XSYMBOL (sym
)->function
;
1116 if (!EQ (def
, Qunbound
))
1121 /* Right now TEM is the result from SYM in ENVIRONMENT,
1122 and if TEM is nil then DEF is SYM's function definition. */
1125 /* SYM is not mentioned in ENVIRONMENT.
1126 Look at its function definition. */
1127 if (EQ (def
, Qunbound
) || !CONSP (def
))
1128 /* Not defined or definition not suitable */
1130 if (EQ (XCAR (def
), Qautoload
))
1132 /* Autoloading function: will it be a macro when loaded? */
1133 tem
= Fnth (make_number (4), def
);
1134 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
1135 /* Yes, load it and try again. */
1137 struct gcpro gcpro1
;
1139 do_autoload (def
, sym
);
1146 else if (!EQ (XCAR (def
), Qmacro
))
1148 else expander
= XCDR (def
);
1152 expander
= XCDR (tem
);
1153 if (NILP (expander
))
1156 form
= apply1 (expander
, XCDR (form
));
1161 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1162 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1163 TAG is evalled to get the tag to use; it must not be nil.
1165 Then the BODY is executed.
1166 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.
1167 If no throw happens, `catch' returns the value of the last BODY form.
1168 If a throw happens, it specifies the value to return from `catch'.
1169 usage: (catch TAG BODY...) */)
1173 register Lisp_Object tag
;
1174 struct gcpro gcpro1
;
1177 tag
= Feval (Fcar (args
));
1179 return internal_catch (tag
, Fprogn
, Fcdr (args
));
1182 /* Set up a catch, then call C function FUNC on argument ARG.
1183 FUNC should return a Lisp_Object.
1184 This is how catches are done from within C code. */
1187 internal_catch (tag
, func
, arg
)
1189 Lisp_Object (*func
) ();
1192 /* This structure is made part of the chain `catchlist'. */
1195 /* Fill in the components of c, and put it on the list. */
1199 c
.backlist
= backtrace_list
;
1200 c
.handlerlist
= handlerlist
;
1201 c
.lisp_eval_depth
= lisp_eval_depth
;
1202 c
.pdlcount
= SPECPDL_INDEX ();
1203 c
.poll_suppress_count
= poll_suppress_count
;
1204 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1205 c
.gcpro
= gcprolist
;
1206 c
.byte_stack
= byte_stack_list
;
1210 if (! _setjmp (c
.jmp
))
1211 c
.val
= (*func
) (arg
);
1213 /* Throw works by a longjmp that comes right here. */
1218 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1219 jump to that CATCH, returning VALUE as the value of that catch.
1221 This is the guts Fthrow and Fsignal; they differ only in the way
1222 they choose the catch tag to throw to. A catch tag for a
1223 condition-case form has a TAG of Qnil.
1225 Before each catch is discarded, unbind all special bindings and
1226 execute all unwind-protect clauses made above that catch. Unwind
1227 the handler stack as we go, so that the proper handlers are in
1228 effect for each unwind-protect clause we run. At the end, restore
1229 some static info saved in CATCH, and longjmp to the location
1232 This is used for correct unwinding in Fthrow and Fsignal. */
1235 unwind_to_catch (catch, value
)
1236 struct catchtag
*catch;
1239 register int last_time
;
1241 /* Save the value in the tag. */
1244 /* Restore certain special C variables. */
1245 set_poll_suppress_count (catch->poll_suppress_count
);
1246 UNBLOCK_INPUT_TO (catch->interrupt_input_blocked
);
1247 handling_signal
= 0;
1252 last_time
= catchlist
== catch;
1254 /* Unwind the specpdl stack, and then restore the proper set of
1256 unbind_to (catchlist
->pdlcount
, Qnil
);
1257 handlerlist
= catchlist
->handlerlist
;
1258 catchlist
= catchlist
->next
;
1260 while (! last_time
);
1262 /* If x_catch_errors was done, turn it off now.
1263 (First we give unbind_to a chance to do that.) */
1264 x_fully_uncatch_errors ();
1266 byte_stack_list
= catch->byte_stack
;
1267 gcprolist
= catch->gcpro
;
1270 gcpro_level
= gcprolist
->level
+ 1;
1274 backtrace_list
= catch->backlist
;
1275 lisp_eval_depth
= catch->lisp_eval_depth
;
1277 _longjmp (catch->jmp
, 1);
1280 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1281 doc
: /* Throw to the catch for TAG and return VALUE from it.
1282 Both TAG and VALUE are evalled. */)
1284 register Lisp_Object tag
, value
;
1286 register struct catchtag
*c
;
1291 for (c
= catchlist
; c
; c
= c
->next
)
1293 if (EQ (c
->tag
, tag
))
1294 unwind_to_catch (c
, value
);
1296 tag
= Fsignal (Qno_catch
, Fcons (tag
, Fcons (value
, Qnil
)));
1301 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1302 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1303 If BODYFORM completes normally, its value is returned
1304 after executing the UNWINDFORMS.
1305 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1306 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1311 int count
= SPECPDL_INDEX ();
1313 record_unwind_protect (Fprogn
, Fcdr (args
));
1314 val
= Feval (Fcar (args
));
1315 return unbind_to (count
, val
);
1318 /* Chain of condition handlers currently in effect.
1319 The elements of this chain are contained in the stack frames
1320 of Fcondition_case and internal_condition_case.
1321 When an error is signaled (by calling Fsignal, below),
1322 this chain is searched for an element that applies. */
1324 struct handler
*handlerlist
;
1326 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1327 doc
: /* Regain control when an error is signaled.
1328 Executes BODYFORM and returns its value if no error happens.
1329 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1330 where the BODY is made of Lisp expressions.
1332 A handler is applicable to an error
1333 if CONDITION-NAME is one of the error's condition names.
1334 If an error happens, the first applicable handler is run.
1336 The car of a handler may be a list of condition names
1337 instead of a single condition name.
1339 When a handler handles an error,
1340 control returns to the condition-case and the handler BODY... is executed
1341 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).
1342 VAR may be nil; then you do not get access to the signal information.
1344 The value of the last BODY form is returned from the condition-case.
1345 See also the function `signal' for more info.
1346 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1350 register Lisp_Object bodyform
, handlers
;
1351 volatile Lisp_Object var
;
1354 bodyform
= Fcar (Fcdr (args
));
1355 handlers
= Fcdr (Fcdr (args
));
1357 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1360 /* Like Fcondition_case, but the args are separate
1361 rather than passed in a list. Used by Fbyte_code. */
1364 internal_lisp_condition_case (var
, bodyform
, handlers
)
1365 volatile Lisp_Object var
;
1366 Lisp_Object bodyform
, handlers
;
1374 for (val
= handlers
; CONSP (val
); val
= XCDR (val
))
1380 && (SYMBOLP (XCAR (tem
))
1381 || CONSP (XCAR (tem
))))))
1382 error ("Invalid condition handler", tem
);
1387 c
.backlist
= backtrace_list
;
1388 c
.handlerlist
= handlerlist
;
1389 c
.lisp_eval_depth
= lisp_eval_depth
;
1390 c
.pdlcount
= SPECPDL_INDEX ();
1391 c
.poll_suppress_count
= poll_suppress_count
;
1392 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1393 c
.gcpro
= gcprolist
;
1394 c
.byte_stack
= byte_stack_list
;
1395 if (_setjmp (c
.jmp
))
1398 specbind (h
.var
, c
.val
);
1399 val
= Fprogn (Fcdr (h
.chosen_clause
));
1401 /* Note that this just undoes the binding of h.var; whoever
1402 longjumped to us unwound the stack to c.pdlcount before
1404 unbind_to (c
.pdlcount
, Qnil
);
1411 h
.handler
= handlers
;
1412 h
.next
= handlerlist
;
1416 val
= Feval (bodyform
);
1418 handlerlist
= h
.next
;
1422 /* Call the function BFUN with no arguments, catching errors within it
1423 according to HANDLERS. If there is an error, call HFUN with
1424 one argument which is the data that describes the error:
1427 HANDLERS can be a list of conditions to catch.
1428 If HANDLERS is Qt, catch all errors.
1429 If HANDLERS is Qerror, catch all errors
1430 but allow the debugger to run if that is enabled. */
1433 internal_condition_case (bfun
, handlers
, hfun
)
1434 Lisp_Object (*bfun
) ();
1435 Lisp_Object handlers
;
1436 Lisp_Object (*hfun
) ();
1442 /* Since Fsignal will close off all calls to x_catch_errors,
1443 we will get the wrong results if some are not closed now. */
1444 if (x_catching_errors ())
1449 c
.backlist
= backtrace_list
;
1450 c
.handlerlist
= handlerlist
;
1451 c
.lisp_eval_depth
= lisp_eval_depth
;
1452 c
.pdlcount
= SPECPDL_INDEX ();
1453 c
.poll_suppress_count
= poll_suppress_count
;
1454 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1455 c
.gcpro
= gcprolist
;
1456 c
.byte_stack
= byte_stack_list
;
1457 if (_setjmp (c
.jmp
))
1459 return (*hfun
) (c
.val
);
1463 h
.handler
= handlers
;
1465 h
.next
= handlerlist
;
1471 handlerlist
= h
.next
;
1475 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1478 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1479 Lisp_Object (*bfun
) ();
1481 Lisp_Object handlers
;
1482 Lisp_Object (*hfun
) ();
1488 /* Since Fsignal will close off all calls to x_catch_errors,
1489 we will get the wrong results if some are not closed now. */
1490 if (x_catching_errors ())
1495 c
.backlist
= backtrace_list
;
1496 c
.handlerlist
= handlerlist
;
1497 c
.lisp_eval_depth
= lisp_eval_depth
;
1498 c
.pdlcount
= SPECPDL_INDEX ();
1499 c
.poll_suppress_count
= poll_suppress_count
;
1500 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1501 c
.gcpro
= gcprolist
;
1502 c
.byte_stack
= byte_stack_list
;
1503 if (_setjmp (c
.jmp
))
1505 return (*hfun
) (c
.val
);
1509 h
.handler
= handlers
;
1511 h
.next
= handlerlist
;
1515 val
= (*bfun
) (arg
);
1517 handlerlist
= h
.next
;
1522 /* Like internal_condition_case but call BFUN with NARGS as first,
1523 and ARGS as second argument. */
1526 internal_condition_case_2 (bfun
, nargs
, args
, handlers
, hfun
)
1527 Lisp_Object (*bfun
) ();
1530 Lisp_Object handlers
;
1531 Lisp_Object (*hfun
) ();
1537 /* Since Fsignal will close off all calls to x_catch_errors,
1538 we will get the wrong results if some are not closed now. */
1539 if (x_catching_errors ())
1544 c
.backlist
= backtrace_list
;
1545 c
.handlerlist
= handlerlist
;
1546 c
.lisp_eval_depth
= lisp_eval_depth
;
1547 c
.pdlcount
= SPECPDL_INDEX ();
1548 c
.poll_suppress_count
= poll_suppress_count
;
1549 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1550 c
.gcpro
= gcprolist
;
1551 c
.byte_stack
= byte_stack_list
;
1552 if (_setjmp (c
.jmp
))
1554 return (*hfun
) (c
.val
);
1558 h
.handler
= handlers
;
1560 h
.next
= handlerlist
;
1564 val
= (*bfun
) (nargs
, args
);
1566 handlerlist
= h
.next
;
1571 static Lisp_Object find_handler_clause
P_ ((Lisp_Object
, Lisp_Object
,
1572 Lisp_Object
, Lisp_Object
,
1575 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1576 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1577 This function does not return.
1579 An error symbol is a symbol with an `error-conditions' property
1580 that is a list of condition names.
1581 A handler for any of those names will get to handle this signal.
1582 The symbol `error' should normally be one of them.
1584 DATA should be a list. Its elements are printed as part of the error message.
1585 See Info anchor `(elisp)Definition of signal' for some details on how this
1586 error message is constructed.
1587 If the signal is handled, DATA is made available to the handler.
1588 See also the function `condition-case'. */)
1589 (error_symbol
, data
)
1590 Lisp_Object error_symbol
, data
;
1592 /* When memory is full, ERROR-SYMBOL is nil,
1593 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1594 That is a special case--don't do this in other situations. */
1595 register struct handler
*allhandlers
= handlerlist
;
1596 Lisp_Object conditions
;
1597 extern int gc_in_progress
;
1598 extern int waiting_for_input
;
1599 Lisp_Object debugger_value
;
1601 Lisp_Object real_error_symbol
;
1602 struct backtrace
*bp
;
1604 immediate_quit
= handling_signal
= 0;
1606 if (gc_in_progress
|| waiting_for_input
)
1609 if (NILP (error_symbol
))
1610 real_error_symbol
= Fcar (data
);
1612 real_error_symbol
= error_symbol
;
1614 #if 0 /* rms: I don't know why this was here,
1615 but it is surely wrong for an error that is handled. */
1616 #ifdef HAVE_X_WINDOWS
1617 if (display_hourglass_p
)
1618 cancel_hourglass ();
1622 /* This hook is used by edebug. */
1623 if (! NILP (Vsignal_hook_function
)
1624 && ! NILP (error_symbol
))
1626 /* Edebug takes care of restoring these variables when it exits. */
1627 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1628 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1630 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1631 max_specpdl_size
= SPECPDL_INDEX () + 40;
1633 call2 (Vsignal_hook_function
, error_symbol
, data
);
1636 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1638 /* Remember from where signal was called. Skip over the frame for
1639 `signal' itself. If a frame for `error' follows, skip that,
1640 too. Don't do this when ERROR_SYMBOL is nil, because that
1641 is a memory-full error. */
1642 Vsignaling_function
= Qnil
;
1643 if (backtrace_list
&& !NILP (error_symbol
))
1645 bp
= backtrace_list
->next
;
1646 if (bp
&& bp
->function
&& EQ (*bp
->function
, Qerror
))
1648 if (bp
&& bp
->function
)
1649 Vsignaling_function
= *bp
->function
;
1652 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1654 register Lisp_Object clause
;
1656 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1657 error_symbol
, data
, &debugger_value
);
1659 if (EQ (clause
, Qlambda
))
1661 /* We can't return values to code which signaled an error, but we
1662 can continue code which has signaled a quit. */
1663 if (EQ (real_error_symbol
, Qquit
))
1666 error ("Cannot return from the debugger in an error");
1671 Lisp_Object unwind_data
;
1672 struct handler
*h
= handlerlist
;
1674 handlerlist
= allhandlers
;
1676 if (NILP (error_symbol
))
1679 unwind_data
= Fcons (error_symbol
, data
);
1680 h
->chosen_clause
= clause
;
1681 unwind_to_catch (h
->tag
, unwind_data
);
1685 handlerlist
= allhandlers
;
1686 /* If no handler is present now, try to run the debugger,
1687 and if that fails, throw to top level. */
1688 find_handler_clause (Qerror
, conditions
, error_symbol
, data
, &debugger_value
);
1690 Fthrow (Qtop_level
, Qt
);
1692 if (! NILP (error_symbol
))
1693 data
= Fcons (error_symbol
, data
);
1695 string
= Ferror_message_string (data
);
1696 fatal ("%s", SDATA (string
), 0);
1699 /* Return nonzero iff LIST is a non-nil atom or
1700 a list containing one of CONDITIONS. */
1703 wants_debugger (list
, conditions
)
1704 Lisp_Object list
, conditions
;
1711 while (CONSP (conditions
))
1713 Lisp_Object
this, tail
;
1714 this = XCAR (conditions
);
1715 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1716 if (EQ (XCAR (tail
), this))
1718 conditions
= XCDR (conditions
);
1723 /* Return 1 if an error with condition-symbols CONDITIONS,
1724 and described by SIGNAL-DATA, should skip the debugger
1725 according to debugger-ignored-errors. */
1728 skip_debugger (conditions
, data
)
1729 Lisp_Object conditions
, data
;
1732 int first_string
= 1;
1733 Lisp_Object error_message
;
1735 error_message
= Qnil
;
1736 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1738 if (STRINGP (XCAR (tail
)))
1742 error_message
= Ferror_message_string (data
);
1746 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1751 Lisp_Object contail
;
1753 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1754 if (EQ (XCAR (tail
), XCAR (contail
)))
1762 /* Value of Qlambda means we have called debugger and user has continued.
1763 There are two ways to pass SIG and DATA:
1764 = SIG is the error symbol, and DATA is the rest of the data.
1765 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1766 This is for memory-full errors only.
1768 Store value returned from debugger into *DEBUGGER_VALUE_PTR.
1770 We need to increase max_specpdl_size temporarily around
1771 anything we do that can push on the specpdl, so as not to get
1772 a second error here in case we're handling specpdl overflow. */
1775 find_handler_clause (handlers
, conditions
, sig
, data
, debugger_value_ptr
)
1776 Lisp_Object handlers
, conditions
, sig
, data
;
1777 Lisp_Object
*debugger_value_ptr
;
1779 register Lisp_Object h
;
1780 register Lisp_Object tem
;
1782 if (EQ (handlers
, Qt
)) /* t is used by handlers for all conditions, set up by C code. */
1784 /* error is used similarly, but means print an error message
1785 and run the debugger if that is enabled. */
1786 if (EQ (handlers
, Qerror
)
1787 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1788 there is a handler. */
1790 int debugger_called
= 0;
1791 Lisp_Object sig_symbol
, combined_data
;
1792 /* This is set to 1 if we are handling a memory-full error,
1793 because these must not run the debugger.
1794 (There is no room in memory to do that!) */
1795 int no_debugger
= 0;
1799 combined_data
= data
;
1800 sig_symbol
= Fcar (data
);
1805 combined_data
= Fcons (sig
, data
);
1809 if (wants_debugger (Vstack_trace_on_error
, conditions
))
1813 internal_with_output_to_temp_buffer ("*Backtrace*",
1814 (Lisp_Object (*) (Lisp_Object
)) Fbacktrace
,
1817 internal_with_output_to_temp_buffer ("*Backtrace*",
1823 && (EQ (sig_symbol
, Qquit
)
1825 : wants_debugger (Vdebug_on_error
, conditions
))
1826 && ! skip_debugger (conditions
, combined_data
)
1827 && when_entered_debugger
< num_nonmacro_input_events
)
1830 = call_debugger (Fcons (Qerror
,
1831 Fcons (combined_data
, Qnil
)));
1832 debugger_called
= 1;
1834 /* If there is no handler, return saying whether we ran the debugger. */
1835 if (EQ (handlers
, Qerror
))
1837 if (debugger_called
)
1842 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1844 Lisp_Object handler
, condit
;
1847 if (!CONSP (handler
))
1849 condit
= Fcar (handler
);
1850 /* Handle a single condition name in handler HANDLER. */
1851 if (SYMBOLP (condit
))
1853 tem
= Fmemq (Fcar (handler
), conditions
);
1857 /* Handle a list of condition names in handler HANDLER. */
1858 else if (CONSP (condit
))
1860 while (CONSP (condit
))
1862 tem
= Fmemq (Fcar (condit
), conditions
);
1865 condit
= XCDR (condit
);
1872 /* dump an error message; called like printf */
1876 error (m
, a1
, a2
, a3
)
1896 int used
= doprnt (buffer
, size
, m
, m
+ mlen
, 3, args
);
1901 buffer
= (char *) xrealloc (buffer
, size
);
1904 buffer
= (char *) xmalloc (size
);
1909 string
= build_string (buffer
);
1913 Fsignal (Qerror
, Fcons (string
, Qnil
));
1917 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
1918 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
1919 This means it contains a description for how to read arguments to give it.
1920 The value is nil for an invalid function or a symbol with no function
1923 Interactively callable functions include strings and vectors (treated
1924 as keyboard macros), lambda-expressions that contain a top-level call
1925 to `interactive', autoload definitions made by `autoload' with non-nil
1926 fourth argument, and some of the built-in functions of Lisp.
1928 Also, a symbol satisfies `commandp' if its function definition does so.
1930 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
1931 then strings and vectors are not accepted. */)
1932 (function
, for_call_interactively
)
1933 Lisp_Object function
, for_call_interactively
;
1935 register Lisp_Object fun
;
1936 register Lisp_Object funcar
;
1940 fun
= indirect_function (fun
);
1941 if (EQ (fun
, Qunbound
))
1944 /* Emacs primitives are interactive if their DEFUN specifies an
1945 interactive spec. */
1948 if (XSUBR (fun
)->prompt
)
1954 /* Bytecode objects are interactive if they are long enough to
1955 have an element whose index is COMPILED_INTERACTIVE, which is
1956 where the interactive spec is stored. */
1957 else if (COMPILEDP (fun
))
1958 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
1961 /* Strings and vectors are keyboard macros. */
1962 if (NILP (for_call_interactively
) && (STRINGP (fun
) || VECTORP (fun
)))
1965 /* Lists may represent commands. */
1968 funcar
= XCAR (fun
);
1969 if (EQ (funcar
, Qlambda
))
1970 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
1971 if (EQ (funcar
, Qautoload
))
1972 return Fcar (Fcdr (Fcdr (XCDR (fun
))));
1978 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1979 doc
: /* Define FUNCTION to autoload from FILE.
1980 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
1981 Third arg DOCSTRING is documentation for the function.
1982 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
1983 Fifth arg TYPE indicates the type of the object:
1984 nil or omitted says FUNCTION is a function,
1985 `keymap' says FUNCTION is really a keymap, and
1986 `macro' or t says FUNCTION is really a macro.
1987 Third through fifth args give info about the real definition.
1988 They default to nil.
1989 If FUNCTION is already defined other than as an autoload,
1990 this does nothing and returns nil. */)
1991 (function
, file
, docstring
, interactive
, type
)
1992 Lisp_Object function
, file
, docstring
, interactive
, type
;
1995 Lisp_Object args
[4];
1998 CHECK_SYMBOL (function
);
1999 CHECK_STRING (file
);
2001 /* If function is defined and not as an autoload, don't override */
2002 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
2003 && !(CONSP (XSYMBOL (function
)->function
)
2004 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
2007 if (NILP (Vpurify_flag
))
2008 /* Only add entries after dumping, because the ones before are
2009 not useful and else we get loads of them from the loaddefs.el. */
2010 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
2014 args
[1] = docstring
;
2015 args
[2] = interactive
;
2018 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
2019 #else /* NO_ARG_ARRAY */
2020 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
2021 #endif /* not NO_ARG_ARRAY */
2025 un_autoload (oldqueue
)
2026 Lisp_Object oldqueue
;
2028 register Lisp_Object queue
, first
, second
;
2030 /* Queue to unwind is current value of Vautoload_queue.
2031 oldqueue is the shadowed value to leave in Vautoload_queue. */
2032 queue
= Vautoload_queue
;
2033 Vautoload_queue
= oldqueue
;
2034 while (CONSP (queue
))
2036 first
= XCAR (queue
);
2037 second
= Fcdr (first
);
2038 first
= Fcar (first
);
2039 if (EQ (first
, make_number (0)))
2042 Ffset (first
, second
);
2043 queue
= XCDR (queue
);
2048 /* Load an autoloaded function.
2049 FUNNAME is the symbol which is the function's name.
2050 FUNDEF is the autoload definition (a list). */
2053 do_autoload (fundef
, funname
)
2054 Lisp_Object fundef
, funname
;
2056 int count
= SPECPDL_INDEX ();
2057 Lisp_Object fun
, queue
, first
, second
;
2058 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2060 /* This is to make sure that loadup.el gives a clear picture
2061 of what files are preloaded and when. */
2062 if (! NILP (Vpurify_flag
))
2063 error ("Attempt to autoload %s while preparing to dump",
2064 SDATA (SYMBOL_NAME (funname
)));
2067 CHECK_SYMBOL (funname
);
2068 GCPRO3 (fun
, funname
, fundef
);
2070 /* Preserve the match data. */
2071 record_unwind_save_match_data ();
2073 /* Value saved here is to be restored into Vautoload_queue. */
2074 record_unwind_protect (un_autoload
, Vautoload_queue
);
2075 Vautoload_queue
= Qt
;
2076 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
, Qt
);
2078 /* Save the old autoloads, in case we ever do an unload. */
2079 queue
= Vautoload_queue
;
2080 while (CONSP (queue
))
2082 first
= XCAR (queue
);
2083 second
= Fcdr (first
);
2084 first
= Fcar (first
);
2086 if (SYMBOLP (first
) && CONSP (second
) && EQ (XCAR (second
), Qautoload
))
2087 Fput (first
, Qautoload
, (XCDR (second
)));
2089 queue
= XCDR (queue
);
2092 /* Once loading finishes, don't undo it. */
2093 Vautoload_queue
= Qt
;
2094 unbind_to (count
, Qnil
);
2096 fun
= Findirect_function (fun
, Qnil
);
2098 if (!NILP (Fequal (fun
, fundef
)))
2099 error ("Autoloading failed to define function %s",
2100 SDATA (SYMBOL_NAME (funname
)));
2105 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
2106 doc
: /* Evaluate FORM and return its value. */)
2110 Lisp_Object fun
, val
, original_fun
, original_args
;
2112 struct backtrace backtrace
;
2113 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2115 if (handling_signal
)
2119 return Fsymbol_value (form
);
2124 if ((consing_since_gc
> gc_cons_threshold
2125 && consing_since_gc
> gc_relative_threshold
)
2127 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2130 Fgarbage_collect ();
2134 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2136 if (max_lisp_eval_depth
< 100)
2137 max_lisp_eval_depth
= 100;
2138 if (lisp_eval_depth
> max_lisp_eval_depth
)
2139 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2142 original_fun
= Fcar (form
);
2143 original_args
= Fcdr (form
);
2145 backtrace
.next
= backtrace_list
;
2146 backtrace_list
= &backtrace
;
2147 backtrace
.function
= &original_fun
; /* This also protects them from gc */
2148 backtrace
.args
= &original_args
;
2149 backtrace
.nargs
= UNEVALLED
;
2150 backtrace
.evalargs
= 1;
2151 backtrace
.debug_on_exit
= 0;
2153 if (debug_on_next_call
)
2154 do_debug_on_call (Qt
);
2156 /* At this point, only original_fun and original_args
2157 have values that will be used below */
2159 fun
= Findirect_function (original_fun
, Qnil
);
2163 Lisp_Object numargs
;
2164 Lisp_Object argvals
[8];
2165 Lisp_Object args_left
;
2166 register int i
, maxargs
;
2168 args_left
= original_args
;
2169 numargs
= Flength (args_left
);
2173 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
2174 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2175 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2177 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2179 backtrace
.evalargs
= 0;
2180 val
= (*XSUBR (fun
)->function
) (args_left
);
2184 if (XSUBR (fun
)->max_args
== MANY
)
2186 /* Pass a vector of evaluated arguments */
2188 register int argnum
= 0;
2190 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2192 GCPRO3 (args_left
, fun
, fun
);
2196 while (!NILP (args_left
))
2198 vals
[argnum
++] = Feval (Fcar (args_left
));
2199 args_left
= Fcdr (args_left
);
2200 gcpro3
.nvars
= argnum
;
2203 backtrace
.args
= vals
;
2204 backtrace
.nargs
= XINT (numargs
);
2206 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
2211 GCPRO3 (args_left
, fun
, fun
);
2212 gcpro3
.var
= argvals
;
2215 maxargs
= XSUBR (fun
)->max_args
;
2216 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
2218 argvals
[i
] = Feval (Fcar (args_left
));
2224 backtrace
.args
= argvals
;
2225 backtrace
.nargs
= XINT (numargs
);
2230 val
= (*XSUBR (fun
)->function
) ();
2233 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
2236 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
2239 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2243 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2244 argvals
[2], argvals
[3]);
2247 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2248 argvals
[3], argvals
[4]);
2251 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2252 argvals
[3], argvals
[4], argvals
[5]);
2255 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2256 argvals
[3], argvals
[4], argvals
[5],
2261 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2262 argvals
[3], argvals
[4], argvals
[5],
2263 argvals
[6], argvals
[7]);
2267 /* Someone has created a subr that takes more arguments than
2268 is supported by this code. We need to either rewrite the
2269 subr to use a different argument protocol, or add more
2270 cases to this switch. */
2274 if (COMPILEDP (fun
))
2275 val
= apply_lambda (fun
, original_args
, 1);
2279 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2280 funcar
= Fcar (fun
);
2281 if (!SYMBOLP (funcar
))
2282 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2283 if (EQ (funcar
, Qautoload
))
2285 do_autoload (fun
, original_fun
);
2288 if (EQ (funcar
, Qmacro
))
2289 val
= Feval (apply1 (Fcdr (fun
), original_args
));
2290 else if (EQ (funcar
, Qlambda
))
2291 val
= apply_lambda (fun
, original_args
, 1);
2293 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2299 if (backtrace
.debug_on_exit
)
2300 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2301 backtrace_list
= backtrace
.next
;
2306 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
2307 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2308 Then return the value FUNCTION returns.
2309 Thus, (apply '+ 1 2 '(3 4)) returns 10.
2310 usage: (apply FUNCTION &rest ARGUMENTS) */)
2315 register int i
, numargs
;
2316 register Lisp_Object spread_arg
;
2317 register Lisp_Object
*funcall_args
;
2319 struct gcpro gcpro1
;
2323 spread_arg
= args
[nargs
- 1];
2324 CHECK_LIST (spread_arg
);
2326 numargs
= XINT (Flength (spread_arg
));
2329 return Ffuncall (nargs
- 1, args
);
2330 else if (numargs
== 1)
2332 args
[nargs
- 1] = XCAR (spread_arg
);
2333 return Ffuncall (nargs
, args
);
2336 numargs
+= nargs
- 2;
2338 fun
= indirect_function (fun
);
2339 if (EQ (fun
, Qunbound
))
2341 /* Let funcall get the error */
2348 if (numargs
< XSUBR (fun
)->min_args
2349 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2350 goto funcall
; /* Let funcall get the error */
2351 else if (XSUBR (fun
)->max_args
> numargs
)
2353 /* Avoid making funcall cons up a yet another new vector of arguments
2354 by explicitly supplying nil's for optional values */
2355 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
2356 * sizeof (Lisp_Object
));
2357 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2358 funcall_args
[++i
] = Qnil
;
2359 GCPRO1 (*funcall_args
);
2360 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2364 /* We add 1 to numargs because funcall_args includes the
2365 function itself as well as its arguments. */
2368 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
2369 * sizeof (Lisp_Object
));
2370 GCPRO1 (*funcall_args
);
2371 gcpro1
.nvars
= 1 + numargs
;
2374 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
2375 /* Spread the last arg we got. Its first element goes in
2376 the slot that it used to occupy, hence this value of I. */
2378 while (!NILP (spread_arg
))
2380 funcall_args
[i
++] = XCAR (spread_arg
);
2381 spread_arg
= XCDR (spread_arg
);
2384 /* By convention, the caller needs to gcpro Ffuncall's args. */
2385 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
2388 /* Run hook variables in various ways. */
2390 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
2391 static Lisp_Object run_hook_with_args
P_ ((int, Lisp_Object
*,
2392 enum run_hooks_condition
));
2394 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2395 doc
: /* Run each hook in HOOKS.
2396 Each argument should be a symbol, a hook variable.
2397 These symbols are processed in the order specified.
2398 If a hook symbol has a non-nil value, that value may be a function
2399 or a list of functions to be called to run the hook.
2400 If the value is a function, it is called with no arguments.
2401 If it is a list, the elements are called, in order, with no arguments.
2403 Major modes should not use this function directly to run their mode
2404 hook; they should use `run-mode-hooks' instead.
2406 Do not use `make-local-variable' to make a hook variable buffer-local.
2407 Instead, use `add-hook' and specify t for the LOCAL argument.
2408 usage: (run-hooks &rest HOOKS) */)
2413 Lisp_Object hook
[1];
2416 for (i
= 0; i
< nargs
; i
++)
2419 run_hook_with_args (1, hook
, to_completion
);
2425 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2426 Srun_hook_with_args
, 1, MANY
, 0,
2427 doc
: /* Run HOOK with the specified arguments ARGS.
2428 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2429 value, that value may be a function or a list of functions to be
2430 called to run the hook. If the value is a function, it is called with
2431 the given arguments and its return value is returned. If it is a list
2432 of functions, those functions are called, in order,
2433 with the given arguments ARGS.
2434 It is best not to depend on the value returned by `run-hook-with-args',
2437 Do not use `make-local-variable' to make a hook variable buffer-local.
2438 Instead, use `add-hook' and specify t for the LOCAL argument.
2439 usage: (run-hook-with-args HOOK &rest ARGS) */)
2444 return run_hook_with_args (nargs
, args
, to_completion
);
2447 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2448 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2449 doc
: /* Run HOOK with the specified arguments ARGS.
2450 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2451 value, that value may be a function or a list of functions to be
2452 called to run the hook. If the value is a function, it is called with
2453 the given arguments and its return value is returned.
2454 If it is a list of functions, those functions are called, in order,
2455 with the given arguments ARGS, until one of them
2456 returns a non-nil value. Then we return that value.
2457 However, if they all return nil, we return nil.
2459 Do not use `make-local-variable' to make a hook variable buffer-local.
2460 Instead, use `add-hook' and specify t for the LOCAL argument.
2461 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2466 return run_hook_with_args (nargs
, args
, until_success
);
2469 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2470 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2471 doc
: /* Run HOOK with the specified arguments ARGS.
2472 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2473 value, that value may be a function or a list of functions to be
2474 called to run the hook. If the value is a function, it is called with
2475 the given arguments and its return value is returned.
2476 If it is a list of functions, those functions are called, in order,
2477 with the given arguments ARGS, until one of them returns nil.
2478 Then we return nil. However, if they all return non-nil, we return non-nil.
2480 Do not use `make-local-variable' to make a hook variable buffer-local.
2481 Instead, use `add-hook' and specify t for the LOCAL argument.
2482 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2487 return run_hook_with_args (nargs
, args
, until_failure
);
2490 /* ARGS[0] should be a hook symbol.
2491 Call each of the functions in the hook value, passing each of them
2492 as arguments all the rest of ARGS (all NARGS - 1 elements).
2493 COND specifies a condition to test after each call
2494 to decide whether to stop.
2495 The caller (or its caller, etc) must gcpro all of ARGS,
2496 except that it isn't necessary to gcpro ARGS[0]. */
2499 run_hook_with_args (nargs
, args
, cond
)
2502 enum run_hooks_condition cond
;
2504 Lisp_Object sym
, val
, ret
;
2505 Lisp_Object globals
;
2506 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2508 /* If we are dying or still initializing,
2509 don't do anything--it would probably crash if we tried. */
2510 if (NILP (Vrun_hooks
))
2514 val
= find_symbol_value (sym
);
2515 ret
= (cond
== until_failure
? Qt
: Qnil
);
2517 if (EQ (val
, Qunbound
) || NILP (val
))
2519 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2522 return Ffuncall (nargs
, args
);
2527 GCPRO3 (sym
, val
, globals
);
2530 CONSP (val
) && ((cond
== to_completion
)
2531 || (cond
== until_success
? NILP (ret
)
2535 if (EQ (XCAR (val
), Qt
))
2537 /* t indicates this hook has a local binding;
2538 it means to run the global binding too. */
2540 for (globals
= Fdefault_value (sym
);
2541 CONSP (globals
) && ((cond
== to_completion
)
2542 || (cond
== until_success
? NILP (ret
)
2544 globals
= XCDR (globals
))
2546 args
[0] = XCAR (globals
);
2547 /* In a global value, t should not occur. If it does, we
2548 must ignore it to avoid an endless loop. */
2549 if (!EQ (args
[0], Qt
))
2550 ret
= Ffuncall (nargs
, args
);
2555 args
[0] = XCAR (val
);
2556 ret
= Ffuncall (nargs
, args
);
2565 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2566 present value of that symbol.
2567 Call each element of FUNLIST,
2568 passing each of them the rest of ARGS.
2569 The caller (or its caller, etc) must gcpro all of ARGS,
2570 except that it isn't necessary to gcpro ARGS[0]. */
2573 run_hook_list_with_args (funlist
, nargs
, args
)
2574 Lisp_Object funlist
;
2580 Lisp_Object globals
;
2581 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2585 GCPRO3 (sym
, val
, globals
);
2587 for (val
= funlist
; CONSP (val
); val
= XCDR (val
))
2589 if (EQ (XCAR (val
), Qt
))
2591 /* t indicates this hook has a local binding;
2592 it means to run the global binding too. */
2594 for (globals
= Fdefault_value (sym
);
2596 globals
= XCDR (globals
))
2598 args
[0] = XCAR (globals
);
2599 /* In a global value, t should not occur. If it does, we
2600 must ignore it to avoid an endless loop. */
2601 if (!EQ (args
[0], Qt
))
2602 Ffuncall (nargs
, args
);
2607 args
[0] = XCAR (val
);
2608 Ffuncall (nargs
, args
);
2615 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2618 run_hook_with_args_2 (hook
, arg1
, arg2
)
2619 Lisp_Object hook
, arg1
, arg2
;
2621 Lisp_Object temp
[3];
2626 Frun_hook_with_args (3, temp
);
2629 /* Apply fn to arg */
2632 Lisp_Object fn
, arg
;
2634 struct gcpro gcpro1
;
2638 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2642 Lisp_Object args
[2];
2646 RETURN_UNGCPRO (Fapply (2, args
));
2648 #else /* not NO_ARG_ARRAY */
2649 RETURN_UNGCPRO (Fapply (2, &fn
));
2650 #endif /* not NO_ARG_ARRAY */
2653 /* Call function fn on no arguments */
2658 struct gcpro gcpro1
;
2661 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2664 /* Call function fn with 1 argument arg1 */
2668 Lisp_Object fn
, arg1
;
2670 struct gcpro gcpro1
;
2672 Lisp_Object args
[2];
2678 RETURN_UNGCPRO (Ffuncall (2, args
));
2679 #else /* not NO_ARG_ARRAY */
2682 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2683 #endif /* not NO_ARG_ARRAY */
2686 /* Call function fn with 2 arguments arg1, arg2 */
2689 call2 (fn
, arg1
, arg2
)
2690 Lisp_Object fn
, arg1
, arg2
;
2692 struct gcpro gcpro1
;
2694 Lisp_Object args
[3];
2700 RETURN_UNGCPRO (Ffuncall (3, args
));
2701 #else /* not NO_ARG_ARRAY */
2704 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2705 #endif /* not NO_ARG_ARRAY */
2708 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2711 call3 (fn
, arg1
, arg2
, arg3
)
2712 Lisp_Object fn
, arg1
, arg2
, arg3
;
2714 struct gcpro gcpro1
;
2716 Lisp_Object args
[4];
2723 RETURN_UNGCPRO (Ffuncall (4, args
));
2724 #else /* not NO_ARG_ARRAY */
2727 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2728 #endif /* not NO_ARG_ARRAY */
2731 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2734 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2735 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2737 struct gcpro gcpro1
;
2739 Lisp_Object args
[5];
2747 RETURN_UNGCPRO (Ffuncall (5, args
));
2748 #else /* not NO_ARG_ARRAY */
2751 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2752 #endif /* not NO_ARG_ARRAY */
2755 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2758 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2759 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2761 struct gcpro gcpro1
;
2763 Lisp_Object args
[6];
2772 RETURN_UNGCPRO (Ffuncall (6, args
));
2773 #else /* not NO_ARG_ARRAY */
2776 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2777 #endif /* not NO_ARG_ARRAY */
2780 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2783 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2784 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2786 struct gcpro gcpro1
;
2788 Lisp_Object args
[7];
2798 RETURN_UNGCPRO (Ffuncall (7, args
));
2799 #else /* not NO_ARG_ARRAY */
2802 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2803 #endif /* not NO_ARG_ARRAY */
2806 /* The caller should GCPRO all the elements of ARGS. */
2808 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2809 doc
: /* Call first argument as a function, passing remaining arguments to it.
2810 Return the value that function returns.
2811 Thus, (funcall 'cons 'x 'y) returns (x . y).
2812 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2819 int numargs
= nargs
- 1;
2820 Lisp_Object lisp_numargs
;
2822 struct backtrace backtrace
;
2823 register Lisp_Object
*internal_args
;
2827 if ((consing_since_gc
> gc_cons_threshold
2828 && consing_since_gc
> gc_relative_threshold
)
2830 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2831 Fgarbage_collect ();
2833 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2835 if (max_lisp_eval_depth
< 100)
2836 max_lisp_eval_depth
= 100;
2837 if (lisp_eval_depth
> max_lisp_eval_depth
)
2838 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2841 backtrace
.next
= backtrace_list
;
2842 backtrace_list
= &backtrace
;
2843 backtrace
.function
= &args
[0];
2844 backtrace
.args
= &args
[1];
2845 backtrace
.nargs
= nargs
- 1;
2846 backtrace
.evalargs
= 0;
2847 backtrace
.debug_on_exit
= 0;
2849 if (debug_on_next_call
)
2850 do_debug_on_call (Qlambda
);
2858 fun
= Findirect_function (fun
, Qnil
);
2862 if (numargs
< XSUBR (fun
)->min_args
2863 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2865 XSETFASTINT (lisp_numargs
, numargs
);
2866 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (lisp_numargs
, Qnil
)));
2869 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2870 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2872 if (XSUBR (fun
)->max_args
== MANY
)
2874 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
2878 if (XSUBR (fun
)->max_args
> numargs
)
2880 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2881 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
2882 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2883 internal_args
[i
] = Qnil
;
2886 internal_args
= args
+ 1;
2887 switch (XSUBR (fun
)->max_args
)
2890 val
= (*XSUBR (fun
)->function
) ();
2893 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
2896 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1]);
2899 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2903 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2904 internal_args
[2], internal_args
[3]);
2907 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2908 internal_args
[2], internal_args
[3],
2912 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2913 internal_args
[2], internal_args
[3],
2914 internal_args
[4], internal_args
[5]);
2917 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2918 internal_args
[2], internal_args
[3],
2919 internal_args
[4], internal_args
[5],
2924 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2925 internal_args
[2], internal_args
[3],
2926 internal_args
[4], internal_args
[5],
2927 internal_args
[6], internal_args
[7]);
2932 /* If a subr takes more than 8 arguments without using MANY
2933 or UNEVALLED, we need to extend this function to support it.
2934 Until this is done, there is no way to call the function. */
2938 if (COMPILEDP (fun
))
2939 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2943 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2944 funcar
= Fcar (fun
);
2945 if (!SYMBOLP (funcar
))
2946 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2947 if (EQ (funcar
, Qlambda
))
2948 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2949 else if (EQ (funcar
, Qautoload
))
2951 do_autoload (fun
, args
[0]);
2956 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2961 if (backtrace
.debug_on_exit
)
2962 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2963 backtrace_list
= backtrace
.next
;
2968 apply_lambda (fun
, args
, eval_flag
)
2969 Lisp_Object fun
, args
;
2972 Lisp_Object args_left
;
2973 Lisp_Object numargs
;
2974 register Lisp_Object
*arg_vector
;
2975 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2977 register Lisp_Object tem
;
2979 numargs
= Flength (args
);
2980 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2983 GCPRO3 (*arg_vector
, args_left
, fun
);
2986 for (i
= 0; i
< XINT (numargs
);)
2988 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2989 if (eval_flag
) tem
= Feval (tem
);
2990 arg_vector
[i
++] = tem
;
2998 backtrace_list
->args
= arg_vector
;
2999 backtrace_list
->nargs
= i
;
3001 backtrace_list
->evalargs
= 0;
3002 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
3004 /* Do the debug-on-exit now, while arg_vector still exists. */
3005 if (backtrace_list
->debug_on_exit
)
3006 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
3007 /* Don't do it again when we return to eval. */
3008 backtrace_list
->debug_on_exit
= 0;
3012 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
3013 and return the result of evaluation.
3014 FUN must be either a lambda-expression or a compiled-code object. */
3017 funcall_lambda (fun
, nargs
, arg_vector
)
3020 register Lisp_Object
*arg_vector
;
3022 Lisp_Object val
, syms_left
, next
;
3023 int count
= SPECPDL_INDEX ();
3024 int i
, optional
, rest
;
3028 syms_left
= XCDR (fun
);
3029 if (CONSP (syms_left
))
3030 syms_left
= XCAR (syms_left
);
3032 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
3034 else if (COMPILEDP (fun
))
3035 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3039 i
= optional
= rest
= 0;
3040 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3044 next
= XCAR (syms_left
);
3045 while (!SYMBOLP (next
))
3046 next
= Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
3048 if (EQ (next
, Qand_rest
))
3050 else if (EQ (next
, Qand_optional
))
3054 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
3058 specbind (next
, arg_vector
[i
++]);
3060 return Fsignal (Qwrong_number_of_arguments
,
3061 Fcons (fun
, Fcons (make_number (nargs
), Qnil
)));
3063 specbind (next
, Qnil
);
3066 if (!NILP (syms_left
))
3067 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
3069 return Fsignal (Qwrong_number_of_arguments
,
3070 Fcons (fun
, Fcons (make_number (nargs
), Qnil
)));
3073 val
= Fprogn (XCDR (XCDR (fun
)));
3076 /* If we have not actually read the bytecode string
3077 and constants vector yet, fetch them from the file. */
3078 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3079 Ffetch_bytecode (fun
);
3080 val
= Fbyte_code (AREF (fun
, COMPILED_BYTECODE
),
3081 AREF (fun
, COMPILED_CONSTANTS
),
3082 AREF (fun
, COMPILED_STACK_DEPTH
));
3085 return unbind_to (count
, val
);
3088 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3090 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3096 if (COMPILEDP (object
) && CONSP (AREF (object
, COMPILED_BYTECODE
)))
3098 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3101 tem
= AREF (object
, COMPILED_BYTECODE
);
3102 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3103 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3105 error ("Invalid byte code");
3107 AREF (object
, COMPILED_BYTECODE
) = XCAR (tem
);
3108 AREF (object
, COMPILED_CONSTANTS
) = XCDR (tem
);
3116 register int count
= SPECPDL_INDEX ();
3117 if (specpdl_size
>= max_specpdl_size
)
3119 if (max_specpdl_size
< 400)
3120 max_specpdl_size
= 400;
3121 if (specpdl_size
>= max_specpdl_size
)
3123 Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil
));
3126 if (specpdl_size
> max_specpdl_size
)
3127 specpdl_size
= max_specpdl_size
;
3128 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
3129 specpdl_ptr
= specpdl
+ count
;
3133 specbind (symbol
, value
)
3134 Lisp_Object symbol
, value
;
3137 Lisp_Object valcontents
;
3139 CHECK_SYMBOL (symbol
);
3140 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3143 /* The most common case is that of a non-constant symbol with a
3144 trivial value. Make that as fast as we can. */
3145 valcontents
= SYMBOL_VALUE (symbol
);
3146 if (!MISCP (valcontents
) && !SYMBOL_CONSTANT_P (symbol
))
3148 specpdl_ptr
->symbol
= symbol
;
3149 specpdl_ptr
->old_value
= valcontents
;
3150 specpdl_ptr
->func
= NULL
;
3152 SET_SYMBOL_VALUE (symbol
, value
);
3156 Lisp_Object valcontents
;
3158 ovalue
= find_symbol_value (symbol
);
3159 specpdl_ptr
->func
= 0;
3160 specpdl_ptr
->old_value
= ovalue
;
3162 valcontents
= XSYMBOL (symbol
)->value
;
3164 if (BUFFER_LOCAL_VALUEP (valcontents
)
3165 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
3166 || BUFFER_OBJFWDP (valcontents
))
3168 Lisp_Object where
, current_buffer
;
3170 current_buffer
= Fcurrent_buffer ();
3172 /* For a local variable, record both the symbol and which
3173 buffer's or frame's value we are saving. */
3174 if (!NILP (Flocal_variable_p (symbol
, Qnil
)))
3175 where
= current_buffer
;
3176 else if (!BUFFER_OBJFWDP (valcontents
)
3177 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
3178 where
= XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
3182 /* We're not using the `unused' slot in the specbinding
3183 structure because this would mean we have to do more
3184 work for simple variables. */
3185 specpdl_ptr
->symbol
= Fcons (symbol
, Fcons (where
, current_buffer
));
3187 /* If SYMBOL is a per-buffer variable which doesn't have a
3188 buffer-local value here, make the `let' change the global
3189 value by changing the value of SYMBOL in all buffers not
3190 having their own value. This is consistent with what
3191 happens with other buffer-local variables. */
3193 && BUFFER_OBJFWDP (valcontents
))
3196 Fset_default (symbol
, value
);
3201 specpdl_ptr
->symbol
= symbol
;
3204 if (BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
))
3205 store_symval_forwarding (symbol
, ovalue
, value
, NULL
);
3207 set_internal (symbol
, value
, 0, 1);
3212 record_unwind_protect (function
, arg
)
3213 Lisp_Object (*function
) P_ ((Lisp_Object
));
3216 eassert (!handling_signal
);
3218 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3220 specpdl_ptr
->func
= function
;
3221 specpdl_ptr
->symbol
= Qnil
;
3222 specpdl_ptr
->old_value
= arg
;
3227 unbind_to (count
, value
)
3231 Lisp_Object quitf
= Vquit_flag
;
3232 struct gcpro gcpro1
, gcpro2
;
3234 GCPRO2 (value
, quitf
);
3237 while (specpdl_ptr
!= specpdl
+ count
)
3239 /* Copy the binding, and decrement specpdl_ptr, before we do
3240 the work to unbind it. We decrement first
3241 so that an error in unbinding won't try to unbind
3242 the same entry again, and we copy the binding first
3243 in case more bindings are made during some of the code we run. */
3245 struct specbinding this_binding
;
3246 this_binding
= *--specpdl_ptr
;
3248 if (this_binding
.func
!= 0)
3249 (*this_binding
.func
) (this_binding
.old_value
);
3250 /* If the symbol is a list, it is really (SYMBOL WHERE
3251 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3252 frame. If WHERE is a buffer or frame, this indicates we
3253 bound a variable that had a buffer-local or frame-local
3254 binding. WHERE nil means that the variable had the default
3255 value when it was bound. CURRENT-BUFFER is the buffer that
3256 was current when the variable was bound. */
3257 else if (CONSP (this_binding
.symbol
))
3259 Lisp_Object symbol
, where
;
3261 symbol
= XCAR (this_binding
.symbol
);
3262 where
= XCAR (XCDR (this_binding
.symbol
));
3265 Fset_default (symbol
, this_binding
.old_value
);
3266 else if (BUFFERP (where
))
3267 set_internal (symbol
, this_binding
.old_value
, XBUFFER (where
), 1);
3269 set_internal (symbol
, this_binding
.old_value
, NULL
, 1);
3273 /* If variable has a trivial value (no forwarding), we can
3274 just set it. No need to check for constant symbols here,
3275 since that was already done by specbind. */
3276 if (!MISCP (SYMBOL_VALUE (this_binding
.symbol
)))
3277 SET_SYMBOL_VALUE (this_binding
.symbol
, this_binding
.old_value
);
3279 set_internal (this_binding
.symbol
, this_binding
.old_value
, 0, 1);
3283 if (NILP (Vquit_flag
) && !NILP (quitf
))
3290 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3291 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3292 The debugger is entered when that frame exits, if the flag is non-nil. */)
3294 Lisp_Object level
, flag
;
3296 register struct backtrace
*backlist
= backtrace_list
;
3299 CHECK_NUMBER (level
);
3301 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
3303 backlist
= backlist
->next
;
3307 backlist
->debug_on_exit
= !NILP (flag
);
3312 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3313 doc
: /* Print a trace of Lisp function calls currently active.
3314 Output stream used is value of `standard-output'. */)
3317 register struct backtrace
*backlist
= backtrace_list
;
3321 extern Lisp_Object Vprint_level
;
3322 struct gcpro gcpro1
;
3324 XSETFASTINT (Vprint_level
, 3);
3331 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
3332 if (backlist
->nargs
== UNEVALLED
)
3334 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
3335 write_string ("\n", -1);
3339 tem
= *backlist
->function
;
3340 Fprin1 (tem
, Qnil
); /* This can QUIT */
3341 write_string ("(", -1);
3342 if (backlist
->nargs
== MANY
)
3344 for (tail
= *backlist
->args
, i
= 0;
3346 tail
= Fcdr (tail
), i
++)
3348 if (i
) write_string (" ", -1);
3349 Fprin1 (Fcar (tail
), Qnil
);
3354 for (i
= 0; i
< backlist
->nargs
; i
++)
3356 if (i
) write_string (" ", -1);
3357 Fprin1 (backlist
->args
[i
], Qnil
);
3360 write_string (")\n", -1);
3362 backlist
= backlist
->next
;
3365 Vprint_level
= Qnil
;
3370 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, NULL
,
3371 doc
: /* Return the function and arguments NFRAMES up from current execution point.
3372 If that frame has not evaluated the arguments yet (or is a special form),
3373 the value is (nil FUNCTION ARG-FORMS...).
3374 If that frame has evaluated its arguments and called its function already,
3375 the value is (t FUNCTION ARG-VALUES...).
3376 A &rest arg is represented as the tail of the list ARG-VALUES.
3377 FUNCTION is whatever was supplied as car of evaluated list,
3378 or a lambda expression for macro calls.
3379 If NFRAMES is more than the number of frames, the value is nil. */)
3381 Lisp_Object nframes
;
3383 register struct backtrace
*backlist
= backtrace_list
;
3387 CHECK_NATNUM (nframes
);
3389 /* Find the frame requested. */
3390 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3391 backlist
= backlist
->next
;
3395 if (backlist
->nargs
== UNEVALLED
)
3396 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3399 if (backlist
->nargs
== MANY
)
3400 tem
= *backlist
->args
;
3402 tem
= Flist (backlist
->nargs
, backlist
->args
);
3404 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3412 register struct backtrace
*backlist
;
3415 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3417 mark_object (*backlist
->function
);
3419 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3422 i
= backlist
->nargs
- 1;
3424 mark_object (backlist
->args
[i
]);
3431 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
3432 doc
: /* *Limit on number of Lisp variable bindings and `unwind-protect's.
3433 If Lisp code tries to increase the total number past this amount,
3434 an error is signaled.
3435 You can safely use a value considerably larger than the default value,
3436 if that proves inconveniently small. However, if you increase it too far,
3437 Emacs could run out of memory trying to make the stack bigger. */);
3439 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
3440 doc
: /* *Limit on depth in `eval', `apply' and `funcall' before error.
3442 This limit serves to catch infinite recursions for you before they cause
3443 actual stack overflow in C, which would be fatal for Emacs.
3444 You can safely make it considerably larger than its default value,
3445 if that proves inconveniently small. However, if you increase it too far,
3446 Emacs could overflow the real C stack, and crash. */);
3448 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
3449 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3450 If the value is t, that means do an ordinary quit.
3451 If the value equals `throw-on-input', that means quit by throwing
3452 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3453 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3454 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3457 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
3458 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3459 Note that `quit-flag' will still be set by typing C-g,
3460 so a quit will be signaled as soon as `inhibit-quit' is nil.
3461 To prevent this happening, set `quit-flag' to nil
3462 before making `inhibit-quit' nil. */);
3463 Vinhibit_quit
= Qnil
;
3465 Qinhibit_quit
= intern ("inhibit-quit");
3466 staticpro (&Qinhibit_quit
);
3468 Qautoload
= intern ("autoload");
3469 staticpro (&Qautoload
);
3471 Qdebug_on_error
= intern ("debug-on-error");
3472 staticpro (&Qdebug_on_error
);
3474 Qmacro
= intern ("macro");
3475 staticpro (&Qmacro
);
3477 Qdeclare
= intern ("declare");
3478 staticpro (&Qdeclare
);
3480 /* Note that the process handling also uses Qexit, but we don't want
3481 to staticpro it twice, so we just do it here. */
3482 Qexit
= intern ("exit");
3485 Qinteractive
= intern ("interactive");
3486 staticpro (&Qinteractive
);
3488 Qcommandp
= intern ("commandp");
3489 staticpro (&Qcommandp
);
3491 Qdefun
= intern ("defun");
3492 staticpro (&Qdefun
);
3494 Qand_rest
= intern ("&rest");
3495 staticpro (&Qand_rest
);
3497 Qand_optional
= intern ("&optional");
3498 staticpro (&Qand_optional
);
3500 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
3501 doc
: /* *Non-nil means errors display a backtrace buffer.
3502 More precisely, this happens for any error that is handled
3503 by the editor command loop.
3504 If the value is a list, an error only means to display a backtrace
3505 if one of its condition symbols appears in the list. */);
3506 Vstack_trace_on_error
= Qnil
;
3508 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
3509 doc
: /* *Non-nil means enter debugger if an error is signaled.
3510 Does not apply to errors handled by `condition-case' or those
3511 matched by `debug-ignored-errors'.
3512 If the value is a list, an error only means to enter the debugger
3513 if one of its condition symbols appears in the list.
3514 When you evaluate an expression interactively, this variable
3515 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3516 See also variable `debug-on-quit'. */);
3517 Vdebug_on_error
= Qnil
;
3519 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
3520 doc
: /* *List of errors for which the debugger should not be called.
3521 Each element may be a condition-name or a regexp that matches error messages.
3522 If any element applies to a given error, that error skips the debugger
3523 and just returns to top level.
3524 This overrides the variable `debug-on-error'.
3525 It does not apply to errors handled by `condition-case'. */);
3526 Vdebug_ignored_errors
= Qnil
;
3528 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
3529 doc
: /* *Non-nil means enter debugger if quit is signaled (C-g, for example).
3530 Does not apply if quit is handled by a `condition-case'. */);
3533 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
3534 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3536 DEFVAR_BOOL ("debugger-may-continue", &debugger_may_continue
,
3537 doc
: /* Non-nil means debugger may continue execution.
3538 This is nil when the debugger is called under circumstances where it
3539 might not be safe to continue. */);
3540 debugger_may_continue
= 1;
3542 DEFVAR_LISP ("debugger", &Vdebugger
,
3543 doc
: /* Function to call to invoke debugger.
3544 If due to frame exit, args are `exit' and the value being returned;
3545 this function's value will be returned instead of that.
3546 If due to error, args are `error' and a list of the args to `signal'.
3547 If due to `apply' or `funcall' entry, one arg, `lambda'.
3548 If due to `eval' entry, one arg, t. */);
3551 DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function
,
3552 doc
: /* If non-nil, this is a function for `signal' to call.
3553 It receives the same arguments that `signal' was given.
3554 The Edebug package uses this to regain control. */);
3555 Vsignal_hook_function
= Qnil
;
3557 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal
,
3558 doc
: /* *Non-nil means call the debugger regardless of condition handlers.
3559 Note that `debug-on-error', `debug-on-quit' and friends
3560 still determine whether to handle the particular condition. */);
3561 Vdebug_on_signal
= Qnil
;
3563 DEFVAR_LISP ("macro-declaration-function", &Vmacro_declaration_function
,
3564 doc
: /* Function to process declarations in a macro definition.
3565 The function will be called with two args MACRO and DECL.
3566 MACRO is the name of the macro being defined.
3567 DECL is a list `(declare ...)' containing the declarations.
3568 The value the function returns is not used. */);
3569 Vmacro_declaration_function
= Qnil
;
3571 Vrun_hooks
= intern ("run-hooks");
3572 staticpro (&Vrun_hooks
);
3574 staticpro (&Vautoload_queue
);
3575 Vautoload_queue
= Qnil
;
3576 staticpro (&Vsignaling_function
);
3577 Vsignaling_function
= Qnil
;
3588 defsubr (&Sfunction
);
3590 defsubr (&Sdefmacro
);
3592 defsubr (&Sdefvaralias
);
3593 defsubr (&Sdefconst
);
3594 defsubr (&Suser_variable_p
);
3598 defsubr (&Smacroexpand
);
3601 defsubr (&Sunwind_protect
);
3602 defsubr (&Scondition_case
);
3604 defsubr (&Sinteractive_p
);
3605 defsubr (&Scalled_interactively_p
);
3606 defsubr (&Scommandp
);
3607 defsubr (&Sautoload
);
3610 defsubr (&Sfuncall
);
3611 defsubr (&Srun_hooks
);
3612 defsubr (&Srun_hook_with_args
);
3613 defsubr (&Srun_hook_with_args_until_success
);
3614 defsubr (&Srun_hook_with_args_until_failure
);
3615 defsubr (&Sfetch_bytecode
);
3616 defsubr (&Sbacktrace_debug
);
3617 defsubr (&Sbacktrace
);
3618 defsubr (&Sbacktrace_frame
);
3621 /* arch-tag: 014a07aa-33ab-4a8f-a3d2-ee8a4a9ff7fb
3622 (do not change this comment) */