1 /* Evaluator for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1987, 1993-1995, 1999-2011 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software: you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation, either version 3 of the License, or
9 (at your option) any later version.
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 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. */
37 struct backtrace
*next
;
38 Lisp_Object
*function
;
39 Lisp_Object
*args
; /* Points to vector of args. */
40 ptrdiff_t nargs
; /* Length of vector. */
41 /* Nonzero means call value of debugger when done with this operation. */
42 unsigned int debug_on_exit
: 1;
45 static struct backtrace
*backtrace_list
;
50 struct catchtag
*catchlist
;
52 /* Chain of condition handlers currently in effect.
53 The elements of this chain are contained in the stack frames
54 of Fcondition_case and internal_condition_case.
55 When an error is signaled (by calling Fsignal, below),
56 this chain is searched for an element that applies. */
61 struct handler
*handlerlist
;
64 /* Count levels of GCPRO to detect failure to UNGCPRO. */
68 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
69 Lisp_Object Qinhibit_quit
;
70 Lisp_Object Qand_rest
;
71 static Lisp_Object Qand_optional
;
72 static Lisp_Object Qdebug_on_error
;
73 static Lisp_Object Qdeclare
;
74 Lisp_Object Qinternal_interpreter_environment
, Qclosure
;
76 static Lisp_Object Qdebug
;
78 /* This holds either the symbol `run-hooks' or nil.
79 It is nil at an early stage of startup, and when Emacs
82 Lisp_Object Vrun_hooks
;
84 /* Non-nil means record all fset's and provide's, to be undone
85 if the file being autoloaded is not fully loaded.
86 They are recorded by being consed onto the front of Vautoload_queue:
87 (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide. */
89 Lisp_Object Vautoload_queue
;
91 /* Current number of specbindings allocated in specpdl. */
93 ptrdiff_t specpdl_size
;
95 /* Pointer to beginning of specpdl. */
97 struct specbinding
*specpdl
;
99 /* Pointer to first unused element in specpdl. */
101 struct specbinding
*specpdl_ptr
;
103 /* Depth in Lisp evaluations and function calls. */
105 static EMACS_INT lisp_eval_depth
;
107 /* The value of num_nonmacro_input_events as of the last time we
108 started to enter the debugger. If we decide to enter the debugger
109 again when this is still equal to num_nonmacro_input_events, then we
110 know that the debugger itself has an error, and we should just
111 signal the error instead of entering an infinite loop of debugger
114 static EMACS_INT when_entered_debugger
;
116 /* The function from which the last `signal' was called. Set in
119 Lisp_Object Vsignaling_function
;
121 /* Set to non-zero while processing X events. Checked in Feval to
122 make sure the Lisp interpreter isn't called from a signal handler,
123 which is unsafe because the interpreter isn't reentrant. */
127 static Lisp_Object
funcall_lambda (Lisp_Object
, ptrdiff_t, Lisp_Object
*);
128 static void unwind_to_catch (struct catchtag
*, Lisp_Object
) NO_RETURN
;
129 static int interactive_p (int);
130 static Lisp_Object
apply_lambda (Lisp_Object fun
, Lisp_Object args
);
131 static Lisp_Object
Ffetch_bytecode (Lisp_Object
);
134 init_eval_once (void)
137 specpdl
= (struct specbinding
*) xmalloc (size
* sizeof (struct specbinding
));
139 specpdl_ptr
= specpdl
;
140 /* Don't forget to update docs (lispref node "Local Variables"). */
141 max_specpdl_size
= 1300; /* 1000 is not enough for CEDET's c-by.el. */
142 max_lisp_eval_depth
= 600;
150 specpdl_ptr
= specpdl
;
155 debug_on_next_call
= 0;
160 /* This is less than the initial value of num_nonmacro_input_events. */
161 when_entered_debugger
= -1;
164 /* Unwind-protect function used by call_debugger. */
167 restore_stack_limits (Lisp_Object data
)
169 max_specpdl_size
= XINT (XCAR (data
));
170 max_lisp_eval_depth
= XINT (XCDR (data
));
174 /* Call the Lisp debugger, giving it argument ARG. */
177 call_debugger (Lisp_Object arg
)
179 int debug_while_redisplaying
;
180 ptrdiff_t count
= SPECPDL_INDEX ();
182 EMACS_INT old_max
= max_specpdl_size
;
184 /* Temporarily bump up the stack limits,
185 so the debugger won't run out of stack. */
187 max_specpdl_size
+= 1;
188 record_unwind_protect (restore_stack_limits
,
189 Fcons (make_number (old_max
),
190 make_number (max_lisp_eval_depth
)));
191 max_specpdl_size
= old_max
;
193 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
194 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
196 if (max_specpdl_size
- 100 < SPECPDL_INDEX ())
197 max_specpdl_size
= SPECPDL_INDEX () + 100;
199 #ifdef HAVE_WINDOW_SYSTEM
200 if (display_hourglass_p
)
204 debug_on_next_call
= 0;
205 when_entered_debugger
= num_nonmacro_input_events
;
207 /* Resetting redisplaying_p to 0 makes sure that debug output is
208 displayed if the debugger is invoked during redisplay. */
209 debug_while_redisplaying
= redisplaying_p
;
211 specbind (intern ("debugger-may-continue"),
212 debug_while_redisplaying
? Qnil
: Qt
);
213 specbind (Qinhibit_redisplay
, Qnil
);
214 specbind (Qdebug_on_error
, Qnil
);
216 #if 0 /* Binding this prevents execution of Lisp code during
217 redisplay, which necessarily leads to display problems. */
218 specbind (Qinhibit_eval_during_redisplay
, Qt
);
221 val
= apply1 (Vdebugger
, arg
);
223 /* Interrupting redisplay and resuming it later is not safe under
224 all circumstances. So, when the debugger returns, abort the
225 interrupted redisplay by going back to the top-level. */
226 if (debug_while_redisplaying
)
229 return unbind_to (count
, val
);
233 do_debug_on_call (Lisp_Object code
)
235 debug_on_next_call
= 0;
236 backtrace_list
->debug_on_exit
= 1;
237 call_debugger (Fcons (code
, Qnil
));
240 /* NOTE!!! Every function that can call EVAL must protect its args
241 and temporaries from garbage collection while it needs them.
242 The definition of `For' shows what you have to do. */
244 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
245 doc
: /* Eval args until one of them yields non-nil, then return that value.
246 The remaining args are not evalled at all.
247 If all args return nil, return nil.
248 usage: (or CONDITIONS...) */)
251 register Lisp_Object val
= Qnil
;
258 val
= eval_sub (XCAR (args
));
268 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
269 doc
: /* Eval args until one of them yields nil, then return nil.
270 The remaining args are not evalled at all.
271 If no arg yields nil, return the last arg's value.
272 usage: (and CONDITIONS...) */)
275 register Lisp_Object val
= Qt
;
282 val
= eval_sub (XCAR (args
));
292 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
293 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
294 Returns the value of THEN or the value of the last of the ELSE's.
295 THEN must be one expression, but ELSE... can be zero or more expressions.
296 If COND yields nil, and there are no ELSE's, the value is nil.
297 usage: (if COND THEN ELSE...) */)
300 register Lisp_Object cond
;
304 cond
= eval_sub (Fcar (args
));
308 return eval_sub (Fcar (Fcdr (args
)));
309 return Fprogn (Fcdr (Fcdr (args
)));
312 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
313 doc
: /* Try each clause until one succeeds.
314 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
315 and, if the value is non-nil, this clause succeeds:
316 then the expressions in BODY are evaluated and the last one's
317 value is the value of the cond-form.
318 If no clause succeeds, cond returns nil.
319 If a clause has one element, as in (CONDITION),
320 CONDITION's value if non-nil is returned from the cond-form.
321 usage: (cond CLAUSES...) */)
324 register Lisp_Object clause
, val
;
331 clause
= Fcar (args
);
332 val
= eval_sub (Fcar (clause
));
335 if (!EQ (XCDR (clause
), Qnil
))
336 val
= Fprogn (XCDR (clause
));
346 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
347 doc
: /* Eval BODY forms sequentially and return value of last one.
348 usage: (progn BODY...) */)
351 register Lisp_Object val
= Qnil
;
358 val
= eval_sub (XCAR (args
));
366 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
367 doc
: /* Eval FIRST and BODY sequentially; return value from FIRST.
368 The value of FIRST is saved during the evaluation of the remaining args,
369 whose values are discarded.
370 usage: (prog1 FIRST BODY...) */)
374 register Lisp_Object args_left
;
375 struct gcpro gcpro1
, gcpro2
;
381 val
= eval_sub (XCAR (args_left
));
382 while (CONSP (args_left
= XCDR (args_left
)))
383 eval_sub (XCAR (args_left
));
389 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
390 doc
: /* Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
391 The value of FORM2 is saved during the evaluation of the
392 remaining args, whose values are discarded.
393 usage: (prog2 FORM1 FORM2 BODY...) */)
399 eval_sub (XCAR (args
));
401 return Fprog1 (XCDR (args
));
404 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
405 doc
: /* Set each SYM to the value of its VAL.
406 The symbols SYM are variables; they are literal (not evaluated).
407 The values VAL are expressions; they are evaluated.
408 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
409 The second VAL is not computed until after the first SYM is set, and so on;
410 each VAL can use the new value of variables set earlier in the `setq'.
411 The return value of the `setq' form is the value of the last VAL.
412 usage: (setq [SYM VAL]...) */)
415 register Lisp_Object args_left
;
416 register Lisp_Object val
, sym
, lex_binding
;
427 val
= eval_sub (Fcar (Fcdr (args_left
)));
428 sym
= Fcar (args_left
);
430 /* Like for eval_sub, we do not check declared_special here since
431 it's been done when let-binding. */
432 if (!NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
434 && !NILP (lex_binding
435 = Fassq (sym
, Vinternal_interpreter_environment
)))
436 XSETCDR (lex_binding
, val
); /* SYM is lexically bound. */
438 Fset (sym
, val
); /* SYM is dynamically bound. */
440 args_left
= Fcdr (Fcdr (args_left
));
442 while (!NILP (args_left
));
448 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
449 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
450 Warning: `quote' does not construct its return value, but just returns
451 the value that was pre-constructed by the Lisp reader (see info node
452 `(elisp)Printed Representation').
453 This means that '(a . b) is not identical to (cons 'a 'b): the former
454 does not cons. Quoting should be reserved for constants that will
455 never be modified by side-effects, unless you like self-modifying code.
456 See the common pitfall in info node `(elisp)Rearrangement' for an example
457 of unexpected results when a quoted object is modified.
458 usage: (quote ARG) */)
461 if (!NILP (Fcdr (args
)))
462 xsignal2 (Qwrong_number_of_arguments
, Qquote
, Flength (args
));
466 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
467 doc
: /* Like `quote', but preferred for objects which are functions.
468 In byte compilation, `function' causes its argument to be compiled.
469 `quote' cannot do that.
470 usage: (function ARG) */)
473 Lisp_Object quoted
= XCAR (args
);
475 if (!NILP (Fcdr (args
)))
476 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
478 if (!NILP (Vinternal_interpreter_environment
)
480 && EQ (XCAR (quoted
), Qlambda
))
481 /* This is a lambda expression within a lexical environment;
482 return an interpreted closure instead of a simple lambda. */
483 return Fcons (Qclosure
, Fcons (Vinternal_interpreter_environment
,
486 /* Simply quote the argument. */
491 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
492 doc
: /* Return t if the containing function was run directly by user input.
493 This means that the function was called with `call-interactively'
494 \(which includes being called as the binding of a key)
495 and input is currently coming from the keyboard (not a keyboard macro),
496 and Emacs is not running in batch mode (`noninteractive' is nil).
498 The only known proper use of `interactive-p' is in deciding whether to
499 display a helpful message, or how to display it. If you're thinking
500 of using it for any other purpose, it is quite likely that you're
501 making a mistake. Think: what do you want to do when the command is
502 called from a keyboard macro?
504 To test whether your function was called with `call-interactively',
505 either (i) add an extra optional argument and give it an `interactive'
506 spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
507 use `called-interactively-p'. */)
510 return interactive_p (1) ? Qt
: Qnil
;
514 DEFUN ("called-interactively-p", Fcalled_interactively_p
, Scalled_interactively_p
, 0, 1, 0,
515 doc
: /* Return t if the containing function was called by `call-interactively'.
516 If KIND is `interactive', then only return t if the call was made
517 interactively by the user, i.e. not in `noninteractive' mode nor
518 when `executing-kbd-macro'.
519 If KIND is `any', on the other hand, it will return t for any kind of
520 interactive call, including being called as the binding of a key, or
521 from a keyboard macro, or in `noninteractive' mode.
523 The only known proper use of `interactive' for KIND is in deciding
524 whether to display a helpful message, or how to display it. If you're
525 thinking of using it for any other purpose, it is quite likely that
526 you're making a mistake. Think: what do you want to do when the
527 command is called from a keyboard macro?
529 This function is meant for implementing advice and other
530 function-modifying features. Instead of using this, it is sometimes
531 cleaner to give your function an extra optional argument whose
532 `interactive' spec specifies non-nil unconditionally (\"p\" is a good
533 way to do this), or via (not (or executing-kbd-macro noninteractive)). */)
536 return ((INTERACTIVE
|| !EQ (kind
, intern ("interactive")))
537 && interactive_p (1)) ? Qt
: Qnil
;
541 /* Return 1 if function in which this appears was called using
544 EXCLUDE_SUBRS_P non-zero means always return 0 if the function
545 called is a built-in. */
548 interactive_p (int exclude_subrs_p
)
550 struct backtrace
*btp
;
553 btp
= backtrace_list
;
555 /* If this isn't a byte-compiled function, there may be a frame at
556 the top for Finteractive_p. If so, skip it. */
557 fun
= Findirect_function (*btp
->function
, Qnil
);
558 if (SUBRP (fun
) && (XSUBR (fun
) == &Sinteractive_p
559 || XSUBR (fun
) == &Scalled_interactively_p
))
562 /* If we're running an Emacs 18-style byte-compiled function, there
563 may be a frame for Fbytecode at the top level. In any version of
564 Emacs there can be Fbytecode frames for subexpressions evaluated
565 inside catch and condition-case. Skip past them.
567 If this isn't a byte-compiled function, then we may now be
568 looking at several frames for special forms. Skip past them. */
570 && (EQ (*btp
->function
, Qbytecode
)
571 || btp
->nargs
== UNEVALLED
))
574 /* `btp' now points at the frame of the innermost function that isn't
575 a special form, ignoring frames for Finteractive_p and/or
576 Fbytecode at the top. If this frame is for a built-in function
577 (such as load or eval-region) return nil. */
578 fun
= Findirect_function (*btp
->function
, Qnil
);
579 if (exclude_subrs_p
&& SUBRP (fun
))
582 /* `btp' points to the frame of a Lisp function that called interactive-p.
583 Return t if that function was called interactively. */
584 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
590 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
591 doc
: /* Define NAME as a function.
592 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
593 See also the function `interactive'.
594 usage: (defun NAME ARGLIST [DOCSTRING] BODY...) */)
597 register Lisp_Object fn_name
;
598 register Lisp_Object defn
;
600 fn_name
= Fcar (args
);
601 CHECK_SYMBOL (fn_name
);
602 defn
= Fcons (Qlambda
, Fcdr (args
));
603 if (!NILP (Vinternal_interpreter_environment
)) /* Mere optimization! */
604 defn
= Ffunction (Fcons (defn
, Qnil
));
605 if (!NILP (Vpurify_flag
))
606 defn
= Fpurecopy (defn
);
607 if (CONSP (XSYMBOL (fn_name
)->function
)
608 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
609 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
610 Ffset (fn_name
, defn
);
611 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
615 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
616 doc
: /* Define NAME as a macro.
617 The actual definition looks like
618 (macro lambda ARGLIST [DOCSTRING] [DECL] BODY...).
619 When the macro is called, as in (NAME ARGS...),
620 the function (lambda ARGLIST BODY...) is applied to
621 the list ARGS... as it appears in the expression,
622 and the result should be a form to be evaluated instead of the original.
624 DECL is a declaration, optional, which can specify how to indent
625 calls to this macro, how Edebug should handle it, and which argument
626 should be treated as documentation. It looks like this:
628 The elements can look like this:
630 Set NAME's `lisp-indent-function' property to INDENT.
633 Set NAME's `edebug-form-spec' property to DEBUG. (This is
634 equivalent to writing a `def-edebug-spec' for the macro.)
637 Set NAME's `doc-string-elt' property to ELT.
639 usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */)
642 register Lisp_Object fn_name
;
643 register Lisp_Object defn
;
644 Lisp_Object lambda_list
, doc
, tail
;
646 fn_name
= Fcar (args
);
647 CHECK_SYMBOL (fn_name
);
648 lambda_list
= Fcar (Fcdr (args
));
649 tail
= Fcdr (Fcdr (args
));
652 if (STRINGP (Fcar (tail
)))
658 if (CONSP (Fcar (tail
))
659 && EQ (Fcar (Fcar (tail
)), Qdeclare
))
661 if (!NILP (Vmacro_declaration_function
))
665 call2 (Vmacro_declaration_function
, fn_name
, Fcar (tail
));
673 tail
= Fcons (lambda_list
, tail
);
675 tail
= Fcons (lambda_list
, Fcons (doc
, tail
));
677 defn
= Fcons (Qlambda
, tail
);
678 if (!NILP (Vinternal_interpreter_environment
)) /* Mere optimization! */
679 defn
= Ffunction (Fcons (defn
, Qnil
));
680 defn
= Fcons (Qmacro
, defn
);
682 if (!NILP (Vpurify_flag
))
683 defn
= Fpurecopy (defn
);
684 if (CONSP (XSYMBOL (fn_name
)->function
)
685 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
686 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
687 Ffset (fn_name
, defn
);
688 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
693 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
694 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
695 Aliased variables always have the same value; setting one sets the other.
696 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
697 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
698 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
699 itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
700 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
701 The return value is BASE-VARIABLE. */)
702 (Lisp_Object new_alias
, Lisp_Object base_variable
, Lisp_Object docstring
)
704 struct Lisp_Symbol
*sym
;
706 CHECK_SYMBOL (new_alias
);
707 CHECK_SYMBOL (base_variable
);
709 sym
= XSYMBOL (new_alias
);
712 /* Not sure why, but why not? */
713 error ("Cannot make a constant an alias");
715 switch (sym
->redirect
)
717 case SYMBOL_FORWARDED
:
718 error ("Cannot make an internal variable an alias");
719 case SYMBOL_LOCALIZED
:
720 error ("Don't know how to make a localized variable an alias");
723 /* http://lists.gnu.org/archive/html/emacs-devel/2008-04/msg00834.html
724 If n_a is bound, but b_v is not, set the value of b_v to n_a,
725 so that old-code that affects n_a before the aliasing is setup
727 if (NILP (Fboundp (base_variable
)))
728 set_internal (base_variable
, find_symbol_value (new_alias
), Qnil
, 1);
731 struct specbinding
*p
;
733 for (p
= specpdl_ptr
; p
> specpdl
; )
734 if ((--p
)->func
== NULL
736 CONSP (p
->symbol
) ? XCAR (p
->symbol
) : p
->symbol
)))
737 error ("Don't know how to make a let-bound variable an alias");
740 sym
->declared_special
= 1;
741 XSYMBOL (base_variable
)->declared_special
= 1;
742 sym
->redirect
= SYMBOL_VARALIAS
;
743 SET_SYMBOL_ALIAS (sym
, XSYMBOL (base_variable
));
744 sym
->constant
= SYMBOL_CONSTANT_P (base_variable
);
745 LOADHIST_ATTACH (new_alias
);
746 /* Even if docstring is nil: remove old docstring. */
747 Fput (new_alias
, Qvariable_documentation
, docstring
);
749 return base_variable
;
753 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
754 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
755 You are not required to define a variable in order to use it,
756 but the definition can supply documentation and an initial value
757 in a way that tags can recognize.
759 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.
760 If SYMBOL is buffer-local, its default value is what is set;
761 buffer-local values are not affected.
762 INITVALUE and DOCSTRING are optional.
763 If DOCSTRING starts with *, this variable is identified as a user option.
764 This means that M-x set-variable recognizes it.
765 See also `user-variable-p'.
766 If INITVALUE is missing, SYMBOL's value is not set.
768 If SYMBOL has a local binding, then this form affects the local
769 binding. This is usually not what you want. Thus, if you need to
770 load a file defining variables, with this form or with `defconst' or
771 `defcustom', you should always load that file _outside_ any bindings
772 for these variables. \(`defconst' and `defcustom' behave similarly in
774 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
777 register Lisp_Object sym
, tem
, tail
;
781 if (!NILP (Fcdr (Fcdr (tail
))))
782 error ("Too many arguments");
784 tem
= Fdefault_boundp (sym
);
787 /* Do it before evaluating the initial value, for self-references. */
788 XSYMBOL (sym
)->declared_special
= 1;
790 if (SYMBOL_CONSTANT_P (sym
))
792 /* For upward compatibility, allow (defvar :foo (quote :foo)). */
793 Lisp_Object tem1
= Fcar (tail
);
795 && EQ (XCAR (tem1
), Qquote
)
796 && CONSP (XCDR (tem1
))
797 && EQ (XCAR (XCDR (tem1
)), sym
)))
798 error ("Constant symbol `%s' specified in defvar",
799 SDATA (SYMBOL_NAME (sym
)));
803 Fset_default (sym
, eval_sub (Fcar (tail
)));
805 { /* Check if there is really a global binding rather than just a let
806 binding that shadows the global unboundness of the var. */
807 volatile struct specbinding
*pdl
= specpdl_ptr
;
808 while (pdl
> specpdl
)
810 if (EQ ((--pdl
)->symbol
, sym
) && !pdl
->func
811 && EQ (pdl
->old_value
, Qunbound
))
813 message_with_string ("Warning: defvar ignored because %s is let-bound",
814 SYMBOL_NAME (sym
), 1);
823 if (!NILP (Vpurify_flag
))
824 tem
= Fpurecopy (tem
);
825 Fput (sym
, Qvariable_documentation
, tem
);
827 LOADHIST_ATTACH (sym
);
829 else if (!NILP (Vinternal_interpreter_environment
)
830 && !XSYMBOL (sym
)->declared_special
)
831 /* A simple (defvar foo) with lexical scoping does "nothing" except
832 declare that var to be dynamically scoped *locally* (i.e. within
833 the current file or let-block). */
834 Vinternal_interpreter_environment
=
835 Fcons (sym
, Vinternal_interpreter_environment
);
838 /* Simple (defvar <var>) should not count as a definition at all.
839 It could get in the way of other definitions, and unloading this
840 package could try to make the variable unbound. */
846 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
847 doc
: /* Define SYMBOL as a constant variable.
848 The intent is that neither programs nor users should ever change this value.
849 Always sets the value of SYMBOL to the result of evalling INITVALUE.
850 If SYMBOL is buffer-local, its default value is what is set;
851 buffer-local values are not affected.
852 DOCSTRING is optional.
854 If SYMBOL has a local binding, then this form sets the local binding's
855 value. However, you should normally not make local bindings for
856 variables defined with this form.
857 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
860 register Lisp_Object sym
, tem
;
863 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
864 error ("Too many arguments");
866 tem
= eval_sub (Fcar (Fcdr (args
)));
867 if (!NILP (Vpurify_flag
))
868 tem
= Fpurecopy (tem
);
869 Fset_default (sym
, tem
);
870 XSYMBOL (sym
)->declared_special
= 1;
871 tem
= Fcar (Fcdr (Fcdr (args
)));
874 if (!NILP (Vpurify_flag
))
875 tem
= Fpurecopy (tem
);
876 Fput (sym
, Qvariable_documentation
, tem
);
878 Fput (sym
, Qrisky_local_variable
, Qt
);
879 LOADHIST_ATTACH (sym
);
883 /* Error handler used in Fuser_variable_p. */
885 user_variable_p_eh (Lisp_Object ignore
)
891 lisp_indirect_variable (Lisp_Object sym
)
893 struct Lisp_Symbol
*s
= indirect_variable (XSYMBOL (sym
));
898 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
899 doc
: /* Return t if VARIABLE is intended to be set and modified by users.
900 \(The alternative is a variable used internally in a Lisp program.)
901 A variable is a user variable if
902 \(1) the first character of its documentation is `*', or
903 \(2) it is customizable (its property list contains a non-nil value
904 of `standard-value' or `custom-autoload'), or
905 \(3) it is an alias for another user variable.
906 Return nil if VARIABLE is an alias and there is a loop in the
907 chain of symbols. */)
908 (Lisp_Object variable
)
910 Lisp_Object documentation
;
912 if (!SYMBOLP (variable
))
915 /* If indirect and there's an alias loop, don't check anything else. */
916 if (XSYMBOL (variable
)->redirect
== SYMBOL_VARALIAS
917 && NILP (internal_condition_case_1 (lisp_indirect_variable
, variable
,
918 Qt
, user_variable_p_eh
)))
923 documentation
= Fget (variable
, Qvariable_documentation
);
924 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
926 if (STRINGP (documentation
)
927 && ((unsigned char) SREF (documentation
, 0) == '*'))
929 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
930 if (CONSP (documentation
)
931 && STRINGP (XCAR (documentation
))
932 && INTEGERP (XCDR (documentation
))
933 && XINT (XCDR (documentation
)) < 0)
935 /* Customizable? See `custom-variable-p'. */
936 if ((!NILP (Fget (variable
, intern ("standard-value"))))
937 || (!NILP (Fget (variable
, intern ("custom-autoload")))))
940 if (!(XSYMBOL (variable
)->redirect
== SYMBOL_VARALIAS
))
943 /* An indirect variable? Let's follow the chain. */
944 XSETSYMBOL (variable
, SYMBOL_ALIAS (XSYMBOL (variable
)));
948 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
949 doc
: /* Bind variables according to VARLIST then eval BODY.
950 The value of the last form in BODY is returned.
951 Each element of VARLIST is a symbol (which is bound to nil)
952 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
953 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
954 usage: (let* VARLIST BODY...) */)
957 Lisp_Object varlist
, var
, val
, elt
, lexenv
;
958 ptrdiff_t count
= SPECPDL_INDEX ();
959 struct gcpro gcpro1
, gcpro2
, gcpro3
;
961 GCPRO3 (args
, elt
, varlist
);
963 lexenv
= Vinternal_interpreter_environment
;
965 varlist
= Fcar (args
);
966 while (CONSP (varlist
))
970 elt
= XCAR (varlist
);
976 else if (! NILP (Fcdr (Fcdr (elt
))))
977 signal_error ("`let' bindings can have only one value-form", elt
);
981 val
= eval_sub (Fcar (Fcdr (elt
)));
984 if (!NILP (lexenv
) && SYMBOLP (var
)
985 && !XSYMBOL (var
)->declared_special
986 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
987 /* Lexically bind VAR by adding it to the interpreter's binding
991 = Fcons (Fcons (var
, val
), Vinternal_interpreter_environment
);
992 if (EQ (Vinternal_interpreter_environment
, lexenv
))
993 /* Save the old lexical environment on the specpdl stack,
994 but only for the first lexical binding, since we'll never
995 need to revert to one of the intermediate ones. */
996 specbind (Qinternal_interpreter_environment
, newenv
);
998 Vinternal_interpreter_environment
= newenv
;
1001 specbind (var
, val
);
1003 varlist
= XCDR (varlist
);
1006 val
= Fprogn (Fcdr (args
));
1007 return unbind_to (count
, val
);
1010 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
1011 doc
: /* Bind variables according to VARLIST then eval BODY.
1012 The value of the last form in BODY is returned.
1013 Each element of VARLIST is a symbol (which is bound to nil)
1014 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
1015 All the VALUEFORMs are evalled before any symbols are bound.
1016 usage: (let VARLIST BODY...) */)
1019 Lisp_Object
*temps
, tem
, lexenv
;
1020 register Lisp_Object elt
, varlist
;
1021 ptrdiff_t count
= SPECPDL_INDEX ();
1023 struct gcpro gcpro1
, gcpro2
;
1026 varlist
= Fcar (args
);
1028 /* Make space to hold the values to give the bound variables. */
1029 elt
= Flength (varlist
);
1030 SAFE_ALLOCA_LISP (temps
, XFASTINT (elt
));
1032 /* Compute the values and store them in `temps'. */
1034 GCPRO2 (args
, *temps
);
1037 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
1040 elt
= XCAR (varlist
);
1042 temps
[argnum
++] = Qnil
;
1043 else if (! NILP (Fcdr (Fcdr (elt
))))
1044 signal_error ("`let' bindings can have only one value-form", elt
);
1046 temps
[argnum
++] = eval_sub (Fcar (Fcdr (elt
)));
1047 gcpro2
.nvars
= argnum
;
1051 lexenv
= Vinternal_interpreter_environment
;
1053 varlist
= Fcar (args
);
1054 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
1058 elt
= XCAR (varlist
);
1059 var
= SYMBOLP (elt
) ? elt
: Fcar (elt
);
1060 tem
= temps
[argnum
++];
1062 if (!NILP (lexenv
) && SYMBOLP (var
)
1063 && !XSYMBOL (var
)->declared_special
1064 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
1065 /* Lexically bind VAR by adding it to the lexenv alist. */
1066 lexenv
= Fcons (Fcons (var
, tem
), lexenv
);
1068 /* Dynamically bind VAR. */
1069 specbind (var
, tem
);
1072 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
1073 /* Instantiate a new lexical environment. */
1074 specbind (Qinternal_interpreter_environment
, lexenv
);
1076 elt
= Fprogn (Fcdr (args
));
1078 return unbind_to (count
, elt
);
1081 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
1082 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
1083 The order of execution is thus TEST, BODY, TEST, BODY and so on
1084 until TEST returns nil.
1085 usage: (while TEST BODY...) */)
1088 Lisp_Object test
, body
;
1089 struct gcpro gcpro1
, gcpro2
;
1091 GCPRO2 (test
, body
);
1095 while (!NILP (eval_sub (test
)))
1105 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
1106 doc
: /* Return result of expanding macros at top level of FORM.
1107 If FORM is not a macro call, it is returned unchanged.
1108 Otherwise, the macro is expanded and the expansion is considered
1109 in place of FORM. When a non-macro-call results, it is returned.
1111 The second optional arg ENVIRONMENT specifies an environment of macro
1112 definitions to shadow the loaded ones for use in file byte-compilation. */)
1113 (Lisp_Object form
, Lisp_Object environment
)
1115 /* With cleanups from Hallvard Furuseth. */
1116 register Lisp_Object expander
, sym
, def
, tem
;
1120 /* Come back here each time we expand a macro call,
1121 in case it expands into another macro call. */
1124 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1125 def
= sym
= XCAR (form
);
1127 /* Trace symbols aliases to other symbols
1128 until we get a symbol that is not an alias. */
1129 while (SYMBOLP (def
))
1133 tem
= Fassq (sym
, environment
);
1136 def
= XSYMBOL (sym
)->function
;
1137 if (!EQ (def
, Qunbound
))
1142 /* Right now TEM is the result from SYM in ENVIRONMENT,
1143 and if TEM is nil then DEF is SYM's function definition. */
1146 /* SYM is not mentioned in ENVIRONMENT.
1147 Look at its function definition. */
1148 if (EQ (def
, Qunbound
) || !CONSP (def
))
1149 /* Not defined or definition not suitable. */
1151 if (EQ (XCAR (def
), Qautoload
))
1153 /* Autoloading function: will it be a macro when loaded? */
1154 tem
= Fnth (make_number (4), def
);
1155 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
1156 /* Yes, load it and try again. */
1158 struct gcpro gcpro1
;
1160 do_autoload (def
, sym
);
1167 else if (!EQ (XCAR (def
), Qmacro
))
1169 else expander
= XCDR (def
);
1173 expander
= XCDR (tem
);
1174 if (NILP (expander
))
1177 form
= apply1 (expander
, XCDR (form
));
1182 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1183 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1184 TAG is evalled to get the tag to use; it must not be nil.
1186 Then the BODY is executed.
1187 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
1188 If no throw happens, `catch' returns the value of the last BODY form.
1189 If a throw happens, it specifies the value to return from `catch'.
1190 usage: (catch TAG BODY...) */)
1193 register Lisp_Object tag
;
1194 struct gcpro gcpro1
;
1197 tag
= eval_sub (Fcar (args
));
1199 return internal_catch (tag
, Fprogn
, Fcdr (args
));
1202 /* Set up a catch, then call C function FUNC on argument ARG.
1203 FUNC should return a Lisp_Object.
1204 This is how catches are done from within C code. */
1207 internal_catch (Lisp_Object tag
, Lisp_Object (*func
) (Lisp_Object
), Lisp_Object arg
)
1209 /* This structure is made part of the chain `catchlist'. */
1212 /* Fill in the components of c, and put it on the list. */
1216 c
.backlist
= backtrace_list
;
1217 c
.handlerlist
= handlerlist
;
1218 c
.lisp_eval_depth
= lisp_eval_depth
;
1219 c
.pdlcount
= SPECPDL_INDEX ();
1220 c
.poll_suppress_count
= poll_suppress_count
;
1221 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1222 c
.gcpro
= gcprolist
;
1223 c
.byte_stack
= byte_stack_list
;
1227 if (! _setjmp (c
.jmp
))
1228 c
.val
= (*func
) (arg
);
1230 /* Throw works by a longjmp that comes right here. */
1235 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1236 jump to that CATCH, returning VALUE as the value of that catch.
1238 This is the guts Fthrow and Fsignal; they differ only in the way
1239 they choose the catch tag to throw to. A catch tag for a
1240 condition-case form has a TAG of Qnil.
1242 Before each catch is discarded, unbind all special bindings and
1243 execute all unwind-protect clauses made above that catch. Unwind
1244 the handler stack as we go, so that the proper handlers are in
1245 effect for each unwind-protect clause we run. At the end, restore
1246 some static info saved in CATCH, and longjmp to the location
1249 This is used for correct unwinding in Fthrow and Fsignal. */
1252 unwind_to_catch (struct catchtag
*catch, Lisp_Object value
)
1254 register int last_time
;
1256 /* Save the value in the tag. */
1259 /* Restore certain special C variables. */
1260 set_poll_suppress_count (catch->poll_suppress_count
);
1261 UNBLOCK_INPUT_TO (catch->interrupt_input_blocked
);
1262 handling_signal
= 0;
1267 last_time
= catchlist
== catch;
1269 /* Unwind the specpdl stack, and then restore the proper set of
1271 unbind_to (catchlist
->pdlcount
, Qnil
);
1272 handlerlist
= catchlist
->handlerlist
;
1273 catchlist
= catchlist
->next
;
1275 while (! last_time
);
1278 /* If x_catch_errors was done, turn it off now.
1279 (First we give unbind_to a chance to do that.) */
1280 #if 0 /* This would disable x_catch_errors after x_connection_closed.
1281 The catch must remain in effect during that delicate
1282 state. --lorentey */
1283 x_fully_uncatch_errors ();
1287 byte_stack_list
= catch->byte_stack
;
1288 gcprolist
= catch->gcpro
;
1290 gcpro_level
= gcprolist
? gcprolist
->level
+ 1 : 0;
1292 backtrace_list
= catch->backlist
;
1293 lisp_eval_depth
= catch->lisp_eval_depth
;
1295 _longjmp (catch->jmp
, 1);
1298 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1299 doc
: /* Throw to the catch for TAG and return VALUE from it.
1300 Both TAG and VALUE are evalled. */)
1301 (register Lisp_Object tag
, Lisp_Object value
)
1303 register struct catchtag
*c
;
1306 for (c
= catchlist
; c
; c
= c
->next
)
1308 if (EQ (c
->tag
, tag
))
1309 unwind_to_catch (c
, value
);
1311 xsignal2 (Qno_catch
, tag
, value
);
1315 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1316 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1317 If BODYFORM completes normally, its value is returned
1318 after executing the UNWINDFORMS.
1319 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1320 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1324 ptrdiff_t count
= SPECPDL_INDEX ();
1326 record_unwind_protect (Fprogn
, Fcdr (args
));
1327 val
= eval_sub (Fcar (args
));
1328 return unbind_to (count
, val
);
1331 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1332 doc
: /* Regain control when an error is signaled.
1333 Executes BODYFORM and returns its value if no error happens.
1334 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1335 where the BODY is made of Lisp expressions.
1337 A handler is applicable to an error
1338 if CONDITION-NAME is one of the error's condition names.
1339 If an error happens, the first applicable handler is run.
1341 The car of a handler may be a list of condition names instead of a
1342 single condition name; then it handles all of them. If the special
1343 condition name `debug' is present in this list, it allows another
1344 condition in the list to run the debugger if `debug-on-error' and the
1345 other usual mechanisms says it should (otherwise, `condition-case'
1346 suppresses the debugger).
1348 When a handler handles an error, control returns to the `condition-case'
1349 and it executes the handler's BODY...
1350 with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
1351 \(If VAR is nil, the handler can't access that information.)
1352 Then the value of the last BODY form is returned from the `condition-case'
1355 See also the function `signal' for more info.
1356 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1359 register Lisp_Object bodyform
, handlers
;
1360 volatile Lisp_Object var
;
1363 bodyform
= Fcar (Fcdr (args
));
1364 handlers
= Fcdr (Fcdr (args
));
1366 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1369 /* Like Fcondition_case, but the args are separate
1370 rather than passed in a list. Used by Fbyte_code. */
1373 internal_lisp_condition_case (volatile Lisp_Object var
, Lisp_Object bodyform
,
1374 Lisp_Object handlers
)
1382 for (val
= handlers
; CONSP (val
); val
= XCDR (val
))
1388 && (SYMBOLP (XCAR (tem
))
1389 || CONSP (XCAR (tem
))))))
1390 error ("Invalid condition handler: %s",
1391 SDATA (Fprin1_to_string (tem
, Qt
)));
1396 c
.backlist
= backtrace_list
;
1397 c
.handlerlist
= handlerlist
;
1398 c
.lisp_eval_depth
= lisp_eval_depth
;
1399 c
.pdlcount
= SPECPDL_INDEX ();
1400 c
.poll_suppress_count
= poll_suppress_count
;
1401 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1402 c
.gcpro
= gcprolist
;
1403 c
.byte_stack
= byte_stack_list
;
1404 if (_setjmp (c
.jmp
))
1407 specbind (h
.var
, c
.val
);
1408 val
= Fprogn (Fcdr (h
.chosen_clause
));
1410 /* Note that this just undoes the binding of h.var; whoever
1411 longjumped to us unwound the stack to c.pdlcount before
1413 unbind_to (c
.pdlcount
, Qnil
);
1420 h
.handler
= handlers
;
1421 h
.next
= handlerlist
;
1425 val
= eval_sub (bodyform
);
1427 handlerlist
= h
.next
;
1431 /* Call the function BFUN with no arguments, catching errors within it
1432 according to HANDLERS. If there is an error, call HFUN with
1433 one argument which is the data that describes the error:
1436 HANDLERS can be a list of conditions to catch.
1437 If HANDLERS is Qt, catch all errors.
1438 If HANDLERS is Qerror, catch all errors
1439 but allow the debugger to run if that is enabled. */
1442 internal_condition_case (Lisp_Object (*bfun
) (void), Lisp_Object handlers
,
1443 Lisp_Object (*hfun
) (Lisp_Object
))
1451 c
.backlist
= backtrace_list
;
1452 c
.handlerlist
= handlerlist
;
1453 c
.lisp_eval_depth
= lisp_eval_depth
;
1454 c
.pdlcount
= SPECPDL_INDEX ();
1455 c
.poll_suppress_count
= poll_suppress_count
;
1456 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1457 c
.gcpro
= gcprolist
;
1458 c
.byte_stack
= byte_stack_list
;
1459 if (_setjmp (c
.jmp
))
1461 return (*hfun
) (c
.val
);
1465 h
.handler
= handlers
;
1467 h
.next
= handlerlist
;
1473 handlerlist
= h
.next
;
1477 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1480 internal_condition_case_1 (Lisp_Object (*bfun
) (Lisp_Object
), Lisp_Object arg
,
1481 Lisp_Object handlers
, Lisp_Object (*hfun
) (Lisp_Object
))
1489 c
.backlist
= backtrace_list
;
1490 c
.handlerlist
= handlerlist
;
1491 c
.lisp_eval_depth
= lisp_eval_depth
;
1492 c
.pdlcount
= SPECPDL_INDEX ();
1493 c
.poll_suppress_count
= poll_suppress_count
;
1494 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1495 c
.gcpro
= gcprolist
;
1496 c
.byte_stack
= byte_stack_list
;
1497 if (_setjmp (c
.jmp
))
1499 return (*hfun
) (c
.val
);
1503 h
.handler
= handlers
;
1505 h
.next
= handlerlist
;
1509 val
= (*bfun
) (arg
);
1511 handlerlist
= h
.next
;
1515 /* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as
1519 internal_condition_case_2 (Lisp_Object (*bfun
) (Lisp_Object
, Lisp_Object
),
1522 Lisp_Object handlers
,
1523 Lisp_Object (*hfun
) (Lisp_Object
))
1531 c
.backlist
= backtrace_list
;
1532 c
.handlerlist
= handlerlist
;
1533 c
.lisp_eval_depth
= lisp_eval_depth
;
1534 c
.pdlcount
= SPECPDL_INDEX ();
1535 c
.poll_suppress_count
= poll_suppress_count
;
1536 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1537 c
.gcpro
= gcprolist
;
1538 c
.byte_stack
= byte_stack_list
;
1539 if (_setjmp (c
.jmp
))
1541 return (*hfun
) (c
.val
);
1545 h
.handler
= handlers
;
1547 h
.next
= handlerlist
;
1551 val
= (*bfun
) (arg1
, arg2
);
1553 handlerlist
= h
.next
;
1557 /* Like internal_condition_case but call BFUN with NARGS as first,
1558 and ARGS as second argument. */
1561 internal_condition_case_n (Lisp_Object (*bfun
) (ptrdiff_t, Lisp_Object
*),
1564 Lisp_Object handlers
,
1565 Lisp_Object (*hfun
) (Lisp_Object
))
1573 c
.backlist
= backtrace_list
;
1574 c
.handlerlist
= handlerlist
;
1575 c
.lisp_eval_depth
= lisp_eval_depth
;
1576 c
.pdlcount
= SPECPDL_INDEX ();
1577 c
.poll_suppress_count
= poll_suppress_count
;
1578 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1579 c
.gcpro
= gcprolist
;
1580 c
.byte_stack
= byte_stack_list
;
1581 if (_setjmp (c
.jmp
))
1583 return (*hfun
) (c
.val
);
1587 h
.handler
= handlers
;
1589 h
.next
= handlerlist
;
1593 val
= (*bfun
) (nargs
, args
);
1595 handlerlist
= h
.next
;
1600 static Lisp_Object
find_handler_clause (Lisp_Object
, Lisp_Object
);
1601 static int maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
,
1604 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1605 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1606 This function does not return.
1608 An error symbol is a symbol with an `error-conditions' property
1609 that is a list of condition names.
1610 A handler for any of those names will get to handle this signal.
1611 The symbol `error' should normally be one of them.
1613 DATA should be a list. Its elements are printed as part of the error message.
1614 See Info anchor `(elisp)Definition of signal' for some details on how this
1615 error message is constructed.
1616 If the signal is handled, DATA is made available to the handler.
1617 See also the function `condition-case'. */)
1618 (Lisp_Object error_symbol
, Lisp_Object data
)
1620 /* When memory is full, ERROR-SYMBOL is nil,
1621 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1622 That is a special case--don't do this in other situations. */
1623 Lisp_Object conditions
;
1625 Lisp_Object real_error_symbol
1626 = (NILP (error_symbol
) ? Fcar (data
) : error_symbol
);
1627 register Lisp_Object clause
= Qnil
;
1629 struct backtrace
*bp
;
1631 immediate_quit
= handling_signal
= 0;
1633 if (gc_in_progress
|| waiting_for_input
)
1636 #if 0 /* rms: I don't know why this was here,
1637 but it is surely wrong for an error that is handled. */
1638 #ifdef HAVE_WINDOW_SYSTEM
1639 if (display_hourglass_p
)
1640 cancel_hourglass ();
1644 /* This hook is used by edebug. */
1645 if (! NILP (Vsignal_hook_function
)
1646 && ! NILP (error_symbol
))
1648 /* Edebug takes care of restoring these variables when it exits. */
1649 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1650 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1652 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1653 max_specpdl_size
= SPECPDL_INDEX () + 40;
1655 call2 (Vsignal_hook_function
, error_symbol
, data
);
1658 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1660 /* Remember from where signal was called. Skip over the frame for
1661 `signal' itself. If a frame for `error' follows, skip that,
1662 too. Don't do this when ERROR_SYMBOL is nil, because that
1663 is a memory-full error. */
1664 Vsignaling_function
= Qnil
;
1665 if (backtrace_list
&& !NILP (error_symbol
))
1667 bp
= backtrace_list
->next
;
1668 if (bp
&& bp
->function
&& EQ (*bp
->function
, Qerror
))
1670 if (bp
&& bp
->function
)
1671 Vsignaling_function
= *bp
->function
;
1674 for (h
= handlerlist
; h
; h
= h
->next
)
1676 clause
= find_handler_clause (h
->handler
, conditions
);
1681 if (/* Don't run the debugger for a memory-full error.
1682 (There is no room in memory to do that!) */
1683 !NILP (error_symbol
)
1684 && (!NILP (Vdebug_on_signal
)
1685 /* If no handler is present now, try to run the debugger. */
1687 /* A `debug' symbol in the handler list disables the normal
1688 suppression of the debugger. */
1689 || (CONSP (clause
) && CONSP (XCAR (clause
))
1690 && !NILP (Fmemq (Qdebug
, XCAR (clause
))))
1691 /* Special handler that means "print a message and run debugger
1693 || EQ (h
->handler
, Qerror
)))
1696 = maybe_call_debugger (conditions
, error_symbol
, data
);
1697 /* We can't return values to code which signaled an error, but we
1698 can continue code which has signaled a quit. */
1699 if (debugger_called
&& EQ (real_error_symbol
, Qquit
))
1705 Lisp_Object unwind_data
1706 = (NILP (error_symbol
) ? data
: Fcons (error_symbol
, data
));
1708 h
->chosen_clause
= clause
;
1709 unwind_to_catch (h
->tag
, unwind_data
);
1714 Fthrow (Qtop_level
, Qt
);
1717 if (! NILP (error_symbol
))
1718 data
= Fcons (error_symbol
, data
);
1720 string
= Ferror_message_string (data
);
1721 fatal ("%s", SDATA (string
));
1724 /* Internal version of Fsignal that never returns.
1725 Used for anything but Qquit (which can return from Fsignal). */
1728 xsignal (Lisp_Object error_symbol
, Lisp_Object data
)
1730 Fsignal (error_symbol
, data
);
1734 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1737 xsignal0 (Lisp_Object error_symbol
)
1739 xsignal (error_symbol
, Qnil
);
1743 xsignal1 (Lisp_Object error_symbol
, Lisp_Object arg
)
1745 xsignal (error_symbol
, list1 (arg
));
1749 xsignal2 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
)
1751 xsignal (error_symbol
, list2 (arg1
, arg2
));
1755 xsignal3 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
1757 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1760 /* Signal `error' with message S, and additional arg ARG.
1761 If ARG is not a genuine list, make it a one-element list. */
1764 signal_error (const char *s
, Lisp_Object arg
)
1766 Lisp_Object tortoise
, hare
;
1768 hare
= tortoise
= arg
;
1769 while (CONSP (hare
))
1776 tortoise
= XCDR (tortoise
);
1778 if (EQ (hare
, tortoise
))
1783 arg
= Fcons (arg
, Qnil
); /* Make it a list. */
1785 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1789 /* Return nonzero if LIST is a non-nil atom or
1790 a list containing one of CONDITIONS. */
1793 wants_debugger (Lisp_Object list
, Lisp_Object conditions
)
1800 while (CONSP (conditions
))
1802 Lisp_Object
this, tail
;
1803 this = XCAR (conditions
);
1804 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1805 if (EQ (XCAR (tail
), this))
1807 conditions
= XCDR (conditions
);
1812 /* Return 1 if an error with condition-symbols CONDITIONS,
1813 and described by SIGNAL-DATA, should skip the debugger
1814 according to debugger-ignored-errors. */
1817 skip_debugger (Lisp_Object conditions
, Lisp_Object data
)
1820 int first_string
= 1;
1821 Lisp_Object error_message
;
1823 error_message
= Qnil
;
1824 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1826 if (STRINGP (XCAR (tail
)))
1830 error_message
= Ferror_message_string (data
);
1834 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1839 Lisp_Object contail
;
1841 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1842 if (EQ (XCAR (tail
), XCAR (contail
)))
1850 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1851 SIG and DATA describe the signal. There are two ways to pass them:
1852 = SIG is the error symbol, and DATA is the rest of the data.
1853 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1854 This is for memory-full errors only. */
1856 maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
, Lisp_Object data
)
1858 Lisp_Object combined_data
;
1860 combined_data
= Fcons (sig
, data
);
1863 /* Don't try to run the debugger with interrupts blocked.
1864 The editing loop would return anyway. */
1866 /* Does user want to enter debugger for this kind of error? */
1869 : wants_debugger (Vdebug_on_error
, conditions
))
1870 && ! skip_debugger (conditions
, combined_data
)
1871 /* RMS: What's this for? */
1872 && when_entered_debugger
< num_nonmacro_input_events
)
1874 call_debugger (Fcons (Qerror
, Fcons (combined_data
, Qnil
)));
1882 find_handler_clause (Lisp_Object handlers
, Lisp_Object conditions
)
1884 register Lisp_Object h
;
1886 /* t is used by handlers for all conditions, set up by C code. */
1887 if (EQ (handlers
, Qt
))
1890 /* error is used similarly, but means print an error message
1891 and run the debugger if that is enabled. */
1892 if (EQ (handlers
, Qerror
))
1895 for (h
= handlers
; CONSP (h
); h
= XCDR (h
))
1897 Lisp_Object handler
= XCAR (h
);
1898 Lisp_Object condit
, tem
;
1900 if (!CONSP (handler
))
1902 condit
= XCAR (handler
);
1903 /* Handle a single condition name in handler HANDLER. */
1904 if (SYMBOLP (condit
))
1906 tem
= Fmemq (Fcar (handler
), conditions
);
1910 /* Handle a list of condition names in handler HANDLER. */
1911 else if (CONSP (condit
))
1914 for (tail
= condit
; CONSP (tail
); tail
= XCDR (tail
))
1916 tem
= Fmemq (XCAR (tail
), conditions
);
1927 /* Dump an error message; called like vprintf. */
1929 verror (const char *m
, va_list ap
)
1932 ptrdiff_t size
= sizeof buf
;
1933 ptrdiff_t size_max
= STRING_BYTES_BOUND
+ 1;
1938 used
= evxprintf (&buffer
, &size
, buf
, size_max
, m
, ap
);
1939 string
= make_string (buffer
, used
);
1943 xsignal1 (Qerror
, string
);
1947 /* Dump an error message; called like printf. */
1951 error (const char *m
, ...)
1959 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
1960 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
1961 This means it contains a description for how to read arguments to give it.
1962 The value is nil for an invalid function or a symbol with no function
1965 Interactively callable functions include strings and vectors (treated
1966 as keyboard macros), lambda-expressions that contain a top-level call
1967 to `interactive', autoload definitions made by `autoload' with non-nil
1968 fourth argument, and some of the built-in functions of Lisp.
1970 Also, a symbol satisfies `commandp' if its function definition does so.
1972 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
1973 then strings and vectors are not accepted. */)
1974 (Lisp_Object function
, Lisp_Object for_call_interactively
)
1976 register Lisp_Object fun
;
1977 register Lisp_Object funcar
;
1978 Lisp_Object if_prop
= Qnil
;
1982 fun
= indirect_function (fun
); /* Check cycles. */
1983 if (NILP (fun
) || EQ (fun
, Qunbound
))
1986 /* Check an `interactive-form' property if present, analogous to the
1987 function-documentation property. */
1989 while (SYMBOLP (fun
))
1991 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
1994 fun
= Fsymbol_function (fun
);
1997 /* Emacs primitives are interactive if their DEFUN specifies an
1998 interactive spec. */
2000 return XSUBR (fun
)->intspec
? Qt
: if_prop
;
2002 /* Bytecode objects are interactive if they are long enough to
2003 have an element whose index is COMPILED_INTERACTIVE, which is
2004 where the interactive spec is stored. */
2005 else if (COMPILEDP (fun
))
2006 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
2009 /* Strings and vectors are keyboard macros. */
2010 if (STRINGP (fun
) || VECTORP (fun
))
2011 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
2013 /* Lists may represent commands. */
2016 funcar
= XCAR (fun
);
2017 if (EQ (funcar
, Qclosure
))
2018 return (!NILP (Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
)))))
2020 else if (EQ (funcar
, Qlambda
))
2021 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
2022 else if (EQ (funcar
, Qautoload
))
2023 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
2028 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
2029 doc
: /* Define FUNCTION to autoload from FILE.
2030 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
2031 Third arg DOCSTRING is documentation for the function.
2032 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
2033 Fifth arg TYPE indicates the type of the object:
2034 nil or omitted says FUNCTION is a function,
2035 `keymap' says FUNCTION is really a keymap, and
2036 `macro' or t says FUNCTION is really a macro.
2037 Third through fifth args give info about the real definition.
2038 They default to nil.
2039 If FUNCTION is already defined other than as an autoload,
2040 this does nothing and returns nil. */)
2041 (Lisp_Object function
, Lisp_Object file
, Lisp_Object docstring
, Lisp_Object interactive
, Lisp_Object type
)
2043 CHECK_SYMBOL (function
);
2044 CHECK_STRING (file
);
2046 /* If function is defined and not as an autoload, don't override. */
2047 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
2048 && !(CONSP (XSYMBOL (function
)->function
)
2049 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
2052 if (NILP (Vpurify_flag
))
2053 /* Only add entries after dumping, because the ones before are
2054 not useful and else we get loads of them from the loaddefs.el. */
2055 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
2057 /* We don't want the docstring in purespace (instead,
2058 Snarf-documentation should (hopefully) overwrite it).
2059 We used to use 0 here, but that leads to accidental sharing in
2060 purecopy's hash-consing, so we use a (hopefully) unique integer
2062 docstring
= make_number (XPNTR (function
));
2063 return Ffset (function
,
2064 Fpurecopy (list5 (Qautoload
, file
, docstring
,
2065 interactive
, type
)));
2069 un_autoload (Lisp_Object oldqueue
)
2071 register Lisp_Object queue
, first
, second
;
2073 /* Queue to unwind is current value of Vautoload_queue.
2074 oldqueue is the shadowed value to leave in Vautoload_queue. */
2075 queue
= Vautoload_queue
;
2076 Vautoload_queue
= oldqueue
;
2077 while (CONSP (queue
))
2079 first
= XCAR (queue
);
2080 second
= Fcdr (first
);
2081 first
= Fcar (first
);
2082 if (EQ (first
, make_number (0)))
2085 Ffset (first
, second
);
2086 queue
= XCDR (queue
);
2091 /* Load an autoloaded function.
2092 FUNNAME is the symbol which is the function's name.
2093 FUNDEF is the autoload definition (a list). */
2096 do_autoload (Lisp_Object fundef
, Lisp_Object funname
)
2098 ptrdiff_t count
= SPECPDL_INDEX ();
2100 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2102 /* This is to make sure that loadup.el gives a clear picture
2103 of what files are preloaded and when. */
2104 if (! NILP (Vpurify_flag
))
2105 error ("Attempt to autoload %s while preparing to dump",
2106 SDATA (SYMBOL_NAME (funname
)));
2109 CHECK_SYMBOL (funname
);
2110 GCPRO3 (fun
, funname
, fundef
);
2112 /* Preserve the match data. */
2113 record_unwind_save_match_data ();
2115 /* If autoloading gets an error (which includes the error of failing
2116 to define the function being called), we use Vautoload_queue
2117 to undo function definitions and `provide' calls made by
2118 the function. We do this in the specific case of autoloading
2119 because autoloading is not an explicit request "load this file",
2120 but rather a request to "call this function".
2122 The value saved here is to be restored into Vautoload_queue. */
2123 record_unwind_protect (un_autoload
, Vautoload_queue
);
2124 Vautoload_queue
= Qt
;
2125 Fload (Fcar (Fcdr (fundef
)), Qnil
, Qt
, Qnil
, Qt
);
2127 /* Once loading finishes, don't undo it. */
2128 Vautoload_queue
= Qt
;
2129 unbind_to (count
, Qnil
);
2131 fun
= Findirect_function (fun
, Qnil
);
2133 if (!NILP (Fequal (fun
, fundef
)))
2134 error ("Autoloading failed to define function %s",
2135 SDATA (SYMBOL_NAME (funname
)));
2140 DEFUN ("eval", Feval
, Seval
, 1, 2, 0,
2141 doc
: /* Evaluate FORM and return its value.
2142 If LEXICAL is t, evaluate using lexical scoping. */)
2143 (Lisp_Object form
, Lisp_Object lexical
)
2145 ptrdiff_t count
= SPECPDL_INDEX ();
2146 specbind (Qinternal_interpreter_environment
,
2147 NILP (lexical
) ? Qnil
: Fcons (Qt
, Qnil
));
2148 return unbind_to (count
, eval_sub (form
));
2151 /* Eval a sub-expression of the current expression (i.e. in the same
2154 eval_sub (Lisp_Object form
)
2156 Lisp_Object fun
, val
, original_fun
, original_args
;
2158 struct backtrace backtrace
;
2159 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2161 if (handling_signal
)
2166 /* Look up its binding in the lexical environment.
2167 We do not pay attention to the declared_special flag here, since we
2168 already did that when let-binding the variable. */
2169 Lisp_Object lex_binding
2170 = !NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
2171 ? Fassq (form
, Vinternal_interpreter_environment
)
2173 if (CONSP (lex_binding
))
2174 return XCDR (lex_binding
);
2176 return Fsymbol_value (form
);
2183 if ((consing_since_gc
> gc_cons_threshold
2184 && consing_since_gc
> gc_relative_threshold
)
2186 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2189 Fgarbage_collect ();
2193 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2195 if (max_lisp_eval_depth
< 100)
2196 max_lisp_eval_depth
= 100;
2197 if (lisp_eval_depth
> max_lisp_eval_depth
)
2198 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2201 original_fun
= Fcar (form
);
2202 original_args
= Fcdr (form
);
2204 backtrace
.next
= backtrace_list
;
2205 backtrace_list
= &backtrace
;
2206 backtrace
.function
= &original_fun
; /* This also protects them from gc. */
2207 backtrace
.args
= &original_args
;
2208 backtrace
.nargs
= UNEVALLED
;
2209 backtrace
.debug_on_exit
= 0;
2211 if (debug_on_next_call
)
2212 do_debug_on_call (Qt
);
2214 /* At this point, only original_fun and original_args
2215 have values that will be used below. */
2218 /* Optimize for no indirection. */
2220 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2221 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2222 fun
= indirect_function (fun
);
2226 Lisp_Object numargs
;
2227 Lisp_Object argvals
[8];
2228 Lisp_Object args_left
;
2229 register int i
, maxargs
;
2231 args_left
= original_args
;
2232 numargs
= Flength (args_left
);
2236 if (XINT (numargs
) < XSUBR (fun
)->min_args
2237 || (XSUBR (fun
)->max_args
>= 0
2238 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2239 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2241 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2242 val
= (XSUBR (fun
)->function
.aUNEVALLED
) (args_left
);
2243 else if (XSUBR (fun
)->max_args
== MANY
)
2245 /* Pass a vector of evaluated arguments. */
2247 ptrdiff_t argnum
= 0;
2250 SAFE_ALLOCA_LISP (vals
, XINT (numargs
));
2252 GCPRO3 (args_left
, fun
, fun
);
2256 while (!NILP (args_left
))
2258 vals
[argnum
++] = eval_sub (Fcar (args_left
));
2259 args_left
= Fcdr (args_left
);
2260 gcpro3
.nvars
= argnum
;
2263 backtrace
.args
= vals
;
2264 backtrace
.nargs
= XINT (numargs
);
2266 val
= (XSUBR (fun
)->function
.aMANY
) (XINT (numargs
), vals
);
2272 GCPRO3 (args_left
, fun
, fun
);
2273 gcpro3
.var
= argvals
;
2276 maxargs
= XSUBR (fun
)->max_args
;
2277 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
2279 argvals
[i
] = eval_sub (Fcar (args_left
));
2285 backtrace
.args
= argvals
;
2286 backtrace
.nargs
= XINT (numargs
);
2291 val
= (XSUBR (fun
)->function
.a0 ());
2294 val
= (XSUBR (fun
)->function
.a1 (argvals
[0]));
2297 val
= (XSUBR (fun
)->function
.a2 (argvals
[0], argvals
[1]));
2300 val
= (XSUBR (fun
)->function
.a3
2301 (argvals
[0], argvals
[1], argvals
[2]));
2304 val
= (XSUBR (fun
)->function
.a4
2305 (argvals
[0], argvals
[1], argvals
[2], argvals
[3]));
2308 val
= (XSUBR (fun
)->function
.a5
2309 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2313 val
= (XSUBR (fun
)->function
.a6
2314 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2315 argvals
[4], argvals
[5]));
2318 val
= (XSUBR (fun
)->function
.a7
2319 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2320 argvals
[4], argvals
[5], argvals
[6]));
2324 val
= (XSUBR (fun
)->function
.a8
2325 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2326 argvals
[4], argvals
[5], argvals
[6], argvals
[7]));
2330 /* Someone has created a subr that takes more arguments than
2331 is supported by this code. We need to either rewrite the
2332 subr to use a different argument protocol, or add more
2333 cases to this switch. */
2338 else if (COMPILEDP (fun
))
2339 val
= apply_lambda (fun
, original_args
);
2342 if (EQ (fun
, Qunbound
))
2343 xsignal1 (Qvoid_function
, original_fun
);
2345 xsignal1 (Qinvalid_function
, original_fun
);
2346 funcar
= XCAR (fun
);
2347 if (!SYMBOLP (funcar
))
2348 xsignal1 (Qinvalid_function
, original_fun
);
2349 if (EQ (funcar
, Qautoload
))
2351 do_autoload (fun
, original_fun
);
2354 if (EQ (funcar
, Qmacro
))
2355 val
= eval_sub (apply1 (Fcdr (fun
), original_args
));
2356 else if (EQ (funcar
, Qlambda
)
2357 || EQ (funcar
, Qclosure
))
2358 val
= apply_lambda (fun
, original_args
);
2360 xsignal1 (Qinvalid_function
, original_fun
);
2365 if (backtrace
.debug_on_exit
)
2366 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2367 backtrace_list
= backtrace
.next
;
2372 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
2373 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2374 Then return the value FUNCTION returns.
2375 Thus, (apply '+ 1 2 '(3 4)) returns 10.
2376 usage: (apply FUNCTION &rest ARGUMENTS) */)
2377 (ptrdiff_t nargs
, Lisp_Object
*args
)
2381 register Lisp_Object spread_arg
;
2382 register Lisp_Object
*funcall_args
;
2383 Lisp_Object fun
, retval
;
2384 struct gcpro gcpro1
;
2389 spread_arg
= args
[nargs
- 1];
2390 CHECK_LIST (spread_arg
);
2392 numargs
= XINT (Flength (spread_arg
));
2395 return Ffuncall (nargs
- 1, args
);
2396 else if (numargs
== 1)
2398 args
[nargs
- 1] = XCAR (spread_arg
);
2399 return Ffuncall (nargs
, args
);
2402 numargs
+= nargs
- 2;
2404 /* Optimize for no indirection. */
2405 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2406 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2407 fun
= indirect_function (fun
);
2408 if (EQ (fun
, Qunbound
))
2410 /* Let funcall get the error. */
2417 if (numargs
< XSUBR (fun
)->min_args
2418 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2419 goto funcall
; /* Let funcall get the error. */
2420 else if (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
> numargs
)
2422 /* Avoid making funcall cons up a yet another new vector of arguments
2423 by explicitly supplying nil's for optional values. */
2424 SAFE_ALLOCA_LISP (funcall_args
, 1 + XSUBR (fun
)->max_args
);
2425 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2426 funcall_args
[++i
] = Qnil
;
2427 GCPRO1 (*funcall_args
);
2428 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2432 /* We add 1 to numargs because funcall_args includes the
2433 function itself as well as its arguments. */
2436 SAFE_ALLOCA_LISP (funcall_args
, 1 + numargs
);
2437 GCPRO1 (*funcall_args
);
2438 gcpro1
.nvars
= 1 + numargs
;
2441 memcpy (funcall_args
, args
, nargs
* sizeof (Lisp_Object
));
2442 /* Spread the last arg we got. Its first element goes in
2443 the slot that it used to occupy, hence this value of I. */
2445 while (!NILP (spread_arg
))
2447 funcall_args
[i
++] = XCAR (spread_arg
);
2448 spread_arg
= XCDR (spread_arg
);
2451 /* By convention, the caller needs to gcpro Ffuncall's args. */
2452 retval
= Ffuncall (gcpro1
.nvars
, funcall_args
);
2459 /* Run hook variables in various ways. */
2462 funcall_nil (ptrdiff_t nargs
, Lisp_Object
*args
)
2464 Ffuncall (nargs
, args
);
2468 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2469 doc
: /* Run each hook in HOOKS.
2470 Each argument should be a symbol, a hook variable.
2471 These symbols are processed in the order specified.
2472 If a hook symbol has a non-nil value, that value may be a function
2473 or a list of functions to be called to run the hook.
2474 If the value is a function, it is called with no arguments.
2475 If it is a list, the elements are called, in order, with no arguments.
2477 Major modes should not use this function directly to run their mode
2478 hook; they should use `run-mode-hooks' instead.
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-hooks &rest HOOKS) */)
2483 (ptrdiff_t nargs
, Lisp_Object
*args
)
2485 Lisp_Object hook
[1];
2488 for (i
= 0; i
< nargs
; i
++)
2491 run_hook_with_args (1, hook
, funcall_nil
);
2497 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2498 Srun_hook_with_args
, 1, MANY
, 0,
2499 doc
: /* Run HOOK with the specified arguments ARGS.
2500 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2501 value, that value may be a function or a list of functions to be
2502 called to run the hook. If the value is a function, it is called with
2503 the given arguments and its return value is returned. If it is a list
2504 of functions, those functions are called, in order,
2505 with the given arguments ARGS.
2506 It is best not to depend on the value returned by `run-hook-with-args',
2509 Do not use `make-local-variable' to make a hook variable buffer-local.
2510 Instead, use `add-hook' and specify t for the LOCAL argument.
2511 usage: (run-hook-with-args HOOK &rest ARGS) */)
2512 (ptrdiff_t nargs
, Lisp_Object
*args
)
2514 return run_hook_with_args (nargs
, args
, funcall_nil
);
2517 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2518 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2519 doc
: /* Run HOOK with the specified arguments ARGS.
2520 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2521 value, that value may be a function or a list of functions to be
2522 called to run the hook. If the value is a function, it is called with
2523 the given arguments and its return value is returned.
2524 If it is a list of functions, those functions are called, in order,
2525 with the given arguments ARGS, until one of them
2526 returns a non-nil value. Then we return that value.
2527 However, if they all return nil, we return nil.
2529 Do not use `make-local-variable' to make a hook variable buffer-local.
2530 Instead, use `add-hook' and specify t for the LOCAL argument.
2531 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2532 (ptrdiff_t nargs
, Lisp_Object
*args
)
2534 return run_hook_with_args (nargs
, args
, Ffuncall
);
2538 funcall_not (ptrdiff_t nargs
, Lisp_Object
*args
)
2540 return NILP (Ffuncall (nargs
, args
)) ? Qt
: Qnil
;
2543 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2544 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2545 doc
: /* Run HOOK with the specified arguments ARGS.
2546 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2547 value, that value may be a function or a list of functions to be
2548 called to run the hook. If the value is a function, it is called with
2549 the given arguments and its return value is returned.
2550 If it is a list of functions, those functions are called, in order,
2551 with the given arguments ARGS, until one of them returns nil.
2552 Then we return nil. However, if they all return non-nil, we return non-nil.
2554 Do not use `make-local-variable' to make a hook variable buffer-local.
2555 Instead, use `add-hook' and specify t for the LOCAL argument.
2556 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2557 (ptrdiff_t nargs
, Lisp_Object
*args
)
2559 return NILP (run_hook_with_args (nargs
, args
, funcall_not
)) ? Qt
: Qnil
;
2563 run_hook_wrapped_funcall (ptrdiff_t nargs
, Lisp_Object
*args
)
2565 Lisp_Object tmp
= args
[0], ret
;
2568 ret
= Ffuncall (nargs
, args
);
2574 DEFUN ("run-hook-wrapped", Frun_hook_wrapped
, Srun_hook_wrapped
, 2, MANY
, 0,
2575 doc
: /* Run HOOK, passing each function through WRAP-FUNCTION.
2576 I.e. instead of calling each function FUN directly with arguments ARGS,
2577 it calls WRAP-FUNCTION with arguments FUN and ARGS.
2578 As soon as a call to WRAP-FUNCTION returns non-nil, `run-hook-wrapped'
2579 aborts and returns that value.
2580 usage: (run-hook-wrapped HOOK WRAP-FUNCTION &rest ARGS) */)
2581 (ptrdiff_t nargs
, Lisp_Object
*args
)
2583 return run_hook_with_args (nargs
, args
, run_hook_wrapped_funcall
);
2586 /* ARGS[0] should be a hook symbol.
2587 Call each of the functions in the hook value, passing each of them
2588 as arguments all the rest of ARGS (all NARGS - 1 elements).
2589 FUNCALL specifies how to call each function on the hook.
2590 The caller (or its caller, etc) must gcpro all of ARGS,
2591 except that it isn't necessary to gcpro ARGS[0]. */
2594 run_hook_with_args (ptrdiff_t nargs
, Lisp_Object
*args
,
2595 Lisp_Object (*funcall
) (ptrdiff_t nargs
, Lisp_Object
*args
))
2597 Lisp_Object sym
, val
, ret
= Qnil
;
2598 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2600 /* If we are dying or still initializing,
2601 don't do anything--it would probably crash if we tried. */
2602 if (NILP (Vrun_hooks
))
2606 val
= find_symbol_value (sym
);
2608 if (EQ (val
, Qunbound
) || NILP (val
))
2610 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2613 return funcall (nargs
, args
);
2617 Lisp_Object global_vals
= Qnil
;
2618 GCPRO3 (sym
, val
, global_vals
);
2621 CONSP (val
) && NILP (ret
);
2624 if (EQ (XCAR (val
), Qt
))
2626 /* t indicates this hook has a local binding;
2627 it means to run the global binding too. */
2628 global_vals
= Fdefault_value (sym
);
2629 if (NILP (global_vals
)) continue;
2631 if (!CONSP (global_vals
) || EQ (XCAR (global_vals
), Qlambda
))
2633 args
[0] = global_vals
;
2634 ret
= funcall (nargs
, args
);
2639 CONSP (global_vals
) && NILP (ret
);
2640 global_vals
= XCDR (global_vals
))
2642 args
[0] = XCAR (global_vals
);
2643 /* In a global value, t should not occur. If it does, we
2644 must ignore it to avoid an endless loop. */
2645 if (!EQ (args
[0], Qt
))
2646 ret
= funcall (nargs
, args
);
2652 args
[0] = XCAR (val
);
2653 ret
= funcall (nargs
, args
);
2662 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2665 run_hook_with_args_2 (Lisp_Object hook
, Lisp_Object arg1
, Lisp_Object arg2
)
2667 Lisp_Object temp
[3];
2672 Frun_hook_with_args (3, temp
);
2675 /* Apply fn to arg. */
2677 apply1 (Lisp_Object fn
, Lisp_Object arg
)
2679 struct gcpro gcpro1
;
2683 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2686 Lisp_Object args
[2];
2690 RETURN_UNGCPRO (Fapply (2, args
));
2694 /* Call function fn on no arguments. */
2696 call0 (Lisp_Object fn
)
2698 struct gcpro gcpro1
;
2701 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2704 /* Call function fn with 1 argument arg1. */
2707 call1 (Lisp_Object fn
, Lisp_Object arg1
)
2709 struct gcpro gcpro1
;
2710 Lisp_Object args
[2];
2716 RETURN_UNGCPRO (Ffuncall (2, args
));
2719 /* Call function fn with 2 arguments arg1, arg2. */
2722 call2 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
)
2724 struct gcpro gcpro1
;
2725 Lisp_Object args
[3];
2731 RETURN_UNGCPRO (Ffuncall (3, args
));
2734 /* Call function fn with 3 arguments arg1, arg2, arg3. */
2737 call3 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2739 struct gcpro gcpro1
;
2740 Lisp_Object args
[4];
2747 RETURN_UNGCPRO (Ffuncall (4, args
));
2750 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
2753 call4 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2756 struct gcpro gcpro1
;
2757 Lisp_Object args
[5];
2765 RETURN_UNGCPRO (Ffuncall (5, args
));
2768 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
2771 call5 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2772 Lisp_Object arg4
, Lisp_Object arg5
)
2774 struct gcpro gcpro1
;
2775 Lisp_Object args
[6];
2784 RETURN_UNGCPRO (Ffuncall (6, args
));
2787 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
2790 call6 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2791 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
)
2793 struct gcpro gcpro1
;
2794 Lisp_Object args
[7];
2804 RETURN_UNGCPRO (Ffuncall (7, args
));
2807 /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
2810 call7 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2811 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
)
2813 struct gcpro gcpro1
;
2814 Lisp_Object args
[8];
2825 RETURN_UNGCPRO (Ffuncall (8, args
));
2828 /* The caller should GCPRO all the elements of ARGS. */
2830 DEFUN ("functionp", Ffunctionp
, Sfunctionp
, 1, 1, 0,
2831 doc
: /* Non-nil if OBJECT is a function. */)
2832 (Lisp_Object object
)
2834 if (SYMBOLP (object
) && !NILP (Ffboundp (object
)))
2836 object
= Findirect_function (object
, Qt
);
2838 if (CONSP (object
) && EQ (XCAR (object
), Qautoload
))
2840 /* Autoloaded symbols are functions, except if they load
2841 macros or keymaps. */
2843 for (i
= 0; i
< 4 && CONSP (object
); i
++)
2844 object
= XCDR (object
);
2846 return (CONSP (object
) && !NILP (XCAR (object
))) ? Qnil
: Qt
;
2851 return (XSUBR (object
)->max_args
!= UNEVALLED
) ? Qt
: Qnil
;
2852 else if (COMPILEDP (object
))
2854 else if (CONSP (object
))
2856 Lisp_Object car
= XCAR (object
);
2857 return (EQ (car
, Qlambda
) || EQ (car
, Qclosure
)) ? Qt
: Qnil
;
2863 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2864 doc
: /* Call first argument as a function, passing remaining arguments to it.
2865 Return the value that function returns.
2866 Thus, (funcall 'cons 'x 'y) returns (x . y).
2867 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2868 (ptrdiff_t nargs
, Lisp_Object
*args
)
2870 Lisp_Object fun
, original_fun
;
2872 ptrdiff_t numargs
= nargs
- 1;
2873 Lisp_Object lisp_numargs
;
2875 struct backtrace backtrace
;
2876 register Lisp_Object
*internal_args
;
2880 if ((consing_since_gc
> gc_cons_threshold
2881 && consing_since_gc
> gc_relative_threshold
)
2883 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2884 Fgarbage_collect ();
2886 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2888 if (max_lisp_eval_depth
< 100)
2889 max_lisp_eval_depth
= 100;
2890 if (lisp_eval_depth
> max_lisp_eval_depth
)
2891 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2894 backtrace
.next
= backtrace_list
;
2895 backtrace_list
= &backtrace
;
2896 backtrace
.function
= &args
[0];
2897 backtrace
.args
= &args
[1];
2898 backtrace
.nargs
= nargs
- 1;
2899 backtrace
.debug_on_exit
= 0;
2901 if (debug_on_next_call
)
2902 do_debug_on_call (Qlambda
);
2906 original_fun
= args
[0];
2910 /* Optimize for no indirection. */
2912 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2913 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2914 fun
= indirect_function (fun
);
2918 if (numargs
< XSUBR (fun
)->min_args
2919 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2921 XSETFASTINT (lisp_numargs
, numargs
);
2922 xsignal2 (Qwrong_number_of_arguments
, original_fun
, lisp_numargs
);
2925 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2926 xsignal1 (Qinvalid_function
, original_fun
);
2928 else if (XSUBR (fun
)->max_args
== MANY
)
2929 val
= (XSUBR (fun
)->function
.aMANY
) (numargs
, args
+ 1);
2932 if (XSUBR (fun
)->max_args
> numargs
)
2934 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2935 memcpy (internal_args
, args
+ 1, numargs
* sizeof (Lisp_Object
));
2936 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2937 internal_args
[i
] = Qnil
;
2940 internal_args
= args
+ 1;
2941 switch (XSUBR (fun
)->max_args
)
2944 val
= (XSUBR (fun
)->function
.a0 ());
2947 val
= (XSUBR (fun
)->function
.a1 (internal_args
[0]));
2950 val
= (XSUBR (fun
)->function
.a2
2951 (internal_args
[0], internal_args
[1]));
2954 val
= (XSUBR (fun
)->function
.a3
2955 (internal_args
[0], internal_args
[1], internal_args
[2]));
2958 val
= (XSUBR (fun
)->function
.a4
2959 (internal_args
[0], internal_args
[1], internal_args
[2],
2963 val
= (XSUBR (fun
)->function
.a5
2964 (internal_args
[0], internal_args
[1], internal_args
[2],
2965 internal_args
[3], internal_args
[4]));
2968 val
= (XSUBR (fun
)->function
.a6
2969 (internal_args
[0], internal_args
[1], internal_args
[2],
2970 internal_args
[3], internal_args
[4], internal_args
[5]));
2973 val
= (XSUBR (fun
)->function
.a7
2974 (internal_args
[0], internal_args
[1], internal_args
[2],
2975 internal_args
[3], internal_args
[4], internal_args
[5],
2980 val
= (XSUBR (fun
)->function
.a8
2981 (internal_args
[0], internal_args
[1], internal_args
[2],
2982 internal_args
[3], internal_args
[4], internal_args
[5],
2983 internal_args
[6], internal_args
[7]));
2988 /* If a subr takes more than 8 arguments without using MANY
2989 or UNEVALLED, we need to extend this function to support it.
2990 Until this is done, there is no way to call the function. */
2995 else if (COMPILEDP (fun
))
2996 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2999 if (EQ (fun
, Qunbound
))
3000 xsignal1 (Qvoid_function
, original_fun
);
3002 xsignal1 (Qinvalid_function
, original_fun
);
3003 funcar
= XCAR (fun
);
3004 if (!SYMBOLP (funcar
))
3005 xsignal1 (Qinvalid_function
, original_fun
);
3006 if (EQ (funcar
, Qlambda
)
3007 || EQ (funcar
, Qclosure
))
3008 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3009 else if (EQ (funcar
, Qautoload
))
3011 do_autoload (fun
, original_fun
);
3016 xsignal1 (Qinvalid_function
, original_fun
);
3020 if (backtrace
.debug_on_exit
)
3021 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
3022 backtrace_list
= backtrace
.next
;
3027 apply_lambda (Lisp_Object fun
, Lisp_Object args
)
3029 Lisp_Object args_left
;
3032 register Lisp_Object
*arg_vector
;
3033 struct gcpro gcpro1
, gcpro2
, gcpro3
;
3034 register Lisp_Object tem
;
3037 numargs
= XFASTINT (Flength (args
));
3038 SAFE_ALLOCA_LISP (arg_vector
, numargs
);
3041 GCPRO3 (*arg_vector
, args_left
, fun
);
3044 for (i
= 0; i
< numargs
; )
3046 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
3047 tem
= eval_sub (tem
);
3048 arg_vector
[i
++] = tem
;
3054 backtrace_list
->args
= arg_vector
;
3055 backtrace_list
->nargs
= i
;
3056 tem
= funcall_lambda (fun
, numargs
, arg_vector
);
3058 /* Do the debug-on-exit now, while arg_vector still exists. */
3059 if (backtrace_list
->debug_on_exit
)
3060 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
3061 /* Don't do it again when we return to eval. */
3062 backtrace_list
->debug_on_exit
= 0;
3067 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
3068 and return the result of evaluation.
3069 FUN must be either a lambda-expression or a compiled-code object. */
3072 funcall_lambda (Lisp_Object fun
, ptrdiff_t nargs
,
3073 register Lisp_Object
*arg_vector
)
3075 Lisp_Object val
, syms_left
, next
, lexenv
;
3076 ptrdiff_t count
= SPECPDL_INDEX ();
3082 if (EQ (XCAR (fun
), Qclosure
))
3084 fun
= XCDR (fun
); /* Drop `closure'. */
3085 lexenv
= XCAR (fun
);
3086 CHECK_LIST_CONS (fun
, fun
);
3090 syms_left
= XCDR (fun
);
3091 if (CONSP (syms_left
))
3092 syms_left
= XCAR (syms_left
);
3094 xsignal1 (Qinvalid_function
, fun
);
3096 else if (COMPILEDP (fun
))
3098 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3099 if (INTEGERP (syms_left
))
3100 /* A byte-code object with a non-nil `push args' slot means we
3101 shouldn't bind any arguments, instead just call the byte-code
3102 interpreter directly; it will push arguments as necessary.
3104 Byte-code objects with either a non-existent, or a nil value for
3105 the `push args' slot (the default), have dynamically-bound
3106 arguments, and use the argument-binding code below instead (as do
3107 all interpreted functions, even lexically bound ones). */
3109 /* If we have not actually read the bytecode string
3110 and constants vector yet, fetch them from the file. */
3111 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3112 Ffetch_bytecode (fun
);
3113 return exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
3114 AREF (fun
, COMPILED_CONSTANTS
),
3115 AREF (fun
, COMPILED_STACK_DEPTH
),
3124 i
= optional
= rest
= 0;
3125 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3129 next
= XCAR (syms_left
);
3130 if (!SYMBOLP (next
))
3131 xsignal1 (Qinvalid_function
, fun
);
3133 if (EQ (next
, Qand_rest
))
3135 else if (EQ (next
, Qand_optional
))
3142 arg
= Flist (nargs
- i
, &arg_vector
[i
]);
3146 arg
= arg_vector
[i
++];
3148 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3152 /* Bind the argument. */
3153 if (!NILP (lexenv
) && SYMBOLP (next
))
3154 /* Lexically bind NEXT by adding it to the lexenv alist. */
3155 lexenv
= Fcons (Fcons (next
, arg
), lexenv
);
3157 /* Dynamically bind NEXT. */
3158 specbind (next
, arg
);
3162 if (!NILP (syms_left
))
3163 xsignal1 (Qinvalid_function
, fun
);
3165 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3167 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
3168 /* Instantiate a new lexical environment. */
3169 specbind (Qinternal_interpreter_environment
, lexenv
);
3172 val
= Fprogn (XCDR (XCDR (fun
)));
3175 /* If we have not actually read the bytecode string
3176 and constants vector yet, fetch them from the file. */
3177 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3178 Ffetch_bytecode (fun
);
3179 val
= exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
3180 AREF (fun
, COMPILED_CONSTANTS
),
3181 AREF (fun
, COMPILED_STACK_DEPTH
),
3185 return unbind_to (count
, val
);
3188 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3190 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3191 (Lisp_Object object
)
3195 if (COMPILEDP (object
) && CONSP (AREF (object
, COMPILED_BYTECODE
)))
3197 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3200 tem
= AREF (object
, COMPILED_BYTECODE
);
3201 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3202 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3204 error ("Invalid byte code");
3206 ASET (object
, COMPILED_BYTECODE
, XCAR (tem
));
3207 ASET (object
, COMPILED_CONSTANTS
, XCDR (tem
));
3215 register ptrdiff_t count
= SPECPDL_INDEX ();
3216 ptrdiff_t max_size
= min (max_specpdl_size
, PTRDIFF_MAX
);
3217 if (max_size
<= specpdl_size
)
3219 if (max_specpdl_size
< 400)
3220 max_size
= max_specpdl_size
= 400;
3221 if (max_size
<= specpdl_size
)
3222 signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil
);
3224 specpdl
= xpalloc (specpdl
, &specpdl_size
, 1, max_size
, sizeof *specpdl
);
3225 specpdl_ptr
= specpdl
+ count
;
3228 /* `specpdl_ptr->symbol' is a field which describes which variable is
3229 let-bound, so it can be properly undone when we unbind_to.
3230 It can have the following two shapes:
3231 - SYMBOL : if it's a plain symbol, it means that we have let-bound
3232 a symbol that is not buffer-local (at least at the time
3233 the let binding started). Note also that it should not be
3234 aliased (i.e. when let-binding V1 that's aliased to V2, we want
3236 - (SYMBOL WHERE . BUFFER) : this means that it is a let-binding for
3237 variable SYMBOL which can be buffer-local. WHERE tells us
3238 which buffer is affected (or nil if the let-binding affects the
3239 global value of the variable) and BUFFER tells us which buffer was
3240 current (i.e. if WHERE is non-nil, then BUFFER==WHERE, otherwise
3241 BUFFER did not yet have a buffer-local value). */
3244 specbind (Lisp_Object symbol
, Lisp_Object value
)
3246 struct Lisp_Symbol
*sym
;
3248 eassert (!handling_signal
);
3250 CHECK_SYMBOL (symbol
);
3251 sym
= XSYMBOL (symbol
);
3252 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3256 switch (sym
->redirect
)
3258 case SYMBOL_VARALIAS
:
3259 sym
= indirect_variable (sym
); XSETSYMBOL (symbol
, sym
); goto start
;
3260 case SYMBOL_PLAINVAL
:
3261 /* The most common case is that of a non-constant symbol with a
3262 trivial value. Make that as fast as we can. */
3263 specpdl_ptr
->symbol
= symbol
;
3264 specpdl_ptr
->old_value
= SYMBOL_VAL (sym
);
3265 specpdl_ptr
->func
= NULL
;
3268 SET_SYMBOL_VAL (sym
, value
);
3270 set_internal (symbol
, value
, Qnil
, 1);
3272 case SYMBOL_LOCALIZED
:
3273 if (SYMBOL_BLV (sym
)->frame_local
)
3274 error ("Frame-local vars cannot be let-bound");
3275 case SYMBOL_FORWARDED
:
3277 Lisp_Object ovalue
= find_symbol_value (symbol
);
3278 specpdl_ptr
->func
= 0;
3279 specpdl_ptr
->old_value
= ovalue
;
3281 eassert (sym
->redirect
!= SYMBOL_LOCALIZED
3282 || (EQ (SYMBOL_BLV (sym
)->where
,
3283 SYMBOL_BLV (sym
)->frame_local
?
3284 Fselected_frame () : Fcurrent_buffer ())));
3286 if (sym
->redirect
== SYMBOL_LOCALIZED
3287 || BUFFER_OBJFWDP (SYMBOL_FWD (sym
)))
3289 Lisp_Object where
, cur_buf
= Fcurrent_buffer ();
3291 /* For a local variable, record both the symbol and which
3292 buffer's or frame's value we are saving. */
3293 if (!NILP (Flocal_variable_p (symbol
, Qnil
)))
3295 eassert (sym
->redirect
!= SYMBOL_LOCALIZED
3296 || (BLV_FOUND (SYMBOL_BLV (sym
))
3297 && EQ (cur_buf
, SYMBOL_BLV (sym
)->where
)));
3300 else if (sym
->redirect
== SYMBOL_LOCALIZED
3301 && BLV_FOUND (SYMBOL_BLV (sym
)))
3302 where
= SYMBOL_BLV (sym
)->where
;
3306 /* We're not using the `unused' slot in the specbinding
3307 structure because this would mean we have to do more
3308 work for simple variables. */
3309 /* FIXME: The third value `current_buffer' is only used in
3310 let_shadows_buffer_binding_p which is itself only used
3311 in set_internal for local_if_set. */
3312 eassert (NILP (where
) || EQ (where
, cur_buf
));
3313 specpdl_ptr
->symbol
= Fcons (symbol
, Fcons (where
, cur_buf
));
3315 /* If SYMBOL is a per-buffer variable which doesn't have a
3316 buffer-local value here, make the `let' change the global
3317 value by changing the value of SYMBOL in all buffers not
3318 having their own value. This is consistent with what
3319 happens with other buffer-local variables. */
3321 && sym
->redirect
== SYMBOL_FORWARDED
)
3323 eassert (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)));
3325 Fset_default (symbol
, value
);
3330 specpdl_ptr
->symbol
= symbol
;
3333 set_internal (symbol
, value
, Qnil
, 1);
3341 record_unwind_protect (Lisp_Object (*function
) (Lisp_Object
), Lisp_Object arg
)
3343 eassert (!handling_signal
);
3345 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3347 specpdl_ptr
->func
= function
;
3348 specpdl_ptr
->symbol
= Qnil
;
3349 specpdl_ptr
->old_value
= arg
;
3354 unbind_to (ptrdiff_t count
, Lisp_Object value
)
3356 Lisp_Object quitf
= Vquit_flag
;
3357 struct gcpro gcpro1
, gcpro2
;
3359 GCPRO2 (value
, quitf
);
3362 while (specpdl_ptr
!= specpdl
+ count
)
3364 /* Copy the binding, and decrement specpdl_ptr, before we do
3365 the work to unbind it. We decrement first
3366 so that an error in unbinding won't try to unbind
3367 the same entry again, and we copy the binding first
3368 in case more bindings are made during some of the code we run. */
3370 struct specbinding this_binding
;
3371 this_binding
= *--specpdl_ptr
;
3373 if (this_binding
.func
!= 0)
3374 (*this_binding
.func
) (this_binding
.old_value
);
3375 /* If the symbol is a list, it is really (SYMBOL WHERE
3376 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3377 frame. If WHERE is a buffer or frame, this indicates we
3378 bound a variable that had a buffer-local or frame-local
3379 binding. WHERE nil means that the variable had the default
3380 value when it was bound. CURRENT-BUFFER is the buffer that
3381 was current when the variable was bound. */
3382 else if (CONSP (this_binding
.symbol
))
3384 Lisp_Object symbol
, where
;
3386 symbol
= XCAR (this_binding
.symbol
);
3387 where
= XCAR (XCDR (this_binding
.symbol
));
3390 Fset_default (symbol
, this_binding
.old_value
);
3391 /* If `where' is non-nil, reset the value in the appropriate
3392 local binding, but only if that binding still exists. */
3393 else if (BUFFERP (where
)
3394 ? !NILP (Flocal_variable_p (symbol
, where
))
3395 : !NILP (Fassq (symbol
, XFRAME (where
)->param_alist
)))
3396 set_internal (symbol
, this_binding
.old_value
, where
, 1);
3398 /* If variable has a trivial value (no forwarding), we can
3399 just set it. No need to check for constant symbols here,
3400 since that was already done by specbind. */
3401 else if (XSYMBOL (this_binding
.symbol
)->redirect
== SYMBOL_PLAINVAL
)
3402 SET_SYMBOL_VAL (XSYMBOL (this_binding
.symbol
),
3403 this_binding
.old_value
);
3405 /* NOTE: we only ever come here if make_local_foo was used for
3406 the first time on this var within this let. */
3407 Fset_default (this_binding
.symbol
, this_binding
.old_value
);
3410 if (NILP (Vquit_flag
) && !NILP (quitf
))
3417 DEFUN ("special-variable-p", Fspecial_variable_p
, Sspecial_variable_p
, 1, 1, 0,
3418 doc
: /* Return non-nil if SYMBOL's global binding has been declared special.
3419 A special variable is one that will be bound dynamically, even in a
3420 context where binding is lexical by default. */)
3421 (Lisp_Object symbol
)
3423 CHECK_SYMBOL (symbol
);
3424 return XSYMBOL (symbol
)->declared_special
? Qt
: Qnil
;
3428 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3429 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3430 The debugger is entered when that frame exits, if the flag is non-nil. */)
3431 (Lisp_Object level
, Lisp_Object flag
)
3433 register struct backtrace
*backlist
= backtrace_list
;
3434 register EMACS_INT i
;
3436 CHECK_NUMBER (level
);
3438 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
3440 backlist
= backlist
->next
;
3444 backlist
->debug_on_exit
= !NILP (flag
);
3449 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3450 doc
: /* Print a trace of Lisp function calls currently active.
3451 Output stream used is value of `standard-output'. */)
3454 register struct backtrace
*backlist
= backtrace_list
;
3457 struct gcpro gcpro1
;
3458 Lisp_Object old_print_level
= Vprint_level
;
3460 if (NILP (Vprint_level
))
3461 XSETFASTINT (Vprint_level
, 8);
3468 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
3469 if (backlist
->nargs
== UNEVALLED
)
3471 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
3472 write_string ("\n", -1);
3476 tem
= *backlist
->function
;
3477 Fprin1 (tem
, Qnil
); /* This can QUIT. */
3478 write_string ("(", -1);
3479 if (backlist
->nargs
== MANY
)
3480 { /* FIXME: Can this happen? */
3482 for (tail
= *backlist
->args
, i
= 0;
3484 tail
= Fcdr (tail
), i
= 1)
3486 if (i
) write_string (" ", -1);
3487 Fprin1 (Fcar (tail
), Qnil
);
3493 for (i
= 0; i
< backlist
->nargs
; i
++)
3495 if (i
) write_string (" ", -1);
3496 Fprin1 (backlist
->args
[i
], Qnil
);
3499 write_string (")\n", -1);
3501 backlist
= backlist
->next
;
3504 Vprint_level
= old_print_level
;
3509 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, NULL
,
3510 doc
: /* Return the function and arguments NFRAMES up from current execution point.
3511 If that frame has not evaluated the arguments yet (or is a special form),
3512 the value is (nil FUNCTION ARG-FORMS...).
3513 If that frame has evaluated its arguments and called its function already,
3514 the value is (t FUNCTION ARG-VALUES...).
3515 A &rest arg is represented as the tail of the list ARG-VALUES.
3516 FUNCTION is whatever was supplied as car of evaluated list,
3517 or a lambda expression for macro calls.
3518 If NFRAMES is more than the number of frames, the value is nil. */)
3519 (Lisp_Object nframes
)
3521 register struct backtrace
*backlist
= backtrace_list
;
3522 register EMACS_INT i
;
3525 CHECK_NATNUM (nframes
);
3527 /* Find the frame requested. */
3528 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3529 backlist
= backlist
->next
;
3533 if (backlist
->nargs
== UNEVALLED
)
3534 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3537 if (backlist
->nargs
== MANY
) /* FIXME: Can this happen? */
3538 tem
= *backlist
->args
;
3540 tem
= Flist (backlist
->nargs
, backlist
->args
);
3542 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3549 mark_backtrace (void)
3551 register struct backtrace
*backlist
;
3554 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3556 mark_object (*backlist
->function
);
3558 if (backlist
->nargs
== UNEVALLED
3559 || backlist
->nargs
== MANY
) /* FIXME: Can this happen? */
3562 i
= backlist
->nargs
;
3564 mark_object (backlist
->args
[i
]);
3572 DEFVAR_INT ("max-specpdl-size", max_specpdl_size
,
3573 doc
: /* *Limit on number of Lisp variable bindings and `unwind-protect's.
3574 If Lisp code tries to increase the total number past this amount,
3575 an error is signaled.
3576 You can safely use a value considerably larger than the default value,
3577 if that proves inconveniently small. However, if you increase it too far,
3578 Emacs could run out of memory trying to make the stack bigger. */);
3580 DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth
,
3581 doc
: /* *Limit on depth in `eval', `apply' and `funcall' before error.
3583 This limit serves to catch infinite recursions for you before they cause
3584 actual stack overflow in C, which would be fatal for Emacs.
3585 You can safely make it considerably larger than its default value,
3586 if that proves inconveniently small. However, if you increase it too far,
3587 Emacs could overflow the real C stack, and crash. */);
3589 DEFVAR_LISP ("quit-flag", Vquit_flag
,
3590 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3591 If the value is t, that means do an ordinary quit.
3592 If the value equals `throw-on-input', that means quit by throwing
3593 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3594 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3595 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3598 DEFVAR_LISP ("inhibit-quit", Vinhibit_quit
,
3599 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3600 Note that `quit-flag' will still be set by typing C-g,
3601 so a quit will be signaled as soon as `inhibit-quit' is nil.
3602 To prevent this happening, set `quit-flag' to nil
3603 before making `inhibit-quit' nil. */);
3604 Vinhibit_quit
= Qnil
;
3606 DEFSYM (Qinhibit_quit
, "inhibit-quit");
3607 DEFSYM (Qautoload
, "autoload");
3608 DEFSYM (Qdebug_on_error
, "debug-on-error");
3609 DEFSYM (Qmacro
, "macro");
3610 DEFSYM (Qdeclare
, "declare");
3612 /* Note that the process handling also uses Qexit, but we don't want
3613 to staticpro it twice, so we just do it here. */
3614 DEFSYM (Qexit
, "exit");
3616 DEFSYM (Qinteractive
, "interactive");
3617 DEFSYM (Qcommandp
, "commandp");
3618 DEFSYM (Qdefun
, "defun");
3619 DEFSYM (Qand_rest
, "&rest");
3620 DEFSYM (Qand_optional
, "&optional");
3621 DEFSYM (Qclosure
, "closure");
3622 DEFSYM (Qdebug
, "debug");
3624 DEFVAR_LISP ("debug-on-error", Vdebug_on_error
,
3625 doc
: /* *Non-nil means enter debugger if an error is signaled.
3626 Does not apply to errors handled by `condition-case' or those
3627 matched by `debug-ignored-errors'.
3628 If the value is a list, an error only means to enter the debugger
3629 if one of its condition symbols appears in the list.
3630 When you evaluate an expression interactively, this variable
3631 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3632 The command `toggle-debug-on-error' toggles this.
3633 See also the variable `debug-on-quit'. */);
3634 Vdebug_on_error
= Qnil
;
3636 DEFVAR_LISP ("debug-ignored-errors", Vdebug_ignored_errors
,
3637 doc
: /* *List of errors for which the debugger should not be called.
3638 Each element may be a condition-name or a regexp that matches error messages.
3639 If any element applies to a given error, that error skips the debugger
3640 and just returns to top level.
3641 This overrides the variable `debug-on-error'.
3642 It does not apply to errors handled by `condition-case'. */);
3643 Vdebug_ignored_errors
= Qnil
;
3645 DEFVAR_BOOL ("debug-on-quit", debug_on_quit
,
3646 doc
: /* *Non-nil means enter debugger if quit is signaled (C-g, for example).
3647 Does not apply if quit is handled by a `condition-case'. */);
3650 DEFVAR_BOOL ("debug-on-next-call", debug_on_next_call
,
3651 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3653 DEFVAR_BOOL ("debugger-may-continue", debugger_may_continue
,
3654 doc
: /* Non-nil means debugger may continue execution.
3655 This is nil when the debugger is called under circumstances where it
3656 might not be safe to continue. */);
3657 debugger_may_continue
= 1;
3659 DEFVAR_LISP ("debugger", Vdebugger
,
3660 doc
: /* Function to call to invoke debugger.
3661 If due to frame exit, args are `exit' and the value being returned;
3662 this function's value will be returned instead of that.
3663 If due to error, args are `error' and a list of the args to `signal'.
3664 If due to `apply' or `funcall' entry, one arg, `lambda'.
3665 If due to `eval' entry, one arg, t. */);
3668 DEFVAR_LISP ("signal-hook-function", Vsignal_hook_function
,
3669 doc
: /* If non-nil, this is a function for `signal' to call.
3670 It receives the same arguments that `signal' was given.
3671 The Edebug package uses this to regain control. */);
3672 Vsignal_hook_function
= Qnil
;
3674 DEFVAR_LISP ("debug-on-signal", Vdebug_on_signal
,
3675 doc
: /* *Non-nil means call the debugger regardless of condition handlers.
3676 Note that `debug-on-error', `debug-on-quit' and friends
3677 still determine whether to handle the particular condition. */);
3678 Vdebug_on_signal
= Qnil
;
3680 DEFVAR_LISP ("macro-declaration-function", Vmacro_declaration_function
,
3681 doc
: /* Function to process declarations in a macro definition.
3682 The function will be called with two args MACRO and DECL.
3683 MACRO is the name of the macro being defined.
3684 DECL is a list `(declare ...)' containing the declarations.
3685 The value the function returns is not used. */);
3686 Vmacro_declaration_function
= Qnil
;
3688 /* When lexical binding is being used,
3689 vinternal_interpreter_environment is non-nil, and contains an alist
3690 of lexically-bound variable, or (t), indicating an empty
3691 environment. The lisp name of this variable would be
3692 `internal-interpreter-environment' if it weren't hidden.
3693 Every element of this list can be either a cons (VAR . VAL)
3694 specifying a lexical binding, or a single symbol VAR indicating
3695 that this variable should use dynamic scoping. */
3696 DEFSYM (Qinternal_interpreter_environment
, "internal-interpreter-environment");
3697 DEFVAR_LISP ("internal-interpreter-environment",
3698 Vinternal_interpreter_environment
,
3699 doc
: /* If non-nil, the current lexical environment of the lisp interpreter.
3700 When lexical binding is not being used, this variable is nil.
3701 A value of `(t)' indicates an empty environment, otherwise it is an
3702 alist of active lexical bindings. */);
3703 Vinternal_interpreter_environment
= Qnil
;
3704 /* Don't export this variable to Elisp, so noone can mess with it
3705 (Just imagine if someone makes it buffer-local). */
3706 Funintern (Qinternal_interpreter_environment
, Qnil
);
3708 DEFSYM (Vrun_hooks
, "run-hooks");
3710 staticpro (&Vautoload_queue
);
3711 Vautoload_queue
= Qnil
;
3712 staticpro (&Vsignaling_function
);
3713 Vsignaling_function
= Qnil
;
3724 defsubr (&Sfunction
);
3726 defsubr (&Sdefmacro
);
3728 defsubr (&Sdefvaralias
);
3729 defsubr (&Sdefconst
);
3730 defsubr (&Suser_variable_p
);
3734 defsubr (&Smacroexpand
);
3737 defsubr (&Sunwind_protect
);
3738 defsubr (&Scondition_case
);
3740 defsubr (&Sinteractive_p
);
3741 defsubr (&Scalled_interactively_p
);
3742 defsubr (&Scommandp
);
3743 defsubr (&Sautoload
);
3746 defsubr (&Sfuncall
);
3747 defsubr (&Srun_hooks
);
3748 defsubr (&Srun_hook_with_args
);
3749 defsubr (&Srun_hook_with_args_until_success
);
3750 defsubr (&Srun_hook_with_args_until_failure
);
3751 defsubr (&Srun_hook_wrapped
);
3752 defsubr (&Sfetch_bytecode
);
3753 defsubr (&Sbacktrace_debug
);
3754 defsubr (&Sbacktrace
);
3755 defsubr (&Sbacktrace_frame
);
3756 defsubr (&Sspecial_variable_p
);
3757 defsubr (&Sfunctionp
);