1 /* Evaluator for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1987, 1993-1995, 1999-2011 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software: you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation, either version 3 of the License, or
9 (at your option) any later version.
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
25 #include "blockinput.h"
28 #include "dispextern.h"
29 #include "frame.h" /* For XFRAME. */
37 struct backtrace
*next
;
38 Lisp_Object
*function
;
39 Lisp_Object
*args
; /* Points to vector of args. */
40 ptrdiff_t nargs
; /* Length of vector. */
41 /* Nonzero means call value of debugger when done with this operation. */
42 unsigned int debug_on_exit
: 1;
45 static struct backtrace
*backtrace_list
;
50 struct catchtag
*catchlist
;
52 /* Chain of condition handlers currently in effect.
53 The elements of this chain are contained in the stack frames
54 of Fcondition_case and internal_condition_case.
55 When an error is signaled (by calling Fsignal, below),
56 this chain is searched for an element that applies. */
61 struct handler
*handlerlist
;
64 /* Count levels of GCPRO to detect failure to UNGCPRO. */
68 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
69 Lisp_Object Qinhibit_quit
;
70 Lisp_Object Qand_rest
;
71 static Lisp_Object Qand_optional
;
72 static Lisp_Object Qdebug_on_error
;
73 static Lisp_Object Qdeclare
;
74 Lisp_Object Qinternal_interpreter_environment
, Qclosure
;
76 static Lisp_Object Qdebug
;
78 /* This holds either the symbol `run-hooks' or nil.
79 It is nil at an early stage of startup, and when Emacs
82 Lisp_Object Vrun_hooks
;
84 /* Non-nil means record all fset's and provide's, to be undone
85 if the file being autoloaded is not fully loaded.
86 They are recorded by being consed onto the front of Vautoload_queue:
87 (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide. */
89 Lisp_Object Vautoload_queue
;
91 /* Current number of specbindings allocated in specpdl. */
93 EMACS_INT specpdl_size
;
95 /* Pointer to beginning of specpdl. */
97 struct specbinding
*specpdl
;
99 /* Pointer to first unused element in specpdl. */
101 struct specbinding
*specpdl_ptr
;
103 /* Depth in Lisp evaluations and function calls. */
105 static EMACS_INT lisp_eval_depth
;
107 /* The value of num_nonmacro_input_events as of the last time we
108 started to enter the debugger. If we decide to enter the debugger
109 again when this is still equal to num_nonmacro_input_events, then we
110 know that the debugger itself has an error, and we should just
111 signal the error instead of entering an infinite loop of debugger
114 static int when_entered_debugger
;
116 /* The function from which the last `signal' was called. Set in
119 Lisp_Object Vsignaling_function
;
121 /* Set to non-zero while processing X events. Checked in Feval to
122 make sure the Lisp interpreter isn't called from a signal handler,
123 which is unsafe because the interpreter isn't reentrant. */
127 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 int 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
;
376 register int argnum
= 0;
387 Lisp_Object tem
= eval_sub (XCAR (args_left
));
390 args_left
= XCDR (args_left
);
392 while (CONSP (args_left
));
398 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
399 doc
: /* Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
400 The value of FORM2 is saved during the evaluation of the
401 remaining args, whose values are discarded.
402 usage: (prog2 FORM1 FORM2 BODY...) */)
406 register Lisp_Object args_left
;
407 struct gcpro gcpro1
, gcpro2
;
408 register int argnum
= -1;
421 Lisp_Object tem
= eval_sub (XCAR (args_left
));
424 args_left
= XCDR (args_left
);
426 while (CONSP (args_left
));
432 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
433 doc
: /* Set each SYM to the value of its VAL.
434 The symbols SYM are variables; they are literal (not evaluated).
435 The values VAL are expressions; they are evaluated.
436 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
437 The second VAL is not computed until after the first SYM is set, and so on;
438 each VAL can use the new value of variables set earlier in the `setq'.
439 The return value of the `setq' form is the value of the last VAL.
440 usage: (setq [SYM VAL]...) */)
443 register Lisp_Object args_left
;
444 register Lisp_Object val
, sym
, lex_binding
;
455 val
= eval_sub (Fcar (Fcdr (args_left
)));
456 sym
= Fcar (args_left
);
458 /* Like for eval_sub, we do not check declared_special here since
459 it's been done when let-binding. */
460 if (!NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
462 && !NILP (lex_binding
463 = Fassq (sym
, Vinternal_interpreter_environment
)))
464 XSETCDR (lex_binding
, val
); /* SYM is lexically bound. */
466 Fset (sym
, val
); /* SYM is dynamically bound. */
468 args_left
= Fcdr (Fcdr (args_left
));
470 while (!NILP(args_left
));
476 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
477 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
478 usage: (quote ARG) */)
481 if (!NILP (Fcdr (args
)))
482 xsignal2 (Qwrong_number_of_arguments
, Qquote
, Flength (args
));
486 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
487 doc
: /* Like `quote', but preferred for objects which are functions.
488 In byte compilation, `function' causes its argument to be compiled.
489 `quote' cannot do that.
490 usage: (function ARG) */)
493 Lisp_Object quoted
= XCAR (args
);
495 if (!NILP (Fcdr (args
)))
496 xsignal2 (Qwrong_number_of_arguments
, Qfunction
, Flength (args
));
498 if (!NILP (Vinternal_interpreter_environment
)
500 && EQ (XCAR (quoted
), Qlambda
))
501 /* This is a lambda expression within a lexical environment;
502 return an interpreted closure instead of a simple lambda. */
503 return Fcons (Qclosure
, Fcons (Vinternal_interpreter_environment
,
506 /* Simply quote the argument. */
511 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
512 doc
: /* Return t if the containing function was run directly by user input.
513 This means that the function was called with `call-interactively'
514 \(which includes being called as the binding of a key)
515 and input is currently coming from the keyboard (not a keyboard macro),
516 and Emacs is not running in batch mode (`noninteractive' is nil).
518 The only known proper use of `interactive-p' is in deciding whether to
519 display a helpful message, or how to display it. If you're thinking
520 of using it for any other purpose, it is quite likely that you're
521 making a mistake. Think: what do you want to do when the command is
522 called from a keyboard macro?
524 To test whether your function was called with `call-interactively',
525 either (i) add an extra optional argument and give it an `interactive'
526 spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
527 use `called-interactively-p'. */)
530 return interactive_p (1) ? Qt
: Qnil
;
534 DEFUN ("called-interactively-p", Fcalled_interactively_p
, Scalled_interactively_p
, 0, 1, 0,
535 doc
: /* Return t if the containing function was called by `call-interactively'.
536 If KIND is `interactive', then only return t if the call was made
537 interactively by the user, i.e. not in `noninteractive' mode nor
538 when `executing-kbd-macro'.
539 If KIND is `any', on the other hand, it will return t for any kind of
540 interactive call, including being called as the binding of a key, or
541 from a keyboard macro, or in `noninteractive' mode.
543 The only known proper use of `interactive' for KIND is in deciding
544 whether to display a helpful message, or how to display it. If you're
545 thinking of using it for any other purpose, it is quite likely that
546 you're making a mistake. Think: what do you want to do when the
547 command is called from a keyboard macro?
549 This function is meant for implementing advice and other
550 function-modifying features. Instead of using this, it is sometimes
551 cleaner to give your function an extra optional argument whose
552 `interactive' spec specifies non-nil unconditionally (\"p\" is a good
553 way to do this), or via (not (or executing-kbd-macro noninteractive)). */)
556 return ((INTERACTIVE
|| !EQ (kind
, intern ("interactive")))
557 && interactive_p (1)) ? Qt
: Qnil
;
561 /* Return 1 if function in which this appears was called using
564 EXCLUDE_SUBRS_P non-zero means always return 0 if the function
565 called is a built-in. */
568 interactive_p (int exclude_subrs_p
)
570 struct backtrace
*btp
;
573 btp
= backtrace_list
;
575 /* If this isn't a byte-compiled function, there may be a frame at
576 the top for Finteractive_p. If so, skip it. */
577 fun
= Findirect_function (*btp
->function
, Qnil
);
578 if (SUBRP (fun
) && (XSUBR (fun
) == &Sinteractive_p
579 || XSUBR (fun
) == &Scalled_interactively_p
))
582 /* If we're running an Emacs 18-style byte-compiled function, there
583 may be a frame for Fbytecode at the top level. In any version of
584 Emacs there can be Fbytecode frames for subexpressions evaluated
585 inside catch and condition-case. Skip past them.
587 If this isn't a byte-compiled function, then we may now be
588 looking at several frames for special forms. Skip past them. */
590 && (EQ (*btp
->function
, Qbytecode
)
591 || btp
->nargs
== UNEVALLED
))
594 /* `btp' now points at the frame of the innermost function that isn't
595 a special form, ignoring frames for Finteractive_p and/or
596 Fbytecode at the top. If this frame is for a built-in function
597 (such as load or eval-region) return nil. */
598 fun
= Findirect_function (*btp
->function
, Qnil
);
599 if (exclude_subrs_p
&& SUBRP (fun
))
602 /* `btp' points to the frame of a Lisp function that called interactive-p.
603 Return t if that function was called interactively. */
604 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
610 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
611 doc
: /* Define NAME as a function.
612 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
613 See also the function `interactive'.
614 usage: (defun NAME ARGLIST [DOCSTRING] BODY...) */)
617 register Lisp_Object fn_name
;
618 register Lisp_Object defn
;
620 fn_name
= Fcar (args
);
621 CHECK_SYMBOL (fn_name
);
622 defn
= Fcons (Qlambda
, Fcdr (args
));
623 if (!NILP (Vinternal_interpreter_environment
)) /* Mere optimization! */
624 defn
= Ffunction (Fcons (defn
, Qnil
));
625 if (!NILP (Vpurify_flag
))
626 defn
= Fpurecopy (defn
);
627 if (CONSP (XSYMBOL (fn_name
)->function
)
628 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
629 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
630 Ffset (fn_name
, defn
);
631 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
635 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
636 doc
: /* Define NAME as a macro.
637 The actual definition looks like
638 (macro lambda ARGLIST [DOCSTRING] [DECL] BODY...).
639 When the macro is called, as in (NAME ARGS...),
640 the function (lambda ARGLIST BODY...) is applied to
641 the list ARGS... as it appears in the expression,
642 and the result should be a form to be evaluated instead of the original.
644 DECL is a declaration, optional, which can specify how to indent
645 calls to this macro, how Edebug should handle it, and which argument
646 should be treated as documentation. It looks like this:
648 The elements can look like this:
650 Set NAME's `lisp-indent-function' property to INDENT.
653 Set NAME's `edebug-form-spec' property to DEBUG. (This is
654 equivalent to writing a `def-edebug-spec' for the macro.)
657 Set NAME's `doc-string-elt' property to ELT.
659 usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...) */)
662 register Lisp_Object fn_name
;
663 register Lisp_Object defn
;
664 Lisp_Object lambda_list
, doc
, tail
;
666 fn_name
= Fcar (args
);
667 CHECK_SYMBOL (fn_name
);
668 lambda_list
= Fcar (Fcdr (args
));
669 tail
= Fcdr (Fcdr (args
));
672 if (STRINGP (Fcar (tail
)))
678 if (CONSP (Fcar (tail
))
679 && EQ (Fcar (Fcar (tail
)), Qdeclare
))
681 if (!NILP (Vmacro_declaration_function
))
685 call2 (Vmacro_declaration_function
, fn_name
, Fcar (tail
));
693 tail
= Fcons (lambda_list
, tail
);
695 tail
= Fcons (lambda_list
, Fcons (doc
, tail
));
697 defn
= Fcons (Qlambda
, tail
);
698 if (!NILP (Vinternal_interpreter_environment
)) /* Mere optimization! */
699 defn
= Ffunction (Fcons (defn
, Qnil
));
700 defn
= Fcons (Qmacro
, defn
);
702 if (!NILP (Vpurify_flag
))
703 defn
= Fpurecopy (defn
);
704 if (CONSP (XSYMBOL (fn_name
)->function
)
705 && EQ (XCAR (XSYMBOL (fn_name
)->function
), Qautoload
))
706 LOADHIST_ATTACH (Fcons (Qt
, fn_name
));
707 Ffset (fn_name
, defn
);
708 LOADHIST_ATTACH (Fcons (Qdefun
, fn_name
));
713 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 3, 0,
714 doc
: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
715 Aliased variables always have the same value; setting one sets the other.
716 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS. If it is
717 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
718 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
719 itself an alias. If NEW-ALIAS is bound, and BASE-VARIABLE is not,
720 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
721 The return value is BASE-VARIABLE. */)
722 (Lisp_Object new_alias
, Lisp_Object base_variable
, Lisp_Object docstring
)
724 struct Lisp_Symbol
*sym
;
726 CHECK_SYMBOL (new_alias
);
727 CHECK_SYMBOL (base_variable
);
729 sym
= XSYMBOL (new_alias
);
732 /* Not sure why, but why not? */
733 error ("Cannot make a constant an alias");
735 switch (sym
->redirect
)
737 case SYMBOL_FORWARDED
:
738 error ("Cannot make an internal variable an alias");
739 case SYMBOL_LOCALIZED
:
740 error ("Don't know how to make a localized variable an alias");
743 /* http://lists.gnu.org/archive/html/emacs-devel/2008-04/msg00834.html
744 If n_a is bound, but b_v is not, set the value of b_v to n_a,
745 so that old-code that affects n_a before the aliasing is setup
747 if (NILP (Fboundp (base_variable
)))
748 set_internal (base_variable
, find_symbol_value (new_alias
), Qnil
, 1);
751 struct specbinding
*p
;
753 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
756 CONSP (p
->symbol
) ? XCAR (p
->symbol
) : p
->symbol
)))
757 error ("Don't know how to make a let-bound variable an alias");
760 sym
->declared_special
= 1;
761 XSYMBOL (base_variable
)->declared_special
= 1;
762 sym
->redirect
= SYMBOL_VARALIAS
;
763 SET_SYMBOL_ALIAS (sym
, XSYMBOL (base_variable
));
764 sym
->constant
= SYMBOL_CONSTANT_P (base_variable
);
765 LOADHIST_ATTACH (new_alias
);
766 /* Even if docstring is nil: remove old docstring. */
767 Fput (new_alias
, Qvariable_documentation
, docstring
);
769 return base_variable
;
773 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
774 doc
: /* Define SYMBOL as a variable, and return SYMBOL.
775 You are not required to define a variable in order to use it,
776 but the definition can supply documentation and an initial value
777 in a way that tags can recognize.
779 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.
780 If SYMBOL is buffer-local, its default value is what is set;
781 buffer-local values are not affected.
782 INITVALUE and DOCSTRING are optional.
783 If DOCSTRING starts with *, this variable is identified as a user option.
784 This means that M-x set-variable recognizes it.
785 See also `user-variable-p'.
786 If INITVALUE is missing, SYMBOL's value is not set.
788 If SYMBOL has a local binding, then this form affects the local
789 binding. This is usually not what you want. Thus, if you need to
790 load a file defining variables, with this form or with `defconst' or
791 `defcustom', you should always load that file _outside_ any bindings
792 for these variables. \(`defconst' and `defcustom' behave similarly in
794 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
797 register Lisp_Object sym
, tem
, tail
;
801 if (!NILP (Fcdr (Fcdr (tail
))))
802 error ("Too many arguments");
804 tem
= Fdefault_boundp (sym
);
807 /* Do it before evaluating the initial value, for self-references. */
808 XSYMBOL (sym
)->declared_special
= 1;
810 if (SYMBOL_CONSTANT_P (sym
))
812 /* For upward compatibility, allow (defvar :foo (quote :foo)). */
813 Lisp_Object tem1
= Fcar (tail
);
815 && EQ (XCAR (tem1
), Qquote
)
816 && CONSP (XCDR (tem1
))
817 && EQ (XCAR (XCDR (tem1
)), sym
)))
818 error ("Constant symbol `%s' specified in defvar",
819 SDATA (SYMBOL_NAME (sym
)));
823 Fset_default (sym
, eval_sub (Fcar (tail
)));
825 { /* Check if there is really a global binding rather than just a let
826 binding that shadows the global unboundness of the var. */
827 volatile struct specbinding
*pdl
= specpdl_ptr
;
828 while (--pdl
>= specpdl
)
830 if (EQ (pdl
->symbol
, sym
) && !pdl
->func
831 && EQ (pdl
->old_value
, Qunbound
))
833 message_with_string ("Warning: defvar ignored because %s is let-bound",
834 SYMBOL_NAME (sym
), 1);
843 if (!NILP (Vpurify_flag
))
844 tem
= Fpurecopy (tem
);
845 Fput (sym
, Qvariable_documentation
, tem
);
847 LOADHIST_ATTACH (sym
);
849 else if (!NILP (Vinternal_interpreter_environment
)
850 && !XSYMBOL (sym
)->declared_special
)
851 /* A simple (defvar foo) with lexical scoping does "nothing" except
852 declare that var to be dynamically scoped *locally* (i.e. within
853 the current file or let-block). */
854 Vinternal_interpreter_environment
=
855 Fcons (sym
, Vinternal_interpreter_environment
);
858 /* Simple (defvar <var>) should not count as a definition at all.
859 It could get in the way of other definitions, and unloading this
860 package could try to make the variable unbound. */
866 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
867 doc
: /* Define SYMBOL as a constant variable.
868 The intent is that neither programs nor users should ever change this value.
869 Always sets the value of SYMBOL to the result of evalling INITVALUE.
870 If SYMBOL is buffer-local, its default value is what is set;
871 buffer-local values are not affected.
872 DOCSTRING is optional.
874 If SYMBOL has a local binding, then this form sets the local binding's
875 value. However, you should normally not make local bindings for
876 variables defined with this form.
877 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
880 register Lisp_Object sym
, tem
;
883 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
884 error ("Too many arguments");
886 tem
= eval_sub (Fcar (Fcdr (args
)));
887 if (!NILP (Vpurify_flag
))
888 tem
= Fpurecopy (tem
);
889 Fset_default (sym
, tem
);
890 XSYMBOL (sym
)->declared_special
= 1;
891 tem
= Fcar (Fcdr (Fcdr (args
)));
894 if (!NILP (Vpurify_flag
))
895 tem
= Fpurecopy (tem
);
896 Fput (sym
, Qvariable_documentation
, tem
);
898 Fput (sym
, Qrisky_local_variable
, Qt
);
899 LOADHIST_ATTACH (sym
);
903 /* Error handler used in Fuser_variable_p. */
905 user_variable_p_eh (Lisp_Object ignore
)
911 lisp_indirect_variable (Lisp_Object sym
)
913 struct Lisp_Symbol
*s
= indirect_variable (XSYMBOL (sym
));
918 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
919 doc
: /* Return t if VARIABLE is intended to be set and modified by users.
920 \(The alternative is a variable used internally in a Lisp program.)
921 A variable is a user variable if
922 \(1) the first character of its documentation is `*', or
923 \(2) it is customizable (its property list contains a non-nil value
924 of `standard-value' or `custom-autoload'), or
925 \(3) it is an alias for another user variable.
926 Return nil if VARIABLE is an alias and there is a loop in the
927 chain of symbols. */)
928 (Lisp_Object variable
)
930 Lisp_Object documentation
;
932 if (!SYMBOLP (variable
))
935 /* If indirect and there's an alias loop, don't check anything else. */
936 if (XSYMBOL (variable
)->redirect
== SYMBOL_VARALIAS
937 && NILP (internal_condition_case_1 (lisp_indirect_variable
, variable
,
938 Qt
, user_variable_p_eh
)))
943 documentation
= Fget (variable
, Qvariable_documentation
);
944 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
946 if (STRINGP (documentation
)
947 && ((unsigned char) SREF (documentation
, 0) == '*'))
949 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
950 if (CONSP (documentation
)
951 && STRINGP (XCAR (documentation
))
952 && INTEGERP (XCDR (documentation
))
953 && XINT (XCDR (documentation
)) < 0)
955 /* Customizable? See `custom-variable-p'. */
956 if ((!NILP (Fget (variable
, intern ("standard-value"))))
957 || (!NILP (Fget (variable
, intern ("custom-autoload")))))
960 if (!(XSYMBOL (variable
)->redirect
== SYMBOL_VARALIAS
))
963 /* An indirect variable? Let's follow the chain. */
964 XSETSYMBOL (variable
, SYMBOL_ALIAS (XSYMBOL (variable
)));
968 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
969 doc
: /* Bind variables according to VARLIST then eval BODY.
970 The value of the last form in BODY is returned.
971 Each element of VARLIST is a symbol (which is bound to nil)
972 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
973 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
974 usage: (let* VARLIST BODY...) */)
977 Lisp_Object varlist
, var
, val
, elt
, lexenv
;
978 int count
= SPECPDL_INDEX ();
979 struct gcpro gcpro1
, gcpro2
, gcpro3
;
981 GCPRO3 (args
, elt
, varlist
);
983 lexenv
= Vinternal_interpreter_environment
;
985 varlist
= Fcar (args
);
986 while (CONSP (varlist
))
990 elt
= XCAR (varlist
);
996 else if (! NILP (Fcdr (Fcdr (elt
))))
997 signal_error ("`let' bindings can have only one value-form", elt
);
1001 val
= eval_sub (Fcar (Fcdr (elt
)));
1004 if (!NILP (lexenv
) && SYMBOLP (var
)
1005 && !XSYMBOL (var
)->declared_special
1006 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
1007 /* Lexically bind VAR by adding it to the interpreter's binding
1011 = Fcons (Fcons (var
, val
), Vinternal_interpreter_environment
);
1012 if (EQ (Vinternal_interpreter_environment
, lexenv
))
1013 /* Save the old lexical environment on the specpdl stack,
1014 but only for the first lexical binding, since we'll never
1015 need to revert to one of the intermediate ones. */
1016 specbind (Qinternal_interpreter_environment
, newenv
);
1018 Vinternal_interpreter_environment
= newenv
;
1021 specbind (var
, val
);
1023 varlist
= XCDR (varlist
);
1026 val
= Fprogn (Fcdr (args
));
1027 return unbind_to (count
, val
);
1030 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
1031 doc
: /* Bind variables according to VARLIST then eval BODY.
1032 The value of the last form in BODY is returned.
1033 Each element of VARLIST is a symbol (which is bound to nil)
1034 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
1035 All the VALUEFORMs are evalled before any symbols are bound.
1036 usage: (let VARLIST BODY...) */)
1039 Lisp_Object
*temps
, tem
, lexenv
;
1040 register Lisp_Object elt
, varlist
;
1041 int count
= SPECPDL_INDEX ();
1043 struct gcpro gcpro1
, gcpro2
;
1046 varlist
= Fcar (args
);
1048 /* Make space to hold the values to give the bound variables. */
1049 elt
= Flength (varlist
);
1050 SAFE_ALLOCA_LISP (temps
, XFASTINT (elt
));
1052 /* Compute the values and store them in `temps'. */
1054 GCPRO2 (args
, *temps
);
1057 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
1060 elt
= XCAR (varlist
);
1062 temps
[argnum
++] = Qnil
;
1063 else if (! NILP (Fcdr (Fcdr (elt
))))
1064 signal_error ("`let' bindings can have only one value-form", elt
);
1066 temps
[argnum
++] = eval_sub (Fcar (Fcdr (elt
)));
1067 gcpro2
.nvars
= argnum
;
1071 lexenv
= Vinternal_interpreter_environment
;
1073 varlist
= Fcar (args
);
1074 for (argnum
= 0; CONSP (varlist
); varlist
= XCDR (varlist
))
1078 elt
= XCAR (varlist
);
1079 var
= SYMBOLP (elt
) ? elt
: Fcar (elt
);
1080 tem
= temps
[argnum
++];
1082 if (!NILP (lexenv
) && SYMBOLP (var
)
1083 && !XSYMBOL (var
)->declared_special
1084 && NILP (Fmemq (var
, Vinternal_interpreter_environment
)))
1085 /* Lexically bind VAR by adding it to the lexenv alist. */
1086 lexenv
= Fcons (Fcons (var
, tem
), lexenv
);
1088 /* Dynamically bind VAR. */
1089 specbind (var
, tem
);
1092 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
1093 /* Instantiate a new lexical environment. */
1094 specbind (Qinternal_interpreter_environment
, lexenv
);
1096 elt
= Fprogn (Fcdr (args
));
1098 return unbind_to (count
, elt
);
1101 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
1102 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
1103 The order of execution is thus TEST, BODY, TEST, BODY and so on
1104 until TEST returns nil.
1105 usage: (while TEST BODY...) */)
1108 Lisp_Object test
, body
;
1109 struct gcpro gcpro1
, gcpro2
;
1111 GCPRO2 (test
, body
);
1115 while (!NILP (eval_sub (test
)))
1125 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
1126 doc
: /* Return result of expanding macros at top level of FORM.
1127 If FORM is not a macro call, it is returned unchanged.
1128 Otherwise, the macro is expanded and the expansion is considered
1129 in place of FORM. When a non-macro-call results, it is returned.
1131 The second optional arg ENVIRONMENT specifies an environment of macro
1132 definitions to shadow the loaded ones for use in file byte-compilation. */)
1133 (Lisp_Object form
, Lisp_Object environment
)
1135 /* With cleanups from Hallvard Furuseth. */
1136 register Lisp_Object expander
, sym
, def
, tem
;
1140 /* Come back here each time we expand a macro call,
1141 in case it expands into another macro call. */
1144 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1145 def
= sym
= XCAR (form
);
1147 /* Trace symbols aliases to other symbols
1148 until we get a symbol that is not an alias. */
1149 while (SYMBOLP (def
))
1153 tem
= Fassq (sym
, environment
);
1156 def
= XSYMBOL (sym
)->function
;
1157 if (!EQ (def
, Qunbound
))
1162 /* Right now TEM is the result from SYM in ENVIRONMENT,
1163 and if TEM is nil then DEF is SYM's function definition. */
1166 /* SYM is not mentioned in ENVIRONMENT.
1167 Look at its function definition. */
1168 if (EQ (def
, Qunbound
) || !CONSP (def
))
1169 /* Not defined or definition not suitable. */
1171 if (EQ (XCAR (def
), Qautoload
))
1173 /* Autoloading function: will it be a macro when loaded? */
1174 tem
= Fnth (make_number (4), def
);
1175 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
1176 /* Yes, load it and try again. */
1178 struct gcpro gcpro1
;
1180 do_autoload (def
, sym
);
1187 else if (!EQ (XCAR (def
), Qmacro
))
1189 else expander
= XCDR (def
);
1193 expander
= XCDR (tem
);
1194 if (NILP (expander
))
1197 form
= apply1 (expander
, XCDR (form
));
1202 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1203 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1204 TAG is evalled to get the tag to use; it must not be nil.
1206 Then the BODY is executed.
1207 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
1208 If no throw happens, `catch' returns the value of the last BODY form.
1209 If a throw happens, it specifies the value to return from `catch'.
1210 usage: (catch TAG BODY...) */)
1213 register Lisp_Object tag
;
1214 struct gcpro gcpro1
;
1217 tag
= eval_sub (Fcar (args
));
1219 return internal_catch (tag
, Fprogn
, Fcdr (args
));
1222 /* Set up a catch, then call C function FUNC on argument ARG.
1223 FUNC should return a Lisp_Object.
1224 This is how catches are done from within C code. */
1227 internal_catch (Lisp_Object tag
, Lisp_Object (*func
) (Lisp_Object
), Lisp_Object arg
)
1229 /* This structure is made part of the chain `catchlist'. */
1232 /* Fill in the components of c, and put it on the list. */
1236 c
.backlist
= backtrace_list
;
1237 c
.handlerlist
= handlerlist
;
1238 c
.lisp_eval_depth
= lisp_eval_depth
;
1239 c
.pdlcount
= SPECPDL_INDEX ();
1240 c
.poll_suppress_count
= poll_suppress_count
;
1241 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1242 c
.gcpro
= gcprolist
;
1243 c
.byte_stack
= byte_stack_list
;
1247 if (! _setjmp (c
.jmp
))
1248 c
.val
= (*func
) (arg
);
1250 /* Throw works by a longjmp that comes right here. */
1255 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1256 jump to that CATCH, returning VALUE as the value of that catch.
1258 This is the guts Fthrow and Fsignal; they differ only in the way
1259 they choose the catch tag to throw to. A catch tag for a
1260 condition-case form has a TAG of Qnil.
1262 Before each catch is discarded, unbind all special bindings and
1263 execute all unwind-protect clauses made above that catch. Unwind
1264 the handler stack as we go, so that the proper handlers are in
1265 effect for each unwind-protect clause we run. At the end, restore
1266 some static info saved in CATCH, and longjmp to the location
1269 This is used for correct unwinding in Fthrow and Fsignal. */
1272 unwind_to_catch (struct catchtag
*catch, Lisp_Object value
)
1274 register int last_time
;
1276 /* Save the value in the tag. */
1279 /* Restore certain special C variables. */
1280 set_poll_suppress_count (catch->poll_suppress_count
);
1281 UNBLOCK_INPUT_TO (catch->interrupt_input_blocked
);
1282 handling_signal
= 0;
1287 last_time
= catchlist
== catch;
1289 /* Unwind the specpdl stack, and then restore the proper set of
1291 unbind_to (catchlist
->pdlcount
, Qnil
);
1292 handlerlist
= catchlist
->handlerlist
;
1293 catchlist
= catchlist
->next
;
1295 while (! last_time
);
1298 /* If x_catch_errors was done, turn it off now.
1299 (First we give unbind_to a chance to do that.) */
1300 #if 0 /* This would disable x_catch_errors after x_connection_closed.
1301 The catch must remain in effect during that delicate
1302 state. --lorentey */
1303 x_fully_uncatch_errors ();
1307 byte_stack_list
= catch->byte_stack
;
1308 gcprolist
= catch->gcpro
;
1310 gcpro_level
= gcprolist
? gcprolist
->level
+ 1 : 0;
1312 backtrace_list
= catch->backlist
;
1313 lisp_eval_depth
= catch->lisp_eval_depth
;
1315 _longjmp (catch->jmp
, 1);
1318 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1319 doc
: /* Throw to the catch for TAG and return VALUE from it.
1320 Both TAG and VALUE are evalled. */)
1321 (register Lisp_Object tag
, Lisp_Object value
)
1323 register struct catchtag
*c
;
1326 for (c
= catchlist
; c
; c
= c
->next
)
1328 if (EQ (c
->tag
, tag
))
1329 unwind_to_catch (c
, value
);
1331 xsignal2 (Qno_catch
, tag
, value
);
1335 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1336 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1337 If BODYFORM completes normally, its value is returned
1338 after executing the UNWINDFORMS.
1339 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1340 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1344 int count
= SPECPDL_INDEX ();
1346 record_unwind_protect (Fprogn
, Fcdr (args
));
1347 val
= eval_sub (Fcar (args
));
1348 return unbind_to (count
, val
);
1351 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1352 doc
: /* Regain control when an error is signaled.
1353 Executes BODYFORM and returns its value if no error happens.
1354 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1355 where the BODY is made of Lisp expressions.
1357 A handler is applicable to an error
1358 if CONDITION-NAME is one of the error's condition names.
1359 If an error happens, the first applicable handler is run.
1361 The car of a handler may be a list of condition names
1362 instead of a single condition name. Then it handles all of them.
1364 When a handler handles an error, control returns to the `condition-case'
1365 and it executes the handler's BODY...
1366 with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
1367 \(If VAR is nil, the handler can't access that information.)
1368 Then the value of the last BODY form is returned from the `condition-case'
1371 See also the function `signal' for more info.
1372 usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
1375 register Lisp_Object bodyform
, handlers
;
1376 volatile Lisp_Object var
;
1379 bodyform
= Fcar (Fcdr (args
));
1380 handlers
= Fcdr (Fcdr (args
));
1382 return internal_lisp_condition_case (var
, bodyform
, handlers
);
1385 /* Like Fcondition_case, but the args are separate
1386 rather than passed in a list. Used by Fbyte_code. */
1389 internal_lisp_condition_case (volatile Lisp_Object var
, Lisp_Object bodyform
,
1390 Lisp_Object handlers
)
1398 for (val
= handlers
; CONSP (val
); val
= XCDR (val
))
1404 && (SYMBOLP (XCAR (tem
))
1405 || CONSP (XCAR (tem
))))))
1406 error ("Invalid condition handler: %s",
1407 SDATA (Fprin1_to_string (tem
, Qt
)));
1412 c
.backlist
= backtrace_list
;
1413 c
.handlerlist
= handlerlist
;
1414 c
.lisp_eval_depth
= lisp_eval_depth
;
1415 c
.pdlcount
= SPECPDL_INDEX ();
1416 c
.poll_suppress_count
= poll_suppress_count
;
1417 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1418 c
.gcpro
= gcprolist
;
1419 c
.byte_stack
= byte_stack_list
;
1420 if (_setjmp (c
.jmp
))
1423 specbind (h
.var
, c
.val
);
1424 val
= Fprogn (Fcdr (h
.chosen_clause
));
1426 /* Note that this just undoes the binding of h.var; whoever
1427 longjumped to us unwound the stack to c.pdlcount before
1429 unbind_to (c
.pdlcount
, Qnil
);
1436 h
.handler
= handlers
;
1437 h
.next
= handlerlist
;
1441 val
= eval_sub (bodyform
);
1443 handlerlist
= h
.next
;
1447 /* Call the function BFUN with no arguments, catching errors within it
1448 according to HANDLERS. If there is an error, call HFUN with
1449 one argument which is the data that describes the error:
1452 HANDLERS can be a list of conditions to catch.
1453 If HANDLERS is Qt, catch all errors.
1454 If HANDLERS is Qerror, catch all errors
1455 but allow the debugger to run if that is enabled. */
1458 internal_condition_case (Lisp_Object (*bfun
) (void), Lisp_Object handlers
,
1459 Lisp_Object (*hfun
) (Lisp_Object
))
1465 /* Since Fsignal will close off all calls to x_catch_errors,
1466 we will get the wrong results if some are not closed now. */
1468 if (x_catching_errors ())
1474 c
.backlist
= backtrace_list
;
1475 c
.handlerlist
= handlerlist
;
1476 c
.lisp_eval_depth
= lisp_eval_depth
;
1477 c
.pdlcount
= SPECPDL_INDEX ();
1478 c
.poll_suppress_count
= poll_suppress_count
;
1479 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1480 c
.gcpro
= gcprolist
;
1481 c
.byte_stack
= byte_stack_list
;
1482 if (_setjmp (c
.jmp
))
1484 return (*hfun
) (c
.val
);
1488 h
.handler
= handlers
;
1490 h
.next
= handlerlist
;
1496 handlerlist
= h
.next
;
1500 /* Like internal_condition_case but call BFUN with ARG as its argument. */
1503 internal_condition_case_1 (Lisp_Object (*bfun
) (Lisp_Object
), Lisp_Object arg
,
1504 Lisp_Object handlers
, Lisp_Object (*hfun
) (Lisp_Object
))
1510 /* Since Fsignal will close off all calls to x_catch_errors,
1511 we will get the wrong results if some are not closed now. */
1513 if (x_catching_errors ())
1519 c
.backlist
= backtrace_list
;
1520 c
.handlerlist
= handlerlist
;
1521 c
.lisp_eval_depth
= lisp_eval_depth
;
1522 c
.pdlcount
= SPECPDL_INDEX ();
1523 c
.poll_suppress_count
= poll_suppress_count
;
1524 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1525 c
.gcpro
= gcprolist
;
1526 c
.byte_stack
= byte_stack_list
;
1527 if (_setjmp (c
.jmp
))
1529 return (*hfun
) (c
.val
);
1533 h
.handler
= handlers
;
1535 h
.next
= handlerlist
;
1539 val
= (*bfun
) (arg
);
1541 handlerlist
= h
.next
;
1545 /* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as
1549 internal_condition_case_2 (Lisp_Object (*bfun
) (Lisp_Object
, Lisp_Object
),
1552 Lisp_Object handlers
,
1553 Lisp_Object (*hfun
) (Lisp_Object
))
1559 /* Since Fsignal will close off all calls to x_catch_errors,
1560 we will get the wrong results if some are not closed now. */
1562 if (x_catching_errors ())
1568 c
.backlist
= backtrace_list
;
1569 c
.handlerlist
= handlerlist
;
1570 c
.lisp_eval_depth
= lisp_eval_depth
;
1571 c
.pdlcount
= SPECPDL_INDEX ();
1572 c
.poll_suppress_count
= poll_suppress_count
;
1573 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1574 c
.gcpro
= gcprolist
;
1575 c
.byte_stack
= byte_stack_list
;
1576 if (_setjmp (c
.jmp
))
1578 return (*hfun
) (c
.val
);
1582 h
.handler
= handlers
;
1584 h
.next
= handlerlist
;
1588 val
= (*bfun
) (arg1
, arg2
);
1590 handlerlist
= h
.next
;
1594 /* Like internal_condition_case but call BFUN with NARGS as first,
1595 and ARGS as second argument. */
1598 internal_condition_case_n (Lisp_Object (*bfun
) (ptrdiff_t, Lisp_Object
*),
1601 Lisp_Object handlers
,
1602 Lisp_Object (*hfun
) (Lisp_Object
))
1608 /* Since Fsignal will close off all calls to x_catch_errors,
1609 we will get the wrong results if some are not closed now. */
1611 if (x_catching_errors ())
1617 c
.backlist
= backtrace_list
;
1618 c
.handlerlist
= handlerlist
;
1619 c
.lisp_eval_depth
= lisp_eval_depth
;
1620 c
.pdlcount
= SPECPDL_INDEX ();
1621 c
.poll_suppress_count
= poll_suppress_count
;
1622 c
.interrupt_input_blocked
= interrupt_input_blocked
;
1623 c
.gcpro
= gcprolist
;
1624 c
.byte_stack
= byte_stack_list
;
1625 if (_setjmp (c
.jmp
))
1627 return (*hfun
) (c
.val
);
1631 h
.handler
= handlers
;
1633 h
.next
= handlerlist
;
1637 val
= (*bfun
) (nargs
, args
);
1639 handlerlist
= h
.next
;
1644 static Lisp_Object
find_handler_clause (Lisp_Object
, Lisp_Object
);
1645 static int maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
,
1648 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1649 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1650 This function does not return.
1652 An error symbol is a symbol with an `error-conditions' property
1653 that is a list of condition names.
1654 A handler for any of those names will get to handle this signal.
1655 The symbol `error' should normally be one of them.
1657 DATA should be a list. Its elements are printed as part of the error message.
1658 See Info anchor `(elisp)Definition of signal' for some details on how this
1659 error message is constructed.
1660 If the signal is handled, DATA is made available to the handler.
1661 See also the function `condition-case'. */)
1662 (Lisp_Object error_symbol
, Lisp_Object data
)
1664 /* When memory is full, ERROR-SYMBOL is nil,
1665 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1666 That is a special case--don't do this in other situations. */
1667 Lisp_Object conditions
;
1669 Lisp_Object real_error_symbol
1670 = (NILP (error_symbol
) ? Fcar (data
) : error_symbol
);
1671 register Lisp_Object clause
= Qnil
;
1673 struct backtrace
*bp
;
1675 immediate_quit
= handling_signal
= 0;
1677 if (gc_in_progress
|| waiting_for_input
)
1680 #if 0 /* rms: I don't know why this was here,
1681 but it is surely wrong for an error that is handled. */
1682 #ifdef HAVE_WINDOW_SYSTEM
1683 if (display_hourglass_p
)
1684 cancel_hourglass ();
1688 /* This hook is used by edebug. */
1689 if (! NILP (Vsignal_hook_function
)
1690 && ! NILP (error_symbol
))
1692 /* Edebug takes care of restoring these variables when it exits. */
1693 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1694 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1696 if (SPECPDL_INDEX () + 40 > max_specpdl_size
)
1697 max_specpdl_size
= SPECPDL_INDEX () + 40;
1699 call2 (Vsignal_hook_function
, error_symbol
, data
);
1702 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1704 /* Remember from where signal was called. Skip over the frame for
1705 `signal' itself. If a frame for `error' follows, skip that,
1706 too. Don't do this when ERROR_SYMBOL is nil, because that
1707 is a memory-full error. */
1708 Vsignaling_function
= Qnil
;
1709 if (backtrace_list
&& !NILP (error_symbol
))
1711 bp
= backtrace_list
->next
;
1712 if (bp
&& bp
->function
&& EQ (*bp
->function
, Qerror
))
1714 if (bp
&& bp
->function
)
1715 Vsignaling_function
= *bp
->function
;
1718 for (h
= handlerlist
; h
; h
= h
->next
)
1720 clause
= find_handler_clause (h
->handler
, conditions
);
1725 if (/* Don't run the debugger for a memory-full error.
1726 (There is no room in memory to do that!) */
1727 !NILP (error_symbol
)
1728 && (!NILP (Vdebug_on_signal
)
1729 /* If no handler is present now, try to run the debugger. */
1731 /* Special handler that means "print a message and run debugger
1733 || EQ (h
->handler
, Qerror
)))
1736 = maybe_call_debugger (conditions
, error_symbol
, data
);
1737 /* We can't return values to code which signaled an error, but we
1738 can continue code which has signaled a quit. */
1739 if (debugger_called
&& EQ (real_error_symbol
, Qquit
))
1745 Lisp_Object unwind_data
1746 = (NILP (error_symbol
) ? data
: Fcons (error_symbol
, data
));
1748 h
->chosen_clause
= clause
;
1749 unwind_to_catch (h
->tag
, unwind_data
);
1754 Fthrow (Qtop_level
, Qt
);
1757 if (! NILP (error_symbol
))
1758 data
= Fcons (error_symbol
, data
);
1760 string
= Ferror_message_string (data
);
1761 fatal ("%s", SDATA (string
));
1764 /* Internal version of Fsignal that never returns.
1765 Used for anything but Qquit (which can return from Fsignal). */
1768 xsignal (Lisp_Object error_symbol
, Lisp_Object data
)
1770 Fsignal (error_symbol
, data
);
1774 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list. */
1777 xsignal0 (Lisp_Object error_symbol
)
1779 xsignal (error_symbol
, Qnil
);
1783 xsignal1 (Lisp_Object error_symbol
, Lisp_Object arg
)
1785 xsignal (error_symbol
, list1 (arg
));
1789 xsignal2 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
)
1791 xsignal (error_symbol
, list2 (arg1
, arg2
));
1795 xsignal3 (Lisp_Object error_symbol
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
1797 xsignal (error_symbol
, list3 (arg1
, arg2
, arg3
));
1800 /* Signal `error' with message S, and additional arg ARG.
1801 If ARG is not a genuine list, make it a one-element list. */
1804 signal_error (const char *s
, Lisp_Object arg
)
1806 Lisp_Object tortoise
, hare
;
1808 hare
= tortoise
= arg
;
1809 while (CONSP (hare
))
1816 tortoise
= XCDR (tortoise
);
1818 if (EQ (hare
, tortoise
))
1823 arg
= Fcons (arg
, Qnil
); /* Make it a list. */
1825 xsignal (Qerror
, Fcons (build_string (s
), arg
));
1829 /* Return nonzero if LIST is a non-nil atom or
1830 a list containing one of CONDITIONS. */
1833 wants_debugger (Lisp_Object list
, Lisp_Object conditions
)
1840 while (CONSP (conditions
))
1842 Lisp_Object
this, tail
;
1843 this = XCAR (conditions
);
1844 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1845 if (EQ (XCAR (tail
), this))
1847 conditions
= XCDR (conditions
);
1852 /* Return 1 if an error with condition-symbols CONDITIONS,
1853 and described by SIGNAL-DATA, should skip the debugger
1854 according to debugger-ignored-errors. */
1857 skip_debugger (Lisp_Object conditions
, Lisp_Object data
)
1860 int first_string
= 1;
1861 Lisp_Object error_message
;
1863 error_message
= Qnil
;
1864 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1866 if (STRINGP (XCAR (tail
)))
1870 error_message
= Ferror_message_string (data
);
1874 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1879 Lisp_Object contail
;
1881 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1882 if (EQ (XCAR (tail
), XCAR (contail
)))
1890 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1891 SIG and DATA describe the signal. There are two ways to pass them:
1892 = SIG is the error symbol, and DATA is the rest of the data.
1893 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1894 This is for memory-full errors only. */
1896 maybe_call_debugger (Lisp_Object conditions
, Lisp_Object sig
, Lisp_Object data
)
1898 Lisp_Object combined_data
;
1900 combined_data
= Fcons (sig
, data
);
1903 /* Don't try to run the debugger with interrupts blocked.
1904 The editing loop would return anyway. */
1906 /* Does user want to enter debugger for this kind of error? */
1909 : wants_debugger (Vdebug_on_error
, conditions
))
1910 && ! skip_debugger (conditions
, combined_data
)
1911 /* RMS: What's this for? */
1912 && when_entered_debugger
< num_nonmacro_input_events
)
1914 call_debugger (Fcons (Qerror
, Fcons (combined_data
, Qnil
)));
1922 find_handler_clause (Lisp_Object handlers
, Lisp_Object conditions
)
1924 register Lisp_Object h
;
1926 /* t is used by handlers for all conditions, set up by C code. */
1927 if (EQ (handlers
, Qt
))
1930 /* error is used similarly, but means print an error message
1931 and run the debugger if that is enabled. */
1932 if (EQ (handlers
, Qerror
))
1935 for (h
= handlers
; CONSP (h
); h
= XCDR (h
))
1937 Lisp_Object handler
= XCAR (h
);
1938 Lisp_Object condit
, tem
;
1940 if (!CONSP (handler
))
1942 condit
= XCAR (handler
);
1943 /* Handle a single condition name in handler HANDLER. */
1944 if (SYMBOLP (condit
))
1946 tem
= Fmemq (Fcar (handler
), conditions
);
1950 /* Handle a list of condition names in handler HANDLER. */
1951 else if (CONSP (condit
))
1954 for (tail
= condit
; CONSP (tail
); tail
= XCDR (tail
))
1956 tem
= Fmemq (XCAR (tail
), conditions
);
1967 /* Dump an error message; called like vprintf. */
1969 verror (const char *m
, va_list ap
)
1972 ptrdiff_t size
= sizeof buf
;
1973 ptrdiff_t size_max
= STRING_BYTES_BOUND
+ 1;
1974 char const *m_end
= m
+ strlen (m
);
1982 va_copy (ap_copy
, ap
);
1983 used
= doprnt (buffer
, size
, m
, m_end
, ap_copy
);
1986 /* Note: the -1 below is because `doprnt' returns the number of bytes
1987 excluding the terminating null byte, and it always terminates with a
1988 null byte, even when producing a truncated message. */
1989 if (used
< size
- 1)
1991 if (size
<= size_max
/ 2)
1993 else if (size
< size_max
)
1996 break; /* and leave the message truncated */
2000 buffer
= (char *) xmalloc (size
);
2003 string
= make_string (buffer
, used
);
2007 xsignal1 (Qerror
, string
);
2011 /* Dump an error message; called like printf. */
2015 error (const char *m
, ...)
2023 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 2, 0,
2024 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
2025 This means it contains a description for how to read arguments to give it.
2026 The value is nil for an invalid function or a symbol with no function
2029 Interactively callable functions include strings and vectors (treated
2030 as keyboard macros), lambda-expressions that contain a top-level call
2031 to `interactive', autoload definitions made by `autoload' with non-nil
2032 fourth argument, and some of the built-in functions of Lisp.
2034 Also, a symbol satisfies `commandp' if its function definition does so.
2036 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
2037 then strings and vectors are not accepted. */)
2038 (Lisp_Object function
, Lisp_Object for_call_interactively
)
2040 register Lisp_Object fun
;
2041 register Lisp_Object funcar
;
2042 Lisp_Object if_prop
= Qnil
;
2046 fun
= indirect_function (fun
); /* Check cycles. */
2047 if (NILP (fun
) || EQ (fun
, Qunbound
))
2050 /* Check an `interactive-form' property if present, analogous to the
2051 function-documentation property. */
2053 while (SYMBOLP (fun
))
2055 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
2058 fun
= Fsymbol_function (fun
);
2061 /* Emacs primitives are interactive if their DEFUN specifies an
2062 interactive spec. */
2064 return XSUBR (fun
)->intspec
? Qt
: if_prop
;
2066 /* Bytecode objects are interactive if they are long enough to
2067 have an element whose index is COMPILED_INTERACTIVE, which is
2068 where the interactive spec is stored. */
2069 else if (COMPILEDP (fun
))
2070 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
2073 /* Strings and vectors are keyboard macros. */
2074 if (STRINGP (fun
) || VECTORP (fun
))
2075 return (NILP (for_call_interactively
) ? Qt
: Qnil
);
2077 /* Lists may represent commands. */
2080 funcar
= XCAR (fun
);
2081 if (EQ (funcar
, Qclosure
))
2082 return (!NILP (Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
)))))
2084 else if (EQ (funcar
, Qlambda
))
2085 return !NILP (Fassq (Qinteractive
, Fcdr (XCDR (fun
)))) ? Qt
: if_prop
;
2086 else if (EQ (funcar
, Qautoload
))
2087 return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun
))))) ? Qt
: if_prop
;
2092 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
2093 doc
: /* Define FUNCTION to autoload from FILE.
2094 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
2095 Third arg DOCSTRING is documentation for the function.
2096 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
2097 Fifth arg TYPE indicates the type of the object:
2098 nil or omitted says FUNCTION is a function,
2099 `keymap' says FUNCTION is really a keymap, and
2100 `macro' or t says FUNCTION is really a macro.
2101 Third through fifth args give info about the real definition.
2102 They default to nil.
2103 If FUNCTION is already defined other than as an autoload,
2104 this does nothing and returns nil. */)
2105 (Lisp_Object function
, Lisp_Object file
, Lisp_Object docstring
, Lisp_Object interactive
, Lisp_Object type
)
2107 CHECK_SYMBOL (function
);
2108 CHECK_STRING (file
);
2110 /* If function is defined and not as an autoload, don't override. */
2111 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
2112 && !(CONSP (XSYMBOL (function
)->function
)
2113 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
2116 if (NILP (Vpurify_flag
))
2117 /* Only add entries after dumping, because the ones before are
2118 not useful and else we get loads of them from the loaddefs.el. */
2119 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
2121 /* We don't want the docstring in purespace (instead,
2122 Snarf-documentation should (hopefully) overwrite it).
2123 We used to use 0 here, but that leads to accidental sharing in
2124 purecopy's hash-consing, so we use a (hopefully) unique integer
2126 docstring
= make_number (XPNTR (function
));
2127 return Ffset (function
,
2128 Fpurecopy (list5 (Qautoload
, file
, docstring
,
2129 interactive
, type
)));
2133 un_autoload (Lisp_Object oldqueue
)
2135 register Lisp_Object queue
, first
, second
;
2137 /* Queue to unwind is current value of Vautoload_queue.
2138 oldqueue is the shadowed value to leave in Vautoload_queue. */
2139 queue
= Vautoload_queue
;
2140 Vautoload_queue
= oldqueue
;
2141 while (CONSP (queue
))
2143 first
= XCAR (queue
);
2144 second
= Fcdr (first
);
2145 first
= Fcar (first
);
2146 if (EQ (first
, make_number (0)))
2149 Ffset (first
, second
);
2150 queue
= XCDR (queue
);
2155 /* Load an autoloaded function.
2156 FUNNAME is the symbol which is the function's name.
2157 FUNDEF is the autoload definition (a list). */
2160 do_autoload (Lisp_Object fundef
, Lisp_Object funname
)
2162 int count
= SPECPDL_INDEX ();
2164 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2166 /* This is to make sure that loadup.el gives a clear picture
2167 of what files are preloaded and when. */
2168 if (! NILP (Vpurify_flag
))
2169 error ("Attempt to autoload %s while preparing to dump",
2170 SDATA (SYMBOL_NAME (funname
)));
2173 CHECK_SYMBOL (funname
);
2174 GCPRO3 (fun
, funname
, fundef
);
2176 /* Preserve the match data. */
2177 record_unwind_save_match_data ();
2179 /* If autoloading gets an error (which includes the error of failing
2180 to define the function being called), we use Vautoload_queue
2181 to undo function definitions and `provide' calls made by
2182 the function. We do this in the specific case of autoloading
2183 because autoloading is not an explicit request "load this file",
2184 but rather a request to "call this function".
2186 The value saved here is to be restored into Vautoload_queue. */
2187 record_unwind_protect (un_autoload
, Vautoload_queue
);
2188 Vautoload_queue
= Qt
;
2189 Fload (Fcar (Fcdr (fundef
)), Qnil
, Qt
, Qnil
, Qt
);
2191 /* Once loading finishes, don't undo it. */
2192 Vautoload_queue
= Qt
;
2193 unbind_to (count
, Qnil
);
2195 fun
= Findirect_function (fun
, Qnil
);
2197 if (!NILP (Fequal (fun
, fundef
)))
2198 error ("Autoloading failed to define function %s",
2199 SDATA (SYMBOL_NAME (funname
)));
2204 DEFUN ("eval", Feval
, Seval
, 1, 2, 0,
2205 doc
: /* Evaluate FORM and return its value.
2206 If LEXICAL is t, evaluate using lexical scoping. */)
2207 (Lisp_Object form
, Lisp_Object lexical
)
2209 int count
= SPECPDL_INDEX ();
2210 specbind (Qinternal_interpreter_environment
,
2211 NILP (lexical
) ? Qnil
: Fcons (Qt
, Qnil
));
2212 return unbind_to (count
, eval_sub (form
));
2215 /* Eval a sub-expression of the current expression (i.e. in the same
2218 eval_sub (Lisp_Object form
)
2220 Lisp_Object fun
, val
, original_fun
, original_args
;
2222 struct backtrace backtrace
;
2223 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2225 if (handling_signal
)
2230 /* Look up its binding in the lexical environment.
2231 We do not pay attention to the declared_special flag here, since we
2232 already did that when let-binding the variable. */
2233 Lisp_Object lex_binding
2234 = !NILP (Vinternal_interpreter_environment
) /* Mere optimization! */
2235 ? Fassq (form
, Vinternal_interpreter_environment
)
2237 if (CONSP (lex_binding
))
2238 return XCDR (lex_binding
);
2240 return Fsymbol_value (form
);
2247 if ((consing_since_gc
> gc_cons_threshold
2248 && consing_since_gc
> gc_relative_threshold
)
2250 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2253 Fgarbage_collect ();
2257 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2259 if (max_lisp_eval_depth
< 100)
2260 max_lisp_eval_depth
= 100;
2261 if (lisp_eval_depth
> max_lisp_eval_depth
)
2262 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2265 original_fun
= Fcar (form
);
2266 original_args
= Fcdr (form
);
2268 backtrace
.next
= backtrace_list
;
2269 backtrace_list
= &backtrace
;
2270 backtrace
.function
= &original_fun
; /* This also protects them from gc. */
2271 backtrace
.args
= &original_args
;
2272 backtrace
.nargs
= UNEVALLED
;
2273 backtrace
.debug_on_exit
= 0;
2275 if (debug_on_next_call
)
2276 do_debug_on_call (Qt
);
2278 /* At this point, only original_fun and original_args
2279 have values that will be used below. */
2282 /* Optimize for no indirection. */
2284 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2285 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2286 fun
= indirect_function (fun
);
2290 Lisp_Object numargs
;
2291 Lisp_Object argvals
[8];
2292 Lisp_Object args_left
;
2293 register int i
, maxargs
;
2295 args_left
= original_args
;
2296 numargs
= Flength (args_left
);
2300 if (XINT (numargs
) < XSUBR (fun
)->min_args
2301 || (XSUBR (fun
)->max_args
>= 0
2302 && XSUBR (fun
)->max_args
< XINT (numargs
)))
2303 xsignal2 (Qwrong_number_of_arguments
, original_fun
, numargs
);
2305 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2306 val
= (XSUBR (fun
)->function
.aUNEVALLED
) (args_left
);
2307 else if (XSUBR (fun
)->max_args
== MANY
)
2309 /* Pass a vector of evaluated arguments. */
2311 ptrdiff_t argnum
= 0;
2314 SAFE_ALLOCA_LISP (vals
, XINT (numargs
));
2316 GCPRO3 (args_left
, fun
, fun
);
2320 while (!NILP (args_left
))
2322 vals
[argnum
++] = eval_sub (Fcar (args_left
));
2323 args_left
= Fcdr (args_left
);
2324 gcpro3
.nvars
= argnum
;
2327 backtrace
.args
= vals
;
2328 backtrace
.nargs
= XINT (numargs
);
2330 val
= (XSUBR (fun
)->function
.aMANY
) (XINT (numargs
), vals
);
2336 GCPRO3 (args_left
, fun
, fun
);
2337 gcpro3
.var
= argvals
;
2340 maxargs
= XSUBR (fun
)->max_args
;
2341 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
2343 argvals
[i
] = eval_sub (Fcar (args_left
));
2349 backtrace
.args
= argvals
;
2350 backtrace
.nargs
= XINT (numargs
);
2355 val
= (XSUBR (fun
)->function
.a0 ());
2358 val
= (XSUBR (fun
)->function
.a1 (argvals
[0]));
2361 val
= (XSUBR (fun
)->function
.a2 (argvals
[0], argvals
[1]));
2364 val
= (XSUBR (fun
)->function
.a3
2365 (argvals
[0], argvals
[1], argvals
[2]));
2368 val
= (XSUBR (fun
)->function
.a4
2369 (argvals
[0], argvals
[1], argvals
[2], argvals
[3]));
2372 val
= (XSUBR (fun
)->function
.a5
2373 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2377 val
= (XSUBR (fun
)->function
.a6
2378 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2379 argvals
[4], argvals
[5]));
2382 val
= (XSUBR (fun
)->function
.a7
2383 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2384 argvals
[4], argvals
[5], argvals
[6]));
2388 val
= (XSUBR (fun
)->function
.a8
2389 (argvals
[0], argvals
[1], argvals
[2], argvals
[3],
2390 argvals
[4], argvals
[5], argvals
[6], argvals
[7]));
2394 /* Someone has created a subr that takes more arguments than
2395 is supported by this code. We need to either rewrite the
2396 subr to use a different argument protocol, or add more
2397 cases to this switch. */
2402 else if (COMPILEDP (fun
))
2403 val
= apply_lambda (fun
, original_args
);
2406 if (EQ (fun
, Qunbound
))
2407 xsignal1 (Qvoid_function
, original_fun
);
2409 xsignal1 (Qinvalid_function
, original_fun
);
2410 funcar
= XCAR (fun
);
2411 if (!SYMBOLP (funcar
))
2412 xsignal1 (Qinvalid_function
, original_fun
);
2413 if (EQ (funcar
, Qautoload
))
2415 do_autoload (fun
, original_fun
);
2418 if (EQ (funcar
, Qmacro
))
2419 val
= eval_sub (apply1 (Fcdr (fun
), original_args
));
2420 else if (EQ (funcar
, Qlambda
)
2421 || EQ (funcar
, Qclosure
))
2422 val
= apply_lambda (fun
, original_args
);
2424 xsignal1 (Qinvalid_function
, original_fun
);
2429 if (backtrace
.debug_on_exit
)
2430 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2431 backtrace_list
= backtrace
.next
;
2436 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
2437 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2438 Then return the value FUNCTION returns.
2439 Thus, (apply '+ 1 2 '(3 4)) returns 10.
2440 usage: (apply FUNCTION &rest ARGUMENTS) */)
2441 (ptrdiff_t nargs
, Lisp_Object
*args
)
2443 ptrdiff_t i
, numargs
;
2444 register Lisp_Object spread_arg
;
2445 register Lisp_Object
*funcall_args
;
2446 Lisp_Object fun
, retval
;
2447 struct gcpro gcpro1
;
2452 spread_arg
= args
[nargs
- 1];
2453 CHECK_LIST (spread_arg
);
2455 numargs
= XINT (Flength (spread_arg
));
2458 return Ffuncall (nargs
- 1, args
);
2459 else if (numargs
== 1)
2461 args
[nargs
- 1] = XCAR (spread_arg
);
2462 return Ffuncall (nargs
, args
);
2465 numargs
+= nargs
- 2;
2467 /* Optimize for no indirection. */
2468 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2469 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2470 fun
= indirect_function (fun
);
2471 if (EQ (fun
, Qunbound
))
2473 /* Let funcall get the error. */
2480 if (numargs
< XSUBR (fun
)->min_args
2481 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2482 goto funcall
; /* Let funcall get the error. */
2483 else if (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
> numargs
)
2485 /* Avoid making funcall cons up a yet another new vector of arguments
2486 by explicitly supplying nil's for optional values. */
2487 SAFE_ALLOCA_LISP (funcall_args
, 1 + XSUBR (fun
)->max_args
);
2488 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2489 funcall_args
[++i
] = Qnil
;
2490 GCPRO1 (*funcall_args
);
2491 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2495 /* We add 1 to numargs because funcall_args includes the
2496 function itself as well as its arguments. */
2499 SAFE_ALLOCA_LISP (funcall_args
, 1 + numargs
);
2500 GCPRO1 (*funcall_args
);
2501 gcpro1
.nvars
= 1 + numargs
;
2504 memcpy (funcall_args
, args
, nargs
* sizeof (Lisp_Object
));
2505 /* Spread the last arg we got. Its first element goes in
2506 the slot that it used to occupy, hence this value of I. */
2508 while (!NILP (spread_arg
))
2510 funcall_args
[i
++] = XCAR (spread_arg
);
2511 spread_arg
= XCDR (spread_arg
);
2514 /* By convention, the caller needs to gcpro Ffuncall's args. */
2515 retval
= Ffuncall (gcpro1
.nvars
, funcall_args
);
2522 /* Run hook variables in various ways. */
2525 funcall_nil (ptrdiff_t nargs
, Lisp_Object
*args
)
2527 Ffuncall (nargs
, args
);
2531 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2532 doc
: /* Run each hook in HOOKS.
2533 Each argument should be a symbol, a hook variable.
2534 These symbols are processed in the order specified.
2535 If a hook symbol has a non-nil value, that value may be a function
2536 or a list of functions to be called to run the hook.
2537 If the value is a function, it is called with no arguments.
2538 If it is a list, the elements are called, in order, with no arguments.
2540 Major modes should not use this function directly to run their mode
2541 hook; they should use `run-mode-hooks' instead.
2543 Do not use `make-local-variable' to make a hook variable buffer-local.
2544 Instead, use `add-hook' and specify t for the LOCAL argument.
2545 usage: (run-hooks &rest HOOKS) */)
2546 (ptrdiff_t nargs
, Lisp_Object
*args
)
2548 Lisp_Object hook
[1];
2551 for (i
= 0; i
< nargs
; i
++)
2554 run_hook_with_args (1, hook
, funcall_nil
);
2560 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2561 Srun_hook_with_args
, 1, MANY
, 0,
2562 doc
: /* Run HOOK with the specified arguments ARGS.
2563 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2564 value, that value may be a function or a list of functions to be
2565 called to run the hook. If the value is a function, it is called with
2566 the given arguments and its return value is returned. If it is a list
2567 of functions, those functions are called, in order,
2568 with the given arguments ARGS.
2569 It is best not to depend on the value returned by `run-hook-with-args',
2572 Do not use `make-local-variable' to make a hook variable buffer-local.
2573 Instead, use `add-hook' and specify t for the LOCAL argument.
2574 usage: (run-hook-with-args HOOK &rest ARGS) */)
2575 (ptrdiff_t nargs
, Lisp_Object
*args
)
2577 return run_hook_with_args (nargs
, args
, funcall_nil
);
2580 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2581 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2582 doc
: /* Run HOOK with the specified arguments ARGS.
2583 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2584 value, that value may be a function or a list of functions to be
2585 called to run the hook. If the value is a function, it is called with
2586 the given arguments and its return value is returned.
2587 If it is a list of functions, those functions are called, in order,
2588 with the given arguments ARGS, until one of them
2589 returns a non-nil value. Then we return that value.
2590 However, if they all return nil, we return nil.
2592 Do not use `make-local-variable' to make a hook variable buffer-local.
2593 Instead, use `add-hook' and specify t for the LOCAL argument.
2594 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2595 (ptrdiff_t nargs
, Lisp_Object
*args
)
2597 return run_hook_with_args (nargs
, args
, Ffuncall
);
2601 funcall_not (ptrdiff_t nargs
, Lisp_Object
*args
)
2603 return NILP (Ffuncall (nargs
, args
)) ? Qt
: Qnil
;
2606 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2607 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2608 doc
: /* Run HOOK with the specified arguments ARGS.
2609 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2610 value, that value may be a function or a list of functions to be
2611 called to run the hook. If the value is a function, it is called with
2612 the given arguments and its return value is returned.
2613 If it is a list of functions, those functions are called, in order,
2614 with the given arguments ARGS, until one of them returns nil.
2615 Then we return nil. However, if they all return non-nil, we return non-nil.
2617 Do not use `make-local-variable' to make a hook variable buffer-local.
2618 Instead, use `add-hook' and specify t for the LOCAL argument.
2619 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2620 (ptrdiff_t nargs
, Lisp_Object
*args
)
2622 return NILP (run_hook_with_args (nargs
, args
, funcall_not
)) ? Qt
: Qnil
;
2626 run_hook_wrapped_funcall (ptrdiff_t nargs
, Lisp_Object
*args
)
2628 Lisp_Object tmp
= args
[0], ret
;
2631 ret
= Ffuncall (nargs
, args
);
2637 DEFUN ("run-hook-wrapped", Frun_hook_wrapped
, Srun_hook_wrapped
, 2, MANY
, 0,
2638 doc
: /* Run HOOK, passing each function through WRAP-FUNCTION.
2639 I.e. instead of calling each function FUN directly with arguments ARGS,
2640 it calls WRAP-FUNCTION with arguments FUN and ARGS.
2641 As soon as a call to WRAP-FUNCTION returns non-nil, `run-hook-wrapped'
2642 aborts and returns that value.
2643 usage: (run-hook-wrapped HOOK WRAP-FUNCTION &rest ARGS) */)
2644 (ptrdiff_t nargs
, Lisp_Object
*args
)
2646 return run_hook_with_args (nargs
, args
, run_hook_wrapped_funcall
);
2649 /* ARGS[0] should be a hook symbol.
2650 Call each of the functions in the hook value, passing each of them
2651 as arguments all the rest of ARGS (all NARGS - 1 elements).
2652 FUNCALL specifies how to call each function on the hook.
2653 The caller (or its caller, etc) must gcpro all of ARGS,
2654 except that it isn't necessary to gcpro ARGS[0]. */
2657 run_hook_with_args (ptrdiff_t nargs
, Lisp_Object
*args
,
2658 Lisp_Object (*funcall
) (ptrdiff_t nargs
, Lisp_Object
*args
))
2660 Lisp_Object sym
, val
, ret
= Qnil
;
2661 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2663 /* If we are dying or still initializing,
2664 don't do anything--it would probably crash if we tried. */
2665 if (NILP (Vrun_hooks
))
2669 val
= find_symbol_value (sym
);
2671 if (EQ (val
, Qunbound
) || NILP (val
))
2673 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2676 return funcall (nargs
, args
);
2680 Lisp_Object global_vals
= Qnil
;
2681 GCPRO3 (sym
, val
, global_vals
);
2684 CONSP (val
) && NILP (ret
);
2687 if (EQ (XCAR (val
), Qt
))
2689 /* t indicates this hook has a local binding;
2690 it means to run the global binding too. */
2691 global_vals
= Fdefault_value (sym
);
2692 if (NILP (global_vals
)) continue;
2694 if (!CONSP (global_vals
) || EQ (XCAR (global_vals
), Qlambda
))
2696 args
[0] = global_vals
;
2697 ret
= funcall (nargs
, args
);
2702 CONSP (global_vals
) && NILP (ret
);
2703 global_vals
= XCDR (global_vals
))
2705 args
[0] = XCAR (global_vals
);
2706 /* In a global value, t should not occur. If it does, we
2707 must ignore it to avoid an endless loop. */
2708 if (!EQ (args
[0], Qt
))
2709 ret
= funcall (nargs
, args
);
2715 args
[0] = XCAR (val
);
2716 ret
= funcall (nargs
, args
);
2725 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2728 run_hook_with_args_2 (Lisp_Object hook
, Lisp_Object arg1
, Lisp_Object arg2
)
2730 Lisp_Object temp
[3];
2735 Frun_hook_with_args (3, temp
);
2738 /* Apply fn to arg. */
2740 apply1 (Lisp_Object fn
, Lisp_Object arg
)
2742 struct gcpro gcpro1
;
2746 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2749 Lisp_Object args
[2];
2753 RETURN_UNGCPRO (Fapply (2, args
));
2757 /* Call function fn on no arguments. */
2759 call0 (Lisp_Object fn
)
2761 struct gcpro gcpro1
;
2764 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2767 /* Call function fn with 1 argument arg1. */
2770 call1 (Lisp_Object fn
, Lisp_Object arg1
)
2772 struct gcpro gcpro1
;
2773 Lisp_Object args
[2];
2779 RETURN_UNGCPRO (Ffuncall (2, args
));
2782 /* Call function fn with 2 arguments arg1, arg2. */
2785 call2 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
)
2787 struct gcpro gcpro1
;
2788 Lisp_Object args
[3];
2794 RETURN_UNGCPRO (Ffuncall (3, args
));
2797 /* Call function fn with 3 arguments arg1, arg2, arg3. */
2800 call3 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2802 struct gcpro gcpro1
;
2803 Lisp_Object args
[4];
2810 RETURN_UNGCPRO (Ffuncall (4, args
));
2813 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
2816 call4 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2819 struct gcpro gcpro1
;
2820 Lisp_Object args
[5];
2828 RETURN_UNGCPRO (Ffuncall (5, args
));
2831 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
2834 call5 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2835 Lisp_Object arg4
, Lisp_Object arg5
)
2837 struct gcpro gcpro1
;
2838 Lisp_Object args
[6];
2847 RETURN_UNGCPRO (Ffuncall (6, args
));
2850 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
2853 call6 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2854 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
)
2856 struct gcpro gcpro1
;
2857 Lisp_Object args
[7];
2867 RETURN_UNGCPRO (Ffuncall (7, args
));
2870 /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
2873 call7 (Lisp_Object fn
, Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
,
2874 Lisp_Object arg4
, Lisp_Object arg5
, Lisp_Object arg6
, Lisp_Object arg7
)
2876 struct gcpro gcpro1
;
2877 Lisp_Object args
[8];
2888 RETURN_UNGCPRO (Ffuncall (8, args
));
2891 /* The caller should GCPRO all the elements of ARGS. */
2893 DEFUN ("functionp", Ffunctionp
, Sfunctionp
, 1, 1, 0,
2894 doc
: /* Non-nil if OBJECT is a function. */)
2895 (Lisp_Object object
)
2897 if (SYMBOLP (object
) && !NILP (Ffboundp (object
)))
2899 object
= Findirect_function (object
, Qt
);
2901 if (CONSP (object
) && EQ (XCAR (object
), Qautoload
))
2903 /* Autoloaded symbols are functions, except if they load
2904 macros or keymaps. */
2906 for (i
= 0; i
< 4 && CONSP (object
); i
++)
2907 object
= XCDR (object
);
2909 return (CONSP (object
) && !NILP (XCAR (object
))) ? Qnil
: Qt
;
2914 return (XSUBR (object
)->max_args
!= UNEVALLED
) ? Qt
: Qnil
;
2915 else if (COMPILEDP (object
))
2917 else if (CONSP (object
))
2919 Lisp_Object car
= XCAR (object
);
2920 return (EQ (car
, Qlambda
) || EQ (car
, Qclosure
)) ? Qt
: Qnil
;
2926 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2927 doc
: /* Call first argument as a function, passing remaining arguments to it.
2928 Return the value that function returns.
2929 Thus, (funcall 'cons 'x 'y) returns (x . y).
2930 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2931 (ptrdiff_t nargs
, Lisp_Object
*args
)
2933 Lisp_Object fun
, original_fun
;
2935 ptrdiff_t numargs
= nargs
- 1;
2936 Lisp_Object lisp_numargs
;
2938 struct backtrace backtrace
;
2939 register Lisp_Object
*internal_args
;
2943 if ((consing_since_gc
> gc_cons_threshold
2944 && consing_since_gc
> gc_relative_threshold
)
2946 (!NILP (Vmemory_full
) && consing_since_gc
> memory_full_cons_threshold
))
2947 Fgarbage_collect ();
2949 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2951 if (max_lisp_eval_depth
< 100)
2952 max_lisp_eval_depth
= 100;
2953 if (lisp_eval_depth
> max_lisp_eval_depth
)
2954 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2957 backtrace
.next
= backtrace_list
;
2958 backtrace_list
= &backtrace
;
2959 backtrace
.function
= &args
[0];
2960 backtrace
.args
= &args
[1];
2961 backtrace
.nargs
= nargs
- 1;
2962 backtrace
.debug_on_exit
= 0;
2964 if (debug_on_next_call
)
2965 do_debug_on_call (Qlambda
);
2969 original_fun
= args
[0];
2973 /* Optimize for no indirection. */
2975 if (SYMBOLP (fun
) && !EQ (fun
, Qunbound
)
2976 && (fun
= XSYMBOL (fun
)->function
, SYMBOLP (fun
)))
2977 fun
= indirect_function (fun
);
2981 if (numargs
< XSUBR (fun
)->min_args
2982 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2984 XSETFASTINT (lisp_numargs
, numargs
);
2985 xsignal2 (Qwrong_number_of_arguments
, original_fun
, lisp_numargs
);
2988 else if (XSUBR (fun
)->max_args
== UNEVALLED
)
2989 xsignal1 (Qinvalid_function
, original_fun
);
2991 else if (XSUBR (fun
)->max_args
== MANY
)
2992 val
= (XSUBR (fun
)->function
.aMANY
) (numargs
, args
+ 1);
2995 if (XSUBR (fun
)->max_args
> numargs
)
2997 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2998 memcpy (internal_args
, args
+ 1, numargs
* sizeof (Lisp_Object
));
2999 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
3000 internal_args
[i
] = Qnil
;
3003 internal_args
= args
+ 1;
3004 switch (XSUBR (fun
)->max_args
)
3007 val
= (XSUBR (fun
)->function
.a0 ());
3010 val
= (XSUBR (fun
)->function
.a1 (internal_args
[0]));
3013 val
= (XSUBR (fun
)->function
.a2
3014 (internal_args
[0], internal_args
[1]));
3017 val
= (XSUBR (fun
)->function
.a3
3018 (internal_args
[0], internal_args
[1], internal_args
[2]));
3021 val
= (XSUBR (fun
)->function
.a4
3022 (internal_args
[0], internal_args
[1], internal_args
[2],
3026 val
= (XSUBR (fun
)->function
.a5
3027 (internal_args
[0], internal_args
[1], internal_args
[2],
3028 internal_args
[3], internal_args
[4]));
3031 val
= (XSUBR (fun
)->function
.a6
3032 (internal_args
[0], internal_args
[1], internal_args
[2],
3033 internal_args
[3], internal_args
[4], internal_args
[5]));
3036 val
= (XSUBR (fun
)->function
.a7
3037 (internal_args
[0], internal_args
[1], internal_args
[2],
3038 internal_args
[3], internal_args
[4], internal_args
[5],
3043 val
= (XSUBR (fun
)->function
.a8
3044 (internal_args
[0], internal_args
[1], internal_args
[2],
3045 internal_args
[3], internal_args
[4], internal_args
[5],
3046 internal_args
[6], internal_args
[7]));
3051 /* If a subr takes more than 8 arguments without using MANY
3052 or UNEVALLED, we need to extend this function to support it.
3053 Until this is done, there is no way to call the function. */
3058 else if (COMPILEDP (fun
))
3059 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3062 if (EQ (fun
, Qunbound
))
3063 xsignal1 (Qvoid_function
, original_fun
);
3065 xsignal1 (Qinvalid_function
, original_fun
);
3066 funcar
= XCAR (fun
);
3067 if (!SYMBOLP (funcar
))
3068 xsignal1 (Qinvalid_function
, original_fun
);
3069 if (EQ (funcar
, Qlambda
)
3070 || EQ (funcar
, Qclosure
))
3071 val
= funcall_lambda (fun
, numargs
, args
+ 1);
3072 else if (EQ (funcar
, Qautoload
))
3074 do_autoload (fun
, original_fun
);
3079 xsignal1 (Qinvalid_function
, original_fun
);
3083 if (backtrace
.debug_on_exit
)
3084 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
3085 backtrace_list
= backtrace
.next
;
3090 apply_lambda (Lisp_Object fun
, Lisp_Object args
)
3092 Lisp_Object args_left
;
3093 ptrdiff_t i
, numargs
;
3094 register Lisp_Object
*arg_vector
;
3095 struct gcpro gcpro1
, gcpro2
, gcpro3
;
3096 register Lisp_Object tem
;
3099 numargs
= XFASTINT (Flength (args
));
3100 SAFE_ALLOCA_LISP (arg_vector
, numargs
);
3103 GCPRO3 (*arg_vector
, args_left
, fun
);
3106 for (i
= 0; i
< numargs
; )
3108 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
3109 tem
= eval_sub (tem
);
3110 arg_vector
[i
++] = tem
;
3116 backtrace_list
->args
= arg_vector
;
3117 backtrace_list
->nargs
= i
;
3118 tem
= funcall_lambda (fun
, numargs
, arg_vector
);
3120 /* Do the debug-on-exit now, while arg_vector still exists. */
3121 if (backtrace_list
->debug_on_exit
)
3122 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
3123 /* Don't do it again when we return to eval. */
3124 backtrace_list
->debug_on_exit
= 0;
3129 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
3130 and return the result of evaluation.
3131 FUN must be either a lambda-expression or a compiled-code object. */
3134 funcall_lambda (Lisp_Object fun
, ptrdiff_t nargs
,
3135 register Lisp_Object
*arg_vector
)
3137 Lisp_Object val
, syms_left
, next
, lexenv
;
3138 int count
= SPECPDL_INDEX ();
3144 if (EQ (XCAR (fun
), Qclosure
))
3146 fun
= XCDR (fun
); /* Drop `closure'. */
3147 lexenv
= XCAR (fun
);
3148 CHECK_LIST_CONS (fun
, fun
);
3152 syms_left
= XCDR (fun
);
3153 if (CONSP (syms_left
))
3154 syms_left
= XCAR (syms_left
);
3156 xsignal1 (Qinvalid_function
, fun
);
3158 else if (COMPILEDP (fun
))
3160 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
3161 if (INTEGERP (syms_left
))
3162 /* A byte-code object with a non-nil `push args' slot means we
3163 shouldn't bind any arguments, instead just call the byte-code
3164 interpreter directly; it will push arguments as necessary.
3166 Byte-code objects with either a non-existent, or a nil value for
3167 the `push args' slot (the default), have dynamically-bound
3168 arguments, and use the argument-binding code below instead (as do
3169 all interpreted functions, even lexically bound ones). */
3171 /* If we have not actually read the bytecode string
3172 and constants vector yet, fetch them from the file. */
3173 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3174 Ffetch_bytecode (fun
);
3175 return exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
3176 AREF (fun
, COMPILED_CONSTANTS
),
3177 AREF (fun
, COMPILED_STACK_DEPTH
),
3186 i
= optional
= rest
= 0;
3187 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
3191 next
= XCAR (syms_left
);
3192 if (!SYMBOLP (next
))
3193 xsignal1 (Qinvalid_function
, fun
);
3195 if (EQ (next
, Qand_rest
))
3197 else if (EQ (next
, Qand_optional
))
3204 arg
= Flist (nargs
- i
, &arg_vector
[i
]);
3208 arg
= arg_vector
[i
++];
3210 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3214 /* Bind the argument. */
3215 if (!NILP (lexenv
) && SYMBOLP (next
))
3216 /* Lexically bind NEXT by adding it to the lexenv alist. */
3217 lexenv
= Fcons (Fcons (next
, arg
), lexenv
);
3219 /* Dynamically bind NEXT. */
3220 specbind (next
, arg
);
3224 if (!NILP (syms_left
))
3225 xsignal1 (Qinvalid_function
, fun
);
3227 xsignal2 (Qwrong_number_of_arguments
, fun
, make_number (nargs
));
3229 if (!EQ (lexenv
, Vinternal_interpreter_environment
))
3230 /* Instantiate a new lexical environment. */
3231 specbind (Qinternal_interpreter_environment
, lexenv
);
3234 val
= Fprogn (XCDR (XCDR (fun
)));
3237 /* If we have not actually read the bytecode string
3238 and constants vector yet, fetch them from the file. */
3239 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
3240 Ffetch_bytecode (fun
);
3241 val
= exec_byte_code (AREF (fun
, COMPILED_BYTECODE
),
3242 AREF (fun
, COMPILED_CONSTANTS
),
3243 AREF (fun
, COMPILED_STACK_DEPTH
),
3247 return unbind_to (count
, val
);
3250 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
3252 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
3253 (Lisp_Object object
)
3257 if (COMPILEDP (object
) && CONSP (AREF (object
, COMPILED_BYTECODE
)))
3259 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
3262 tem
= AREF (object
, COMPILED_BYTECODE
);
3263 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
3264 error ("Invalid byte code in %s", SDATA (XCAR (tem
)));
3266 error ("Invalid byte code");
3268 ASET (object
, COMPILED_BYTECODE
, XCAR (tem
));
3269 ASET (object
, COMPILED_CONSTANTS
, XCDR (tem
));
3277 register int count
= SPECPDL_INDEX ();
3279 min (max_specpdl_size
,
3280 min (max (PTRDIFF_MAX
, SIZE_MAX
) / sizeof (struct specbinding
),
3283 if (max_size
<= specpdl_size
)
3285 if (max_specpdl_size
< 400)
3286 max_size
= max_specpdl_size
= 400;
3287 if (max_size
<= specpdl_size
)
3288 signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil
);
3290 size
= specpdl_size
< max_size
/ 2 ? 2 * specpdl_size
: max_size
;
3291 specpdl
= ((struct specbinding
*)
3292 xrealloc (specpdl
, size
* sizeof (struct specbinding
)));
3293 specpdl_size
= size
;
3294 specpdl_ptr
= specpdl
+ count
;
3297 /* `specpdl_ptr->symbol' is a field which describes which variable is
3298 let-bound, so it can be properly undone when we unbind_to.
3299 It can have the following two shapes:
3300 - SYMBOL : if it's a plain symbol, it means that we have let-bound
3301 a symbol that is not buffer-local (at least at the time
3302 the let binding started). Note also that it should not be
3303 aliased (i.e. when let-binding V1 that's aliased to V2, we want
3305 - (SYMBOL WHERE . BUFFER) : this means that it is a let-binding for
3306 variable SYMBOL which can be buffer-local. WHERE tells us
3307 which buffer is affected (or nil if the let-binding affects the
3308 global value of the variable) and BUFFER tells us which buffer was
3309 current (i.e. if WHERE is non-nil, then BUFFER==WHERE, otherwise
3310 BUFFER did not yet have a buffer-local value). */
3313 specbind (Lisp_Object symbol
, Lisp_Object value
)
3315 struct Lisp_Symbol
*sym
;
3317 eassert (!handling_signal
);
3319 CHECK_SYMBOL (symbol
);
3320 sym
= XSYMBOL (symbol
);
3321 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3325 switch (sym
->redirect
)
3327 case SYMBOL_VARALIAS
:
3328 sym
= indirect_variable (sym
); XSETSYMBOL (symbol
, sym
); goto start
;
3329 case SYMBOL_PLAINVAL
:
3330 /* The most common case is that of a non-constant symbol with a
3331 trivial value. Make that as fast as we can. */
3332 specpdl_ptr
->symbol
= symbol
;
3333 specpdl_ptr
->old_value
= SYMBOL_VAL (sym
);
3334 specpdl_ptr
->func
= NULL
;
3337 SET_SYMBOL_VAL (sym
, value
);
3339 set_internal (symbol
, value
, Qnil
, 1);
3341 case SYMBOL_LOCALIZED
:
3342 if (SYMBOL_BLV (sym
)->frame_local
)
3343 error ("Frame-local vars cannot be let-bound");
3344 case SYMBOL_FORWARDED
:
3346 Lisp_Object ovalue
= find_symbol_value (symbol
);
3347 specpdl_ptr
->func
= 0;
3348 specpdl_ptr
->old_value
= ovalue
;
3350 eassert (sym
->redirect
!= SYMBOL_LOCALIZED
3351 || (EQ (SYMBOL_BLV (sym
)->where
,
3352 SYMBOL_BLV (sym
)->frame_local
?
3353 Fselected_frame () : Fcurrent_buffer ())));
3355 if (sym
->redirect
== SYMBOL_LOCALIZED
3356 || BUFFER_OBJFWDP (SYMBOL_FWD (sym
)))
3358 Lisp_Object where
, cur_buf
= Fcurrent_buffer ();
3360 /* For a local variable, record both the symbol and which
3361 buffer's or frame's value we are saving. */
3362 if (!NILP (Flocal_variable_p (symbol
, Qnil
)))
3364 eassert (sym
->redirect
!= SYMBOL_LOCALIZED
3365 || (BLV_FOUND (SYMBOL_BLV (sym
))
3366 && EQ (cur_buf
, SYMBOL_BLV (sym
)->where
)));
3369 else if (sym
->redirect
== SYMBOL_LOCALIZED
3370 && BLV_FOUND (SYMBOL_BLV (sym
)))
3371 where
= SYMBOL_BLV (sym
)->where
;
3375 /* We're not using the `unused' slot in the specbinding
3376 structure because this would mean we have to do more
3377 work for simple variables. */
3378 /* FIXME: The third value `current_buffer' is only used in
3379 let_shadows_buffer_binding_p which is itself only used
3380 in set_internal for local_if_set. */
3381 eassert (NILP (where
) || EQ (where
, cur_buf
));
3382 specpdl_ptr
->symbol
= Fcons (symbol
, Fcons (where
, cur_buf
));
3384 /* If SYMBOL is a per-buffer variable which doesn't have a
3385 buffer-local value here, make the `let' change the global
3386 value by changing the value of SYMBOL in all buffers not
3387 having their own value. This is consistent with what
3388 happens with other buffer-local variables. */
3390 && sym
->redirect
== SYMBOL_FORWARDED
)
3392 eassert (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)));
3394 Fset_default (symbol
, value
);
3399 specpdl_ptr
->symbol
= symbol
;
3402 set_internal (symbol
, value
, Qnil
, 1);
3410 record_unwind_protect (Lisp_Object (*function
) (Lisp_Object
), Lisp_Object arg
)
3412 eassert (!handling_signal
);
3414 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3416 specpdl_ptr
->func
= function
;
3417 specpdl_ptr
->symbol
= Qnil
;
3418 specpdl_ptr
->old_value
= arg
;
3423 unbind_to (int count
, Lisp_Object value
)
3425 Lisp_Object quitf
= Vquit_flag
;
3426 struct gcpro gcpro1
, gcpro2
;
3428 GCPRO2 (value
, quitf
);
3431 while (specpdl_ptr
!= specpdl
+ count
)
3433 /* Copy the binding, and decrement specpdl_ptr, before we do
3434 the work to unbind it. We decrement first
3435 so that an error in unbinding won't try to unbind
3436 the same entry again, and we copy the binding first
3437 in case more bindings are made during some of the code we run. */
3439 struct specbinding this_binding
;
3440 this_binding
= *--specpdl_ptr
;
3442 if (this_binding
.func
!= 0)
3443 (*this_binding
.func
) (this_binding
.old_value
);
3444 /* If the symbol is a list, it is really (SYMBOL WHERE
3445 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3446 frame. If WHERE is a buffer or frame, this indicates we
3447 bound a variable that had a buffer-local or frame-local
3448 binding. WHERE nil means that the variable had the default
3449 value when it was bound. CURRENT-BUFFER is the buffer that
3450 was current when the variable was bound. */
3451 else if (CONSP (this_binding
.symbol
))
3453 Lisp_Object symbol
, where
;
3455 symbol
= XCAR (this_binding
.symbol
);
3456 where
= XCAR (XCDR (this_binding
.symbol
));
3459 Fset_default (symbol
, this_binding
.old_value
);
3460 /* If `where' is non-nil, reset the value in the appropriate
3461 local binding, but only if that binding still exists. */
3462 else if (BUFFERP (where
)
3463 ? !NILP (Flocal_variable_p (symbol
, where
))
3464 : !NILP (Fassq (symbol
, XFRAME (where
)->param_alist
)))
3465 set_internal (symbol
, this_binding
.old_value
, where
, 1);
3467 /* If variable has a trivial value (no forwarding), we can
3468 just set it. No need to check for constant symbols here,
3469 since that was already done by specbind. */
3470 else if (XSYMBOL (this_binding
.symbol
)->redirect
== SYMBOL_PLAINVAL
)
3471 SET_SYMBOL_VAL (XSYMBOL (this_binding
.symbol
),
3472 this_binding
.old_value
);
3474 /* NOTE: we only ever come here if make_local_foo was used for
3475 the first time on this var within this let. */
3476 Fset_default (this_binding
.symbol
, this_binding
.old_value
);
3479 if (NILP (Vquit_flag
) && !NILP (quitf
))
3486 DEFUN ("special-variable-p", Fspecial_variable_p
, Sspecial_variable_p
, 1, 1, 0,
3487 doc
: /* Return non-nil if SYMBOL's global binding has been declared special.
3488 A special variable is one that will be bound dynamically, even in a
3489 context where binding is lexical by default. */)
3490 (Lisp_Object symbol
)
3492 CHECK_SYMBOL (symbol
);
3493 return XSYMBOL (symbol
)->declared_special
? Qt
: Qnil
;
3497 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3498 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3499 The debugger is entered when that frame exits, if the flag is non-nil. */)
3500 (Lisp_Object level
, Lisp_Object flag
)
3502 register struct backtrace
*backlist
= backtrace_list
;
3505 CHECK_NUMBER (level
);
3507 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
3509 backlist
= backlist
->next
;
3513 backlist
->debug_on_exit
= !NILP (flag
);
3518 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3519 doc
: /* Print a trace of Lisp function calls currently active.
3520 Output stream used is value of `standard-output'. */)
3523 register struct backtrace
*backlist
= backtrace_list
;
3526 struct gcpro gcpro1
;
3527 Lisp_Object old_print_level
= Vprint_level
;
3529 if (NILP (Vprint_level
))
3530 XSETFASTINT (Vprint_level
, 8);
3537 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
3538 if (backlist
->nargs
== UNEVALLED
)
3540 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
3541 write_string ("\n", -1);
3545 tem
= *backlist
->function
;
3546 Fprin1 (tem
, Qnil
); /* This can QUIT. */
3547 write_string ("(", -1);
3548 if (backlist
->nargs
== MANY
)
3549 { /* FIXME: Can this happen? */
3551 for (tail
= *backlist
->args
, i
= 0;
3553 tail
= Fcdr (tail
), i
= 1)
3555 if (i
) write_string (" ", -1);
3556 Fprin1 (Fcar (tail
), Qnil
);
3562 for (i
= 0; i
< backlist
->nargs
; i
++)
3564 if (i
) write_string (" ", -1);
3565 Fprin1 (backlist
->args
[i
], Qnil
);
3568 write_string (")\n", -1);
3570 backlist
= backlist
->next
;
3573 Vprint_level
= old_print_level
;
3578 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, NULL
,
3579 doc
: /* Return the function and arguments NFRAMES up from current execution point.
3580 If that frame has not evaluated the arguments yet (or is a special form),
3581 the value is (nil FUNCTION ARG-FORMS...).
3582 If that frame has evaluated its arguments and called its function already,
3583 the value is (t FUNCTION ARG-VALUES...).
3584 A &rest arg is represented as the tail of the list ARG-VALUES.
3585 FUNCTION is whatever was supplied as car of evaluated list,
3586 or a lambda expression for macro calls.
3587 If NFRAMES is more than the number of frames, the value is nil. */)
3588 (Lisp_Object nframes
)
3590 register struct backtrace
*backlist
= backtrace_list
;
3591 register EMACS_INT i
;
3594 CHECK_NATNUM (nframes
);
3596 /* Find the frame requested. */
3597 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3598 backlist
= backlist
->next
;
3602 if (backlist
->nargs
== UNEVALLED
)
3603 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3606 if (backlist
->nargs
== MANY
) /* FIXME: Can this happen? */
3607 tem
= *backlist
->args
;
3609 tem
= Flist (backlist
->nargs
, backlist
->args
);
3611 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3618 mark_backtrace (void)
3620 register struct backtrace
*backlist
;
3623 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3625 mark_object (*backlist
->function
);
3627 if (backlist
->nargs
== UNEVALLED
3628 || backlist
->nargs
== MANY
) /* FIXME: Can this happen? */
3631 i
= backlist
->nargs
;
3633 mark_object (backlist
->args
[i
]);
3641 DEFVAR_INT ("max-specpdl-size", max_specpdl_size
,
3642 doc
: /* *Limit on number of Lisp variable bindings and `unwind-protect's.
3643 If Lisp code tries to increase the total number past this amount,
3644 an error is signaled.
3645 You can safely use a value considerably larger than the default value,
3646 if that proves inconveniently small. However, if you increase it too far,
3647 Emacs could run out of memory trying to make the stack bigger. */);
3649 DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth
,
3650 doc
: /* *Limit on depth in `eval', `apply' and `funcall' before error.
3652 This limit serves to catch infinite recursions for you before they cause
3653 actual stack overflow in C, which would be fatal for Emacs.
3654 You can safely make it considerably larger than its default value,
3655 if that proves inconveniently small. However, if you increase it too far,
3656 Emacs could overflow the real C stack, and crash. */);
3658 DEFVAR_LISP ("quit-flag", Vquit_flag
,
3659 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3660 If the value is t, that means do an ordinary quit.
3661 If the value equals `throw-on-input', that means quit by throwing
3662 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3663 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3664 but `inhibit-quit' non-nil prevents anything from taking notice of that. */);
3667 DEFVAR_LISP ("inhibit-quit", Vinhibit_quit
,
3668 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3669 Note that `quit-flag' will still be set by typing C-g,
3670 so a quit will be signaled as soon as `inhibit-quit' is nil.
3671 To prevent this happening, set `quit-flag' to nil
3672 before making `inhibit-quit' nil. */);
3673 Vinhibit_quit
= Qnil
;
3675 DEFSYM (Qinhibit_quit
, "inhibit-quit");
3676 DEFSYM (Qautoload
, "autoload");
3677 DEFSYM (Qdebug_on_error
, "debug-on-error");
3678 DEFSYM (Qmacro
, "macro");
3679 DEFSYM (Qdeclare
, "declare");
3681 /* Note that the process handling also uses Qexit, but we don't want
3682 to staticpro it twice, so we just do it here. */
3683 DEFSYM (Qexit
, "exit");
3685 DEFSYM (Qinteractive
, "interactive");
3686 DEFSYM (Qcommandp
, "commandp");
3687 DEFSYM (Qdefun
, "defun");
3688 DEFSYM (Qand_rest
, "&rest");
3689 DEFSYM (Qand_optional
, "&optional");
3690 DEFSYM (Qclosure
, "closure");
3691 DEFSYM (Qdebug
, "debug");
3693 DEFVAR_LISP ("debug-on-error", Vdebug_on_error
,
3694 doc
: /* *Non-nil means enter debugger if an error is signaled.
3695 Does not apply to errors handled by `condition-case' or those
3696 matched by `debug-ignored-errors'.
3697 If the value is a list, an error only means to enter the debugger
3698 if one of its condition symbols appears in the list.
3699 When you evaluate an expression interactively, this variable
3700 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3701 The command `toggle-debug-on-error' toggles this.
3702 See also the variable `debug-on-quit'. */);
3703 Vdebug_on_error
= Qnil
;
3705 DEFVAR_LISP ("debug-ignored-errors", Vdebug_ignored_errors
,
3706 doc
: /* *List of errors for which the debugger should not be called.
3707 Each element may be a condition-name or a regexp that matches error messages.
3708 If any element applies to a given error, that error skips the debugger
3709 and just returns to top level.
3710 This overrides the variable `debug-on-error'.
3711 It does not apply to errors handled by `condition-case'. */);
3712 Vdebug_ignored_errors
= Qnil
;
3714 DEFVAR_BOOL ("debug-on-quit", debug_on_quit
,
3715 doc
: /* *Non-nil means enter debugger if quit is signaled (C-g, for example).
3716 Does not apply if quit is handled by a `condition-case'. */);
3719 DEFVAR_BOOL ("debug-on-next-call", debug_on_next_call
,
3720 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3722 DEFVAR_BOOL ("debugger-may-continue", debugger_may_continue
,
3723 doc
: /* Non-nil means debugger may continue execution.
3724 This is nil when the debugger is called under circumstances where it
3725 might not be safe to continue. */);
3726 debugger_may_continue
= 1;
3728 DEFVAR_LISP ("debugger", Vdebugger
,
3729 doc
: /* Function to call to invoke debugger.
3730 If due to frame exit, args are `exit' and the value being returned;
3731 this function's value will be returned instead of that.
3732 If due to error, args are `error' and a list of the args to `signal'.
3733 If due to `apply' or `funcall' entry, one arg, `lambda'.
3734 If due to `eval' entry, one arg, t. */);
3737 DEFVAR_LISP ("signal-hook-function", Vsignal_hook_function
,
3738 doc
: /* If non-nil, this is a function for `signal' to call.
3739 It receives the same arguments that `signal' was given.
3740 The Edebug package uses this to regain control. */);
3741 Vsignal_hook_function
= Qnil
;
3743 DEFVAR_LISP ("debug-on-signal", Vdebug_on_signal
,
3744 doc
: /* *Non-nil means call the debugger regardless of condition handlers.
3745 Note that `debug-on-error', `debug-on-quit' and friends
3746 still determine whether to handle the particular condition. */);
3747 Vdebug_on_signal
= Qnil
;
3749 DEFVAR_LISP ("macro-declaration-function", Vmacro_declaration_function
,
3750 doc
: /* Function to process declarations in a macro definition.
3751 The function will be called with two args MACRO and DECL.
3752 MACRO is the name of the macro being defined.
3753 DECL is a list `(declare ...)' containing the declarations.
3754 The value the function returns is not used. */);
3755 Vmacro_declaration_function
= Qnil
;
3757 /* When lexical binding is being used,
3758 vinternal_interpreter_environment is non-nil, and contains an alist
3759 of lexically-bound variable, or (t), indicating an empty
3760 environment. The lisp name of this variable would be
3761 `internal-interpreter-environment' if it weren't hidden.
3762 Every element of this list can be either a cons (VAR . VAL)
3763 specifying a lexical binding, or a single symbol VAR indicating
3764 that this variable should use dynamic scoping. */
3765 DEFSYM (Qinternal_interpreter_environment
, "internal-interpreter-environment");
3766 DEFVAR_LISP ("internal-interpreter-environment",
3767 Vinternal_interpreter_environment
,
3768 doc
: /* If non-nil, the current lexical environment of the lisp interpreter.
3769 When lexical binding is not being used, this variable is nil.
3770 A value of `(t)' indicates an empty environment, otherwise it is an
3771 alist of active lexical bindings. */);
3772 Vinternal_interpreter_environment
= Qnil
;
3773 /* Don't export this variable to Elisp, so noone can mess with it
3774 (Just imagine if someone makes it buffer-local). */
3775 Funintern (Qinternal_interpreter_environment
, Qnil
);
3777 DEFSYM (Vrun_hooks
, "run-hooks");
3779 staticpro (&Vautoload_queue
);
3780 Vautoload_queue
= Qnil
;
3781 staticpro (&Vsignaling_function
);
3782 Vsignaling_function
= Qnil
;
3793 defsubr (&Sfunction
);
3795 defsubr (&Sdefmacro
);
3797 defsubr (&Sdefvaralias
);
3798 defsubr (&Sdefconst
);
3799 defsubr (&Suser_variable_p
);
3803 defsubr (&Smacroexpand
);
3806 defsubr (&Sunwind_protect
);
3807 defsubr (&Scondition_case
);
3809 defsubr (&Sinteractive_p
);
3810 defsubr (&Scalled_interactively_p
);
3811 defsubr (&Scommandp
);
3812 defsubr (&Sautoload
);
3815 defsubr (&Sfuncall
);
3816 defsubr (&Srun_hooks
);
3817 defsubr (&Srun_hook_with_args
);
3818 defsubr (&Srun_hook_with_args_until_success
);
3819 defsubr (&Srun_hook_with_args_until_failure
);
3820 defsubr (&Srun_hook_wrapped
);
3821 defsubr (&Sfetch_bytecode
);
3822 defsubr (&Sbacktrace_debug
);
3823 defsubr (&Sbacktrace
);
3824 defsubr (&Sbacktrace_frame
);
3825 defsubr (&Sspecial_variable_p
);
3826 defsubr (&Sfunctionp
);