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 ptrdiff_t specpdl_size
;
95 /* Pointer to beginning of specpdl. */
97 struct specbinding
*specpdl
;
99 /* Pointer to first unused element in specpdl. */
101 struct specbinding
*specpdl_ptr
;
103 /* Depth in Lisp evaluations and function calls. */
105 static EMACS_INT lisp_eval_depth
;
107 /* The value of num_nonmacro_input_events as of the last time we
108 started to enter the debugger. If we decide to enter the debugger
109 again when this is still equal to num_nonmacro_input_events, then we
110 know that the debugger itself has an error, and we should just
111 signal the error instead of entering an infinite loop of debugger
114 static EMACS_INT when_entered_debugger
;
116 /* The function from which the last `signal' was called. Set in
119 Lisp_Object Vsignaling_function
;
121 /* Set to non-zero while processing X events. Checked in Feval to
122 make sure the Lisp interpreter isn't called from a signal handler,
123 which is unsafe because the interpreter isn't reentrant. */
127 static Lisp_Object
funcall_lambda (Lisp_Object
, ptrdiff_t, Lisp_Object
*);
128 static void unwind_to_catch (struct catchtag
*, Lisp_Object
) NO_RETURN
;
129 static int interactive_p (int);
130 static Lisp_Object
apply_lambda (Lisp_Object fun
, Lisp_Object args
);
131 static Lisp_Object
Ffetch_bytecode (Lisp_Object
);
134 init_eval_once (void)
137 specpdl
= (struct specbinding
*) xmalloc (size
* sizeof (struct specbinding
));
139 specpdl_ptr
= specpdl
;
140 /* Don't forget to update docs (lispref node "Local Variables"). */
141 max_specpdl_size
= 1300; /* 1000 is not enough for CEDET's c-by.el. */
142 max_lisp_eval_depth
= 600;
150 specpdl_ptr
= specpdl
;
155 debug_on_next_call
= 0;
160 /* This is less than the initial value of num_nonmacro_input_events. */
161 when_entered_debugger
= -1;
164 /* Unwind-protect function used by call_debugger. */
167 restore_stack_limits (Lisp_Object data
)
169 max_specpdl_size
= XINT (XCAR (data
));
170 max_lisp_eval_depth
= XINT (XCDR (data
));
174 /* Call the Lisp debugger, giving it argument ARG. */
177 call_debugger (Lisp_Object arg
)
179 int debug_while_redisplaying
;
180 ptrdiff_t count
= SPECPDL_INDEX ();
182 EMACS_INT old_max
= max_specpdl_size
;
184 /* Temporarily bump up the stack limits,
185 so the debugger won't run out of stack. */
187 max_specpdl_size
+= 1;
188 record_unwind_protect (restore_stack_limits
,
189 Fcons (make_number (old_max
),
190 make_number (max_lisp_eval_depth
)));
191 max_specpdl_size
= old_max
;
193 if (lisp_eval_depth
+ 40 > max_lisp_eval_depth
)
194 max_lisp_eval_depth
= lisp_eval_depth
+ 40;
196 if (max_specpdl_size
- 100 < SPECPDL_INDEX ())
197 max_specpdl_size
= SPECPDL_INDEX () + 100;
199 #ifdef HAVE_WINDOW_SYSTEM
200 if (display_hourglass_p
)
204 debug_on_next_call
= 0;
205 when_entered_debugger
= num_nonmacro_input_events
;
207 /* Resetting redisplaying_p to 0 makes sure that debug output is
208 displayed if the debugger is invoked during redisplay. */
209 debug_while_redisplaying
= redisplaying_p
;
211 specbind (intern ("debugger-may-continue"),
212 debug_while_redisplaying
? Qnil
: Qt
);
213 specbind (Qinhibit_redisplay
, Qnil
);
214 specbind (Qdebug_on_error
, Qnil
);
216 #if 0 /* Binding this prevents execution of Lisp code during
217 redisplay, which necessarily leads to display problems. */
218 specbind (Qinhibit_eval_during_redisplay
, Qt
);
221 val
= apply1 (Vdebugger
, arg
);
223 /* Interrupting redisplay and resuming it later is not safe under
224 all circumstances. So, when the debugger returns, abort the
225 interrupted redisplay by going back to the top-level. */
226 if (debug_while_redisplaying
)
229 return unbind_to (count
, val
);
233 do_debug_on_call (Lisp_Object code
)
235 debug_on_next_call
= 0;
236 backtrace_list
->debug_on_exit
= 1;
237 call_debugger (Fcons (code
, Qnil
));
240 /* NOTE!!! Every function that can call EVAL must protect its args
241 and temporaries from garbage collection while it needs them.
242 The definition of `For' shows what you have to do. */
244 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
245 doc
: /* Eval args until one of them yields non-nil, then return that value.
246 The remaining args are not evalled at all.
247 If all args return nil, return nil.
248 usage: (or CONDITIONS...) */)
251 register Lisp_Object val
= Qnil
;
258 val
= eval_sub (XCAR (args
));
268 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
269 doc
: /* Eval args until one of them yields nil, then return nil.
270 The remaining args are not evalled at all.
271 If no arg yields nil, return the last arg's value.
272 usage: (and CONDITIONS...) */)
275 register Lisp_Object val
= Qt
;
282 val
= eval_sub (XCAR (args
));
292 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
293 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
294 Returns the value of THEN or the value of the last of the ELSE's.
295 THEN must be one expression, but ELSE... can be zero or more expressions.
296 If COND yields nil, and there are no ELSE's, the value is nil.
297 usage: (if COND THEN ELSE...) */)
300 register Lisp_Object cond
;
304 cond
= eval_sub (Fcar (args
));
308 return eval_sub (Fcar (Fcdr (args
)));
309 return Fprogn (Fcdr (Fcdr (args
)));
312 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
313 doc
: /* Try each clause until one succeeds.
314 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
315 and, if the value is non-nil, this clause succeeds:
316 then the expressions in BODY are evaluated and the last one's
317 value is the value of the cond-form.
318 If no clause succeeds, cond returns nil.
319 If a clause has one element, as in (CONDITION),
320 CONDITION's value if non-nil is returned from the cond-form.
321 usage: (cond CLAUSES...) */)
324 register Lisp_Object clause
, val
;
331 clause
= Fcar (args
);
332 val
= eval_sub (Fcar (clause
));
335 if (!EQ (XCDR (clause
), Qnil
))
336 val
= Fprogn (XCDR (clause
));
346 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
347 doc
: /* Eval BODY forms sequentially and return value of last one.
348 usage: (progn BODY...) */)
351 register Lisp_Object val
= Qnil
;
358 val
= eval_sub (XCAR (args
));
366 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
367 doc
: /* Eval FIRST and BODY sequentially; return value from FIRST.
368 The value of FIRST is saved during the evaluation of the remaining args,
369 whose values are discarded.
370 usage: (prog1 FIRST BODY...) */)
374 register Lisp_Object args_left
;
375 struct gcpro gcpro1
, gcpro2
;
381 val
= eval_sub (XCAR (args_left
));
382 while (CONSP (args_left
= XCDR (args_left
)))
383 eval_sub (XCAR (args_left
));
389 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
390 doc
: /* Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
391 The value of FORM2 is saved during the evaluation of the
392 remaining args, whose values are discarded.
393 usage: (prog2 FORM1 FORM2 BODY...) */)
399 eval_sub (XCAR (args
));
401 return Fprog1 (XCDR (args
));
404 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
405 doc
: /* Set each SYM to the value of its VAL.
406 The symbols SYM are variables; they are literal (not evaluated).
407 The values VAL are expressions; they are evaluated.
408 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
409 The second VAL is not computed until after the first SYM is set, and so on;
410 each VAL can use the new value of variables set earlier in the `setq'.
411 The return value of the `setq' form is the value of the last VAL.
412 usage: (setq [SYM VAL]...) */)
415 register Lisp_Object args_left
;
416 register Lisp_Object val
, sym
, lex_binding
;
427 val
= eval_sub (Fcar (Fcdr (args_left
)));
428 sym
= Fcar (args_left
);
430 /* Like for eval_sub, we do not check declared_special here since
431 it's been done when let-binding. */
432 if (!NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
434 && !NILP (lex_binding
435 = Fassq (sym
, Vinternal_interpreter_environment
)))
436 XSETCDR (lex_binding
, val
); /* SYM is lexically bound. */
438 Fset (sym
, val
); /* SYM is dynamically bound. */
440 args_left
= Fcdr (Fcdr (args_left
));
442 while (!NILP (args_left
));
448 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
449 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
450 Warning: `quote' does not construct its return value, but just returns
451 the value that was pre-constructed by the Lisp reader (see info node
452 `(elisp)Printed Representation').
453 This means that '(a . b) is not identical to (cons 'a 'b): the former
454 does not cons. Quoting should be reserved for constants that will
455 never be modified by side-effects, unless you like self-modifying code.
456 See the common pitfall in info node `(elisp)Rearrangement' for an example
457 of unexpected results when a quoted object is modified.
458 usage: (quote ARG) */)
461 if (!NILP (Fcdr (args
)))
462 xsignal2 (Qwrong_number_of_arguments
, Qquote
, Flength (args
));
466 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
467 doc
: /* Like `quote', but preferred for objects which are functions.
468 In byte compilation, `function' causes its argument to be compiled.
469 `quote' cannot do that.
470 usage: (function ARG) */)
473 Lisp_Object quoted
= XCAR (args
);
475 if (!NILP (Fcdr (args
)))
476 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
478 if (!NILP (Vinternal_interpreter_environment
)
480 && EQ (XCAR (quoted
), Qlambda
))
481 /* This is a lambda expression within a lexical environment;
482 return an interpreted closure instead of a simple lambda. */
483 return Fcons (Qclosure
, Fcons (Vinternal_interpreter_environment
,
486 /* Simply quote the argument. */
491 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
492 doc
: /* Return t if the containing function was run directly by user input.
493 This means that the function was called with `call-interactively'
494 \(which includes being called as the binding of a key)
495 and input is currently coming from the keyboard (not a keyboard macro),
496 and Emacs is not running in batch mode (`noninteractive' is nil).
498 The only known proper use of `interactive-p' is in deciding whether to
499 display a helpful message, or how to display it. If you're thinking
500 of using it for any other purpose, it is quite likely that you're
501 making a mistake. Think: what do you want to do when the command is
502 called from a keyboard macro?
504 To test whether your function was called with `call-interactively',
505 either (i) add an extra optional argument and give it an `interactive'
506 spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
507 use `called-interactively-p'. */)
510 return interactive_p (1) ? Qt
: Qnil
;
514 DEFUN ("called-interactively-p", Fcalled_interactively_p
, Scalled_interactively_p
, 0, 1, 0,
515 doc
: /* Return t if the containing function was called by `call-interactively'.
516 If KIND is `interactive', then only return t if the call was made
517 interactively by the user, i.e. not in `noninteractive' mode nor
518 when `executing-kbd-macro'.
519 If KIND is `any', on the other hand, it will return t for any kind of
520 interactive call, including being called as the binding of a key, or
521 from a keyboard macro, or in `noninteractive' mode.
523 The only known proper use of `interactive' for KIND is in deciding
524 whether to display a helpful message, or how to display it. If you're
525 thinking of using it for any other purpose, it is quite likely that
526 you're making a mistake. Think: what do you want to do when the
527 command is called from a keyboard macro?
529 This function is meant for implementing advice and other
530 function-modifying features. Instead of using this, it is sometimes
531 cleaner to give your function an extra optional argument whose
532 `interactive' spec specifies non-nil unconditionally (\"p\" is a good
533 way to do this), or via (not (or executing-kbd-macro noninteractive)). */)
536 return ((INTERACTIVE
|| !EQ (kind
, intern ("interactive")))
537 && interactive_p (1)) ? Qt
: Qnil
;
541 /* Return 1 if function in which this appears was called using
544 EXCLUDE_SUBRS_P non-zero means always return 0 if the function
545 called is a built-in. */
548 interactive_p (int exclude_subrs_p
)
550 struct backtrace
*btp
;
553 btp
= backtrace_list
;
555 /* If this isn't a byte-compiled function, there may be a frame at
556 the top for Finteractive_p. If so, skip it. */
557 fun
= Findirect_function (*btp
->function
, Qnil
);
558 if (SUBRP (fun
) && (XSUBR (fun
) == &Sinteractive_p
559 || XSUBR (fun
) == &Scalled_interactively_p
))
562 /* If we're running an Emacs 18-style byte-compiled function, there
563 may be a frame for Fbytecode at the top level. In any version of
564 Emacs there can be Fbytecode frames for subexpressions evaluated
565 inside catch and condition-case. Skip past them.
567 If this isn't a byte-compiled function, then we may now be
568 looking at several frames for special forms. Skip past them. */
570 && (EQ (*btp
->function
, Qbytecode
)
571 || btp
->nargs
== UNEVALLED
))
574 /* `btp' now points at the frame of the innermost function that isn't
575 a special form, ignoring frames for Finteractive_p and/or
576 Fbytecode at the top. If this frame is for a built-in function
577 (such as load or eval-region) return nil. */
578 fun
= Findirect_function (*btp
->function
, Qnil
);
579 if (exclude_subrs_p
&& SUBRP (fun
))
582 /* `btp' points to the frame of a Lisp function that called interactive-p.
583 Return t if that function was called interactively. */
584 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
590 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
591 doc
: /* Define NAME as a function.
592 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
593 See also the function `interactive'.
594 usage: (defun NAME ARGLIST [DOCSTRING] BODY...) */)
597 register Lisp_Object fn_name
;
598 register Lisp_Object defn
;
600 fn_name
= Fcar (args
);
601 CHECK_SYMBOL (fn_name
);
602 defn
= Fcons (Qlambda
, Fcdr (args
));
603 if (!NILP (Vinternal_interpreter_environment
)) /* Mere optimization! */
604 defn
= Ffunction (Fcons (defn
, Qnil
));
605 if (!NILP (Vpurify_flag
))
606 defn
= Fpurecopy (defn
);
607 if (CONSP (XSYMBOL (fn_name
)->function
)
608 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
609 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
610 Ffset (fn_name
, defn
);
611 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
615 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
616 doc
: /* Define NAME as a macro.
617 The actual definition looks like
618 (macro lambda ARGLIST [DOCSTRING] [DECL] BODY...).
619 When the macro is called, as in (NAME ARGS...),
620 the function (lambda ARGLIST BODY...) is applied to
621 the list ARGS... as it appears in the expression,
622 and the result should be a form to be evaluated instead of the original.
624 DECL is a declaration, optional, which can specify how to indent
625 calls to this macro, how Edebug should handle it, and which argument
626 should be treated as documentation. It looks like this:
628 The elements can look like this:
630 Set NAME's `lisp-indent-function' property to INDENT.
633 Set NAME's `edebug-form-spec' property to DEBUG. (This is
634 equivalent to writing a `def-edebug-spec' for the macro.)
637 Set NAME's `doc-string-elt' property to ELT.
639 usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */)
642 register Lisp_Object fn_name
;
643 register Lisp_Object defn
;
644 Lisp_Object lambda_list
, doc
, tail
;
646 fn_name
= Fcar (args
);
647 CHECK_SYMBOL (fn_name
);
648 lambda_list
= Fcar (Fcdr (args
));
649 tail
= Fcdr (Fcdr (args
));
652 if (STRINGP (Fcar (tail
)))
658 if (CONSP (Fcar (tail
))
659 && EQ (Fcar (Fcar (tail
)), Qdeclare
))
661 if (!NILP (Vmacro_declaration_function
))
665 call2 (Vmacro_declaration_function
, fn_name
, Fcar (tail
));
673 tail
= Fcons (lambda_list
, tail
);
675 tail
= Fcons (lambda_list
, Fcons (doc
, tail
));
677 defn
= Fcons (Qlambda
, tail
);
678 if (!NILP (Vinternal_interpreter_environment
)) /* Mere optimization! */
679 defn
= Ffunction (Fcons (defn
, Qnil
));
680 defn
= Fcons (Qmacro
, defn
);
682 if (!NILP (Vpurify_flag
))
683 defn
= Fpurecopy (defn
);
684 if (CONSP (XSYMBOL (fn_name
)->function
)
685 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
686 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
687 Ffset (fn_name
, defn
);
688 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
693 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
694 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
695 Aliased variables always have the same value; setting one sets the other.
696 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
697 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
698 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
699 itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
700 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
701 The return value is BASE-VARIABLE. */)
702 (Lisp_Object new_alias
, Lisp_Object base_variable
, Lisp_Object docstring
)
704 struct Lisp_Symbol
*sym
;
706 CHECK_SYMBOL (new_alias
);
707 CHECK_SYMBOL (base_variable
);
709 sym
= XSYMBOL (new_alias
);
712 /* Not sure why, but why not? */
713 error ("Cannot make a constant an alias");
715 switch (sym
->redirect
)
717 case SYMBOL_FORWARDED
:
718 error ("Cannot make an internal variable an alias");
719 case SYMBOL_LOCALIZED
:
720 error ("Don't know how to make a localized variable an alias");
723 /* http://lists.gnu.org/archive/html/emacs-devel/2008-04/msg00834.html
724 If n_a is bound, but b_v is not, set the value of b_v to n_a,
725 so that old-code that affects n_a before the aliasing is setup
727 if (NILP (Fboundp (base_variable
)))
728 set_internal (base_variable
, find_symbol_value (new_alias
), Qnil
, 1);
731 struct specbinding
*p
;
733 for (p
= specpdl_ptr
; p
> specpdl
; )
734 if ((--p
)->func
== NULL
736 CONSP (p
->symbol
) ? XCAR (p
->symbol
) : p
->symbol
)))
737 error ("Don't know how to make a let-bound variable an alias");
740 sym
->declared_special
= 1;
741 XSYMBOL (base_variable
)->declared_special
= 1;
742 sym
->redirect
= SYMBOL_VARALIAS
;
743 SET_SYMBOL_ALIAS (sym
, XSYMBOL (base_variable
));
744 sym
->constant
= SYMBOL_CONSTANT_P (base_variable
);
745 LOADHIST_ATTACH (new_alias
);
746 /* Even if docstring is nil: remove old docstring. */
747 Fput (new_alias
, Qvariable_documentation
, docstring
);
749 return base_variable
;
753 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
754 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
755 You are not required to define a variable in order to use it,
756 but the definition can supply documentation and an initial value
757 in a way that tags can recognize.
759 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.
760 If SYMBOL is buffer-local, its default value is what is set;
761 buffer-local values are not affected.
762 INITVALUE and DOCSTRING are optional.
763 If DOCSTRING starts with *, this variable is identified as a user option.
764 This means that M-x set-variable recognizes it.
765 See also `user-variable-p'.
766 If INITVALUE is missing, SYMBOL's value is not set.
768 If SYMBOL has a local binding, then this form affects the local
769 binding. This is usually not what you want. Thus, if you need to
770 load a file defining variables, with this form or with `defconst' or
771 `defcustom', you should always load that file _outside_ any bindings
772 for these variables. \(`defconst' and `defcustom' behave similarly in
774 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
777 register Lisp_Object sym
, tem
, tail
;
781 if (!NILP (Fcdr (Fcdr (tail
))))
782 error ("Too many arguments");
784 tem
= Fdefault_boundp (sym
);
787 /* Do it before evaluating the initial value, for self-references. */
788 XSYMBOL (sym
)->declared_special
= 1;
790 if (SYMBOL_CONSTANT_P (sym
))
792 /* For upward compatibility, allow (defvar :foo (quote :foo)). */
793 Lisp_Object tem1
= Fcar (tail
);
795 && EQ (XCAR (tem1
), Qquote
)
796 && CONSP (XCDR (tem1
))
797 && EQ (XCAR (XCDR (tem1
)), sym
)))
798 error ("Constant symbol `%s' specified in defvar",
799 SDATA (SYMBOL_NAME (sym
)));
803 Fset_default (sym
, eval_sub (Fcar (tail
)));
805 { /* Check if there is really a global binding rather than just a let
806 binding that shadows the global unboundness of the var. */
807 volatile struct specbinding
*pdl
= specpdl_ptr
;
808 while (pdl
> specpdl
)
810 if (EQ ((--pdl
)->symbol
, sym
) && !pdl
->func
811 && EQ (pdl
->old_value
, Qunbound
))
813 message_with_string ("Warning: defvar ignored because %s is let-bound",
814 SYMBOL_NAME (sym
), 1);
823 if (!NILP (Vpurify_flag
))
824 tem
= Fpurecopy (tem
);
825 Fput (sym
, Qvariable_documentation
, tem
);
827 LOADHIST_ATTACH (sym
);
829 else if (!NILP (Vinternal_interpreter_environment
)
830 && !XSYMBOL (sym
)->declared_special
)
831 /* A simple (defvar foo) with lexical scoping does "nothing" except
832 declare that var to be dynamically scoped *locally* (i.e. within
833 the current file or let-block). */
834 Vinternal_interpreter_environment
=
835 Fcons (sym
, Vinternal_interpreter_environment
);
838 /* Simple (defvar <var>) should not count as a definition at all.
839 It could get in the way of other definitions, and unloading this
840 package could try to make the variable unbound. */
846 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
847 doc
: /* Define SYMBOL as a constant variable.
848 The intent is that neither programs nor users should ever change this value.
849 Always sets the value of SYMBOL to the result of evalling INITVALUE.
850 If SYMBOL is buffer-local, its default value is what is set;
851 buffer-local values are not affected.
852 DOCSTRING is optional.
854 If SYMBOL has a local binding, then this form sets the local binding's
855 value. However, you should normally not make local bindings for
856 variables defined with this form.
857 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
860 register Lisp_Object sym
, tem
;
863 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
864 error ("Too many arguments");
866 tem
= eval_sub (Fcar (Fcdr (args
)));
867 if (!NILP (Vpurify_flag
))
868 tem
= Fpurecopy (tem
);
869 Fset_default (sym
, tem
);
870 XSYMBOL (sym
)->declared_special
= 1;
871 tem
= Fcar (Fcdr (Fcdr (args
)));
874 if (!NILP (Vpurify_flag
))
875 tem
= Fpurecopy (tem
);
876 Fput (sym
, Qvariable_documentation
, tem
);
878 Fput (sym
, Qrisky_local_variable
, Qt
);
879 LOADHIST_ATTACH (sym
);
883 /* Error handler used in Fuser_variable_p. */
885 user_variable_p_eh (Lisp_Object ignore
)
891 lisp_indirect_variable (Lisp_Object sym
)
893 struct Lisp_Symbol
*s
= indirect_variable (XSYMBOL (sym
));
898 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
899 doc
: /* Return t if VARIABLE is intended to be set and modified by users.
900 \(The alternative is a variable used internally in a Lisp program.)
901 A variable is a user variable if
902 \(1) the first character of its documentation is `*', or
903 \(2) it is customizable (its property list contains a non-nil value
904 of `standard-value' or `custom-autoload'), or
905 \(3) it is an alias for another user variable.
906 Return nil if VARIABLE is an alias and there is a loop in the
907 chain of symbols. */)
908 (Lisp_Object variable
)
910 Lisp_Object documentation
;
912 if (!SYMBOLP (variable
))
915 /* If indirect and there's an alias loop, don't check anything else. */
916 if (XSYMBOL (variable
)->redirect
== SYMBOL_VARALIAS
917 && NILP (internal_condition_case_1 (lisp_indirect_variable
, variable
,
918 Qt
, user_variable_p_eh
)))
923 documentation
= Fget (variable
, Qvariable_documentation
);
924 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
926 if (STRINGP (documentation
)
927 && ((unsigned char) SREF (documentation
, 0) == '*'))
929 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
930 if (CONSP (documentation
)
931 && STRINGP (XCAR (documentation
))
932 && INTEGERP (XCDR (documentation
))
933 && XINT (XCDR (documentation
)) < 0)
935 /* Customizable? See `custom-variable-p'. */
936 if ((!NILP (Fget (variable
, intern ("standard-value"))))
937 || (!NILP (Fget (variable
, intern ("custom-autoload")))))
940 if (!(XSYMBOL (variable
)->redirect
== SYMBOL_VARALIAS
))
943 /* An indirect variable? Let's follow the chain. */
944 XSETSYMBOL (variable
, SYMBOL_ALIAS (XSYMBOL (variable
)));
948 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
949 doc
: /* Bind variables according to VARLIST then eval BODY.
950 The value of the last form in BODY is returned.
951 Each element of VARLIST is a symbol (which is bound to nil)
952 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
953 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
954 usage: (let* VARLIST BODY...) */)
957 Lisp_Object varlist
, var
, val
, elt
, lexenv
;
958 ptrdiff_t count
= SPECPDL_INDEX ();
959 struct gcpro gcpro1
, gcpro2
, gcpro3
;
961 GCPRO3 (args
, elt
, varlist
);
963 lexenv
= Vinternal_interpreter_environment
;
965 varlist
= Fcar (args
);
966 while (CONSP (varlist
))
970 elt
= XCAR (varlist
);
976 else if (! NILP (Fcdr (Fcdr (elt
))))
977 signal_error ("`let' bindings can have only one value-form", elt
);
981 val
= eval_sub (Fcar (Fcdr (elt
)));
984 if (!NILP (lexenv
) && SYMBOLP (var
)
985 && !XSYMBOL (var
)->declared_special
986 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
987 /* Lexically bind VAR by adding it to the interpreter's binding
991 = Fcons (Fcons (var
, val
), Vinternal_interpreter_environment
);
992 if (EQ (Vinternal_interpreter_environment
, lexenv
))
993 /* Save the old lexical environment on the specpdl stack,
994 but only for the first lexical binding, since we'll never
995 need to revert to one of the intermediate ones. */
996 specbind (Qinternal_interpreter_environment
, newenv
);
998 Vinternal_interpreter_environment
= newenv
;
1001 specbind (var
, val
);
1003 varlist
= XCDR (varlist
);
1006 val
= Fprogn (Fcdr (args
));
1007 return unbind_to (count
, val
);
1010 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
1011 doc
: /* Bind variables according to VARLIST then eval BODY.
1012 The value of the last form in BODY is returned.
1013 Each element of VARLIST is a symbol (which is bound to nil)
1014 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
1015 All the VALUEFORMs are evalled before any symbols are bound.
1016 usage: (let VARLIST BODY...) */)
1019 Lisp_Object
*temps
, tem
, lexenv
;
1020 register Lisp_Object elt
, varlist
;
1021 ptrdiff_t count
= SPECPDL_INDEX ();
1023 struct gcpro gcpro1
, gcpro2
;
1026 varlist
= Fcar (args
);
1028 /* Make space to hold the values to give the bound variables. */
1029 elt
= Flength (varlist
);
1030 SAFE_ALLOCA_LISP (temps
, XFASTINT (elt
));
1032 /* Compute the values and store them in `temps'. */
1034 GCPRO2 (args
, *temps
);
1037 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
1040 elt
= XCAR (varlist
);
1042 temps
[argnum
++] = Qnil
;
1043 else if (! NILP (Fcdr (Fcdr (elt
))))
1044 signal_error ("`let' bindings can have only one value-form", elt
);
1046 temps
[argnum
++] = eval_sub (Fcar (Fcdr (elt
)));
1047 gcpro2
.nvars
= argnum
;
1051 lexenv
= Vinternal_interpreter_environment
;
1053 varlist
= Fcar (args
);
1054 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
1058 elt
= XCAR (varlist
);
1059 var
= SYMBOLP (elt
) ? elt
: Fcar (elt
);
1060 tem
= temps
[argnum
++];
1062 if (!NILP (lexenv
) && SYMBOLP (var
)
1063 && !XSYMBOL (var
)->declared_special
1064 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
1065 /* Lexically bind VAR by adding it to the lexenv alist. */
1066 lexenv
= Fcons (Fcons (var
, tem
), lexenv
);
1068 /* Dynamically bind VAR. */
1069 specbind (var
, tem
);
1072 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
1073 /* Instantiate a new lexical environment. */
1074 specbind (Qinternal_interpreter_environment
, lexenv
);
1076 elt
= Fprogn (Fcdr (args
));
1078 return unbind_to (count
, elt
);
1081 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
1082 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
1083 The order of execution is thus TEST, BODY, TEST, BODY and so on
1084 until TEST returns nil.
1085 usage: (while TEST BODY...) */)
1088 Lisp_Object test
, body
;
1089 struct gcpro gcpro1
, gcpro2
;
1091 GCPRO2 (test
, body
);
1095 while (!NILP (eval_sub (test
)))
1105 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
1106 doc
: /* Return result of expanding macros at top level of FORM.
1107 If FORM is not a macro call, it is returned unchanged.
1108 Otherwise, the macro is expanded and the expansion is considered
1109 in place of FORM. When a non-macro-call results, it is returned.
1111 The second optional arg ENVIRONMENT specifies an environment of macro
1112 definitions to shadow the loaded ones for use in file byte-compilation. */)
1113 (Lisp_Object form
, Lisp_Object environment
)
1115 /* With cleanups from Hallvard Furuseth. */
1116 register Lisp_Object expander
, sym
, def
, tem
;
1120 /* Come back here each time we expand a macro call,
1121 in case it expands into another macro call. */
1124 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1125 def
= sym
= XCAR (form
);
1127 /* Trace symbols aliases to other symbols
1128 until we get a symbol that is not an alias. */
1129 while (SYMBOLP (def
))
1133 tem
= Fassq (sym
, environment
);
1136 def
= XSYMBOL (sym
)->function
;
1137 if (!EQ (def
, Qunbound
))
1142 /* Right now TEM is the result from SYM in ENVIRONMENT,
1143 and if TEM is nil then DEF is SYM's function definition. */
1146 /* SYM is not mentioned in ENVIRONMENT.
1147 Look at its function definition. */
1148 if (EQ (def
, Qunbound
) || !CONSP (def
))
1149 /* Not defined or definition not suitable. */
1151 if (EQ (XCAR (def
), Qautoload
))
1153 /* Autoloading function: will it be a macro when loaded? */
1154 tem
= Fnth (make_number (4), def
);
1155 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
1156 /* Yes, load it and try again. */
1158 struct gcpro gcpro1
;
1160 do_autoload (def
, sym
);
1167 else if (!EQ (XCAR (def
), Qmacro
))
1169 else expander
= XCDR (def
);
1173 expander
= XCDR (tem
);
1174 if (NILP (expander
))
1177 form
= apply1 (expander
, XCDR (form
));
1182 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1183 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1184 TAG is evalled to get the tag to use; it must not be nil.
1186 Then the BODY is executed.
1187 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
1188 If no throw happens, `catch' returns the value of the last BODY form.
1189 If a throw happens, it specifies the value to return from `catch'.
1190 usage: (catch TAG BODY...) */)
1193 register Lisp_Object tag
;
1194 struct gcpro gcpro1
;
1197 tag
= eval_sub (Fcar (args
));
1199 return internal_catch (tag
, Fprogn
, Fcdr (args
));
1202 /* Set up a catch, then call C function FUNC on argument ARG.
1203 FUNC should return a Lisp_Object.
1204 This is how catches are done from within C code. */
1207 internal_catch (Lisp_Object tag
, Lisp_Object (*func
) (Lisp_Object
), Lisp_Object arg
)
1209 /* This structure is made part of the chain `catchlist'. */
1212 /* Fill in the components of c, and put it on the list. */
1216 c
.backlist
= backtrace_list
;
1217 c
.handlerlist
= handlerlist
;
1218 c
.lisp_eval_depth
= lisp_eval_depth
;
1219 c
.pdlcount
= SPECPDL_INDEX ();
1220 c
.poll_suppress_count
= poll_suppress_count
;
1221 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1222 c
.gcpro
= gcprolist
;
1223 c
.byte_stack
= byte_stack_list
;
1227 if (! _setjmp (c
.jmp
))
1228 c
.val
= (*func
) (arg
);
1230 /* Throw works by a longjmp that comes right here. */
1235 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1236 jump to that CATCH, returning VALUE as the value of that catch.
1238 This is the guts Fthrow and Fsignal; they differ only in the way
1239 they choose the catch tag to throw to. A catch tag for a
1240 condition-case form has a TAG of Qnil.
1242 Before each catch is discarded, unbind all special bindings and
1243 execute all unwind-protect clauses made above that catch. Unwind
1244 the handler stack as we go, so that the proper handlers are in
1245 effect for each unwind-protect clause we run. At the end, restore
1246 some static info saved in CATCH, and longjmp to the location
1249 This is used for correct unwinding in Fthrow and Fsignal. */
1252 unwind_to_catch (struct catchtag
*catch, Lisp_Object value
)
1254 register int last_time
;
1256 /* Save the value in the tag. */
1259 /* Restore certain special C variables. */
1260 set_poll_suppress_count (catch->poll_suppress_count
);
1261 UNBLOCK_INPUT_TO (catch->interrupt_input_blocked
);
1262 handling_signal
= 0;
1267 last_time
= catchlist
== catch;
1269 /* Unwind the specpdl stack, and then restore the proper set of
1271 unbind_to (catchlist
->pdlcount
, Qnil
);
1272 handlerlist
= catchlist
->handlerlist
;
1273 catchlist
= catchlist
->next
;
1275 while (! last_time
);
1278 /* If x_catch_errors was done, turn it off now.
1279 (First we give unbind_to a chance to do that.) */
1280 #if 0 /* This would disable x_catch_errors after x_connection_closed.
1281 The catch must remain in effect during that delicate
1282 state. --lorentey */
1283 x_fully_uncatch_errors ();
1287 byte_stack_list
= catch->byte_stack
;
1288 gcprolist
= catch->gcpro
;
1290 gcpro_level
= gcprolist
? gcprolist
->level
+ 1 : 0;
1292 backtrace_list
= catch->backlist
;
1293 lisp_eval_depth
= catch->lisp_eval_depth
;
1295 _longjmp (catch->jmp
, 1);
1298 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1299 doc
: /* Throw to the catch for TAG and return VALUE from it.
1300 Both TAG and VALUE are evalled. */)
1301 (register Lisp_Object tag
, Lisp_Object value
)
1303 register struct catchtag
*c
;
1306 for (c
= catchlist
; c
; c
= c
->next
)
1308 if (EQ (c
->tag
, tag
))
1309 unwind_to_catch (c
, value
);
1311 xsignal2 (Qno_catch
, tag
, value
);
1315 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1316 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1317 If BODYFORM completes normally, its value is returned
1318 after executing the UNWINDFORMS.
1319 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1320 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1324 ptrdiff_t count
= SPECPDL_INDEX ();
1326 record_unwind_protect (Fprogn
, Fcdr (args
));
1327 val
= eval_sub (Fcar (args
));
1328 return unbind_to (count
, val
);
1331 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1332 doc
: /* Regain control when an error is signaled.
1333 Executes BODYFORM and returns its value if no error happens.
1334 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1335 where the BODY is made of Lisp expressions.
1337 A handler is applicable to an error
1338 if CONDITION-NAME is one of the error's condition names.
1339 If an error happens, the first applicable handler is run.
1341 The car of a handler may be a list of condition names instead of a
1342 single condition name; then it handles all of them. If the special
1343 condition name `debug' is present in this list, it allows another
1344 condition in the list to run the debugger if `debug-on-error' and the
1345 other usual mechanisms says it should (otherwise, `condition-case'
1346 suppresses the debugger).
1348 When a handler handles an error, control returns to the `condition-case'
1349 and it executes the handler's BODY...
1350 with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
1351 \(If VAR is nil, the handler can't access that information.)
1352 Then the value of the last BODY form is returned from the `condition-case'
1355 See also the function `signal' for more info.
1356 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1359 register Lisp_Object bodyform
, handlers
;
1360 volatile Lisp_Object var
;
1363 bodyform
= Fcar (Fcdr (args
));
1364 handlers
= Fcdr (Fcdr (args
));
1366 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1369 /* Like Fcondition_case, but the args are separate
1370 rather than passed in a list. Used by Fbyte_code. */
1373 internal_lisp_condition_case (volatile Lisp_Object var
, Lisp_Object bodyform
,
1374 Lisp_Object handlers
)
1382 for (val
= handlers
; CONSP (val
); val
= XCDR (val
))
1388 && (SYMBOLP (XCAR (tem
))
1389 || CONSP (XCAR (tem
))))))
1390 error ("Invalid condition handler: %s",
1391 SDATA (Fprin1_to_string (tem
, Qt
)));
1396 c
.backlist
= backtrace_list
;
1397 c
.handlerlist
= handlerlist
;
1398 c
.lisp_eval_depth
= lisp_eval_depth
;
1399 c
.pdlcount
= SPECPDL_INDEX ();
1400 c
.poll_suppress_count
= poll_suppress_count
;
1401 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1402 c
.gcpro
= gcprolist
;
1403 c
.byte_stack
= byte_stack_list
;
1404 if (_setjmp (c
.jmp
))
1407 specbind (h
.var
, c
.val
);
1408 val
= Fprogn (Fcdr (h
.chosen_clause
));
1410 /* Note that this just undoes the binding of h.var; whoever
1411 longjumped to us unwound the stack to c.pdlcount before
1413 unbind_to (c
.pdlcount
, Qnil
);
1420 h
.handler
= handlers
;
1421 h
.next
= handlerlist
;
1425 val
= eval_sub (bodyform
);
1427 handlerlist
= h
.next
;
1431 /* Call the function BFUN with no arguments, catching errors within it
1432 according to HANDLERS. If there is an error, call HFUN with
1433 one argument which is the data that describes the error:
1436 HANDLERS can be a list of conditions to catch.
1437 If HANDLERS is Qt, catch all errors.
1438 If HANDLERS is Qerror, catch all errors
1439 but allow the debugger to run if that is enabled. */
1442 internal_condition_case (Lisp_Object (*bfun
) (void), Lisp_Object handlers
,
1443 Lisp_Object (*hfun
) (Lisp_Object
))
1451 c
.backlist
= backtrace_list
;
1452 c
.handlerlist
= handlerlist
;
1453 c
.lisp_eval_depth
= lisp_eval_depth
;
1454 c
.pdlcount
= SPECPDL_INDEX ();
1455 c
.poll_suppress_count
= poll_suppress_count
;
1456 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1457 c
.gcpro
= gcprolist
;
1458 c
.byte_stack
= byte_stack_list
;
1459 if (_setjmp (c
.jmp
))
1461 return (*hfun
) (c
.val
);
1465 h
.handler
= handlers
;
1467 h
.next
= handlerlist
;
1473 handlerlist
= h
.next
;
1477 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1480 internal_condition_case_1 (Lisp_Object (*bfun
) (Lisp_Object
), Lisp_Object arg
,
1481 Lisp_Object handlers
, Lisp_Object (*hfun
) (Lisp_Object
))
1489 c
.backlist
= backtrace_list
;
1490 c
.handlerlist
= handlerlist
;
1491 c
.lisp_eval_depth
= lisp_eval_depth
;
1492 c
.pdlcount
= SPECPDL_INDEX ();
1493 c
.poll_suppress_count
= poll_suppress_count
;
1494 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1495 c
.gcpro
= gcprolist
;
1496 c
.byte_stack
= byte_stack_list
;
1497 if (_setjmp (c
.jmp
))
1499 return (*hfun
) (c
.val
);
1503 h
.handler
= handlers
;
1505 h
.next
= handlerlist
;
1509 val
= (*bfun
) (arg
);
1511 handlerlist
= h
.next
;
1515 /* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as
1519 internal_condition_case_2 (Lisp_Object (*bfun
) (Lisp_Object
, Lisp_Object
),
1522 Lisp_Object handlers
,
1523 Lisp_Object (*hfun
) (Lisp_Object
))
1531 c
.backlist
= backtrace_list
;
1532 c
.handlerlist
= handlerlist
;
1533 c
.lisp_eval_depth
= lisp_eval_depth
;
1534 c
.pdlcount
= SPECPDL_INDEX ();
1535 c
.poll_suppress_count
= poll_suppress_count
;
1536 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1537 c
.gcpro
= gcprolist
;
1538 c
.byte_stack
= byte_stack_list
;
1539 if (_setjmp (c
.jmp
))
1541 return (*hfun
) (c
.val
);
1545 h
.handler
= handlers
;
1547 h
.next
= handlerlist
;
1551 val
= (*bfun
) (arg1
, arg2
);
1553 handlerlist
= h
.next
;
1557 /* Like internal_condition_case but call BFUN with NARGS as first,
1558 and ARGS as second argument. */
1561 internal_condition_case_n (Lisp_Object (*bfun
) (ptrdiff_t, Lisp_Object
*),
1564 Lisp_Object handlers
,
1565 Lisp_Object (*hfun
) (Lisp_Object
))
1573 c
.backlist
= backtrace_list
;
1574 c
.handlerlist
= handlerlist
;
1575 c
.lisp_eval_depth
= lisp_eval_depth
;
1576 c
.pdlcount
= SPECPDL_INDEX ();
1577 c
.poll_suppress_count
= poll_suppress_count
;
1578 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1579 c
.gcpro
= gcprolist
;
1580 c
.byte_stack
= byte_stack_list
;
1581 if (_setjmp (c
.jmp
))
1583 return (*hfun
) (c
.val
);
1587 h
.handler
= handlers
;
1589 h
.next
= handlerlist
;
1593 val
= (*bfun
) (nargs
, args
);
1595 handlerlist
= h
.next
;
1600 static Lisp_Object
find_handler_clause (Lisp_Object
, Lisp_Object
);
1601 static int maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
,
1605 process_quit_flag (void)
1607 Lisp_Object flag
= Vquit_flag
;
1609 if (EQ (flag
, Qkill_emacs
))
1611 if (EQ (Vthrow_on_input
, flag
))
1612 Fthrow (Vthrow_on_input
, Qt
);
1613 Fsignal (Qquit
, Qnil
);
1616 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1617 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1618 This function does not return.
1620 An error symbol is a symbol with an `error-conditions' property
1621 that is a list of condition names.
1622 A handler for any of those names will get to handle this signal.
1623 The symbol `error' should normally be one of them.
1625 DATA should be a list. Its elements are printed as part of the error message.
1626 See Info anchor `(elisp)Definition of signal' for some details on how this
1627 error message is constructed.
1628 If the signal is handled, DATA is made available to the handler.
1629 See also the function `condition-case'. */)
1630 (Lisp_Object error_symbol
, Lisp_Object data
)
1632 /* When memory is full, ERROR-SYMBOL is nil,
1633 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1634 That is a special case--don't do this in other situations. */
1635 Lisp_Object conditions
;
1637 Lisp_Object real_error_symbol
1638 = (NILP (error_symbol
) ? Fcar (data
) : error_symbol
);
1639 register Lisp_Object clause
= Qnil
;
1641 struct backtrace
*bp
;
1643 immediate_quit
= handling_signal
= 0;
1645 if (gc_in_progress
|| waiting_for_input
)
1648 #if 0 /* rms: I don't know why this was here,
1649 but it is surely wrong for an error that is handled. */
1650 #ifdef HAVE_WINDOW_SYSTEM
1651 if (display_hourglass_p
)
1652 cancel_hourglass ();
1656 /* This hook is used by edebug. */
1657 if (! NILP (Vsignal_hook_function
)
1658 && ! NILP (error_symbol
))
1660 /* Edebug takes care of restoring these variables when it exits. */
1661 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1662 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1664 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1665 max_specpdl_size
= SPECPDL_INDEX () + 40;
1667 call2 (Vsignal_hook_function
, error_symbol
, data
);
1670 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1672 /* Remember from where signal was called. Skip over the frame for
1673 `signal' itself. If a frame for `error' follows, skip that,
1674 too. Don't do this when ERROR_SYMBOL is nil, because that
1675 is a memory-full error. */
1676 Vsignaling_function
= Qnil
;
1677 if (backtrace_list
&& !NILP (error_symbol
))
1679 bp
= backtrace_list
->next
;
1680 if (bp
&& bp
->function
&& EQ (*bp
->function
, Qerror
))
1682 if (bp
&& bp
->function
)
1683 Vsignaling_function
= *bp
->function
;
1686 for (h
= handlerlist
; h
; h
= h
->next
)
1688 clause
= find_handler_clause (h
->handler
, conditions
);
1693 if (/* Don't run the debugger for a memory-full error.
1694 (There is no room in memory to do that!) */
1695 !NILP (error_symbol
)
1696 && (!NILP (Vdebug_on_signal
)
1697 /* If no handler is present now, try to run the debugger. */
1699 /* A `debug' symbol in the handler list disables the normal
1700 suppression of the debugger. */
1701 || (CONSP (clause
) && CONSP (XCAR (clause
))
1702 && !NILP (Fmemq (Qdebug
, XCAR (clause
))))
1703 /* Special handler that means "print a message and run debugger
1705 || EQ (h
->handler
, Qerror
)))
1708 = maybe_call_debugger (conditions
, error_symbol
, data
);
1709 /* We can't return values to code which signaled an error, but we
1710 can continue code which has signaled a quit. */
1711 if (debugger_called
&& EQ (real_error_symbol
, Qquit
))
1717 Lisp_Object unwind_data
1718 = (NILP (error_symbol
) ? data
: Fcons (error_symbol
, data
));
1720 h
->chosen_clause
= clause
;
1721 unwind_to_catch (h
->tag
, unwind_data
);
1726 Fthrow (Qtop_level
, Qt
);
1729 if (! NILP (error_symbol
))
1730 data
= Fcons (error_symbol
, data
);
1732 string
= Ferror_message_string (data
);
1733 fatal ("%s", SDATA (string
));
1736 /* Internal version of Fsignal that never returns.
1737 Used for anything but Qquit (which can return from Fsignal). */
1740 xsignal (Lisp_Object error_symbol
, Lisp_Object data
)
1742 Fsignal (error_symbol
, data
);
1746 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1749 xsignal0 (Lisp_Object error_symbol
)
1751 xsignal (error_symbol
, Qnil
);
1755 xsignal1 (Lisp_Object error_symbol
, Lisp_Object arg
)
1757 xsignal (error_symbol
, list1 (arg
));
1761 xsignal2 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
)
1763 xsignal (error_symbol
, list2 (arg1
, arg2
));
1767 xsignal3 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
1769 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1772 /* Signal `error' with message S, and additional arg ARG.
1773 If ARG is not a genuine list, make it a one-element list. */
1776 signal_error (const char *s
, Lisp_Object arg
)
1778 Lisp_Object tortoise
, hare
;
1780 hare
= tortoise
= arg
;
1781 while (CONSP (hare
))
1788 tortoise
= XCDR (tortoise
);
1790 if (EQ (hare
, tortoise
))
1795 arg
= Fcons (arg
, Qnil
); /* Make it a list. */
1797 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1801 /* Return nonzero if LIST is a non-nil atom or
1802 a list containing one of CONDITIONS. */
1805 wants_debugger (Lisp_Object list
, Lisp_Object conditions
)
1812 while (CONSP (conditions
))
1814 Lisp_Object
this, tail
;
1815 this = XCAR (conditions
);
1816 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1817 if (EQ (XCAR (tail
), this))
1819 conditions
= XCDR (conditions
);
1824 /* Return 1 if an error with condition-symbols CONDITIONS,
1825 and described by SIGNAL-DATA, should skip the debugger
1826 according to debugger-ignored-errors. */
1829 skip_debugger (Lisp_Object conditions
, Lisp_Object data
)
1832 int first_string
= 1;
1833 Lisp_Object error_message
;
1835 error_message
= Qnil
;
1836 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1838 if (STRINGP (XCAR (tail
)))
1842 error_message
= Ferror_message_string (data
);
1846 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1851 Lisp_Object contail
;
1853 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1854 if (EQ (XCAR (tail
), XCAR (contail
)))
1862 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1863 SIG and DATA describe the signal. There are two ways to pass them:
1864 = SIG is the error symbol, and DATA is the rest of the data.
1865 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1866 This is for memory-full errors only. */
1868 maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
, Lisp_Object data
)
1870 Lisp_Object combined_data
;
1872 combined_data
= Fcons (sig
, data
);
1875 /* Don't try to run the debugger with interrupts blocked.
1876 The editing loop would return anyway. */
1878 /* Does user want to enter debugger for this kind of error? */
1881 : wants_debugger (Vdebug_on_error
, conditions
))
1882 && ! skip_debugger (conditions
, combined_data
)
1883 /* RMS: What's this for? */
1884 && when_entered_debugger
< num_nonmacro_input_events
)
1886 call_debugger (Fcons (Qerror
, Fcons (combined_data
, Qnil
)));
1894 find_handler_clause (Lisp_Object handlers
, Lisp_Object conditions
)
1896 register Lisp_Object h
;
1898 /* t is used by handlers for all conditions, set up by C code. */
1899 if (EQ (handlers
, Qt
))
1902 /* error is used similarly, but means print an error message
1903 and run the debugger if that is enabled. */
1904 if (EQ (handlers
, Qerror
))
1907 for (h
= handlers
; CONSP (h
); h
= XCDR (h
))
1909 Lisp_Object handler
= XCAR (h
);
1910 Lisp_Object condit
, tem
;
1912 if (!CONSP (handler
))
1914 condit
= XCAR (handler
);
1915 /* Handle a single condition name in handler HANDLER. */
1916 if (SYMBOLP (condit
))
1918 tem
= Fmemq (Fcar (handler
), conditions
);
1922 /* Handle a list of condition names in handler HANDLER. */
1923 else if (CONSP (condit
))
1926 for (tail
= condit
; CONSP (tail
); tail
= XCDR (tail
))
1928 tem
= Fmemq (XCAR (tail
), conditions
);
1939 /* Dump an error message; called like vprintf. */
1941 verror (const char *m
, va_list ap
)
1944 ptrdiff_t size
= sizeof buf
;
1945 ptrdiff_t size_max
= STRING_BYTES_BOUND
+ 1;
1950 used
= evxprintf (&buffer
, &size
, buf
, size_max
, m
, ap
);
1951 string
= make_string (buffer
, used
);
1955 xsignal1 (Qerror
, string
);
1959 /* Dump an error message; called like printf. */
1963 error (const char *m
, ...)
1971 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
1972 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
1973 This means it contains a description for how to read arguments to give it.
1974 The value is nil for an invalid function or a symbol with no function
1977 Interactively callable functions include strings and vectors (treated
1978 as keyboard macros), lambda-expressions that contain a top-level call
1979 to `interactive', autoload definitions made by `autoload' with non-nil
1980 fourth argument, and some of the built-in functions of Lisp.
1982 Also, a symbol satisfies `commandp' if its function definition does so.
1984 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
1985 then strings and vectors are not accepted. */)
1986 (Lisp_Object function
, Lisp_Object for_call_interactively
)
1988 register Lisp_Object fun
;
1989 register Lisp_Object funcar
;
1990 Lisp_Object if_prop
= Qnil
;
1994 fun
= indirect_function (fun
); /* Check cycles. */
1995 if (NILP (fun
) || EQ (fun
, Qunbound
))
1998 /* Check an `interactive-form' property if present, analogous to the
1999 function-documentation property. */
2001 while (SYMBOLP (fun
))
2003 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
2006 fun
= Fsymbol_function (fun
);
2009 /* Emacs primitives are interactive if their DEFUN specifies an
2010 interactive spec. */
2012 return XSUBR (fun
)->intspec
? Qt
: if_prop
;
2014 /* Bytecode objects are interactive if they are long enough to
2015 have an element whose index is COMPILED_INTERACTIVE, which is
2016 where the interactive spec is stored. */
2017 else if (COMPILEDP (fun
))
2018 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
2021 /* Strings and vectors are keyboard macros. */
2022 if (STRINGP (fun
) || VECTORP (fun
))
2023 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
2025 /* Lists may represent commands. */
2028 funcar
= XCAR (fun
);
2029 if (EQ (funcar
, Qclosure
))
2030 return (!NILP (Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
)))))
2032 else if (EQ (funcar
, Qlambda
))
2033 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
2034 else if (EQ (funcar
, Qautoload
))
2035 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
2040 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
2041 doc
: /* Define FUNCTION to autoload from FILE.
2042 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
2043 Third arg DOCSTRING is documentation for the function.
2044 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
2045 Fifth arg TYPE indicates the type of the object:
2046 nil or omitted says FUNCTION is a function,
2047 `keymap' says FUNCTION is really a keymap, and
2048 `macro' or t says FUNCTION is really a macro.
2049 Third through fifth args give info about the real definition.
2050 They default to nil.
2051 If FUNCTION is already defined other than as an autoload,
2052 this does nothing and returns nil. */)
2053 (Lisp_Object function
, Lisp_Object file
, Lisp_Object docstring
, Lisp_Object interactive
, Lisp_Object type
)
2055 CHECK_SYMBOL (function
);
2056 CHECK_STRING (file
);
2058 /* If function is defined and not as an autoload, don't override. */
2059 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
2060 && !(CONSP (XSYMBOL (function
)->function
)
2061 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
2064 if (NILP (Vpurify_flag
))
2065 /* Only add entries after dumping, because the ones before are
2066 not useful and else we get loads of them from the loaddefs.el. */
2067 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
2069 /* We don't want the docstring in purespace (instead,
2070 Snarf-documentation should (hopefully) overwrite it).
2071 We used to use 0 here, but that leads to accidental sharing in
2072 purecopy's hash-consing, so we use a (hopefully) unique integer
2074 docstring
= make_number (XPNTR (function
));
2075 return Ffset (function
,
2076 Fpurecopy (list5 (Qautoload
, file
, docstring
,
2077 interactive
, type
)));
2081 un_autoload (Lisp_Object oldqueue
)
2083 register Lisp_Object queue
, first
, second
;
2085 /* Queue to unwind is current value of Vautoload_queue.
2086 oldqueue is the shadowed value to leave in Vautoload_queue. */
2087 queue
= Vautoload_queue
;
2088 Vautoload_queue
= oldqueue
;
2089 while (CONSP (queue
))
2091 first
= XCAR (queue
);
2092 second
= Fcdr (first
);
2093 first
= Fcar (first
);
2094 if (EQ (first
, make_number (0)))
2097 Ffset (first
, second
);
2098 queue
= XCDR (queue
);
2103 /* Load an autoloaded function.
2104 FUNNAME is the symbol which is the function's name.
2105 FUNDEF is the autoload definition (a list). */
2108 do_autoload (Lisp_Object fundef
, Lisp_Object funname
)
2110 ptrdiff_t count
= SPECPDL_INDEX ();
2112 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2114 /* This is to make sure that loadup.el gives a clear picture
2115 of what files are preloaded and when. */
2116 if (! NILP (Vpurify_flag
))
2117 error ("Attempt to autoload %s while preparing to dump",
2118 SDATA (SYMBOL_NAME (funname
)));
2121 CHECK_SYMBOL (funname
);
2122 GCPRO3 (fun
, funname
, fundef
);
2124 /* Preserve the match data. */
2125 record_unwind_save_match_data ();
2127 /* If autoloading gets an error (which includes the error of failing
2128 to define the function being called), we use Vautoload_queue
2129 to undo function definitions and `provide' calls made by
2130 the function. We do this in the specific case of autoloading
2131 because autoloading is not an explicit request "load this file",
2132 but rather a request to "call this function".
2134 The value saved here is to be restored into Vautoload_queue. */
2135 record_unwind_protect (un_autoload
, Vautoload_queue
);
2136 Vautoload_queue
= Qt
;
2137 Fload (Fcar (Fcdr (fundef
)), Qnil
, Qt
, Qnil
, Qt
);
2139 /* Once loading finishes, don't undo it. */
2140 Vautoload_queue
= Qt
;
2141 unbind_to (count
, Qnil
);
2143 fun
= Findirect_function (fun
, Qnil
);
2145 if (!NILP (Fequal (fun
, fundef
)))
2146 error ("Autoloading failed to define function %s",
2147 SDATA (SYMBOL_NAME (funname
)));
2152 DEFUN ("eval", Feval
, Seval
, 1, 2, 0,
2153 doc
: /* Evaluate FORM and return its value.
2154 If LEXICAL is t, evaluate using lexical scoping. */)
2155 (Lisp_Object form
, Lisp_Object lexical
)
2157 ptrdiff_t count
= SPECPDL_INDEX ();
2158 specbind (Qinternal_interpreter_environment
,
2159 NILP (lexical
) ? Qnil
: Fcons (Qt
, Qnil
));
2160 return unbind_to (count
, eval_sub (form
));
2163 /* Eval a sub-expression of the current expression (i.e. in the same
2166 eval_sub (Lisp_Object form
)
2168 Lisp_Object fun
, val
, original_fun
, original_args
;
2170 struct backtrace backtrace
;
2171 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2173 if (handling_signal
)
2178 /* Look up its binding in the lexical environment.
2179 We do not pay attention to the declared_special flag here, since we
2180 already did that when let-binding the variable. */
2181 Lisp_Object lex_binding
2182 = !NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
2183 ? Fassq (form
, Vinternal_interpreter_environment
)
2185 if (CONSP (lex_binding
))
2186 return XCDR (lex_binding
);
2188 return Fsymbol_value (form
);
2195 if ((consing_since_gc
> gc_cons_threshold
2196 && consing_since_gc
> gc_relative_threshold
)
2198 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2201 Fgarbage_collect ();
2205 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2207 if (max_lisp_eval_depth
< 100)
2208 max_lisp_eval_depth
= 100;
2209 if (lisp_eval_depth
> max_lisp_eval_depth
)
2210 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2213 original_fun
= Fcar (form
);
2214 original_args
= Fcdr (form
);
2216 backtrace
.next
= backtrace_list
;
2217 backtrace_list
= &backtrace
;
2218 backtrace
.function
= &original_fun
; /* This also protects them from gc. */
2219 backtrace
.args
= &original_args
;
2220 backtrace
.nargs
= UNEVALLED
;
2221 backtrace
.debug_on_exit
= 0;
2223 if (debug_on_next_call
)
2224 do_debug_on_call (Qt
);
2226 /* At this point, only original_fun and original_args
2227 have values that will be used below. */
2230 /* Optimize for no indirection. */
2232 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2233 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2234 fun
= indirect_function (fun
);
2238 Lisp_Object numargs
;
2239 Lisp_Object argvals
[8];
2240 Lisp_Object args_left
;
2241 register int i
, maxargs
;
2243 args_left
= original_args
;
2244 numargs
= Flength (args_left
);
2248 if (XINT (numargs
) < XSUBR (fun
)->min_args
2249 || (XSUBR (fun
)->max_args
>= 0
2250 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2251 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2253 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2254 val
= (XSUBR (fun
)->function
.aUNEVALLED
) (args_left
);
2255 else if (XSUBR (fun
)->max_args
== MANY
)
2257 /* Pass a vector of evaluated arguments. */
2259 ptrdiff_t argnum
= 0;
2262 SAFE_ALLOCA_LISP (vals
, XINT (numargs
));
2264 GCPRO3 (args_left
, fun
, fun
);
2268 while (!NILP (args_left
))
2270 vals
[argnum
++] = eval_sub (Fcar (args_left
));
2271 args_left
= Fcdr (args_left
);
2272 gcpro3
.nvars
= argnum
;
2275 backtrace
.args
= vals
;
2276 backtrace
.nargs
= XINT (numargs
);
2278 val
= (XSUBR (fun
)->function
.aMANY
) (XINT (numargs
), vals
);
2284 GCPRO3 (args_left
, fun
, fun
);
2285 gcpro3
.var
= argvals
;
2288 maxargs
= XSUBR (fun
)->max_args
;
2289 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
2291 argvals
[i
] = eval_sub (Fcar (args_left
));
2297 backtrace
.args
= argvals
;
2298 backtrace
.nargs
= XINT (numargs
);
2303 val
= (XSUBR (fun
)->function
.a0 ());
2306 val
= (XSUBR (fun
)->function
.a1 (argvals
[0]));
2309 val
= (XSUBR (fun
)->function
.a2 (argvals
[0], argvals
[1]));
2312 val
= (XSUBR (fun
)->function
.a3
2313 (argvals
[0], argvals
[1], argvals
[2]));
2316 val
= (XSUBR (fun
)->function
.a4
2317 (argvals
[0], argvals
[1], argvals
[2], argvals
[3]));
2320 val
= (XSUBR (fun
)->function
.a5
2321 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2325 val
= (XSUBR (fun
)->function
.a6
2326 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2327 argvals
[4], argvals
[5]));
2330 val
= (XSUBR (fun
)->function
.a7
2331 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2332 argvals
[4], argvals
[5], argvals
[6]));
2336 val
= (XSUBR (fun
)->function
.a8
2337 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2338 argvals
[4], argvals
[5], argvals
[6], argvals
[7]));
2342 /* Someone has created a subr that takes more arguments than
2343 is supported by this code. We need to either rewrite the
2344 subr to use a different argument protocol, or add more
2345 cases to this switch. */
2350 else if (COMPILEDP (fun
))
2351 val
= apply_lambda (fun
, original_args
);
2354 if (EQ (fun
, Qunbound
))
2355 xsignal1 (Qvoid_function
, original_fun
);
2357 xsignal1 (Qinvalid_function
, original_fun
);
2358 funcar
= XCAR (fun
);
2359 if (!SYMBOLP (funcar
))
2360 xsignal1 (Qinvalid_function
, original_fun
);
2361 if (EQ (funcar
, Qautoload
))
2363 do_autoload (fun
, original_fun
);
2366 if (EQ (funcar
, Qmacro
))
2367 val
= eval_sub (apply1 (Fcdr (fun
), original_args
));
2368 else if (EQ (funcar
, Qlambda
)
2369 || EQ (funcar
, Qclosure
))
2370 val
= apply_lambda (fun
, original_args
);
2372 xsignal1 (Qinvalid_function
, original_fun
);
2377 if (backtrace
.debug_on_exit
)
2378 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2379 backtrace_list
= backtrace
.next
;
2384 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
2385 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2386 Then return the value FUNCTION returns.
2387 Thus, (apply '+ 1 2 '(3 4)) returns 10.
2388 usage: (apply FUNCTION &rest ARGUMENTS) */)
2389 (ptrdiff_t nargs
, Lisp_Object
*args
)
2393 register Lisp_Object spread_arg
;
2394 register Lisp_Object
*funcall_args
;
2395 Lisp_Object fun
, retval
;
2396 struct gcpro gcpro1
;
2401 spread_arg
= args
[nargs
- 1];
2402 CHECK_LIST (spread_arg
);
2404 numargs
= XINT (Flength (spread_arg
));
2407 return Ffuncall (nargs
- 1, args
);
2408 else if (numargs
== 1)
2410 args
[nargs
- 1] = XCAR (spread_arg
);
2411 return Ffuncall (nargs
, args
);
2414 numargs
+= nargs
- 2;
2416 /* Optimize for no indirection. */
2417 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2418 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2419 fun
= indirect_function (fun
);
2420 if (EQ (fun
, Qunbound
))
2422 /* Let funcall get the error. */
2429 if (numargs
< XSUBR (fun
)->min_args
2430 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2431 goto funcall
; /* Let funcall get the error. */
2432 else if (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
> numargs
)
2434 /* Avoid making funcall cons up a yet another new vector of arguments
2435 by explicitly supplying nil's for optional values. */
2436 SAFE_ALLOCA_LISP (funcall_args
, 1 + XSUBR (fun
)->max_args
);
2437 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2438 funcall_args
[++i
] = Qnil
;
2439 GCPRO1 (*funcall_args
);
2440 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2444 /* We add 1 to numargs because funcall_args includes the
2445 function itself as well as its arguments. */
2448 SAFE_ALLOCA_LISP (funcall_args
, 1 + numargs
);
2449 GCPRO1 (*funcall_args
);
2450 gcpro1
.nvars
= 1 + numargs
;
2453 memcpy (funcall_args
, args
, nargs
* sizeof (Lisp_Object
));
2454 /* Spread the last arg we got. Its first element goes in
2455 the slot that it used to occupy, hence this value of I. */
2457 while (!NILP (spread_arg
))
2459 funcall_args
[i
++] = XCAR (spread_arg
);
2460 spread_arg
= XCDR (spread_arg
);
2463 /* By convention, the caller needs to gcpro Ffuncall's args. */
2464 retval
= Ffuncall (gcpro1
.nvars
, funcall_args
);
2471 /* Run hook variables in various ways. */
2474 funcall_nil (ptrdiff_t nargs
, Lisp_Object
*args
)
2476 Ffuncall (nargs
, args
);
2480 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2481 doc
: /* Run each hook in HOOKS.
2482 Each argument should be a symbol, a hook variable.
2483 These symbols are processed in the order specified.
2484 If a hook symbol has a non-nil value, that value may be a function
2485 or a list of functions to be called to run the hook.
2486 If the value is a function, it is called with no arguments.
2487 If it is a list, the elements are called, in order, with no arguments.
2489 Major modes should not use this function directly to run their mode
2490 hook; they should use `run-mode-hooks' instead.
2492 Do not use `make-local-variable' to make a hook variable buffer-local.
2493 Instead, use `add-hook' and specify t for the LOCAL argument.
2494 usage: (run-hooks &rest HOOKS) */)
2495 (ptrdiff_t nargs
, Lisp_Object
*args
)
2497 Lisp_Object hook
[1];
2500 for (i
= 0; i
< nargs
; i
++)
2503 run_hook_with_args (1, hook
, funcall_nil
);
2509 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2510 Srun_hook_with_args
, 1, MANY
, 0,
2511 doc
: /* Run HOOK with the specified arguments ARGS.
2512 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2513 value, that value may be a function or a list of functions to be
2514 called to run the hook. If the value is a function, it is called with
2515 the given arguments and its return value is returned. If it is a list
2516 of functions, those functions are called, in order,
2517 with the given arguments ARGS.
2518 It is best not to depend on the value returned by `run-hook-with-args',
2521 Do not use `make-local-variable' to make a hook variable buffer-local.
2522 Instead, use `add-hook' and specify t for the LOCAL argument.
2523 usage: (run-hook-with-args HOOK &rest ARGS) */)
2524 (ptrdiff_t nargs
, Lisp_Object
*args
)
2526 return run_hook_with_args (nargs
, args
, funcall_nil
);
2529 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2530 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2531 doc
: /* Run HOOK with the specified arguments ARGS.
2532 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2533 value, that value may be a function or a list of functions to be
2534 called to run the hook. If the value is a function, it is called with
2535 the given arguments and its return value is returned.
2536 If it is a list of functions, those functions are called, in order,
2537 with the given arguments ARGS, until one of them
2538 returns a non-nil value. Then we return that value.
2539 However, if they all return nil, we return nil.
2541 Do not use `make-local-variable' to make a hook variable buffer-local.
2542 Instead, use `add-hook' and specify t for the LOCAL argument.
2543 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2544 (ptrdiff_t nargs
, Lisp_Object
*args
)
2546 return run_hook_with_args (nargs
, args
, Ffuncall
);
2550 funcall_not (ptrdiff_t nargs
, Lisp_Object
*args
)
2552 return NILP (Ffuncall (nargs
, args
)) ? Qt
: Qnil
;
2555 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2556 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2557 doc
: /* Run HOOK with the specified arguments ARGS.
2558 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2559 value, that value may be a function or a list of functions to be
2560 called to run the hook. If the value is a function, it is called with
2561 the given arguments and its return value is returned.
2562 If it is a list of functions, those functions are called, in order,
2563 with the given arguments ARGS, until one of them returns nil.
2564 Then we return nil. However, if they all return non-nil, we return non-nil.
2566 Do not use `make-local-variable' to make a hook variable buffer-local.
2567 Instead, use `add-hook' and specify t for the LOCAL argument.
2568 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2569 (ptrdiff_t nargs
, Lisp_Object
*args
)
2571 return NILP (run_hook_with_args (nargs
, args
, funcall_not
)) ? Qt
: Qnil
;
2575 run_hook_wrapped_funcall (ptrdiff_t nargs
, Lisp_Object
*args
)
2577 Lisp_Object tmp
= args
[0], ret
;
2580 ret
= Ffuncall (nargs
, args
);
2586 DEFUN ("run-hook-wrapped", Frun_hook_wrapped
, Srun_hook_wrapped
, 2, MANY
, 0,
2587 doc
: /* Run HOOK, passing each function through WRAP-FUNCTION.
2588 I.e. instead of calling each function FUN directly with arguments ARGS,
2589 it calls WRAP-FUNCTION with arguments FUN and ARGS.
2590 As soon as a call to WRAP-FUNCTION returns non-nil, `run-hook-wrapped'
2591 aborts and returns that value.
2592 usage: (run-hook-wrapped HOOK WRAP-FUNCTION &rest ARGS) */)
2593 (ptrdiff_t nargs
, Lisp_Object
*args
)
2595 return run_hook_with_args (nargs
, args
, run_hook_wrapped_funcall
);
2598 /* ARGS[0] should be a hook symbol.
2599 Call each of the functions in the hook value, passing each of them
2600 as arguments all the rest of ARGS (all NARGS - 1 elements).
2601 FUNCALL specifies how to call each function on the hook.
2602 The caller (or its caller, etc) must gcpro all of ARGS,
2603 except that it isn't necessary to gcpro ARGS[0]. */
2606 run_hook_with_args (ptrdiff_t nargs
, Lisp_Object
*args
,
2607 Lisp_Object (*funcall
) (ptrdiff_t nargs
, Lisp_Object
*args
))
2609 Lisp_Object sym
, val
, ret
= Qnil
;
2610 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2612 /* If we are dying or still initializing,
2613 don't do anything--it would probably crash if we tried. */
2614 if (NILP (Vrun_hooks
))
2618 val
= find_symbol_value (sym
);
2620 if (EQ (val
, Qunbound
) || NILP (val
))
2622 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2625 return funcall (nargs
, args
);
2629 Lisp_Object global_vals
= Qnil
;
2630 GCPRO3 (sym
, val
, global_vals
);
2633 CONSP (val
) && NILP (ret
);
2636 if (EQ (XCAR (val
), Qt
))
2638 /* t indicates this hook has a local binding;
2639 it means to run the global binding too. */
2640 global_vals
= Fdefault_value (sym
);
2641 if (NILP (global_vals
)) continue;
2643 if (!CONSP (global_vals
) || EQ (XCAR (global_vals
), Qlambda
))
2645 args
[0] = global_vals
;
2646 ret
= funcall (nargs
, args
);
2651 CONSP (global_vals
) && NILP (ret
);
2652 global_vals
= XCDR (global_vals
))
2654 args
[0] = XCAR (global_vals
);
2655 /* In a global value, t should not occur. If it does, we
2656 must ignore it to avoid an endless loop. */
2657 if (!EQ (args
[0], Qt
))
2658 ret
= funcall (nargs
, args
);
2664 args
[0] = XCAR (val
);
2665 ret
= funcall (nargs
, args
);
2674 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2677 run_hook_with_args_2 (Lisp_Object hook
, Lisp_Object arg1
, Lisp_Object arg2
)
2679 Lisp_Object temp
[3];
2684 Frun_hook_with_args (3, temp
);
2687 /* Apply fn to arg. */
2689 apply1 (Lisp_Object fn
, Lisp_Object arg
)
2691 struct gcpro gcpro1
;
2695 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2698 Lisp_Object args
[2];
2702 RETURN_UNGCPRO (Fapply (2, args
));
2706 /* Call function fn on no arguments. */
2708 call0 (Lisp_Object fn
)
2710 struct gcpro gcpro1
;
2713 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2716 /* Call function fn with 1 argument arg1. */
2719 call1 (Lisp_Object fn
, Lisp_Object arg1
)
2721 struct gcpro gcpro1
;
2722 Lisp_Object args
[2];
2728 RETURN_UNGCPRO (Ffuncall (2, args
));
2731 /* Call function fn with 2 arguments arg1, arg2. */
2734 call2 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
)
2736 struct gcpro gcpro1
;
2737 Lisp_Object args
[3];
2743 RETURN_UNGCPRO (Ffuncall (3, args
));
2746 /* Call function fn with 3 arguments arg1, arg2, arg3. */
2749 call3 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2751 struct gcpro gcpro1
;
2752 Lisp_Object args
[4];
2759 RETURN_UNGCPRO (Ffuncall (4, args
));
2762 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
2765 call4 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2768 struct gcpro gcpro1
;
2769 Lisp_Object args
[5];
2777 RETURN_UNGCPRO (Ffuncall (5, args
));
2780 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
2783 call5 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2784 Lisp_Object arg4
, Lisp_Object arg5
)
2786 struct gcpro gcpro1
;
2787 Lisp_Object args
[6];
2796 RETURN_UNGCPRO (Ffuncall (6, args
));
2799 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
2802 call6 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2803 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
)
2805 struct gcpro gcpro1
;
2806 Lisp_Object args
[7];
2816 RETURN_UNGCPRO (Ffuncall (7, args
));
2819 /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
2822 call7 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2823 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
)
2825 struct gcpro gcpro1
;
2826 Lisp_Object args
[8];
2837 RETURN_UNGCPRO (Ffuncall (8, args
));
2840 /* The caller should GCPRO all the elements of ARGS. */
2842 DEFUN ("functionp", Ffunctionp
, Sfunctionp
, 1, 1, 0,
2843 doc
: /* Non-nil if OBJECT is a function. */)
2844 (Lisp_Object object
)
2846 if (SYMBOLP (object
) && !NILP (Ffboundp (object
)))
2848 object
= Findirect_function (object
, Qt
);
2850 if (CONSP (object
) && EQ (XCAR (object
), Qautoload
))
2852 /* Autoloaded symbols are functions, except if they load
2853 macros or keymaps. */
2855 for (i
= 0; i
< 4 && CONSP (object
); i
++)
2856 object
= XCDR (object
);
2858 return (CONSP (object
) && !NILP (XCAR (object
))) ? Qnil
: Qt
;
2863 return (XSUBR (object
)->max_args
!= UNEVALLED
) ? Qt
: Qnil
;
2864 else if (COMPILEDP (object
))
2866 else if (CONSP (object
))
2868 Lisp_Object car
= XCAR (object
);
2869 return (EQ (car
, Qlambda
) || EQ (car
, Qclosure
)) ? Qt
: Qnil
;
2875 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2876 doc
: /* Call first argument as a function, passing remaining arguments to it.
2877 Return the value that function returns.
2878 Thus, (funcall 'cons 'x 'y) returns (x . y).
2879 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2880 (ptrdiff_t nargs
, Lisp_Object
*args
)
2882 Lisp_Object fun
, original_fun
;
2884 ptrdiff_t numargs
= nargs
- 1;
2885 Lisp_Object lisp_numargs
;
2887 struct backtrace backtrace
;
2888 register Lisp_Object
*internal_args
;
2892 if ((consing_since_gc
> gc_cons_threshold
2893 && consing_since_gc
> gc_relative_threshold
)
2895 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2896 Fgarbage_collect ();
2898 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2900 if (max_lisp_eval_depth
< 100)
2901 max_lisp_eval_depth
= 100;
2902 if (lisp_eval_depth
> max_lisp_eval_depth
)
2903 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2906 backtrace
.next
= backtrace_list
;
2907 backtrace_list
= &backtrace
;
2908 backtrace
.function
= &args
[0];
2909 backtrace
.args
= &args
[1];
2910 backtrace
.nargs
= nargs
- 1;
2911 backtrace
.debug_on_exit
= 0;
2913 if (debug_on_next_call
)
2914 do_debug_on_call (Qlambda
);
2918 original_fun
= args
[0];
2922 /* Optimize for no indirection. */
2924 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2925 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2926 fun
= indirect_function (fun
);
2930 if (numargs
< XSUBR (fun
)->min_args
2931 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2933 XSETFASTINT (lisp_numargs
, numargs
);
2934 xsignal2 (Qwrong_number_of_arguments
, original_fun
, lisp_numargs
);
2937 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2938 xsignal1 (Qinvalid_function
, original_fun
);
2940 else if (XSUBR (fun
)->max_args
== MANY
)
2941 val
= (XSUBR (fun
)->function
.aMANY
) (numargs
, args
+ 1);
2944 if (XSUBR (fun
)->max_args
> numargs
)
2946 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2947 memcpy (internal_args
, args
+ 1, numargs
* sizeof (Lisp_Object
));
2948 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2949 internal_args
[i
] = Qnil
;
2952 internal_args
= args
+ 1;
2953 switch (XSUBR (fun
)->max_args
)
2956 val
= (XSUBR (fun
)->function
.a0 ());
2959 val
= (XSUBR (fun
)->function
.a1 (internal_args
[0]));
2962 val
= (XSUBR (fun
)->function
.a2
2963 (internal_args
[0], internal_args
[1]));
2966 val
= (XSUBR (fun
)->function
.a3
2967 (internal_args
[0], internal_args
[1], internal_args
[2]));
2970 val
= (XSUBR (fun
)->function
.a4
2971 (internal_args
[0], internal_args
[1], internal_args
[2],
2975 val
= (XSUBR (fun
)->function
.a5
2976 (internal_args
[0], internal_args
[1], internal_args
[2],
2977 internal_args
[3], internal_args
[4]));
2980 val
= (XSUBR (fun
)->function
.a6
2981 (internal_args
[0], internal_args
[1], internal_args
[2],
2982 internal_args
[3], internal_args
[4], internal_args
[5]));
2985 val
= (XSUBR (fun
)->function
.a7
2986 (internal_args
[0], internal_args
[1], internal_args
[2],
2987 internal_args
[3], internal_args
[4], internal_args
[5],
2992 val
= (XSUBR (fun
)->function
.a8
2993 (internal_args
[0], internal_args
[1], internal_args
[2],
2994 internal_args
[3], internal_args
[4], internal_args
[5],
2995 internal_args
[6], internal_args
[7]));
3000 /* If a subr takes more than 8 arguments without using MANY
3001 or UNEVALLED, we need to extend this function to support it.
3002 Until this is done, there is no way to call the function. */
3007 else if (COMPILEDP (fun
))
3008 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3011 if (EQ (fun
, Qunbound
))
3012 xsignal1 (Qvoid_function
, original_fun
);
3014 xsignal1 (Qinvalid_function
, original_fun
);
3015 funcar
= XCAR (fun
);
3016 if (!SYMBOLP (funcar
))
3017 xsignal1 (Qinvalid_function
, original_fun
);
3018 if (EQ (funcar
, Qlambda
)
3019 || EQ (funcar
, Qclosure
))
3020 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3021 else if (EQ (funcar
, Qautoload
))
3023 do_autoload (fun
, original_fun
);
3028 xsignal1 (Qinvalid_function
, original_fun
);
3032 if (backtrace
.debug_on_exit
)
3033 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
3034 backtrace_list
= backtrace
.next
;
3039 apply_lambda (Lisp_Object fun
, Lisp_Object args
)
3041 Lisp_Object args_left
;
3044 register Lisp_Object
*arg_vector
;
3045 struct gcpro gcpro1
, gcpro2
, gcpro3
;
3046 register Lisp_Object tem
;
3049 numargs
= XFASTINT (Flength (args
));
3050 SAFE_ALLOCA_LISP (arg_vector
, numargs
);
3053 GCPRO3 (*arg_vector
, args_left
, fun
);
3056 for (i
= 0; i
< numargs
; )
3058 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
3059 tem
= eval_sub (tem
);
3060 arg_vector
[i
++] = tem
;
3066 backtrace_list
->args
= arg_vector
;
3067 backtrace_list
->nargs
= i
;
3068 tem
= funcall_lambda (fun
, numargs
, arg_vector
);
3070 /* Do the debug-on-exit now, while arg_vector still exists. */
3071 if (backtrace_list
->debug_on_exit
)
3072 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
3073 /* Don't do it again when we return to eval. */
3074 backtrace_list
->debug_on_exit
= 0;
3079 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
3080 and return the result of evaluation.
3081 FUN must be either a lambda-expression or a compiled-code object. */
3084 funcall_lambda (Lisp_Object fun
, ptrdiff_t nargs
,
3085 register Lisp_Object
*arg_vector
)
3087 Lisp_Object val
, syms_left
, next
, lexenv
;
3088 ptrdiff_t count
= SPECPDL_INDEX ();
3094 if (EQ (XCAR (fun
), Qclosure
))
3096 fun
= XCDR (fun
); /* Drop `closure'. */
3097 lexenv
= XCAR (fun
);
3098 CHECK_LIST_CONS (fun
, fun
);
3102 syms_left
= XCDR (fun
);
3103 if (CONSP (syms_left
))
3104 syms_left
= XCAR (syms_left
);
3106 xsignal1 (Qinvalid_function
, fun
);
3108 else if (COMPILEDP (fun
))
3110 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3111 if (INTEGERP (syms_left
))
3112 /* A byte-code object with a non-nil `push args' slot means we
3113 shouldn't bind any arguments, instead just call the byte-code
3114 interpreter directly; it will push arguments as necessary.
3116 Byte-code objects with either a non-existent, or a nil value for
3117 the `push args' slot (the default), have dynamically-bound
3118 arguments, and use the argument-binding code below instead (as do
3119 all interpreted functions, even lexically bound ones). */
3121 /* If we have not actually read the bytecode string
3122 and constants vector yet, fetch them from the file. */
3123 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3124 Ffetch_bytecode (fun
);
3125 return exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
3126 AREF (fun
, COMPILED_CONSTANTS
),
3127 AREF (fun
, COMPILED_STACK_DEPTH
),
3136 i
= optional
= rest
= 0;
3137 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3141 next
= XCAR (syms_left
);
3142 if (!SYMBOLP (next
))
3143 xsignal1 (Qinvalid_function
, fun
);
3145 if (EQ (next
, Qand_rest
))
3147 else if (EQ (next
, Qand_optional
))
3154 arg
= Flist (nargs
- i
, &arg_vector
[i
]);
3158 arg
= arg_vector
[i
++];
3160 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3164 /* Bind the argument. */
3165 if (!NILP (lexenv
) && SYMBOLP (next
))
3166 /* Lexically bind NEXT by adding it to the lexenv alist. */
3167 lexenv
= Fcons (Fcons (next
, arg
), lexenv
);
3169 /* Dynamically bind NEXT. */
3170 specbind (next
, arg
);
3174 if (!NILP (syms_left
))
3175 xsignal1 (Qinvalid_function
, fun
);
3177 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3179 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
3180 /* Instantiate a new lexical environment. */
3181 specbind (Qinternal_interpreter_environment
, lexenv
);
3184 val
= Fprogn (XCDR (XCDR (fun
)));
3187 /* If we have not actually read the bytecode string
3188 and constants vector yet, fetch them from the file. */
3189 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3190 Ffetch_bytecode (fun
);
3191 val
= exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
3192 AREF (fun
, COMPILED_CONSTANTS
),
3193 AREF (fun
, COMPILED_STACK_DEPTH
),
3197 return unbind_to (count
, val
);
3200 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3202 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3203 (Lisp_Object object
)
3207 if (COMPILEDP (object
) && CONSP (AREF (object
, COMPILED_BYTECODE
)))
3209 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3212 tem
= AREF (object
, COMPILED_BYTECODE
);
3213 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3214 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3216 error ("Invalid byte code");
3218 ASET (object
, COMPILED_BYTECODE
, XCAR (tem
));
3219 ASET (object
, COMPILED_CONSTANTS
, XCDR (tem
));
3227 register ptrdiff_t count
= SPECPDL_INDEX ();
3228 ptrdiff_t max_size
= min (max_specpdl_size
, PTRDIFF_MAX
);
3229 if (max_size
<= specpdl_size
)
3231 if (max_specpdl_size
< 400)
3232 max_size
= max_specpdl_size
= 400;
3233 if (max_size
<= specpdl_size
)
3234 signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil
);
3236 specpdl
= xpalloc (specpdl
, &specpdl_size
, 1, max_size
, sizeof *specpdl
);
3237 specpdl_ptr
= specpdl
+ count
;
3240 /* `specpdl_ptr->symbol' is a field which describes which variable is
3241 let-bound, so it can be properly undone when we unbind_to.
3242 It can have the following two shapes:
3243 - SYMBOL : if it's a plain symbol, it means that we have let-bound
3244 a symbol that is not buffer-local (at least at the time
3245 the let binding started). Note also that it should not be
3246 aliased (i.e. when let-binding V1 that's aliased to V2, we want
3248 - (SYMBOL WHERE . BUFFER) : this means that it is a let-binding for
3249 variable SYMBOL which can be buffer-local. WHERE tells us
3250 which buffer is affected (or nil if the let-binding affects the
3251 global value of the variable) and BUFFER tells us which buffer was
3252 current (i.e. if WHERE is non-nil, then BUFFER==WHERE, otherwise
3253 BUFFER did not yet have a buffer-local value). */
3256 specbind (Lisp_Object symbol
, Lisp_Object value
)
3258 struct Lisp_Symbol
*sym
;
3260 eassert (!handling_signal
);
3262 CHECK_SYMBOL (symbol
);
3263 sym
= XSYMBOL (symbol
);
3264 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3268 switch (sym
->redirect
)
3270 case SYMBOL_VARALIAS
:
3271 sym
= indirect_variable (sym
); XSETSYMBOL (symbol
, sym
); goto start
;
3272 case SYMBOL_PLAINVAL
:
3273 /* The most common case is that of a non-constant symbol with a
3274 trivial value. Make that as fast as we can. */
3275 specpdl_ptr
->symbol
= symbol
;
3276 specpdl_ptr
->old_value
= SYMBOL_VAL (sym
);
3277 specpdl_ptr
->func
= NULL
;
3280 SET_SYMBOL_VAL (sym
, value
);
3282 set_internal (symbol
, value
, Qnil
, 1);
3284 case SYMBOL_LOCALIZED
:
3285 if (SYMBOL_BLV (sym
)->frame_local
)
3286 error ("Frame-local vars cannot be let-bound");
3287 case SYMBOL_FORWARDED
:
3289 Lisp_Object ovalue
= find_symbol_value (symbol
);
3290 specpdl_ptr
->func
= 0;
3291 specpdl_ptr
->old_value
= ovalue
;
3293 eassert (sym
->redirect
!= SYMBOL_LOCALIZED
3294 || (EQ (SYMBOL_BLV (sym
)->where
,
3295 SYMBOL_BLV (sym
)->frame_local
?
3296 Fselected_frame () : Fcurrent_buffer ())));
3298 if (sym
->redirect
== SYMBOL_LOCALIZED
3299 || BUFFER_OBJFWDP (SYMBOL_FWD (sym
)))
3301 Lisp_Object where
, cur_buf
= Fcurrent_buffer ();
3303 /* For a local variable, record both the symbol and which
3304 buffer's or frame's value we are saving. */
3305 if (!NILP (Flocal_variable_p (symbol
, Qnil
)))
3307 eassert (sym
->redirect
!= SYMBOL_LOCALIZED
3308 || (BLV_FOUND (SYMBOL_BLV (sym
))
3309 && EQ (cur_buf
, SYMBOL_BLV (sym
)->where
)));
3312 else if (sym
->redirect
== SYMBOL_LOCALIZED
3313 && BLV_FOUND (SYMBOL_BLV (sym
)))
3314 where
= SYMBOL_BLV (sym
)->where
;
3318 /* We're not using the `unused' slot in the specbinding
3319 structure because this would mean we have to do more
3320 work for simple variables. */
3321 /* FIXME: The third value `current_buffer' is only used in
3322 let_shadows_buffer_binding_p which is itself only used
3323 in set_internal for local_if_set. */
3324 eassert (NILP (where
) || EQ (where
, cur_buf
));
3325 specpdl_ptr
->symbol
= Fcons (symbol
, Fcons (where
, cur_buf
));
3327 /* If SYMBOL is a per-buffer variable which doesn't have a
3328 buffer-local value here, make the `let' change the global
3329 value by changing the value of SYMBOL in all buffers not
3330 having their own value. This is consistent with what
3331 happens with other buffer-local variables. */
3333 && sym
->redirect
== SYMBOL_FORWARDED
)
3335 eassert (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)));
3337 Fset_default (symbol
, value
);
3342 specpdl_ptr
->symbol
= symbol
;
3345 set_internal (symbol
, value
, Qnil
, 1);
3353 record_unwind_protect (Lisp_Object (*function
) (Lisp_Object
), Lisp_Object arg
)
3355 eassert (!handling_signal
);
3357 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3359 specpdl_ptr
->func
= function
;
3360 specpdl_ptr
->symbol
= Qnil
;
3361 specpdl_ptr
->old_value
= arg
;
3366 unbind_to (ptrdiff_t count
, Lisp_Object value
)
3368 Lisp_Object quitf
= Vquit_flag
;
3369 struct gcpro gcpro1
, gcpro2
;
3371 GCPRO2 (value
, quitf
);
3374 while (specpdl_ptr
!= specpdl
+ count
)
3376 /* Copy the binding, and decrement specpdl_ptr, before we do
3377 the work to unbind it. We decrement first
3378 so that an error in unbinding won't try to unbind
3379 the same entry again, and we copy the binding first
3380 in case more bindings are made during some of the code we run. */
3382 struct specbinding this_binding
;
3383 this_binding
= *--specpdl_ptr
;
3385 if (this_binding
.func
!= 0)
3386 (*this_binding
.func
) (this_binding
.old_value
);
3387 /* If the symbol is a list, it is really (SYMBOL WHERE
3388 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3389 frame. If WHERE is a buffer or frame, this indicates we
3390 bound a variable that had a buffer-local or frame-local
3391 binding. WHERE nil means that the variable had the default
3392 value when it was bound. CURRENT-BUFFER is the buffer that
3393 was current when the variable was bound. */
3394 else if (CONSP (this_binding
.symbol
))
3396 Lisp_Object symbol
, where
;
3398 symbol
= XCAR (this_binding
.symbol
);
3399 where
= XCAR (XCDR (this_binding
.symbol
));
3402 Fset_default (symbol
, this_binding
.old_value
);
3403 /* If `where' is non-nil, reset the value in the appropriate
3404 local binding, but only if that binding still exists. */
3405 else if (BUFFERP (where
)
3406 ? !NILP (Flocal_variable_p (symbol
, where
))
3407 : !NILP (Fassq (symbol
, XFRAME (where
)->param_alist
)))
3408 set_internal (symbol
, this_binding
.old_value
, where
, 1);
3410 /* If variable has a trivial value (no forwarding), we can
3411 just set it. No need to check for constant symbols here,
3412 since that was already done by specbind. */
3413 else if (XSYMBOL (this_binding
.symbol
)->redirect
== SYMBOL_PLAINVAL
)
3414 SET_SYMBOL_VAL (XSYMBOL (this_binding
.symbol
),
3415 this_binding
.old_value
);
3417 /* NOTE: we only ever come here if make_local_foo was used for
3418 the first time on this var within this let. */
3419 Fset_default (this_binding
.symbol
, this_binding
.old_value
);
3422 if (NILP (Vquit_flag
) && !NILP (quitf
))
3429 DEFUN ("special-variable-p", Fspecial_variable_p
, Sspecial_variable_p
, 1, 1, 0,
3430 doc
: /* Return non-nil if SYMBOL's global binding has been declared special.
3431 A special variable is one that will be bound dynamically, even in a
3432 context where binding is lexical by default. */)
3433 (Lisp_Object symbol
)
3435 CHECK_SYMBOL (symbol
);
3436 return XSYMBOL (symbol
)->declared_special
? Qt
: Qnil
;
3440 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3441 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3442 The debugger is entered when that frame exits, if the flag is non-nil. */)
3443 (Lisp_Object level
, Lisp_Object flag
)
3445 register struct backtrace
*backlist
= backtrace_list
;
3446 register EMACS_INT i
;
3448 CHECK_NUMBER (level
);
3450 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
3452 backlist
= backlist
->next
;
3456 backlist
->debug_on_exit
= !NILP (flag
);
3461 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3462 doc
: /* Print a trace of Lisp function calls currently active.
3463 Output stream used is value of `standard-output'. */)
3466 register struct backtrace
*backlist
= backtrace_list
;
3469 struct gcpro gcpro1
;
3470 Lisp_Object old_print_level
= Vprint_level
;
3472 if (NILP (Vprint_level
))
3473 XSETFASTINT (Vprint_level
, 8);
3480 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
3481 if (backlist
->nargs
== UNEVALLED
)
3483 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
3484 write_string ("\n", -1);
3488 tem
= *backlist
->function
;
3489 Fprin1 (tem
, Qnil
); /* This can QUIT. */
3490 write_string ("(", -1);
3491 if (backlist
->nargs
== MANY
)
3492 { /* FIXME: Can this happen? */
3494 for (tail
= *backlist
->args
, i
= 0;
3496 tail
= Fcdr (tail
), i
= 1)
3498 if (i
) write_string (" ", -1);
3499 Fprin1 (Fcar (tail
), Qnil
);
3505 for (i
= 0; i
< backlist
->nargs
; i
++)
3507 if (i
) write_string (" ", -1);
3508 Fprin1 (backlist
->args
[i
], Qnil
);
3511 write_string (")\n", -1);
3513 backlist
= backlist
->next
;
3516 Vprint_level
= old_print_level
;
3521 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, NULL
,
3522 doc
: /* Return the function and arguments NFRAMES up from current execution point.
3523 If that frame has not evaluated the arguments yet (or is a special form),
3524 the value is (nil FUNCTION ARG-FORMS...).
3525 If that frame has evaluated its arguments and called its function already,
3526 the value is (t FUNCTION ARG-VALUES...).
3527 A &rest arg is represented as the tail of the list ARG-VALUES.
3528 FUNCTION is whatever was supplied as car of evaluated list,
3529 or a lambda expression for macro calls.
3530 If NFRAMES is more than the number of frames, the value is nil. */)
3531 (Lisp_Object nframes
)
3533 register struct backtrace
*backlist
= backtrace_list
;
3534 register EMACS_INT i
;
3537 CHECK_NATNUM (nframes
);
3539 /* Find the frame requested. */
3540 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3541 backlist
= backlist
->next
;
3545 if (backlist
->nargs
== UNEVALLED
)
3546 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3549 if (backlist
->nargs
== MANY
) /* FIXME: Can this happen? */
3550 tem
= *backlist
->args
;
3552 tem
= Flist (backlist
->nargs
, backlist
->args
);
3554 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3561 mark_backtrace (void)
3563 register struct backtrace
*backlist
;
3566 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3568 mark_object (*backlist
->function
);
3570 if (backlist
->nargs
== UNEVALLED
3571 || backlist
->nargs
== MANY
) /* FIXME: Can this happen? */
3574 i
= backlist
->nargs
;
3576 mark_object (backlist
->args
[i
]);
3584 DEFVAR_INT ("max-specpdl-size", max_specpdl_size
,
3585 doc
: /* *Limit on number of Lisp variable bindings and `unwind-protect's.
3586 If Lisp code tries to increase the total number past this amount,
3587 an error is signaled.
3588 You can safely use a value considerably larger than the default value,
3589 if that proves inconveniently small. However, if you increase it too far,
3590 Emacs could run out of memory trying to make the stack bigger. */);
3592 DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth
,
3593 doc
: /* *Limit on depth in `eval', `apply' and `funcall' before error.
3595 This limit serves to catch infinite recursions for you before they cause
3596 actual stack overflow in C, which would be fatal for Emacs.
3597 You can safely make it considerably larger than its default value,
3598 if that proves inconveniently small. However, if you increase it too far,
3599 Emacs could overflow the real C stack, and crash. */);
3601 DEFVAR_LISP ("quit-flag", Vquit_flag
,
3602 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3603 If the value is t, that means do an ordinary quit.
3604 If the value equals `throw-on-input', that means quit by throwing
3605 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3606 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3607 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3610 DEFVAR_LISP ("inhibit-quit", Vinhibit_quit
,
3611 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3612 Note that `quit-flag' will still be set by typing C-g,
3613 so a quit will be signaled as soon as `inhibit-quit' is nil.
3614 To prevent this happening, set `quit-flag' to nil
3615 before making `inhibit-quit' nil. */);
3616 Vinhibit_quit
= Qnil
;
3618 DEFSYM (Qinhibit_quit
, "inhibit-quit");
3619 DEFSYM (Qautoload
, "autoload");
3620 DEFSYM (Qdebug_on_error
, "debug-on-error");
3621 DEFSYM (Qmacro
, "macro");
3622 DEFSYM (Qdeclare
, "declare");
3624 /* Note that the process handling also uses Qexit, but we don't want
3625 to staticpro it twice, so we just do it here. */
3626 DEFSYM (Qexit
, "exit");
3628 DEFSYM (Qinteractive
, "interactive");
3629 DEFSYM (Qcommandp
, "commandp");
3630 DEFSYM (Qdefun
, "defun");
3631 DEFSYM (Qand_rest
, "&rest");
3632 DEFSYM (Qand_optional
, "&optional");
3633 DEFSYM (Qclosure
, "closure");
3634 DEFSYM (Qdebug
, "debug");
3636 DEFVAR_LISP ("debug-on-error", Vdebug_on_error
,
3637 doc
: /* *Non-nil means enter debugger if an error is signaled.
3638 Does not apply to errors handled by `condition-case' or those
3639 matched by `debug-ignored-errors'.
3640 If the value is a list, an error only means to enter the debugger
3641 if one of its condition symbols appears in the list.
3642 When you evaluate an expression interactively, this variable
3643 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3644 The command `toggle-debug-on-error' toggles this.
3645 See also the variable `debug-on-quit'. */);
3646 Vdebug_on_error
= Qnil
;
3648 DEFVAR_LISP ("debug-ignored-errors", Vdebug_ignored_errors
,
3649 doc
: /* *List of errors for which the debugger should not be called.
3650 Each element may be a condition-name or a regexp that matches error messages.
3651 If any element applies to a given error, that error skips the debugger
3652 and just returns to top level.
3653 This overrides the variable `debug-on-error'.
3654 It does not apply to errors handled by `condition-case'. */);
3655 Vdebug_ignored_errors
= Qnil
;
3657 DEFVAR_BOOL ("debug-on-quit", debug_on_quit
,
3658 doc
: /* *Non-nil means enter debugger if quit is signaled (C-g, for example).
3659 Does not apply if quit is handled by a `condition-case'. */);
3662 DEFVAR_BOOL ("debug-on-next-call", debug_on_next_call
,
3663 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3665 DEFVAR_BOOL ("debugger-may-continue", debugger_may_continue
,
3666 doc
: /* Non-nil means debugger may continue execution.
3667 This is nil when the debugger is called under circumstances where it
3668 might not be safe to continue. */);
3669 debugger_may_continue
= 1;
3671 DEFVAR_LISP ("debugger", Vdebugger
,
3672 doc
: /* Function to call to invoke debugger.
3673 If due to frame exit, args are `exit' and the value being returned;
3674 this function's value will be returned instead of that.
3675 If due to error, args are `error' and a list of the args to `signal'.
3676 If due to `apply' or `funcall' entry, one arg, `lambda'.
3677 If due to `eval' entry, one arg, t. */);
3680 DEFVAR_LISP ("signal-hook-function", Vsignal_hook_function
,
3681 doc
: /* If non-nil, this is a function for `signal' to call.
3682 It receives the same arguments that `signal' was given.
3683 The Edebug package uses this to regain control. */);
3684 Vsignal_hook_function
= Qnil
;
3686 DEFVAR_LISP ("debug-on-signal", Vdebug_on_signal
,
3687 doc
: /* *Non-nil means call the debugger regardless of condition handlers.
3688 Note that `debug-on-error', `debug-on-quit' and friends
3689 still determine whether to handle the particular condition. */);
3690 Vdebug_on_signal
= Qnil
;
3692 DEFVAR_LISP ("macro-declaration-function", Vmacro_declaration_function
,
3693 doc
: /* Function to process declarations in a macro definition.
3694 The function will be called with two args MACRO and DECL.
3695 MACRO is the name of the macro being defined.
3696 DECL is a list `(declare ...)' containing the declarations.
3697 The value the function returns is not used. */);
3698 Vmacro_declaration_function
= Qnil
;
3700 /* When lexical binding is being used,
3701 vinternal_interpreter_environment is non-nil, and contains an alist
3702 of lexically-bound variable, or (t), indicating an empty
3703 environment. The lisp name of this variable would be
3704 `internal-interpreter-environment' if it weren't hidden.
3705 Every element of this list can be either a cons (VAR . VAL)
3706 specifying a lexical binding, or a single symbol VAR indicating
3707 that this variable should use dynamic scoping. */
3708 DEFSYM (Qinternal_interpreter_environment
, "internal-interpreter-environment");
3709 DEFVAR_LISP ("internal-interpreter-environment",
3710 Vinternal_interpreter_environment
,
3711 doc
: /* If non-nil, the current lexical environment of the lisp interpreter.
3712 When lexical binding is not being used, this variable is nil.
3713 A value of `(t)' indicates an empty environment, otherwise it is an
3714 alist of active lexical bindings. */);
3715 Vinternal_interpreter_environment
= Qnil
;
3716 /* Don't export this variable to Elisp, so no one can mess with it
3717 (Just imagine if someone makes it buffer-local). */
3718 Funintern (Qinternal_interpreter_environment
, Qnil
);
3720 DEFSYM (Vrun_hooks
, "run-hooks");
3722 staticpro (&Vautoload_queue
);
3723 Vautoload_queue
= Qnil
;
3724 staticpro (&Vsignaling_function
);
3725 Vsignaling_function
= Qnil
;
3736 defsubr (&Sfunction
);
3738 defsubr (&Sdefmacro
);
3740 defsubr (&Sdefvaralias
);
3741 defsubr (&Sdefconst
);
3742 defsubr (&Suser_variable_p
);
3746 defsubr (&Smacroexpand
);
3749 defsubr (&Sunwind_protect
);
3750 defsubr (&Scondition_case
);
3752 defsubr (&Sinteractive_p
);
3753 defsubr (&Scalled_interactively_p
);
3754 defsubr (&Scommandp
);
3755 defsubr (&Sautoload
);
3758 defsubr (&Sfuncall
);
3759 defsubr (&Srun_hooks
);
3760 defsubr (&Srun_hook_with_args
);
3761 defsubr (&Srun_hook_with_args_until_success
);
3762 defsubr (&Srun_hook_with_args_until_failure
);
3763 defsubr (&Srun_hook_wrapped
);
3764 defsubr (&Sfetch_bytecode
);
3765 defsubr (&Sbacktrace_debug
);
3766 defsubr (&Sbacktrace
);
3767 defsubr (&Sbacktrace_frame
);
3768 defsubr (&Sspecial_variable_p
);
3769 defsubr (&Sfunctionp
);