1 /* Evaluator for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1987, 1993-1995, 1999-2012 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 EMACS_INT 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 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 /* If non-nil, Lisp code must not be run since some part of Emacs is
128 in an inconsistent state. Currently, x-create-frame uses this to
129 avoid triggering window-configuration-change-hook while the new
130 frame is half-initialized. */
131 Lisp_Object inhibit_lisp_code
;
133 static Lisp_Object
funcall_lambda (Lisp_Object
, ptrdiff_t, Lisp_Object
*);
134 static void unwind_to_catch (struct catchtag
*, Lisp_Object
) NO_RETURN
;
135 static int interactive_p (int);
136 static Lisp_Object
apply_lambda (Lisp_Object fun
, Lisp_Object args
);
137 static Lisp_Object
Ffetch_bytecode (Lisp_Object
);
140 init_eval_once (void)
143 specpdl
= (struct specbinding
*) xmalloc (size
* sizeof (struct specbinding
));
145 specpdl_ptr
= specpdl
;
146 /* Don't forget to update docs (lispref node "Local Variables"). */
147 max_specpdl_size
= 1300; /* 1000 is not enough for CEDET's c-by.el. */
148 max_lisp_eval_depth
= 600;
156 specpdl_ptr
= specpdl
;
161 debug_on_next_call
= 0;
166 /* This is less than the initial value of num_nonmacro_input_events. */
167 when_entered_debugger
= -1;
170 /* Unwind-protect function used by call_debugger. */
173 restore_stack_limits (Lisp_Object data
)
175 max_specpdl_size
= XINT (XCAR (data
));
176 max_lisp_eval_depth
= XINT (XCDR (data
));
180 /* Call the Lisp debugger, giving it argument ARG. */
183 call_debugger (Lisp_Object arg
)
185 int debug_while_redisplaying
;
186 int count
= SPECPDL_INDEX ();
188 EMACS_INT old_max
= max_specpdl_size
;
190 /* Temporarily bump up the stack limits,
191 so the debugger won't run out of stack. */
193 max_specpdl_size
+= 1;
194 record_unwind_protect (restore_stack_limits
,
195 Fcons (make_number (old_max
),
196 make_number (max_lisp_eval_depth
)));
197 max_specpdl_size
= old_max
;
199 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
200 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
202 if (max_specpdl_size
- 100 < SPECPDL_INDEX ())
203 max_specpdl_size
= SPECPDL_INDEX () + 100;
205 #ifdef HAVE_WINDOW_SYSTEM
206 if (display_hourglass_p
)
210 debug_on_next_call
= 0;
211 when_entered_debugger
= num_nonmacro_input_events
;
213 /* Resetting redisplaying_p to 0 makes sure that debug output is
214 displayed if the debugger is invoked during redisplay. */
215 debug_while_redisplaying
= redisplaying_p
;
217 specbind (intern ("debugger-may-continue"),
218 debug_while_redisplaying
? Qnil
: Qt
);
219 specbind (Qinhibit_redisplay
, Qnil
);
220 specbind (Qdebug_on_error
, Qnil
);
222 #if 0 /* Binding this prevents execution of Lisp code during
223 redisplay, which necessarily leads to display problems. */
224 specbind (Qinhibit_eval_during_redisplay
, Qt
);
227 val
= apply1 (Vdebugger
, arg
);
229 /* Interrupting redisplay and resuming it later is not safe under
230 all circumstances. So, when the debugger returns, abort the
231 interrupted redisplay by going back to the top-level. */
232 if (debug_while_redisplaying
)
235 return unbind_to (count
, val
);
239 do_debug_on_call (Lisp_Object code
)
241 debug_on_next_call
= 0;
242 backtrace_list
->debug_on_exit
= 1;
243 call_debugger (Fcons (code
, Qnil
));
246 /* NOTE!!! Every function that can call EVAL must protect its args
247 and temporaries from garbage collection while it needs them.
248 The definition of `For' shows what you have to do. */
250 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
251 doc
: /* Eval args until one of them yields non-nil, then return that value.
252 The remaining args are not evalled at all.
253 If all args return nil, return nil.
254 usage: (or CONDITIONS...) */)
257 register Lisp_Object val
= Qnil
;
264 val
= eval_sub (XCAR (args
));
274 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
275 doc
: /* Eval args until one of them yields nil, then return nil.
276 The remaining args are not evalled at all.
277 If no arg yields nil, return the last arg's value.
278 usage: (and CONDITIONS...) */)
281 register Lisp_Object val
= Qt
;
288 val
= eval_sub (XCAR (args
));
298 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
299 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
300 Returns the value of THEN or the value of the last of the ELSE's.
301 THEN must be one expression, but ELSE... can be zero or more expressions.
302 If COND yields nil, and there are no ELSE's, the value is nil.
303 usage: (if COND THEN ELSE...) */)
306 register Lisp_Object cond
;
310 cond
= eval_sub (Fcar (args
));
314 return eval_sub (Fcar (Fcdr (args
)));
315 return Fprogn (Fcdr (Fcdr (args
)));
318 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
319 doc
: /* Try each clause until one succeeds.
320 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
321 and, if the value is non-nil, this clause succeeds:
322 then the expressions in BODY are evaluated and the last one's
323 value is the value of the cond-form.
324 If no clause succeeds, cond returns nil.
325 If a clause has one element, as in (CONDITION),
326 CONDITION's value if non-nil is returned from the cond-form.
327 usage: (cond CLAUSES...) */)
330 register Lisp_Object clause
, val
;
337 clause
= Fcar (args
);
338 val
= eval_sub (Fcar (clause
));
341 if (!EQ (XCDR (clause
), Qnil
))
342 val
= Fprogn (XCDR (clause
));
352 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
353 doc
: /* Eval BODY forms sequentially and return value of last one.
354 usage: (progn BODY...) */)
357 register Lisp_Object val
= Qnil
;
364 val
= eval_sub (XCAR (args
));
372 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
373 doc
: /* Eval FIRST and BODY sequentially; return value from FIRST.
374 The value of FIRST is saved during the evaluation of the remaining args,
375 whose values are discarded.
376 usage: (prog1 FIRST BODY...) */)
380 register Lisp_Object args_left
;
381 struct gcpro gcpro1
, gcpro2
;
382 register int argnum
= 0;
393 Lisp_Object tem
= eval_sub (XCAR (args_left
));
396 args_left
= XCDR (args_left
);
398 while (CONSP (args_left
));
404 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
405 doc
: /* Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
406 The value of FORM2 is saved during the evaluation of the
407 remaining args, whose values are discarded.
408 usage: (prog2 FORM1 FORM2 BODY...) */)
412 register Lisp_Object args_left
;
413 struct gcpro gcpro1
, gcpro2
;
414 register int argnum
= -1;
427 Lisp_Object tem
= eval_sub (XCAR (args_left
));
430 args_left
= XCDR (args_left
);
432 while (CONSP (args_left
));
438 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
439 doc
: /* Set each SYM to the value of its VAL.
440 The symbols SYM are variables; they are literal (not evaluated).
441 The values VAL are expressions; they are evaluated.
442 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
443 The second VAL is not computed until after the first SYM is set, and so on;
444 each VAL can use the new value of variables set earlier in the `setq'.
445 The return value of the `setq' form is the value of the last VAL.
446 usage: (setq [SYM VAL]...) */)
449 register Lisp_Object args_left
;
450 register Lisp_Object val
, sym
, lex_binding
;
461 val
= eval_sub (Fcar (Fcdr (args_left
)));
462 sym
= Fcar (args_left
);
464 /* Like for eval_sub, we do not check declared_special here since
465 it's been done when let-binding. */
466 if (!NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
468 && !NILP (lex_binding
469 = Fassq (sym
, Vinternal_interpreter_environment
)))
470 XSETCDR (lex_binding
, val
); /* SYM is lexically bound. */
472 Fset (sym
, val
); /* SYM is dynamically bound. */
474 args_left
= Fcdr (Fcdr (args_left
));
476 while (!NILP (args_left
));
482 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
483 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
484 Warning: `quote' does not construct its return value, but just returns
485 the value that was pre-constructed by the Lisp reader (see info node
486 `(elisp)Printed Representation').
487 This means that '(a . b) is not identical to (cons 'a 'b): the former
488 does not cons. Quoting should be reserved for constants that will
489 never be modified by side-effects, unless you like self-modifying code.
490 See the common pitfall in info node `(elisp)Rearrangement' for an example
491 of unexpected results when a quoted object is modified.
492 usage: (quote ARG) */)
495 if (!NILP (Fcdr (args
)))
496 xsignal2 (Qwrong_number_of_arguments
, Qquote
, Flength (args
));
500 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
501 doc
: /* Like `quote', but preferred for objects which are functions.
502 In byte compilation, `function' causes its argument to be compiled.
503 `quote' cannot do that.
504 usage: (function ARG) */)
507 Lisp_Object quoted
= XCAR (args
);
509 if (!NILP (Fcdr (args
)))
510 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
512 if (!NILP (Vinternal_interpreter_environment
)
514 && EQ (XCAR (quoted
), Qlambda
))
515 /* This is a lambda expression within a lexical environment;
516 return an interpreted closure instead of a simple lambda. */
517 return Fcons (Qclosure
, Fcons (Vinternal_interpreter_environment
,
520 /* Simply quote the argument. */
525 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
526 doc
: /* Return t if the containing function was run directly by user input.
527 This means that the function was called with `call-interactively'
528 \(which includes being called as the binding of a key)
529 and input is currently coming from the keyboard (not a keyboard macro),
530 and Emacs is not running in batch mode (`noninteractive' is nil).
532 The only known proper use of `interactive-p' is in deciding whether to
533 display a helpful message, or how to display it. If you're thinking
534 of using it for any other purpose, it is quite likely that you're
535 making a mistake. Think: what do you want to do when the command is
536 called from a keyboard macro?
538 To test whether your function was called with `call-interactively',
539 either (i) add an extra optional argument and give it an `interactive'
540 spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
541 use `called-interactively-p'. */)
544 return interactive_p (1) ? Qt
: Qnil
;
548 DEFUN ("called-interactively-p", Fcalled_interactively_p
, Scalled_interactively_p
, 0, 1, 0,
549 doc
: /* Return t if the containing function was called by `call-interactively'.
550 If KIND is `interactive', then only return t if the call was made
551 interactively by the user, i.e. not in `noninteractive' mode nor
552 when `executing-kbd-macro'.
553 If KIND is `any', on the other hand, it will return t for any kind of
554 interactive call, including being called as the binding of a key, or
555 from a keyboard macro, or in `noninteractive' mode.
557 The only known proper use of `interactive' for KIND is in deciding
558 whether to display a helpful message, or how to display it. If you're
559 thinking of using it for any other purpose, it is quite likely that
560 you're making a mistake. Think: what do you want to do when the
561 command is called from a keyboard macro?
563 Instead of using this function, it is sometimes cleaner to give your
564 function an extra optional argument whose `interactive' spec specifies
565 non-nil unconditionally (\"p\" is a good way to do this), or via
566 \(not (or executing-kbd-macro noninteractive)). */)
569 return ((INTERACTIVE
|| !EQ (kind
, intern ("interactive")))
570 && interactive_p (1)) ? Qt
: Qnil
;
574 /* Return 1 if function in which this appears was called using
577 EXCLUDE_SUBRS_P non-zero means always return 0 if the function
578 called is a built-in. */
581 interactive_p (int exclude_subrs_p
)
583 struct backtrace
*btp
;
586 btp
= backtrace_list
;
588 /* If this isn't a byte-compiled function, there may be a frame at
589 the top for Finteractive_p. If so, skip it. */
590 fun
= Findirect_function (*btp
->function
, Qnil
);
591 if (SUBRP (fun
) && (XSUBR (fun
) == &Sinteractive_p
592 || XSUBR (fun
) == &Scalled_interactively_p
))
595 /* If we're running an Emacs 18-style byte-compiled function, there
596 may be a frame for Fbytecode at the top level. In any version of
597 Emacs there can be Fbytecode frames for subexpressions evaluated
598 inside catch and condition-case. Skip past them.
600 If this isn't a byte-compiled function, then we may now be
601 looking at several frames for special forms. Skip past them. */
603 && (EQ (*btp
->function
, Qbytecode
)
604 || btp
->nargs
== UNEVALLED
))
607 /* `btp' now points at the frame of the innermost function that isn't
608 a special form, ignoring frames for Finteractive_p and/or
609 Fbytecode at the top. If this frame is for a built-in function
610 (such as load or eval-region) return nil. */
611 fun
= Findirect_function (*btp
->function
, Qnil
);
612 if (exclude_subrs_p
&& SUBRP (fun
))
615 /* `btp' points to the frame of a Lisp function that called interactive-p.
616 Return t if that function was called interactively. */
617 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
623 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
624 doc
: /* Define NAME as a function.
625 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
626 See also the function `interactive'.
627 usage: (defun NAME ARGLIST [DOCSTRING] BODY...) */)
630 register Lisp_Object fn_name
;
631 register Lisp_Object defn
;
633 fn_name
= Fcar (args
);
634 CHECK_SYMBOL (fn_name
);
635 defn
= Fcons (Qlambda
, Fcdr (args
));
636 if (!NILP (Vinternal_interpreter_environment
)) /* Mere optimization! */
637 defn
= Ffunction (Fcons (defn
, Qnil
));
638 if (!NILP (Vpurify_flag
))
639 defn
= Fpurecopy (defn
);
640 if (CONSP (XSYMBOL (fn_name
)->function
)
641 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
642 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
643 Ffset (fn_name
, defn
);
644 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
648 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
649 doc
: /* Define NAME as a macro.
650 The actual definition looks like
651 (macro lambda ARGLIST [DOCSTRING] [DECL] BODY...).
652 When the macro is called, as in (NAME ARGS...),
653 the function (lambda ARGLIST BODY...) is applied to
654 the list ARGS... as it appears in the expression,
655 and the result should be a form to be evaluated instead of the original.
657 DECL is a declaration, optional, which can specify how to indent
658 calls to this macro, how Edebug should handle it, and which argument
659 should be treated as documentation. It looks like this:
661 The elements can look like this:
663 Set NAME's `lisp-indent-function' property to INDENT.
666 Set NAME's `edebug-form-spec' property to DEBUG. (This is
667 equivalent to writing a `def-edebug-spec' for the macro.)
670 Set NAME's `doc-string-elt' property to ELT.
672 usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */)
675 register Lisp_Object fn_name
;
676 register Lisp_Object defn
;
677 Lisp_Object lambda_list
, doc
, tail
;
679 fn_name
= Fcar (args
);
680 CHECK_SYMBOL (fn_name
);
681 lambda_list
= Fcar (Fcdr (args
));
682 tail
= Fcdr (Fcdr (args
));
685 if (STRINGP (Fcar (tail
)))
691 if (CONSP (Fcar (tail
))
692 && EQ (Fcar (Fcar (tail
)), Qdeclare
))
694 if (!NILP (Vmacro_declaration_function
))
698 call2 (Vmacro_declaration_function
, fn_name
, Fcar (tail
));
706 tail
= Fcons (lambda_list
, tail
);
708 tail
= Fcons (lambda_list
, Fcons (doc
, tail
));
710 defn
= Fcons (Qlambda
, tail
);
711 if (!NILP (Vinternal_interpreter_environment
)) /* Mere optimization! */
712 defn
= Ffunction (Fcons (defn
, Qnil
));
713 defn
= Fcons (Qmacro
, defn
);
715 if (!NILP (Vpurify_flag
))
716 defn
= Fpurecopy (defn
);
717 if (CONSP (XSYMBOL (fn_name
)->function
)
718 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
719 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
720 Ffset (fn_name
, defn
);
721 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
726 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
727 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
728 Aliased variables always have the same value; setting one sets the other.
729 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
730 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
731 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
732 itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
733 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
734 The return value is BASE-VARIABLE. */)
735 (Lisp_Object new_alias
, Lisp_Object base_variable
, Lisp_Object docstring
)
737 struct Lisp_Symbol
*sym
;
739 CHECK_SYMBOL (new_alias
);
740 CHECK_SYMBOL (base_variable
);
742 sym
= XSYMBOL (new_alias
);
745 /* Not sure why, but why not? */
746 error ("Cannot make a constant an alias");
748 switch (sym
->redirect
)
750 case SYMBOL_FORWARDED
:
751 error ("Cannot make an internal variable an alias");
752 case SYMBOL_LOCALIZED
:
753 error ("Don't know how to make a localized variable an alias");
756 /* http://lists.gnu.org/archive/html/emacs-devel/2008-04/msg00834.html
757 If n_a is bound, but b_v is not, set the value of b_v to n_a,
758 so that old-code that affects n_a before the aliasing is setup
760 if (NILP (Fboundp (base_variable
)))
761 set_internal (base_variable
, find_symbol_value (new_alias
), Qnil
, 1);
764 struct specbinding
*p
;
766 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
769 CONSP (p
->symbol
) ? XCAR (p
->symbol
) : p
->symbol
)))
770 error ("Don't know how to make a let-bound variable an alias");
773 sym
->declared_special
= 1;
774 XSYMBOL (base_variable
)->declared_special
= 1;
775 sym
->redirect
= SYMBOL_VARALIAS
;
776 SET_SYMBOL_ALIAS (sym
, XSYMBOL (base_variable
));
777 sym
->constant
= SYMBOL_CONSTANT_P (base_variable
);
778 LOADHIST_ATTACH (new_alias
);
779 /* Even if docstring is nil: remove old docstring. */
780 Fput (new_alias
, Qvariable_documentation
, docstring
);
782 return base_variable
;
786 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
787 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
788 You are not required to define a variable in order to use it, but
789 defining it lets you supply an initial value and documentation, which
790 can be referred to by the Emacs help facilities and other programming
791 tools. The `defvar' form also declares the variable as \"special\",
792 so that it is always dynamically bound even if `lexical-binding' is t.
794 The optional argument INITVALUE is evaluated, and used to set SYMBOL,
795 only if SYMBOL's value is void. If SYMBOL is buffer-local, its
796 default value is what is set; buffer-local values are not affected.
797 If INITVALUE is missing, SYMBOL's value is not set.
799 If SYMBOL has a local binding, then this form affects the local
800 binding. This is usually not what you want. Thus, if you need to
801 load a file defining variables, with this form or with `defconst' or
802 `defcustom', you should always load that file _outside_ any bindings
803 for these variables. \(`defconst' and `defcustom' behave similarly in
806 The optional argument DOCSTRING is a documentation string for the
809 To define a user option, use `defcustom' instead of `defvar'.
810 The function `user-variable-p' also identifies a variable as a user
811 option if its DOCSTRING starts with *, but this behavior is obsolete.
812 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
815 register Lisp_Object sym
, tem
, tail
;
819 if (!NILP (Fcdr (Fcdr (tail
))))
820 error ("Too many arguments");
822 tem
= Fdefault_boundp (sym
);
825 /* Do it before evaluating the initial value, for self-references. */
826 XSYMBOL (sym
)->declared_special
= 1;
828 if (SYMBOL_CONSTANT_P (sym
))
830 /* For upward compatibility, allow (defvar :foo (quote :foo)). */
831 Lisp_Object tem1
= Fcar (tail
);
833 && EQ (XCAR (tem1
), Qquote
)
834 && CONSP (XCDR (tem1
))
835 && EQ (XCAR (XCDR (tem1
)), sym
)))
836 error ("Constant symbol `%s' specified in defvar",
837 SDATA (SYMBOL_NAME (sym
)));
841 Fset_default (sym
, eval_sub (Fcar (tail
)));
843 { /* Check if there is really a global binding rather than just a let
844 binding that shadows the global unboundness of the var. */
845 volatile struct specbinding
*pdl
= specpdl_ptr
;
846 while (--pdl
>= specpdl
)
848 if (EQ (pdl
->symbol
, sym
) && !pdl
->func
849 && EQ (pdl
->old_value
, Qunbound
))
851 message_with_string ("Warning: defvar ignored because %s is let-bound",
852 SYMBOL_NAME (sym
), 1);
861 if (!NILP (Vpurify_flag
))
862 tem
= Fpurecopy (tem
);
863 Fput (sym
, Qvariable_documentation
, tem
);
865 LOADHIST_ATTACH (sym
);
867 else if (!NILP (Vinternal_interpreter_environment
)
868 && !XSYMBOL (sym
)->declared_special
)
869 /* A simple (defvar foo) with lexical scoping does "nothing" except
870 declare that var to be dynamically scoped *locally* (i.e. within
871 the current file or let-block). */
872 Vinternal_interpreter_environment
=
873 Fcons (sym
, Vinternal_interpreter_environment
);
876 /* Simple (defvar <var>) should not count as a definition at all.
877 It could get in the way of other definitions, and unloading this
878 package could try to make the variable unbound. */
884 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
885 doc
: /* Define SYMBOL as a constant variable.
886 This declares that neither programs nor users should ever change the
887 value. This constancy is not actually enforced by Emacs Lisp, but
888 SYMBOL is marked as a special variable so that it is never lexically
891 The `defconst' form always sets the value of SYMBOL to the result of
892 evalling INITVALUE. If SYMBOL is buffer-local, its default value is
893 what is set; buffer-local values are not affected. If SYMBOL has a
894 local binding, then this form sets the local binding's value.
895 However, you should normally not make local bindings for variables
896 defined with this form.
898 The optional DOCSTRING specifies the variable's documentation string.
899 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
902 register Lisp_Object sym
, tem
;
905 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
906 error ("Too many arguments");
908 tem
= eval_sub (Fcar (Fcdr (args
)));
909 if (!NILP (Vpurify_flag
))
910 tem
= Fpurecopy (tem
);
911 Fset_default (sym
, tem
);
912 XSYMBOL (sym
)->declared_special
= 1;
913 tem
= Fcar (Fcdr (Fcdr (args
)));
916 if (!NILP (Vpurify_flag
))
917 tem
= Fpurecopy (tem
);
918 Fput (sym
, Qvariable_documentation
, tem
);
920 Fput (sym
, Qrisky_local_variable
, Qt
);
921 LOADHIST_ATTACH (sym
);
925 /* Error handler used in Fuser_variable_p. */
927 user_variable_p_eh (Lisp_Object ignore
)
933 lisp_indirect_variable (Lisp_Object sym
)
935 struct Lisp_Symbol
*s
= indirect_variable (XSYMBOL (sym
));
940 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
941 doc
: /* Return t if VARIABLE is intended to be set and modified by users.
942 \(The alternative is a variable used internally in a Lisp program.)
944 This function returns t if (i) the first character of its
945 documentation is `*', or (ii) it is customizable (its property list
946 contains a non-nil value of `standard-value' or `custom-autoload'), or
947 \(iii) it is an alias for a user variable.
949 But condition (i) is considered obsolete, so for most purposes this is
950 equivalent to `custom-variable-p'. */)
951 (Lisp_Object variable
)
953 Lisp_Object documentation
;
955 if (!SYMBOLP (variable
))
958 /* If indirect and there's an alias loop, don't check anything else. */
959 if (XSYMBOL (variable
)->redirect
== SYMBOL_VARALIAS
960 && NILP (internal_condition_case_1 (lisp_indirect_variable
, variable
,
961 Qt
, user_variable_p_eh
)))
966 documentation
= Fget (variable
, Qvariable_documentation
);
967 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
969 if (STRINGP (documentation
)
970 && ((unsigned char) SREF (documentation
, 0) == '*'))
972 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
973 if (CONSP (documentation
)
974 && STRINGP (XCAR (documentation
))
975 && INTEGERP (XCDR (documentation
))
976 && XINT (XCDR (documentation
)) < 0)
978 /* Customizable? See `custom-variable-p'. */
979 if ((!NILP (Fget (variable
, intern ("standard-value"))))
980 || (!NILP (Fget (variable
, intern ("custom-autoload")))))
983 if (!(XSYMBOL (variable
)->redirect
== SYMBOL_VARALIAS
))
986 /* An indirect variable? Let's follow the chain. */
987 XSETSYMBOL (variable
, SYMBOL_ALIAS (XSYMBOL (variable
)));
991 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
992 doc
: /* Bind variables according to VARLIST then eval BODY.
993 The value of the last form in BODY is returned.
994 Each element of VARLIST is a symbol (which is bound to nil)
995 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
996 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
997 usage: (let* VARLIST BODY...) */)
1000 Lisp_Object varlist
, var
, val
, elt
, lexenv
;
1001 int count
= SPECPDL_INDEX ();
1002 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1004 GCPRO3 (args
, elt
, varlist
);
1006 lexenv
= Vinternal_interpreter_environment
;
1008 varlist
= Fcar (args
);
1009 while (CONSP (varlist
))
1013 elt
= XCAR (varlist
);
1019 else if (! NILP (Fcdr (Fcdr (elt
))))
1020 signal_error ("`let' bindings can have only one value-form", elt
);
1024 val
= eval_sub (Fcar (Fcdr (elt
)));
1027 if (!NILP (lexenv
) && SYMBOLP (var
)
1028 && !XSYMBOL (var
)->declared_special
1029 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
1030 /* Lexically bind VAR by adding it to the interpreter's binding
1034 = Fcons (Fcons (var
, val
), Vinternal_interpreter_environment
);
1035 if (EQ (Vinternal_interpreter_environment
, lexenv
))
1036 /* Save the old lexical environment on the specpdl stack,
1037 but only for the first lexical binding, since we'll never
1038 need to revert to one of the intermediate ones. */
1039 specbind (Qinternal_interpreter_environment
, newenv
);
1041 Vinternal_interpreter_environment
= newenv
;
1044 specbind (var
, val
);
1046 varlist
= XCDR (varlist
);
1049 val
= Fprogn (Fcdr (args
));
1050 return unbind_to (count
, val
);
1053 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
1054 doc
: /* Bind variables according to VARLIST then eval BODY.
1055 The value of the last form in BODY is returned.
1056 Each element of VARLIST is a symbol (which is bound to nil)
1057 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
1058 All the VALUEFORMs are evalled before any symbols are bound.
1059 usage: (let VARLIST BODY...) */)
1062 Lisp_Object
*temps
, tem
, lexenv
;
1063 register Lisp_Object elt
, varlist
;
1064 int count
= SPECPDL_INDEX ();
1066 struct gcpro gcpro1
, gcpro2
;
1069 varlist
= Fcar (args
);
1071 /* Make space to hold the values to give the bound variables. */
1072 elt
= Flength (varlist
);
1073 SAFE_ALLOCA_LISP (temps
, XFASTINT (elt
));
1075 /* Compute the values and store them in `temps'. */
1077 GCPRO2 (args
, *temps
);
1080 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
1083 elt
= XCAR (varlist
);
1085 temps
[argnum
++] = Qnil
;
1086 else if (! NILP (Fcdr (Fcdr (elt
))))
1087 signal_error ("`let' bindings can have only one value-form", elt
);
1089 temps
[argnum
++] = eval_sub (Fcar (Fcdr (elt
)));
1090 gcpro2
.nvars
= argnum
;
1094 lexenv
= Vinternal_interpreter_environment
;
1096 varlist
= Fcar (args
);
1097 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
1101 elt
= XCAR (varlist
);
1102 var
= SYMBOLP (elt
) ? elt
: Fcar (elt
);
1103 tem
= temps
[argnum
++];
1105 if (!NILP (lexenv
) && SYMBOLP (var
)
1106 && !XSYMBOL (var
)->declared_special
1107 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
1108 /* Lexically bind VAR by adding it to the lexenv alist. */
1109 lexenv
= Fcons (Fcons (var
, tem
), lexenv
);
1111 /* Dynamically bind VAR. */
1112 specbind (var
, tem
);
1115 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
1116 /* Instantiate a new lexical environment. */
1117 specbind (Qinternal_interpreter_environment
, lexenv
);
1119 elt
= Fprogn (Fcdr (args
));
1121 return unbind_to (count
, elt
);
1124 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
1125 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
1126 The order of execution is thus TEST, BODY, TEST, BODY and so on
1127 until TEST returns nil.
1128 usage: (while TEST BODY...) */)
1131 Lisp_Object test
, body
;
1132 struct gcpro gcpro1
, gcpro2
;
1134 GCPRO2 (test
, body
);
1138 while (!NILP (eval_sub (test
)))
1148 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
1149 doc
: /* Return result of expanding macros at top level of FORM.
1150 If FORM is not a macro call, it is returned unchanged.
1151 Otherwise, the macro is expanded and the expansion is considered
1152 in place of FORM. When a non-macro-call results, it is returned.
1154 The second optional arg ENVIRONMENT specifies an environment of macro
1155 definitions to shadow the loaded ones for use in file byte-compilation. */)
1156 (Lisp_Object form
, Lisp_Object environment
)
1158 /* With cleanups from Hallvard Furuseth. */
1159 register Lisp_Object expander
, sym
, def
, tem
;
1163 /* Come back here each time we expand a macro call,
1164 in case it expands into another macro call. */
1167 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1168 def
= sym
= XCAR (form
);
1170 /* Trace symbols aliases to other symbols
1171 until we get a symbol that is not an alias. */
1172 while (SYMBOLP (def
))
1176 tem
= Fassq (sym
, environment
);
1179 def
= XSYMBOL (sym
)->function
;
1180 if (!EQ (def
, Qunbound
))
1185 /* Right now TEM is the result from SYM in ENVIRONMENT,
1186 and if TEM is nil then DEF is SYM's function definition. */
1189 /* SYM is not mentioned in ENVIRONMENT.
1190 Look at its function definition. */
1191 if (EQ (def
, Qunbound
) || !CONSP (def
))
1192 /* Not defined or definition not suitable. */
1194 if (EQ (XCAR (def
), Qautoload
))
1196 /* Autoloading function: will it be a macro when loaded? */
1197 tem
= Fnth (make_number (4), def
);
1198 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
1199 /* Yes, load it and try again. */
1201 struct gcpro gcpro1
;
1203 do_autoload (def
, sym
);
1210 else if (!EQ (XCAR (def
), Qmacro
))
1212 else expander
= XCDR (def
);
1216 expander
= XCDR (tem
);
1217 if (NILP (expander
))
1220 form
= apply1 (expander
, XCDR (form
));
1225 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1226 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1227 TAG is evalled to get the tag to use; it must not be nil.
1229 Then the BODY is executed.
1230 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
1231 If no throw happens, `catch' returns the value of the last BODY form.
1232 If a throw happens, it specifies the value to return from `catch'.
1233 usage: (catch TAG BODY...) */)
1236 register Lisp_Object tag
;
1237 struct gcpro gcpro1
;
1240 tag
= eval_sub (Fcar (args
));
1242 return internal_catch (tag
, Fprogn
, Fcdr (args
));
1245 /* Set up a catch, then call C function FUNC on argument ARG.
1246 FUNC should return a Lisp_Object.
1247 This is how catches are done from within C code. */
1250 internal_catch (Lisp_Object tag
, Lisp_Object (*func
) (Lisp_Object
), Lisp_Object arg
)
1252 /* This structure is made part of the chain `catchlist'. */
1255 /* Fill in the components of c, and put it on the list. */
1259 c
.backlist
= backtrace_list
;
1260 c
.handlerlist
= handlerlist
;
1261 c
.lisp_eval_depth
= lisp_eval_depth
;
1262 c
.pdlcount
= SPECPDL_INDEX ();
1263 c
.poll_suppress_count
= poll_suppress_count
;
1264 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1265 c
.gcpro
= gcprolist
;
1266 c
.byte_stack
= byte_stack_list
;
1270 if (! _setjmp (c
.jmp
))
1271 c
.val
= (*func
) (arg
);
1273 /* Throw works by a longjmp that comes right here. */
1278 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1279 jump to that CATCH, returning VALUE as the value of that catch.
1281 This is the guts Fthrow and Fsignal; they differ only in the way
1282 they choose the catch tag to throw to. A catch tag for a
1283 condition-case form has a TAG of Qnil.
1285 Before each catch is discarded, unbind all special bindings and
1286 execute all unwind-protect clauses made above that catch. Unwind
1287 the handler stack as we go, so that the proper handlers are in
1288 effect for each unwind-protect clause we run. At the end, restore
1289 some static info saved in CATCH, and longjmp to the location
1292 This is used for correct unwinding in Fthrow and Fsignal. */
1295 unwind_to_catch (struct catchtag
*catch, Lisp_Object value
)
1297 register int last_time
;
1299 /* Save the value in the tag. */
1302 /* Restore certain special C variables. */
1303 set_poll_suppress_count (catch->poll_suppress_count
);
1304 UNBLOCK_INPUT_TO (catch->interrupt_input_blocked
);
1305 handling_signal
= 0;
1310 last_time
= catchlist
== catch;
1312 /* Unwind the specpdl stack, and then restore the proper set of
1314 unbind_to (catchlist
->pdlcount
, Qnil
);
1315 handlerlist
= catchlist
->handlerlist
;
1316 catchlist
= catchlist
->next
;
1318 while (! last_time
);
1321 /* If x_catch_errors was done, turn it off now.
1322 (First we give unbind_to a chance to do that.) */
1323 #if 0 /* This would disable x_catch_errors after x_connection_closed.
1324 The catch must remain in effect during that delicate
1325 state. --lorentey */
1326 x_fully_uncatch_errors ();
1330 byte_stack_list
= catch->byte_stack
;
1331 gcprolist
= catch->gcpro
;
1333 gcpro_level
= gcprolist
? gcprolist
->level
+ 1 : 0;
1335 backtrace_list
= catch->backlist
;
1336 lisp_eval_depth
= catch->lisp_eval_depth
;
1338 _longjmp (catch->jmp
, 1);
1341 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1342 doc
: /* Throw to the catch for TAG and return VALUE from it.
1343 Both TAG and VALUE are evalled. */)
1344 (register Lisp_Object tag
, Lisp_Object value
)
1346 register struct catchtag
*c
;
1349 for (c
= catchlist
; c
; c
= c
->next
)
1351 if (EQ (c
->tag
, tag
))
1352 unwind_to_catch (c
, value
);
1354 xsignal2 (Qno_catch
, tag
, value
);
1358 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1359 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1360 If BODYFORM completes normally, its value is returned
1361 after executing the UNWINDFORMS.
1362 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1363 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1367 int count
= SPECPDL_INDEX ();
1369 record_unwind_protect (Fprogn
, Fcdr (args
));
1370 val
= eval_sub (Fcar (args
));
1371 return unbind_to (count
, val
);
1374 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1375 doc
: /* Regain control when an error is signaled.
1376 Executes BODYFORM and returns its value if no error happens.
1377 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1378 where the BODY is made of Lisp expressions.
1380 A handler is applicable to an error
1381 if CONDITION-NAME is one of the error's condition names.
1382 If an error happens, the first applicable handler is run.
1384 The car of a handler may be a list of condition names instead of a
1385 single condition name; then it handles all of them. If the special
1386 condition name `debug' is present in this list, it allows another
1387 condition in the list to run the debugger if `debug-on-error' and the
1388 other usual mechanisms says it should (otherwise, `condition-case'
1389 suppresses the debugger).
1391 When a handler handles an error, control returns to the `condition-case'
1392 and it executes the handler's BODY...
1393 with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
1394 \(If VAR is nil, the handler can't access that information.)
1395 Then the value of the last BODY form is returned from the `condition-case'
1398 See also the function `signal' for more info.
1399 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1402 register Lisp_Object bodyform
, handlers
;
1403 volatile Lisp_Object var
;
1406 bodyform
= Fcar (Fcdr (args
));
1407 handlers
= Fcdr (Fcdr (args
));
1409 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1412 /* Like Fcondition_case, but the args are separate
1413 rather than passed in a list. Used by Fbyte_code. */
1416 internal_lisp_condition_case (volatile Lisp_Object var
, Lisp_Object bodyform
,
1417 Lisp_Object handlers
)
1425 for (val
= handlers
; CONSP (val
); val
= XCDR (val
))
1431 && (SYMBOLP (XCAR (tem
))
1432 || CONSP (XCAR (tem
))))))
1433 error ("Invalid condition handler: %s",
1434 SDATA (Fprin1_to_string (tem
, Qt
)));
1439 c
.backlist
= backtrace_list
;
1440 c
.handlerlist
= handlerlist
;
1441 c
.lisp_eval_depth
= lisp_eval_depth
;
1442 c
.pdlcount
= SPECPDL_INDEX ();
1443 c
.poll_suppress_count
= poll_suppress_count
;
1444 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1445 c
.gcpro
= gcprolist
;
1446 c
.byte_stack
= byte_stack_list
;
1447 if (_setjmp (c
.jmp
))
1450 specbind (h
.var
, c
.val
);
1451 val
= Fprogn (Fcdr (h
.chosen_clause
));
1453 /* Note that this just undoes the binding of h.var; whoever
1454 longjumped to us unwound the stack to c.pdlcount before
1456 unbind_to (c
.pdlcount
, Qnil
);
1463 h
.handler
= handlers
;
1464 h
.next
= handlerlist
;
1468 val
= eval_sub (bodyform
);
1470 handlerlist
= h
.next
;
1474 /* Call the function BFUN with no arguments, catching errors within it
1475 according to HANDLERS. If there is an error, call HFUN with
1476 one argument which is the data that describes the error:
1479 HANDLERS can be a list of conditions to catch.
1480 If HANDLERS is Qt, catch all errors.
1481 If HANDLERS is Qerror, catch all errors
1482 but allow the debugger to run if that is enabled. */
1485 internal_condition_case (Lisp_Object (*bfun
) (void), Lisp_Object handlers
,
1486 Lisp_Object (*hfun
) (Lisp_Object
))
1494 c
.backlist
= backtrace_list
;
1495 c
.handlerlist
= handlerlist
;
1496 c
.lisp_eval_depth
= lisp_eval_depth
;
1497 c
.pdlcount
= SPECPDL_INDEX ();
1498 c
.poll_suppress_count
= poll_suppress_count
;
1499 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1500 c
.gcpro
= gcprolist
;
1501 c
.byte_stack
= byte_stack_list
;
1502 if (_setjmp (c
.jmp
))
1504 return (*hfun
) (c
.val
);
1508 h
.handler
= handlers
;
1510 h
.next
= handlerlist
;
1516 handlerlist
= h
.next
;
1520 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1523 internal_condition_case_1 (Lisp_Object (*bfun
) (Lisp_Object
), Lisp_Object arg
,
1524 Lisp_Object handlers
, Lisp_Object (*hfun
) (Lisp_Object
))
1532 c
.backlist
= backtrace_list
;
1533 c
.handlerlist
= handlerlist
;
1534 c
.lisp_eval_depth
= lisp_eval_depth
;
1535 c
.pdlcount
= SPECPDL_INDEX ();
1536 c
.poll_suppress_count
= poll_suppress_count
;
1537 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1538 c
.gcpro
= gcprolist
;
1539 c
.byte_stack
= byte_stack_list
;
1540 if (_setjmp (c
.jmp
))
1542 return (*hfun
) (c
.val
);
1546 h
.handler
= handlers
;
1548 h
.next
= handlerlist
;
1552 val
= (*bfun
) (arg
);
1554 handlerlist
= h
.next
;
1558 /* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as
1562 internal_condition_case_2 (Lisp_Object (*bfun
) (Lisp_Object
, Lisp_Object
),
1565 Lisp_Object handlers
,
1566 Lisp_Object (*hfun
) (Lisp_Object
))
1574 c
.backlist
= backtrace_list
;
1575 c
.handlerlist
= handlerlist
;
1576 c
.lisp_eval_depth
= lisp_eval_depth
;
1577 c
.pdlcount
= SPECPDL_INDEX ();
1578 c
.poll_suppress_count
= poll_suppress_count
;
1579 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1580 c
.gcpro
= gcprolist
;
1581 c
.byte_stack
= byte_stack_list
;
1582 if (_setjmp (c
.jmp
))
1584 return (*hfun
) (c
.val
);
1588 h
.handler
= handlers
;
1590 h
.next
= handlerlist
;
1594 val
= (*bfun
) (arg1
, arg2
);
1596 handlerlist
= h
.next
;
1600 /* Like internal_condition_case but call BFUN with NARGS as first,
1601 and ARGS as second argument. */
1604 internal_condition_case_n (Lisp_Object (*bfun
) (ptrdiff_t, Lisp_Object
*),
1607 Lisp_Object handlers
,
1608 Lisp_Object (*hfun
) (Lisp_Object
))
1616 c
.backlist
= backtrace_list
;
1617 c
.handlerlist
= handlerlist
;
1618 c
.lisp_eval_depth
= lisp_eval_depth
;
1619 c
.pdlcount
= SPECPDL_INDEX ();
1620 c
.poll_suppress_count
= poll_suppress_count
;
1621 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1622 c
.gcpro
= gcprolist
;
1623 c
.byte_stack
= byte_stack_list
;
1624 if (_setjmp (c
.jmp
))
1626 return (*hfun
) (c
.val
);
1630 h
.handler
= handlers
;
1632 h
.next
= handlerlist
;
1636 val
= (*bfun
) (nargs
, args
);
1638 handlerlist
= h
.next
;
1643 static Lisp_Object
find_handler_clause (Lisp_Object
, Lisp_Object
);
1644 static int maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
,
1648 process_quit_flag (void)
1650 Lisp_Object flag
= Vquit_flag
;
1652 if (EQ (flag
, Qkill_emacs
))
1654 if (EQ (Vthrow_on_input
, flag
))
1655 Fthrow (Vthrow_on_input
, Qt
);
1656 Fsignal (Qquit
, Qnil
);
1659 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1660 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1661 This function does not return.
1663 An error symbol is a symbol with an `error-conditions' property
1664 that is a list of condition names.
1665 A handler for any of those names will get to handle this signal.
1666 The symbol `error' should normally be one of them.
1668 DATA should be a list. Its elements are printed as part of the error message.
1669 See Info anchor `(elisp)Definition of signal' for some details on how this
1670 error message is constructed.
1671 If the signal is handled, DATA is made available to the handler.
1672 See also the function `condition-case'. */)
1673 (Lisp_Object error_symbol
, Lisp_Object data
)
1675 /* When memory is full, ERROR-SYMBOL is nil,
1676 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1677 That is a special case--don't do this in other situations. */
1678 Lisp_Object conditions
;
1680 Lisp_Object real_error_symbol
1681 = (NILP (error_symbol
) ? Fcar (data
) : error_symbol
);
1682 register Lisp_Object clause
= Qnil
;
1684 struct backtrace
*bp
;
1686 immediate_quit
= handling_signal
= 0;
1688 if (gc_in_progress
|| waiting_for_input
)
1691 #if 0 /* rms: I don't know why this was here,
1692 but it is surely wrong for an error that is handled. */
1693 #ifdef HAVE_WINDOW_SYSTEM
1694 if (display_hourglass_p
)
1695 cancel_hourglass ();
1699 /* This hook is used by edebug. */
1700 if (! NILP (Vsignal_hook_function
)
1701 && ! NILP (error_symbol
))
1703 /* Edebug takes care of restoring these variables when it exits. */
1704 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1705 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1707 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1708 max_specpdl_size
= SPECPDL_INDEX () + 40;
1710 call2 (Vsignal_hook_function
, error_symbol
, data
);
1713 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1715 /* Remember from where signal was called. Skip over the frame for
1716 `signal' itself. If a frame for `error' follows, skip that,
1717 too. Don't do this when ERROR_SYMBOL is nil, because that
1718 is a memory-full error. */
1719 Vsignaling_function
= Qnil
;
1720 if (backtrace_list
&& !NILP (error_symbol
))
1722 bp
= backtrace_list
->next
;
1723 if (bp
&& bp
->function
&& EQ (*bp
->function
, Qerror
))
1725 if (bp
&& bp
->function
)
1726 Vsignaling_function
= *bp
->function
;
1729 for (h
= handlerlist
; h
; h
= h
->next
)
1731 clause
= find_handler_clause (h
->handler
, conditions
);
1736 if (/* Don't run the debugger for a memory-full error.
1737 (There is no room in memory to do that!) */
1738 !NILP (error_symbol
)
1739 && (!NILP (Vdebug_on_signal
)
1740 /* If no handler is present now, try to run the debugger. */
1742 /* A `debug' symbol in the handler list disables the normal
1743 suppression of the debugger. */
1744 || (CONSP (clause
) && CONSP (XCAR (clause
))
1745 && !NILP (Fmemq (Qdebug
, XCAR (clause
))))
1746 /* Special handler that means "print a message and run debugger
1748 || EQ (h
->handler
, Qerror
)))
1751 = maybe_call_debugger (conditions
, error_symbol
, data
);
1752 /* We can't return values to code which signaled an error, but we
1753 can continue code which has signaled a quit. */
1754 if (debugger_called
&& EQ (real_error_symbol
, Qquit
))
1760 Lisp_Object unwind_data
1761 = (NILP (error_symbol
) ? data
: Fcons (error_symbol
, data
));
1763 h
->chosen_clause
= clause
;
1764 unwind_to_catch (h
->tag
, unwind_data
);
1769 Fthrow (Qtop_level
, Qt
);
1772 if (! NILP (error_symbol
))
1773 data
= Fcons (error_symbol
, data
);
1775 string
= Ferror_message_string (data
);
1776 fatal ("%s", SDATA (string
));
1779 /* Internal version of Fsignal that never returns.
1780 Used for anything but Qquit (which can return from Fsignal). */
1783 xsignal (Lisp_Object error_symbol
, Lisp_Object data
)
1785 Fsignal (error_symbol
, data
);
1789 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1792 xsignal0 (Lisp_Object error_symbol
)
1794 xsignal (error_symbol
, Qnil
);
1798 xsignal1 (Lisp_Object error_symbol
, Lisp_Object arg
)
1800 xsignal (error_symbol
, list1 (arg
));
1804 xsignal2 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
)
1806 xsignal (error_symbol
, list2 (arg1
, arg2
));
1810 xsignal3 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
1812 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1815 /* Signal `error' with message S, and additional arg ARG.
1816 If ARG is not a genuine list, make it a one-element list. */
1819 signal_error (const char *s
, Lisp_Object arg
)
1821 Lisp_Object tortoise
, hare
;
1823 hare
= tortoise
= arg
;
1824 while (CONSP (hare
))
1831 tortoise
= XCDR (tortoise
);
1833 if (EQ (hare
, tortoise
))
1838 arg
= Fcons (arg
, Qnil
); /* Make it a list. */
1840 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1844 /* Return nonzero if LIST is a non-nil atom or
1845 a list containing one of CONDITIONS. */
1848 wants_debugger (Lisp_Object list
, Lisp_Object conditions
)
1855 while (CONSP (conditions
))
1857 Lisp_Object
this, tail
;
1858 this = XCAR (conditions
);
1859 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1860 if (EQ (XCAR (tail
), this))
1862 conditions
= XCDR (conditions
);
1867 /* Return 1 if an error with condition-symbols CONDITIONS,
1868 and described by SIGNAL-DATA, should skip the debugger
1869 according to debugger-ignored-errors. */
1872 skip_debugger (Lisp_Object conditions
, Lisp_Object data
)
1875 int first_string
= 1;
1876 Lisp_Object error_message
;
1878 error_message
= Qnil
;
1879 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1881 if (STRINGP (XCAR (tail
)))
1885 error_message
= Ferror_message_string (data
);
1889 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1894 Lisp_Object contail
;
1896 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1897 if (EQ (XCAR (tail
), XCAR (contail
)))
1905 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1906 SIG and DATA describe the signal. There are two ways to pass them:
1907 = SIG is the error symbol, and DATA is the rest of the data.
1908 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1909 This is for memory-full errors only. */
1911 maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
, Lisp_Object data
)
1913 Lisp_Object combined_data
;
1915 combined_data
= Fcons (sig
, data
);
1918 /* Don't try to run the debugger with interrupts blocked.
1919 The editing loop would return anyway. */
1921 /* Does user want to enter debugger for this kind of error? */
1924 : wants_debugger (Vdebug_on_error
, conditions
))
1925 && ! skip_debugger (conditions
, combined_data
)
1926 /* RMS: What's this for? */
1927 && when_entered_debugger
< num_nonmacro_input_events
)
1929 call_debugger (Fcons (Qerror
, Fcons (combined_data
, Qnil
)));
1937 find_handler_clause (Lisp_Object handlers
, Lisp_Object conditions
)
1939 register Lisp_Object h
;
1941 /* t is used by handlers for all conditions, set up by C code. */
1942 if (EQ (handlers
, Qt
))
1945 /* error is used similarly, but means print an error message
1946 and run the debugger if that is enabled. */
1947 if (EQ (handlers
, Qerror
))
1950 for (h
= handlers
; CONSP (h
); h
= XCDR (h
))
1952 Lisp_Object handler
= XCAR (h
);
1953 Lisp_Object condit
, tem
;
1955 if (!CONSP (handler
))
1957 condit
= XCAR (handler
);
1958 /* Handle a single condition name in handler HANDLER. */
1959 if (SYMBOLP (condit
))
1961 tem
= Fmemq (Fcar (handler
), conditions
);
1965 /* Handle a list of condition names in handler HANDLER. */
1966 else if (CONSP (condit
))
1969 for (tail
= condit
; CONSP (tail
); tail
= XCDR (tail
))
1971 tem
= Fmemq (XCAR (tail
), conditions
);
1982 /* Dump an error message; called like vprintf. */
1984 verror (const char *m
, va_list ap
)
1987 ptrdiff_t size
= sizeof buf
;
1988 ptrdiff_t size_max
= STRING_BYTES_BOUND
+ 1;
1993 used
= evxprintf (&buffer
, &size
, buf
, size_max
, m
, ap
);
1994 string
= make_string (buffer
, used
);
1998 xsignal1 (Qerror
, string
);
2002 /* Dump an error message; called like printf. */
2006 error (const char *m
, ...)
2014 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
2015 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
2016 This means it contains a description for how to read arguments to give it.
2017 The value is nil for an invalid function or a symbol with no function
2020 Interactively callable functions include strings and vectors (treated
2021 as keyboard macros), lambda-expressions that contain a top-level call
2022 to `interactive', autoload definitions made by `autoload' with non-nil
2023 fourth argument, and some of the built-in functions of Lisp.
2025 Also, a symbol satisfies `commandp' if its function definition does so.
2027 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
2028 then strings and vectors are not accepted. */)
2029 (Lisp_Object function
, Lisp_Object for_call_interactively
)
2031 register Lisp_Object fun
;
2032 register Lisp_Object funcar
;
2033 Lisp_Object if_prop
= Qnil
;
2037 fun
= indirect_function (fun
); /* Check cycles. */
2038 if (NILP (fun
) || EQ (fun
, Qunbound
))
2041 /* Check an `interactive-form' property if present, analogous to the
2042 function-documentation property. */
2044 while (SYMBOLP (fun
))
2046 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
2049 fun
= Fsymbol_function (fun
);
2052 /* Emacs primitives are interactive if their DEFUN specifies an
2053 interactive spec. */
2055 return XSUBR (fun
)->intspec
? Qt
: if_prop
;
2057 /* Bytecode objects are interactive if they are long enough to
2058 have an element whose index is COMPILED_INTERACTIVE, which is
2059 where the interactive spec is stored. */
2060 else if (COMPILEDP (fun
))
2061 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
2064 /* Strings and vectors are keyboard macros. */
2065 if (STRINGP (fun
) || VECTORP (fun
))
2066 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
2068 /* Lists may represent commands. */
2071 funcar
= XCAR (fun
);
2072 if (EQ (funcar
, Qclosure
))
2073 return (!NILP (Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
)))))
2075 else if (EQ (funcar
, Qlambda
))
2076 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
2077 else if (EQ (funcar
, Qautoload
))
2078 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
2083 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
2084 doc
: /* Define FUNCTION to autoload from FILE.
2085 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
2086 Third arg DOCSTRING is documentation for the function.
2087 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
2088 Fifth arg TYPE indicates the type of the object:
2089 nil or omitted says FUNCTION is a function,
2090 `keymap' says FUNCTION is really a keymap, and
2091 `macro' or t says FUNCTION is really a macro.
2092 Third through fifth args give info about the real definition.
2093 They default to nil.
2094 If FUNCTION is already defined other than as an autoload,
2095 this does nothing and returns nil. */)
2096 (Lisp_Object function
, Lisp_Object file
, Lisp_Object docstring
, Lisp_Object interactive
, Lisp_Object type
)
2098 CHECK_SYMBOL (function
);
2099 CHECK_STRING (file
);
2101 /* If function is defined and not as an autoload, don't override. */
2102 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
2103 && !(CONSP (XSYMBOL (function
)->function
)
2104 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
2107 if (NILP (Vpurify_flag
))
2108 /* Only add entries after dumping, because the ones before are
2109 not useful and else we get loads of them from the loaddefs.el. */
2110 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
2112 /* We don't want the docstring in purespace (instead,
2113 Snarf-documentation should (hopefully) overwrite it).
2114 We used to use 0 here, but that leads to accidental sharing in
2115 purecopy's hash-consing, so we use a (hopefully) unique integer
2117 docstring
= make_number (XPNTR (function
));
2118 return Ffset (function
,
2119 Fpurecopy (list5 (Qautoload
, file
, docstring
,
2120 interactive
, type
)));
2124 un_autoload (Lisp_Object oldqueue
)
2126 register Lisp_Object queue
, first
, second
;
2128 /* Queue to unwind is current value of Vautoload_queue.
2129 oldqueue is the shadowed value to leave in Vautoload_queue. */
2130 queue
= Vautoload_queue
;
2131 Vautoload_queue
= oldqueue
;
2132 while (CONSP (queue
))
2134 first
= XCAR (queue
);
2135 second
= Fcdr (first
);
2136 first
= Fcar (first
);
2137 if (EQ (first
, make_number (0)))
2140 Ffset (first
, second
);
2141 queue
= XCDR (queue
);
2146 /* Load an autoloaded function.
2147 FUNNAME is the symbol which is the function's name.
2148 FUNDEF is the autoload definition (a list). */
2151 do_autoload (Lisp_Object fundef
, Lisp_Object funname
)
2153 int count
= SPECPDL_INDEX ();
2155 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2157 /* This is to make sure that loadup.el gives a clear picture
2158 of what files are preloaded and when. */
2159 if (! NILP (Vpurify_flag
))
2160 error ("Attempt to autoload %s while preparing to dump",
2161 SDATA (SYMBOL_NAME (funname
)));
2164 CHECK_SYMBOL (funname
);
2165 GCPRO3 (fun
, funname
, fundef
);
2167 /* Preserve the match data. */
2168 record_unwind_save_match_data ();
2170 /* If autoloading gets an error (which includes the error of failing
2171 to define the function being called), we use Vautoload_queue
2172 to undo function definitions and `provide' calls made by
2173 the function. We do this in the specific case of autoloading
2174 because autoloading is not an explicit request "load this file",
2175 but rather a request to "call this function".
2177 The value saved here is to be restored into Vautoload_queue. */
2178 record_unwind_protect (un_autoload
, Vautoload_queue
);
2179 Vautoload_queue
= Qt
;
2180 Fload (Fcar (Fcdr (fundef
)), Qnil
, Qt
, Qnil
, Qt
);
2182 /* Once loading finishes, don't undo it. */
2183 Vautoload_queue
= Qt
;
2184 unbind_to (count
, Qnil
);
2186 fun
= Findirect_function (fun
, Qnil
);
2188 if (!NILP (Fequal (fun
, fundef
)))
2189 error ("Autoloading failed to define function %s",
2190 SDATA (SYMBOL_NAME (funname
)));
2195 DEFUN ("eval", Feval
, Seval
, 1, 2, 0,
2196 doc
: /* Evaluate FORM and return its value.
2197 If LEXICAL is t, evaluate using lexical scoping. */)
2198 (Lisp_Object form
, Lisp_Object lexical
)
2200 int count
= SPECPDL_INDEX ();
2201 specbind (Qinternal_interpreter_environment
,
2202 NILP (lexical
) ? Qnil
: Fcons (Qt
, Qnil
));
2203 return unbind_to (count
, eval_sub (form
));
2206 /* Eval a sub-expression of the current expression (i.e. in the same
2209 eval_sub (Lisp_Object form
)
2211 Lisp_Object fun
, val
, original_fun
, original_args
;
2213 struct backtrace backtrace
;
2214 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2216 if (handling_signal
)
2221 /* Look up its binding in the lexical environment.
2222 We do not pay attention to the declared_special flag here, since we
2223 already did that when let-binding the variable. */
2224 Lisp_Object lex_binding
2225 = !NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
2226 ? Fassq (form
, Vinternal_interpreter_environment
)
2228 if (CONSP (lex_binding
))
2229 return XCDR (lex_binding
);
2231 return Fsymbol_value (form
);
2238 if ((consing_since_gc
> gc_cons_threshold
2239 && consing_since_gc
> gc_relative_threshold
)
2241 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2244 Fgarbage_collect ();
2248 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2250 if (max_lisp_eval_depth
< 100)
2251 max_lisp_eval_depth
= 100;
2252 if (lisp_eval_depth
> max_lisp_eval_depth
)
2253 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2256 original_fun
= Fcar (form
);
2257 original_args
= Fcdr (form
);
2259 backtrace
.next
= backtrace_list
;
2260 backtrace_list
= &backtrace
;
2261 backtrace
.function
= &original_fun
; /* This also protects them from gc. */
2262 backtrace
.args
= &original_args
;
2263 backtrace
.nargs
= UNEVALLED
;
2264 backtrace
.debug_on_exit
= 0;
2266 if (debug_on_next_call
)
2267 do_debug_on_call (Qt
);
2269 /* At this point, only original_fun and original_args
2270 have values that will be used below. */
2273 /* Optimize for no indirection. */
2275 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2276 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2277 fun
= indirect_function (fun
);
2281 Lisp_Object numargs
;
2282 Lisp_Object argvals
[8];
2283 Lisp_Object args_left
;
2284 register int i
, maxargs
;
2286 args_left
= original_args
;
2287 numargs
= Flength (args_left
);
2291 if (XINT (numargs
) < XSUBR (fun
)->min_args
2292 || (XSUBR (fun
)->max_args
>= 0
2293 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2294 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2296 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2297 val
= (XSUBR (fun
)->function
.aUNEVALLED
) (args_left
);
2298 else if (XSUBR (fun
)->max_args
== MANY
)
2300 /* Pass a vector of evaluated arguments. */
2302 ptrdiff_t argnum
= 0;
2305 SAFE_ALLOCA_LISP (vals
, XINT (numargs
));
2307 GCPRO3 (args_left
, fun
, fun
);
2311 while (!NILP (args_left
))
2313 vals
[argnum
++] = eval_sub (Fcar (args_left
));
2314 args_left
= Fcdr (args_left
);
2315 gcpro3
.nvars
= argnum
;
2318 backtrace
.args
= vals
;
2319 backtrace
.nargs
= XINT (numargs
);
2321 val
= (XSUBR (fun
)->function
.aMANY
) (XINT (numargs
), vals
);
2327 GCPRO3 (args_left
, fun
, fun
);
2328 gcpro3
.var
= argvals
;
2331 maxargs
= XSUBR (fun
)->max_args
;
2332 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
2334 argvals
[i
] = eval_sub (Fcar (args_left
));
2340 backtrace
.args
= argvals
;
2341 backtrace
.nargs
= XINT (numargs
);
2346 val
= (XSUBR (fun
)->function
.a0 ());
2349 val
= (XSUBR (fun
)->function
.a1 (argvals
[0]));
2352 val
= (XSUBR (fun
)->function
.a2 (argvals
[0], argvals
[1]));
2355 val
= (XSUBR (fun
)->function
.a3
2356 (argvals
[0], argvals
[1], argvals
[2]));
2359 val
= (XSUBR (fun
)->function
.a4
2360 (argvals
[0], argvals
[1], argvals
[2], argvals
[3]));
2363 val
= (XSUBR (fun
)->function
.a5
2364 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2368 val
= (XSUBR (fun
)->function
.a6
2369 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2370 argvals
[4], argvals
[5]));
2373 val
= (XSUBR (fun
)->function
.a7
2374 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2375 argvals
[4], argvals
[5], argvals
[6]));
2379 val
= (XSUBR (fun
)->function
.a8
2380 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2381 argvals
[4], argvals
[5], argvals
[6], argvals
[7]));
2385 /* Someone has created a subr that takes more arguments than
2386 is supported by this code. We need to either rewrite the
2387 subr to use a different argument protocol, or add more
2388 cases to this switch. */
2393 else if (COMPILEDP (fun
))
2394 val
= apply_lambda (fun
, original_args
);
2397 if (EQ (fun
, Qunbound
))
2398 xsignal1 (Qvoid_function
, original_fun
);
2400 xsignal1 (Qinvalid_function
, original_fun
);
2401 funcar
= XCAR (fun
);
2402 if (!SYMBOLP (funcar
))
2403 xsignal1 (Qinvalid_function
, original_fun
);
2404 if (EQ (funcar
, Qautoload
))
2406 do_autoload (fun
, original_fun
);
2409 if (EQ (funcar
, Qmacro
))
2410 val
= eval_sub (apply1 (Fcdr (fun
), original_args
));
2411 else if (EQ (funcar
, Qlambda
)
2412 || EQ (funcar
, Qclosure
))
2413 val
= apply_lambda (fun
, original_args
);
2415 xsignal1 (Qinvalid_function
, original_fun
);
2420 if (backtrace
.debug_on_exit
)
2421 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2422 backtrace_list
= backtrace
.next
;
2427 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
2428 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2429 Then return the value FUNCTION returns.
2430 Thus, (apply '+ 1 2 '(3 4)) returns 10.
2431 usage: (apply FUNCTION &rest ARGUMENTS) */)
2432 (ptrdiff_t nargs
, Lisp_Object
*args
)
2434 ptrdiff_t i
, numargs
;
2435 register Lisp_Object spread_arg
;
2436 register Lisp_Object
*funcall_args
;
2437 Lisp_Object fun
, retval
;
2438 struct gcpro gcpro1
;
2443 spread_arg
= args
[nargs
- 1];
2444 CHECK_LIST (spread_arg
);
2446 numargs
= XINT (Flength (spread_arg
));
2449 return Ffuncall (nargs
- 1, args
);
2450 else if (numargs
== 1)
2452 args
[nargs
- 1] = XCAR (spread_arg
);
2453 return Ffuncall (nargs
, args
);
2456 numargs
+= nargs
- 2;
2458 /* Optimize for no indirection. */
2459 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2460 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2461 fun
= indirect_function (fun
);
2462 if (EQ (fun
, Qunbound
))
2464 /* Let funcall get the error. */
2471 if (numargs
< XSUBR (fun
)->min_args
2472 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2473 goto funcall
; /* Let funcall get the error. */
2474 else if (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
> numargs
)
2476 /* Avoid making funcall cons up a yet another new vector of arguments
2477 by explicitly supplying nil's for optional values. */
2478 SAFE_ALLOCA_LISP (funcall_args
, 1 + XSUBR (fun
)->max_args
);
2479 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2480 funcall_args
[++i
] = Qnil
;
2481 GCPRO1 (*funcall_args
);
2482 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2486 /* We add 1 to numargs because funcall_args includes the
2487 function itself as well as its arguments. */
2490 SAFE_ALLOCA_LISP (funcall_args
, 1 + numargs
);
2491 GCPRO1 (*funcall_args
);
2492 gcpro1
.nvars
= 1 + numargs
;
2495 memcpy (funcall_args
, args
, nargs
* sizeof (Lisp_Object
));
2496 /* Spread the last arg we got. Its first element goes in
2497 the slot that it used to occupy, hence this value of I. */
2499 while (!NILP (spread_arg
))
2501 funcall_args
[i
++] = XCAR (spread_arg
);
2502 spread_arg
= XCDR (spread_arg
);
2505 /* By convention, the caller needs to gcpro Ffuncall's args. */
2506 retval
= Ffuncall (gcpro1
.nvars
, funcall_args
);
2513 /* Run hook variables in various ways. */
2516 funcall_nil (ptrdiff_t nargs
, Lisp_Object
*args
)
2518 Ffuncall (nargs
, args
);
2522 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2523 doc
: /* Run each hook in HOOKS.
2524 Each argument should be a symbol, a hook variable.
2525 These symbols are processed in the order specified.
2526 If a hook symbol has a non-nil value, that value may be a function
2527 or a list of functions to be called to run the hook.
2528 If the value is a function, it is called with no arguments.
2529 If it is a list, the elements are called, in order, with no arguments.
2531 Major modes should not use this function directly to run their mode
2532 hook; they should use `run-mode-hooks' instead.
2534 Do not use `make-local-variable' to make a hook variable buffer-local.
2535 Instead, use `add-hook' and specify t for the LOCAL argument.
2536 usage: (run-hooks &rest HOOKS) */)
2537 (ptrdiff_t nargs
, Lisp_Object
*args
)
2539 Lisp_Object hook
[1];
2542 for (i
= 0; i
< nargs
; i
++)
2545 run_hook_with_args (1, hook
, funcall_nil
);
2551 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2552 Srun_hook_with_args
, 1, MANY
, 0,
2553 doc
: /* Run HOOK with the specified arguments ARGS.
2554 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2555 value, that value may be a function or a list of functions to be
2556 called to run the hook. If the value is a function, it is called with
2557 the given arguments and its return value is returned. If it is a list
2558 of functions, those functions are called, in order,
2559 with the given arguments ARGS.
2560 It is best not to depend on the value returned by `run-hook-with-args',
2563 Do not use `make-local-variable' to make a hook variable buffer-local.
2564 Instead, use `add-hook' and specify t for the LOCAL argument.
2565 usage: (run-hook-with-args HOOK &rest ARGS) */)
2566 (ptrdiff_t nargs
, Lisp_Object
*args
)
2568 return run_hook_with_args (nargs
, args
, funcall_nil
);
2571 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2572 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2573 doc
: /* Run HOOK with the specified arguments ARGS.
2574 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2575 value, that value may be a function or a list of functions to be
2576 called to run the hook. If the value is a function, it is called with
2577 the given arguments and its return value is returned.
2578 If it is a list of functions, those functions are called, in order,
2579 with the given arguments ARGS, until one of them
2580 returns a non-nil value. Then we return that value.
2581 However, if they all return nil, we return nil.
2583 Do not use `make-local-variable' to make a hook variable buffer-local.
2584 Instead, use `add-hook' and specify t for the LOCAL argument.
2585 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2586 (ptrdiff_t nargs
, Lisp_Object
*args
)
2588 return run_hook_with_args (nargs
, args
, Ffuncall
);
2592 funcall_not (ptrdiff_t nargs
, Lisp_Object
*args
)
2594 return NILP (Ffuncall (nargs
, args
)) ? Qt
: Qnil
;
2597 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2598 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2599 doc
: /* Run HOOK with the specified arguments ARGS.
2600 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2601 value, that value may be a function or a list of functions to be
2602 called to run the hook. If the value is a function, it is called with
2603 the given arguments and its return value is returned.
2604 If it is a list of functions, those functions are called, in order,
2605 with the given arguments ARGS, until one of them returns nil.
2606 Then we return nil. However, if they all return non-nil, we return non-nil.
2608 Do not use `make-local-variable' to make a hook variable buffer-local.
2609 Instead, use `add-hook' and specify t for the LOCAL argument.
2610 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2611 (ptrdiff_t nargs
, Lisp_Object
*args
)
2613 return NILP (run_hook_with_args (nargs
, args
, funcall_not
)) ? Qt
: Qnil
;
2617 run_hook_wrapped_funcall (ptrdiff_t nargs
, Lisp_Object
*args
)
2619 Lisp_Object tmp
= args
[0], ret
;
2622 ret
= Ffuncall (nargs
, args
);
2628 DEFUN ("run-hook-wrapped", Frun_hook_wrapped
, Srun_hook_wrapped
, 2, MANY
, 0,
2629 doc
: /* Run HOOK, passing each function through WRAP-FUNCTION.
2630 I.e. instead of calling each function FUN directly with arguments ARGS,
2631 it calls WRAP-FUNCTION with arguments FUN and ARGS.
2632 As soon as a call to WRAP-FUNCTION returns non-nil, `run-hook-wrapped'
2633 aborts and returns that value.
2634 usage: (run-hook-wrapped HOOK WRAP-FUNCTION &rest ARGS) */)
2635 (ptrdiff_t nargs
, Lisp_Object
*args
)
2637 return run_hook_with_args (nargs
, args
, run_hook_wrapped_funcall
);
2640 /* ARGS[0] should be a hook symbol.
2641 Call each of the functions in the hook value, passing each of them
2642 as arguments all the rest of ARGS (all NARGS - 1 elements).
2643 FUNCALL specifies how to call each function on the hook.
2644 The caller (or its caller, etc) must gcpro all of ARGS,
2645 except that it isn't necessary to gcpro ARGS[0]. */
2648 run_hook_with_args (ptrdiff_t nargs
, Lisp_Object
*args
,
2649 Lisp_Object (*funcall
) (ptrdiff_t nargs
, Lisp_Object
*args
))
2651 Lisp_Object sym
, val
, ret
= Qnil
;
2652 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2654 /* If we are dying or still initializing,
2655 don't do anything--it would probably crash if we tried. */
2656 if (NILP (Vrun_hooks
))
2660 val
= find_symbol_value (sym
);
2662 if (EQ (val
, Qunbound
) || NILP (val
))
2664 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2667 return funcall (nargs
, args
);
2671 Lisp_Object global_vals
= Qnil
;
2672 GCPRO3 (sym
, val
, global_vals
);
2675 CONSP (val
) && NILP (ret
);
2678 if (EQ (XCAR (val
), Qt
))
2680 /* t indicates this hook has a local binding;
2681 it means to run the global binding too. */
2682 global_vals
= Fdefault_value (sym
);
2683 if (NILP (global_vals
)) continue;
2685 if (!CONSP (global_vals
) || EQ (XCAR (global_vals
), Qlambda
))
2687 args
[0] = global_vals
;
2688 ret
= funcall (nargs
, args
);
2693 CONSP (global_vals
) && NILP (ret
);
2694 global_vals
= XCDR (global_vals
))
2696 args
[0] = XCAR (global_vals
);
2697 /* In a global value, t should not occur. If it does, we
2698 must ignore it to avoid an endless loop. */
2699 if (!EQ (args
[0], Qt
))
2700 ret
= funcall (nargs
, args
);
2706 args
[0] = XCAR (val
);
2707 ret
= funcall (nargs
, args
);
2716 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2719 run_hook_with_args_2 (Lisp_Object hook
, Lisp_Object arg1
, Lisp_Object arg2
)
2721 Lisp_Object temp
[3];
2726 Frun_hook_with_args (3, temp
);
2729 /* Apply fn to arg. */
2731 apply1 (Lisp_Object fn
, Lisp_Object arg
)
2733 struct gcpro gcpro1
;
2737 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2740 Lisp_Object args
[2];
2744 RETURN_UNGCPRO (Fapply (2, args
));
2748 /* Call function fn on no arguments. */
2750 call0 (Lisp_Object fn
)
2752 struct gcpro gcpro1
;
2755 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2758 /* Call function fn with 1 argument arg1. */
2761 call1 (Lisp_Object fn
, Lisp_Object arg1
)
2763 struct gcpro gcpro1
;
2764 Lisp_Object args
[2];
2770 RETURN_UNGCPRO (Ffuncall (2, args
));
2773 /* Call function fn with 2 arguments arg1, arg2. */
2776 call2 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
)
2778 struct gcpro gcpro1
;
2779 Lisp_Object args
[3];
2785 RETURN_UNGCPRO (Ffuncall (3, args
));
2788 /* Call function fn with 3 arguments arg1, arg2, arg3. */
2791 call3 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2793 struct gcpro gcpro1
;
2794 Lisp_Object args
[4];
2801 RETURN_UNGCPRO (Ffuncall (4, args
));
2804 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
2807 call4 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2810 struct gcpro gcpro1
;
2811 Lisp_Object args
[5];
2819 RETURN_UNGCPRO (Ffuncall (5, args
));
2822 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
2825 call5 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2826 Lisp_Object arg4
, Lisp_Object arg5
)
2828 struct gcpro gcpro1
;
2829 Lisp_Object args
[6];
2838 RETURN_UNGCPRO (Ffuncall (6, args
));
2841 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
2844 call6 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2845 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
)
2847 struct gcpro gcpro1
;
2848 Lisp_Object args
[7];
2858 RETURN_UNGCPRO (Ffuncall (7, args
));
2861 /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
2864 call7 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2865 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
)
2867 struct gcpro gcpro1
;
2868 Lisp_Object args
[8];
2879 RETURN_UNGCPRO (Ffuncall (8, args
));
2882 /* The caller should GCPRO all the elements of ARGS. */
2884 DEFUN ("functionp", Ffunctionp
, Sfunctionp
, 1, 1, 0,
2885 doc
: /* Non-nil if OBJECT is a function. */)
2886 (Lisp_Object object
)
2888 if (SYMBOLP (object
) && !NILP (Ffboundp (object
)))
2890 object
= Findirect_function (object
, Qt
);
2892 if (CONSP (object
) && EQ (XCAR (object
), Qautoload
))
2894 /* Autoloaded symbols are functions, except if they load
2895 macros or keymaps. */
2897 for (i
= 0; i
< 4 && CONSP (object
); i
++)
2898 object
= XCDR (object
);
2900 return (CONSP (object
) && !NILP (XCAR (object
))) ? Qnil
: Qt
;
2905 return (XSUBR (object
)->max_args
!= UNEVALLED
) ? Qt
: Qnil
;
2906 else if (COMPILEDP (object
))
2908 else if (CONSP (object
))
2910 Lisp_Object car
= XCAR (object
);
2911 return (EQ (car
, Qlambda
) || EQ (car
, Qclosure
)) ? Qt
: Qnil
;
2917 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2918 doc
: /* Call first argument as a function, passing remaining arguments to it.
2919 Return the value that function returns.
2920 Thus, (funcall 'cons 'x 'y) returns (x . y).
2921 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2922 (ptrdiff_t nargs
, Lisp_Object
*args
)
2924 Lisp_Object fun
, original_fun
;
2926 ptrdiff_t numargs
= nargs
- 1;
2927 Lisp_Object lisp_numargs
;
2929 struct backtrace backtrace
;
2930 register Lisp_Object
*internal_args
;
2934 if ((consing_since_gc
> gc_cons_threshold
2935 && consing_since_gc
> gc_relative_threshold
)
2937 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2938 Fgarbage_collect ();
2940 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2942 if (max_lisp_eval_depth
< 100)
2943 max_lisp_eval_depth
= 100;
2944 if (lisp_eval_depth
> max_lisp_eval_depth
)
2945 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2948 backtrace
.next
= backtrace_list
;
2949 backtrace_list
= &backtrace
;
2950 backtrace
.function
= &args
[0];
2951 backtrace
.args
= &args
[1];
2952 backtrace
.nargs
= nargs
- 1;
2953 backtrace
.debug_on_exit
= 0;
2955 if (debug_on_next_call
)
2956 do_debug_on_call (Qlambda
);
2960 original_fun
= args
[0];
2964 /* Optimize for no indirection. */
2966 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2967 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2968 fun
= indirect_function (fun
);
2972 if (numargs
< XSUBR (fun
)->min_args
2973 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2975 XSETFASTINT (lisp_numargs
, numargs
);
2976 xsignal2 (Qwrong_number_of_arguments
, original_fun
, lisp_numargs
);
2979 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2980 xsignal1 (Qinvalid_function
, original_fun
);
2982 else if (XSUBR (fun
)->max_args
== MANY
)
2983 val
= (XSUBR (fun
)->function
.aMANY
) (numargs
, args
+ 1);
2986 if (XSUBR (fun
)->max_args
> numargs
)
2988 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2989 memcpy (internal_args
, args
+ 1, numargs
* sizeof (Lisp_Object
));
2990 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2991 internal_args
[i
] = Qnil
;
2994 internal_args
= args
+ 1;
2995 switch (XSUBR (fun
)->max_args
)
2998 val
= (XSUBR (fun
)->function
.a0 ());
3001 val
= (XSUBR (fun
)->function
.a1 (internal_args
[0]));
3004 val
= (XSUBR (fun
)->function
.a2
3005 (internal_args
[0], internal_args
[1]));
3008 val
= (XSUBR (fun
)->function
.a3
3009 (internal_args
[0], internal_args
[1], internal_args
[2]));
3012 val
= (XSUBR (fun
)->function
.a4
3013 (internal_args
[0], internal_args
[1], internal_args
[2],
3017 val
= (XSUBR (fun
)->function
.a5
3018 (internal_args
[0], internal_args
[1], internal_args
[2],
3019 internal_args
[3], internal_args
[4]));
3022 val
= (XSUBR (fun
)->function
.a6
3023 (internal_args
[0], internal_args
[1], internal_args
[2],
3024 internal_args
[3], internal_args
[4], internal_args
[5]));
3027 val
= (XSUBR (fun
)->function
.a7
3028 (internal_args
[0], internal_args
[1], internal_args
[2],
3029 internal_args
[3], internal_args
[4], internal_args
[5],
3034 val
= (XSUBR (fun
)->function
.a8
3035 (internal_args
[0], internal_args
[1], internal_args
[2],
3036 internal_args
[3], internal_args
[4], internal_args
[5],
3037 internal_args
[6], internal_args
[7]));
3042 /* If a subr takes more than 8 arguments without using MANY
3043 or UNEVALLED, we need to extend this function to support it.
3044 Until this is done, there is no way to call the function. */
3049 else if (COMPILEDP (fun
))
3050 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3053 if (EQ (fun
, Qunbound
))
3054 xsignal1 (Qvoid_function
, original_fun
);
3056 xsignal1 (Qinvalid_function
, original_fun
);
3057 funcar
= XCAR (fun
);
3058 if (!SYMBOLP (funcar
))
3059 xsignal1 (Qinvalid_function
, original_fun
);
3060 if (EQ (funcar
, Qlambda
)
3061 || EQ (funcar
, Qclosure
))
3062 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3063 else if (EQ (funcar
, Qautoload
))
3065 do_autoload (fun
, original_fun
);
3070 xsignal1 (Qinvalid_function
, original_fun
);
3074 if (backtrace
.debug_on_exit
)
3075 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
3076 backtrace_list
= backtrace
.next
;
3081 apply_lambda (Lisp_Object fun
, Lisp_Object args
)
3083 Lisp_Object args_left
;
3084 ptrdiff_t i
, numargs
;
3085 register Lisp_Object
*arg_vector
;
3086 struct gcpro gcpro1
, gcpro2
, gcpro3
;
3087 register Lisp_Object tem
;
3090 numargs
= XFASTINT (Flength (args
));
3091 SAFE_ALLOCA_LISP (arg_vector
, numargs
);
3094 GCPRO3 (*arg_vector
, args_left
, fun
);
3097 for (i
= 0; i
< numargs
; )
3099 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
3100 tem
= eval_sub (tem
);
3101 arg_vector
[i
++] = tem
;
3107 backtrace_list
->args
= arg_vector
;
3108 backtrace_list
->nargs
= i
;
3109 tem
= funcall_lambda (fun
, numargs
, arg_vector
);
3111 /* Do the debug-on-exit now, while arg_vector still exists. */
3112 if (backtrace_list
->debug_on_exit
)
3113 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
3114 /* Don't do it again when we return to eval. */
3115 backtrace_list
->debug_on_exit
= 0;
3120 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
3121 and return the result of evaluation.
3122 FUN must be either a lambda-expression or a compiled-code object. */
3125 funcall_lambda (Lisp_Object fun
, ptrdiff_t nargs
,
3126 register Lisp_Object
*arg_vector
)
3128 Lisp_Object val
, syms_left
, next
, lexenv
;
3129 int count
= SPECPDL_INDEX ();
3135 if (EQ (XCAR (fun
), Qclosure
))
3137 fun
= XCDR (fun
); /* Drop `closure'. */
3138 lexenv
= XCAR (fun
);
3139 CHECK_LIST_CONS (fun
, fun
);
3143 syms_left
= XCDR (fun
);
3144 if (CONSP (syms_left
))
3145 syms_left
= XCAR (syms_left
);
3147 xsignal1 (Qinvalid_function
, fun
);
3149 else if (COMPILEDP (fun
))
3151 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3152 if (INTEGERP (syms_left
))
3153 /* A byte-code object with a non-nil `push args' slot means we
3154 shouldn't bind any arguments, instead just call the byte-code
3155 interpreter directly; it will push arguments as necessary.
3157 Byte-code objects with either a non-existent, or a nil value for
3158 the `push args' slot (the default), have dynamically-bound
3159 arguments, and use the argument-binding code below instead (as do
3160 all interpreted functions, even lexically bound ones). */
3162 /* If we have not actually read the bytecode string
3163 and constants vector yet, fetch them from the file. */
3164 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3165 Ffetch_bytecode (fun
);
3166 return exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
3167 AREF (fun
, COMPILED_CONSTANTS
),
3168 AREF (fun
, COMPILED_STACK_DEPTH
),
3177 i
= optional
= rest
= 0;
3178 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3182 next
= XCAR (syms_left
);
3183 if (!SYMBOLP (next
))
3184 xsignal1 (Qinvalid_function
, fun
);
3186 if (EQ (next
, Qand_rest
))
3188 else if (EQ (next
, Qand_optional
))
3195 arg
= Flist (nargs
- i
, &arg_vector
[i
]);
3199 arg
= arg_vector
[i
++];
3201 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3205 /* Bind the argument. */
3206 if (!NILP (lexenv
) && SYMBOLP (next
))
3207 /* Lexically bind NEXT by adding it to the lexenv alist. */
3208 lexenv
= Fcons (Fcons (next
, arg
), lexenv
);
3210 /* Dynamically bind NEXT. */
3211 specbind (next
, arg
);
3215 if (!NILP (syms_left
))
3216 xsignal1 (Qinvalid_function
, fun
);
3218 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3220 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
3221 /* Instantiate a new lexical environment. */
3222 specbind (Qinternal_interpreter_environment
, lexenv
);
3225 val
= Fprogn (XCDR (XCDR (fun
)));
3228 /* If we have not actually read the bytecode string
3229 and constants vector yet, fetch them from the file. */
3230 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3231 Ffetch_bytecode (fun
);
3232 val
= exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
3233 AREF (fun
, COMPILED_CONSTANTS
),
3234 AREF (fun
, COMPILED_STACK_DEPTH
),
3238 return unbind_to (count
, val
);
3241 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3243 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3244 (Lisp_Object object
)
3248 if (COMPILEDP (object
) && CONSP (AREF (object
, COMPILED_BYTECODE
)))
3250 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3253 tem
= AREF (object
, COMPILED_BYTECODE
);
3254 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3255 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3257 error ("Invalid byte code");
3259 ASET (object
, COMPILED_BYTECODE
, XCAR (tem
));
3260 ASET (object
, COMPILED_CONSTANTS
, XCDR (tem
));
3268 register int count
= SPECPDL_INDEX ();
3270 min (max_specpdl_size
,
3271 min (max (PTRDIFF_MAX
, SIZE_MAX
) / sizeof (struct specbinding
),
3274 if (max_size
<= specpdl_size
)
3276 if (max_specpdl_size
< 400)
3277 max_size
= max_specpdl_size
= 400;
3278 if (max_size
<= specpdl_size
)
3279 signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil
);
3281 size
= specpdl_size
< max_size
/ 2 ? 2 * specpdl_size
: max_size
;
3282 specpdl
= xnrealloc (specpdl
, size
, sizeof *specpdl
);
3283 specpdl_size
= size
;
3284 specpdl_ptr
= specpdl
+ count
;
3287 /* `specpdl_ptr->symbol' is a field which describes which variable is
3288 let-bound, so it can be properly undone when we unbind_to.
3289 It can have the following two shapes:
3290 - SYMBOL : if it's a plain symbol, it means that we have let-bound
3291 a symbol that is not buffer-local (at least at the time
3292 the let binding started). Note also that it should not be
3293 aliased (i.e. when let-binding V1 that's aliased to V2, we want
3295 - (SYMBOL WHERE . BUFFER) : this means that it is a let-binding for
3296 variable SYMBOL which can be buffer-local. WHERE tells us
3297 which buffer is affected (or nil if the let-binding affects the
3298 global value of the variable) and BUFFER tells us which buffer was
3299 current (i.e. if WHERE is non-nil, then BUFFER==WHERE, otherwise
3300 BUFFER did not yet have a buffer-local value). */
3303 specbind (Lisp_Object symbol
, Lisp_Object value
)
3305 struct Lisp_Symbol
*sym
;
3307 eassert (!handling_signal
);
3309 CHECK_SYMBOL (symbol
);
3310 sym
= XSYMBOL (symbol
);
3311 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3315 switch (sym
->redirect
)
3317 case SYMBOL_VARALIAS
:
3318 sym
= indirect_variable (sym
); XSETSYMBOL (symbol
, sym
); goto start
;
3319 case SYMBOL_PLAINVAL
:
3320 /* The most common case is that of a non-constant symbol with a
3321 trivial value. Make that as fast as we can. */
3322 specpdl_ptr
->symbol
= symbol
;
3323 specpdl_ptr
->old_value
= SYMBOL_VAL (sym
);
3324 specpdl_ptr
->func
= NULL
;
3327 SET_SYMBOL_VAL (sym
, value
);
3329 set_internal (symbol
, value
, Qnil
, 1);
3331 case SYMBOL_LOCALIZED
:
3332 if (SYMBOL_BLV (sym
)->frame_local
)
3333 error ("Frame-local vars cannot be let-bound");
3334 case SYMBOL_FORWARDED
:
3336 Lisp_Object ovalue
= find_symbol_value (symbol
);
3337 specpdl_ptr
->func
= 0;
3338 specpdl_ptr
->old_value
= ovalue
;
3340 eassert (sym
->redirect
!= SYMBOL_LOCALIZED
3341 || (EQ (SYMBOL_BLV (sym
)->where
,
3342 SYMBOL_BLV (sym
)->frame_local
?
3343 Fselected_frame () : Fcurrent_buffer ())));
3345 if (sym
->redirect
== SYMBOL_LOCALIZED
3346 || BUFFER_OBJFWDP (SYMBOL_FWD (sym
)))
3348 Lisp_Object where
, cur_buf
= Fcurrent_buffer ();
3350 /* For a local variable, record both the symbol and which
3351 buffer's or frame's value we are saving. */
3352 if (!NILP (Flocal_variable_p (symbol
, Qnil
)))
3354 eassert (sym
->redirect
!= SYMBOL_LOCALIZED
3355 || (BLV_FOUND (SYMBOL_BLV (sym
))
3356 && EQ (cur_buf
, SYMBOL_BLV (sym
)->where
)));
3359 else if (sym
->redirect
== SYMBOL_LOCALIZED
3360 && BLV_FOUND (SYMBOL_BLV (sym
)))
3361 where
= SYMBOL_BLV (sym
)->where
;
3365 /* We're not using the `unused' slot in the specbinding
3366 structure because this would mean we have to do more
3367 work for simple variables. */
3368 /* FIXME: The third value `current_buffer' is only used in
3369 let_shadows_buffer_binding_p which is itself only used
3370 in set_internal for local_if_set. */
3371 eassert (NILP (where
) || EQ (where
, cur_buf
));
3372 specpdl_ptr
->symbol
= Fcons (symbol
, Fcons (where
, cur_buf
));
3374 /* If SYMBOL is a per-buffer variable which doesn't have a
3375 buffer-local value here, make the `let' change the global
3376 value by changing the value of SYMBOL in all buffers not
3377 having their own value. This is consistent with what
3378 happens with other buffer-local variables. */
3380 && sym
->redirect
== SYMBOL_FORWARDED
)
3382 eassert (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)));
3384 Fset_default (symbol
, value
);
3389 specpdl_ptr
->symbol
= symbol
;
3392 set_internal (symbol
, value
, Qnil
, 1);
3400 record_unwind_protect (Lisp_Object (*function
) (Lisp_Object
), Lisp_Object arg
)
3402 eassert (!handling_signal
);
3404 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3406 specpdl_ptr
->func
= function
;
3407 specpdl_ptr
->symbol
= Qnil
;
3408 specpdl_ptr
->old_value
= arg
;
3413 unbind_to (int count
, Lisp_Object value
)
3415 Lisp_Object quitf
= Vquit_flag
;
3416 struct gcpro gcpro1
, gcpro2
;
3418 GCPRO2 (value
, quitf
);
3421 while (specpdl_ptr
!= specpdl
+ count
)
3423 /* Copy the binding, and decrement specpdl_ptr, before we do
3424 the work to unbind it. We decrement first
3425 so that an error in unbinding won't try to unbind
3426 the same entry again, and we copy the binding first
3427 in case more bindings are made during some of the code we run. */
3429 struct specbinding this_binding
;
3430 this_binding
= *--specpdl_ptr
;
3432 if (this_binding
.func
!= 0)
3433 (*this_binding
.func
) (this_binding
.old_value
);
3434 /* If the symbol is a list, it is really (SYMBOL WHERE
3435 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3436 frame. If WHERE is a buffer or frame, this indicates we
3437 bound a variable that had a buffer-local or frame-local
3438 binding. WHERE nil means that the variable had the default
3439 value when it was bound. CURRENT-BUFFER is the buffer that
3440 was current when the variable was bound. */
3441 else if (CONSP (this_binding
.symbol
))
3443 Lisp_Object symbol
, where
;
3445 symbol
= XCAR (this_binding
.symbol
);
3446 where
= XCAR (XCDR (this_binding
.symbol
));
3449 Fset_default (symbol
, this_binding
.old_value
);
3450 /* If `where' is non-nil, reset the value in the appropriate
3451 local binding, but only if that binding still exists. */
3452 else if (BUFFERP (where
)
3453 ? !NILP (Flocal_variable_p (symbol
, where
))
3454 : !NILP (Fassq (symbol
, XFRAME (where
)->param_alist
)))
3455 set_internal (symbol
, this_binding
.old_value
, where
, 1);
3457 /* If variable has a trivial value (no forwarding), we can
3458 just set it. No need to check for constant symbols here,
3459 since that was already done by specbind. */
3460 else if (XSYMBOL (this_binding
.symbol
)->redirect
== SYMBOL_PLAINVAL
)
3461 SET_SYMBOL_VAL (XSYMBOL (this_binding
.symbol
),
3462 this_binding
.old_value
);
3464 /* NOTE: we only ever come here if make_local_foo was used for
3465 the first time on this var within this let. */
3466 Fset_default (this_binding
.symbol
, this_binding
.old_value
);
3469 if (NILP (Vquit_flag
) && !NILP (quitf
))
3476 DEFUN ("special-variable-p", Fspecial_variable_p
, Sspecial_variable_p
, 1, 1, 0,
3477 doc
: /* Return non-nil if SYMBOL's global binding has been declared special.
3478 A special variable is one that will be bound dynamically, even in a
3479 context where binding is lexical by default. */)
3480 (Lisp_Object symbol
)
3482 CHECK_SYMBOL (symbol
);
3483 return XSYMBOL (symbol
)->declared_special
? Qt
: Qnil
;
3487 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3488 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3489 The debugger is entered when that frame exits, if the flag is non-nil. */)
3490 (Lisp_Object level
, Lisp_Object flag
)
3492 register struct backtrace
*backlist
= backtrace_list
;
3495 CHECK_NUMBER (level
);
3497 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
3499 backlist
= backlist
->next
;
3503 backlist
->debug_on_exit
= !NILP (flag
);
3508 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3509 doc
: /* Print a trace of Lisp function calls currently active.
3510 Output stream used is value of `standard-output'. */)
3513 register struct backtrace
*backlist
= backtrace_list
;
3516 struct gcpro gcpro1
;
3517 Lisp_Object old_print_level
= Vprint_level
;
3519 if (NILP (Vprint_level
))
3520 XSETFASTINT (Vprint_level
, 8);
3527 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
3528 if (backlist
->nargs
== UNEVALLED
)
3530 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
3531 write_string ("\n", -1);
3535 tem
= *backlist
->function
;
3536 Fprin1 (tem
, Qnil
); /* This can QUIT. */
3537 write_string ("(", -1);
3538 if (backlist
->nargs
== MANY
)
3539 { /* FIXME: Can this happen? */
3541 for (tail
= *backlist
->args
, i
= 0;
3543 tail
= Fcdr (tail
), i
= 1)
3545 if (i
) write_string (" ", -1);
3546 Fprin1 (Fcar (tail
), Qnil
);
3552 for (i
= 0; i
< backlist
->nargs
; i
++)
3554 if (i
) write_string (" ", -1);
3555 Fprin1 (backlist
->args
[i
], Qnil
);
3558 write_string (")\n", -1);
3560 backlist
= backlist
->next
;
3563 Vprint_level
= old_print_level
;
3568 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, NULL
,
3569 doc
: /* Return the function and arguments NFRAMES up from current execution point.
3570 If that frame has not evaluated the arguments yet (or is a special form),
3571 the value is (nil FUNCTION ARG-FORMS...).
3572 If that frame has evaluated its arguments and called its function already,
3573 the value is (t FUNCTION ARG-VALUES...).
3574 A &rest arg is represented as the tail of the list ARG-VALUES.
3575 FUNCTION is whatever was supplied as car of evaluated list,
3576 or a lambda expression for macro calls.
3577 If NFRAMES is more than the number of frames, the value is nil. */)
3578 (Lisp_Object nframes
)
3580 register struct backtrace
*backlist
= backtrace_list
;
3581 register EMACS_INT i
;
3584 CHECK_NATNUM (nframes
);
3586 /* Find the frame requested. */
3587 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3588 backlist
= backlist
->next
;
3592 if (backlist
->nargs
== UNEVALLED
)
3593 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3596 if (backlist
->nargs
== MANY
) /* FIXME: Can this happen? */
3597 tem
= *backlist
->args
;
3599 tem
= Flist (backlist
->nargs
, backlist
->args
);
3601 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3608 mark_backtrace (void)
3610 register struct backtrace
*backlist
;
3613 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3615 mark_object (*backlist
->function
);
3617 if (backlist
->nargs
== UNEVALLED
3618 || backlist
->nargs
== MANY
) /* FIXME: Can this happen? */
3621 i
= backlist
->nargs
;
3623 mark_object (backlist
->args
[i
]);
3631 DEFVAR_INT ("max-specpdl-size", max_specpdl_size
,
3632 doc
: /* *Limit on number of Lisp variable bindings and `unwind-protect's.
3633 If Lisp code tries to increase the total number past this amount,
3634 an error is signaled.
3635 You can safely use a value considerably larger than the default value,
3636 if that proves inconveniently small. However, if you increase it too far,
3637 Emacs could run out of memory trying to make the stack bigger. */);
3639 DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth
,
3640 doc
: /* *Limit on depth in `eval', `apply' and `funcall' before error.
3642 This limit serves to catch infinite recursions for you before they cause
3643 actual stack overflow in C, which would be fatal for Emacs.
3644 You can safely make it considerably larger than its default value,
3645 if that proves inconveniently small. However, if you increase it too far,
3646 Emacs could overflow the real C stack, and crash. */);
3648 DEFVAR_LISP ("quit-flag", Vquit_flag
,
3649 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3650 If the value is t, that means do an ordinary quit.
3651 If the value equals `throw-on-input', that means quit by throwing
3652 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3653 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3654 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3657 DEFVAR_LISP ("inhibit-quit", Vinhibit_quit
,
3658 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3659 Note that `quit-flag' will still be set by typing C-g,
3660 so a quit will be signaled as soon as `inhibit-quit' is nil.
3661 To prevent this happening, set `quit-flag' to nil
3662 before making `inhibit-quit' nil. */);
3663 Vinhibit_quit
= Qnil
;
3665 DEFSYM (Qinhibit_quit
, "inhibit-quit");
3666 DEFSYM (Qautoload
, "autoload");
3667 DEFSYM (Qdebug_on_error
, "debug-on-error");
3668 DEFSYM (Qmacro
, "macro");
3669 DEFSYM (Qdeclare
, "declare");
3671 /* Note that the process handling also uses Qexit, but we don't want
3672 to staticpro it twice, so we just do it here. */
3673 DEFSYM (Qexit
, "exit");
3675 DEFSYM (Qinteractive
, "interactive");
3676 DEFSYM (Qcommandp
, "commandp");
3677 DEFSYM (Qdefun
, "defun");
3678 DEFSYM (Qand_rest
, "&rest");
3679 DEFSYM (Qand_optional
, "&optional");
3680 DEFSYM (Qclosure
, "closure");
3681 DEFSYM (Qdebug
, "debug");
3683 DEFVAR_LISP ("debug-on-error", Vdebug_on_error
,
3684 doc
: /* *Non-nil means enter debugger if an error is signaled.
3685 Does not apply to errors handled by `condition-case' or those
3686 matched by `debug-ignored-errors'.
3687 If the value is a list, an error only means to enter the debugger
3688 if one of its condition symbols appears in the list.
3689 When you evaluate an expression interactively, this variable
3690 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3691 The command `toggle-debug-on-error' toggles this.
3692 See also the variable `debug-on-quit'. */);
3693 Vdebug_on_error
= Qnil
;
3695 DEFVAR_LISP ("debug-ignored-errors", Vdebug_ignored_errors
,
3696 doc
: /* *List of errors for which the debugger should not be called.
3697 Each element may be a condition-name or a regexp that matches error messages.
3698 If any element applies to a given error, that error skips the debugger
3699 and just returns to top level.
3700 This overrides the variable `debug-on-error'.
3701 It does not apply to errors handled by `condition-case'. */);
3702 Vdebug_ignored_errors
= Qnil
;
3704 DEFVAR_BOOL ("debug-on-quit", debug_on_quit
,
3705 doc
: /* *Non-nil means enter debugger if quit is signaled (C-g, for example).
3706 Does not apply if quit is handled by a `condition-case'. */);
3709 DEFVAR_BOOL ("debug-on-next-call", debug_on_next_call
,
3710 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3712 DEFVAR_BOOL ("debugger-may-continue", debugger_may_continue
,
3713 doc
: /* Non-nil means debugger may continue execution.
3714 This is nil when the debugger is called under circumstances where it
3715 might not be safe to continue. */);
3716 debugger_may_continue
= 1;
3718 DEFVAR_LISP ("debugger", Vdebugger
,
3719 doc
: /* Function to call to invoke debugger.
3720 If due to frame exit, args are `exit' and the value being returned;
3721 this function's value will be returned instead of that.
3722 If due to error, args are `error' and a list of the args to `signal'.
3723 If due to `apply' or `funcall' entry, one arg, `lambda'.
3724 If due to `eval' entry, one arg, t. */);
3727 DEFVAR_LISP ("signal-hook-function", Vsignal_hook_function
,
3728 doc
: /* If non-nil, this is a function for `signal' to call.
3729 It receives the same arguments that `signal' was given.
3730 The Edebug package uses this to regain control. */);
3731 Vsignal_hook_function
= Qnil
;
3733 DEFVAR_LISP ("debug-on-signal", Vdebug_on_signal
,
3734 doc
: /* *Non-nil means call the debugger regardless of condition handlers.
3735 Note that `debug-on-error', `debug-on-quit' and friends
3736 still determine whether to handle the particular condition. */);
3737 Vdebug_on_signal
= Qnil
;
3739 DEFVAR_LISP ("macro-declaration-function", Vmacro_declaration_function
,
3740 doc
: /* Function to process declarations in a macro definition.
3741 The function will be called with two args MACRO and DECL.
3742 MACRO is the name of the macro being defined.
3743 DECL is a list `(declare ...)' containing the declarations.
3744 The value the function returns is not used. */);
3745 Vmacro_declaration_function
= Qnil
;
3747 /* When lexical binding is being used,
3748 vinternal_interpreter_environment is non-nil, and contains an alist
3749 of lexically-bound variable, or (t), indicating an empty
3750 environment. The lisp name of this variable would be
3751 `internal-interpreter-environment' if it weren't hidden.
3752 Every element of this list can be either a cons (VAR . VAL)
3753 specifying a lexical binding, or a single symbol VAR indicating
3754 that this variable should use dynamic scoping. */
3755 DEFSYM (Qinternal_interpreter_environment
, "internal-interpreter-environment");
3756 DEFVAR_LISP ("internal-interpreter-environment",
3757 Vinternal_interpreter_environment
,
3758 doc
: /* If non-nil, the current lexical environment of the lisp interpreter.
3759 When lexical binding is not being used, this variable is nil.
3760 A value of `(t)' indicates an empty environment, otherwise it is an
3761 alist of active lexical bindings. */);
3762 Vinternal_interpreter_environment
= Qnil
;
3763 /* Don't export this variable to Elisp, so no one can mess with it
3764 (Just imagine if someone makes it buffer-local). */
3765 Funintern (Qinternal_interpreter_environment
, Qnil
);
3767 DEFSYM (Vrun_hooks
, "run-hooks");
3769 staticpro (&Vautoload_queue
);
3770 Vautoload_queue
= Qnil
;
3771 staticpro (&Vsignaling_function
);
3772 Vsignaling_function
= Qnil
;
3774 inhibit_lisp_code
= Qnil
;
3785 defsubr (&Sfunction
);
3787 defsubr (&Sdefmacro
);
3789 defsubr (&Sdefvaralias
);
3790 defsubr (&Sdefconst
);
3791 defsubr (&Suser_variable_p
);
3795 defsubr (&Smacroexpand
);
3798 defsubr (&Sunwind_protect
);
3799 defsubr (&Scondition_case
);
3801 defsubr (&Sinteractive_p
);
3802 defsubr (&Scalled_interactively_p
);
3803 defsubr (&Scommandp
);
3804 defsubr (&Sautoload
);
3807 defsubr (&Sfuncall
);
3808 defsubr (&Srun_hooks
);
3809 defsubr (&Srun_hook_with_args
);
3810 defsubr (&Srun_hook_with_args_until_success
);
3811 defsubr (&Srun_hook_with_args_until_failure
);
3812 defsubr (&Srun_hook_wrapped
);
3813 defsubr (&Sfetch_bytecode
);
3814 defsubr (&Sbacktrace_debug
);
3815 defsubr (&Sbacktrace
);
3816 defsubr (&Sbacktrace_frame
);
3817 defsubr (&Sspecial_variable_p
);
3818 defsubr (&Sfunctionp
);