1 /* Evaluator for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 99, 2000, 2001
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
25 #include "blockinput.h"
28 #include "dispextern.h"
31 /* This definition is duplicated in alloc.c and keyboard.c */
32 /* Putting it in lisp.h makes cc bomb out! */
36 struct backtrace
*next
;
37 Lisp_Object
*function
;
38 Lisp_Object
*args
; /* Points to vector of args. */
39 int nargs
; /* Length of vector.
40 If nargs is UNEVALLED, args points to slot holding
41 list of unevalled args */
43 /* Nonzero means call value of debugger when done with this operation. */
47 struct backtrace
*backtrace_list
;
49 /* This structure helps implement the `catch' and `throw' control
50 structure. A struct catchtag contains all the information needed
51 to restore the state of the interpreter after a non-local jump.
53 Handlers for error conditions (represented by `struct handler'
54 structures) just point to a catch tag to do the cleanup required
57 catchtag structures are chained together in the C calling stack;
58 the `next' member points to the next outer catchtag.
60 A call like (throw TAG VAL) searches for a catchtag whose `tag'
61 member is TAG, and then unbinds to it. The `val' member is used to
62 hold VAL while the stack is unwound; `val' is returned as the value
65 All the other members are concerned with restoring the interpreter
72 struct catchtag
*next
;
75 struct backtrace
*backlist
;
76 struct handler
*handlerlist
;
79 int poll_suppress_count
;
80 struct byte_stack
*byte_stack
;
83 struct catchtag
*catchlist
;
86 /* Count levels of GCPRO to detect failure to UNGCPRO. */
90 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
91 Lisp_Object Qinhibit_quit
, Vinhibit_quit
, Vquit_flag
;
92 Lisp_Object Qand_rest
, Qand_optional
;
93 Lisp_Object Qdebug_on_error
;
95 /* This holds either the symbol `run-hooks' or nil.
96 It is nil at an early stage of startup, and when Emacs
99 Lisp_Object Vrun_hooks
;
101 /* Non-nil means record all fset's and provide's, to be undone
102 if the file being autoloaded is not fully loaded.
103 They are recorded by being consed onto the front of Vautoload_queue:
104 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */
106 Lisp_Object Vautoload_queue
;
108 /* Current number of specbindings allocated in specpdl. */
112 /* Pointer to beginning of specpdl. */
114 struct specbinding
*specpdl
;
116 /* Pointer to first unused element in specpdl. */
118 struct specbinding
*specpdl_ptr
;
120 /* Maximum size allowed for specpdl allocation */
122 int max_specpdl_size
;
124 /* Depth in Lisp evaluations and function calls. */
128 /* Maximum allowed depth in Lisp evaluations and function calls. */
130 int max_lisp_eval_depth
;
132 /* Nonzero means enter debugger before next function call */
134 int debug_on_next_call
;
136 /* Non-zero means debugger may continue. This is zero when the
137 debugger is called during redisplay, where it might not be safe to
138 continue the interrupted redisplay. */
140 int debugger_may_continue
;
142 /* List of conditions (non-nil atom means all) which cause a backtrace
143 if an error is handled by the command loop's error handler. */
145 Lisp_Object Vstack_trace_on_error
;
147 /* List of conditions (non-nil atom means all) which enter the debugger
148 if an error is handled by the command loop's error handler. */
150 Lisp_Object Vdebug_on_error
;
152 /* List of conditions and regexps specifying error messages which
153 do not enter the debugger even if Vdebug_on_error says they should. */
155 Lisp_Object Vdebug_ignored_errors
;
157 /* Non-nil means call the debugger even if the error will be handled. */
159 Lisp_Object Vdebug_on_signal
;
161 /* Hook for edebug to use. */
163 Lisp_Object Vsignal_hook_function
;
165 /* Nonzero means enter debugger if a quit signal
166 is handled by the command loop's error handler. */
170 /* The value of num_nonmacro_input_events as of the last time we
171 started to enter the debugger. If we decide to enter the debugger
172 again when this is still equal to num_nonmacro_input_events, then we
173 know that the debugger itself has an error, and we should just
174 signal the error instead of entering an infinite loop of debugger
177 int when_entered_debugger
;
179 Lisp_Object Vdebugger
;
181 /* The function from which the last `signal' was called. Set in
184 Lisp_Object Vsignaling_function
;
186 /* Set to non-zero while processing X events. Checked in Feval to
187 make sure the Lisp interpreter isn't called from a signal handler,
188 which is unsafe because the interpreter isn't reentrant. */
192 static Lisp_Object funcall_lambda
P_ ((Lisp_Object
, int, Lisp_Object
*));
198 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
199 specpdl_ptr
= specpdl
;
200 max_specpdl_size
= 600;
201 max_lisp_eval_depth
= 300;
209 specpdl_ptr
= specpdl
;
214 debug_on_next_call
= 0;
219 /* This is less than the initial value of num_nonmacro_input_events. */
220 when_entered_debugger
= -1;
227 int debug_while_redisplaying
;
228 int count
= specpdl_ptr
- specpdl
;
231 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
232 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
234 if (specpdl_size
+ 40 > max_specpdl_size
)
235 max_specpdl_size
= specpdl_size
+ 40;
237 #ifdef HAVE_X_WINDOWS
238 if (display_hourglass_p
)
242 debug_on_next_call
= 0;
243 when_entered_debugger
= num_nonmacro_input_events
;
245 /* Resetting redisplaying_p to 0 makes sure that debug output is
246 displayed if the debugger is invoked during redisplay. */
247 debug_while_redisplaying
= redisplaying_p
;
249 specbind (intern ("debugger-may-continue"),
250 debug_while_redisplaying
? Qnil
: Qt
);
251 specbind (Qinhibit_redisplay
, Qnil
);
253 #if 0 /* Binding this prevents execution of Lisp code during
254 redisplay, which necessarily leads to display problems. */
255 specbind (Qinhibit_eval_during_redisplay
, Qt
);
258 val
= apply1 (Vdebugger
, arg
);
260 /* Interrupting redisplay and resuming it later is not safe under
261 all circumstances. So, when the debugger returns, abort the
262 interrupted redisplay by going back to the top-level. */
263 if (debug_while_redisplaying
)
266 return unbind_to (count
, val
);
270 do_debug_on_call (code
)
273 debug_on_next_call
= 0;
274 backtrace_list
->debug_on_exit
= 1;
275 call_debugger (Fcons (code
, Qnil
));
278 /* NOTE!!! Every function that can call EVAL must protect its args
279 and temporaries from garbage collection while it needs them.
280 The definition of `For' shows what you have to do. */
282 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
283 doc
: /* Eval args until one of them yields non-nil, then return that value.
284 The remaining args are not evalled at all.
285 If all args return nil, return nil.
286 usage: (or CONDITIONS ...) */)
290 register Lisp_Object val
;
291 Lisp_Object args_left
;
302 val
= Feval (Fcar (args_left
));
305 args_left
= Fcdr (args_left
);
307 while (!NILP(args_left
));
313 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
314 doc
: /* Eval args until one of them yields nil, then return nil.
315 The remaining args are not evalled at all.
316 If no arg yields nil, return the last arg's value.
317 usage: (and CONDITIONS ...) */)
321 register Lisp_Object val
;
322 Lisp_Object args_left
;
333 val
= Feval (Fcar (args_left
));
336 args_left
= Fcdr (args_left
);
338 while (!NILP(args_left
));
344 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
345 doc
: /* If COND yields non-nil, do THEN, else do ELSE...
346 Returns the value of THEN or the value of the last of the ELSE's.
347 THEN must be one expression, but ELSE... can be zero or more expressions.
348 If COND yields nil, and there are no ELSE's, the value is nil.
349 usage: (if COND THEN ELSE...) */)
353 register Lisp_Object cond
;
357 cond
= Feval (Fcar (args
));
361 return Feval (Fcar (Fcdr (args
)));
362 return Fprogn (Fcdr (Fcdr (args
)));
365 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
366 doc
: /* Try each clause until one succeeds.
367 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
368 and, if the value is non-nil, this clause succeeds:
369 then the expressions in BODY are evaluated and the last one's
370 value is the value of the cond-form.
371 If no clause succeeds, cond returns nil.
372 If a clause has one element, as in (CONDITION),
373 CONDITION's value if non-nil is returned from the cond-form.
374 usage: (cond CLAUSES...) */)
378 register Lisp_Object clause
, val
;
385 clause
= Fcar (args
);
386 val
= Feval (Fcar (clause
));
389 if (!EQ (XCDR (clause
), Qnil
))
390 val
= Fprogn (XCDR (clause
));
400 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
401 doc
: /* Eval BODY forms sequentially and return value of last one.
402 usage: (progn BODY ...) */)
406 register Lisp_Object val
;
407 Lisp_Object args_left
;
418 val
= Feval (Fcar (args_left
));
419 args_left
= Fcdr (args_left
);
421 while (!NILP(args_left
));
427 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
428 doc
: /* Eval FIRST and BODY sequentially; value from FIRST.
429 The value of FIRST is saved during the evaluation of the remaining args,
430 whose values are discarded.
431 usage: (prog1 FIRST BODY...) */)
436 register Lisp_Object args_left
;
437 struct gcpro gcpro1
, gcpro2
;
438 register int argnum
= 0;
450 val
= Feval (Fcar (args_left
));
452 Feval (Fcar (args_left
));
453 args_left
= Fcdr (args_left
);
455 while (!NILP(args_left
));
461 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
462 doc
: /* Eval X, Y and BODY sequentially; value from Y.
463 The value of Y is saved during the evaluation of the remaining args,
464 whose values are discarded.
465 usage: (prog2 X Y BODY...) */)
470 register Lisp_Object args_left
;
471 struct gcpro gcpro1
, gcpro2
;
472 register int argnum
= -1;
486 val
= Feval (Fcar (args_left
));
488 Feval (Fcar (args_left
));
489 args_left
= Fcdr (args_left
);
491 while (!NILP (args_left
));
497 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
498 doc
: /* Set each SYM to the value of its VAL.
499 The symbols SYM are variables; they are literal (not evaluated).
500 The values VAL are expressions; they are evaluated.
501 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
502 The second VAL is not computed until after the first SYM is set, and so on;
503 each VAL can use the new value of variables set earlier in the `setq'.
504 The return value of the `setq' form is the value of the last VAL.
505 usage: (setq SYM VAL SYM VAL ...) */)
509 register Lisp_Object args_left
;
510 register Lisp_Object val
, sym
;
521 val
= Feval (Fcar (Fcdr (args_left
)));
522 sym
= Fcar (args_left
);
524 args_left
= Fcdr (Fcdr (args_left
));
526 while (!NILP(args_left
));
532 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
533 doc
: /* Return the argument, without evaluating it. `(quote x)' yields `x'.
534 usage: (quote ARG) */)
541 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
542 doc
: /* Like `quote', but preferred for objects which are functions.
543 In byte compilation, `function' causes its argument to be compiled.
544 `quote' cannot do that.
545 usage: (function ARG) */)
553 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
554 doc
: /* Return t if function in which this appears was called interactively.
555 This means that the function was called with call-interactively (which
556 includes being called as the binding of a key)
557 and input is currently coming from the keyboard (not in keyboard macro). */)
560 return interactive_p (1) ? Qt
: Qnil
;
564 /* Return 1 if function in which this appears was called
565 interactively. This means that the function was called with
566 call-interactively (which includes being called as the binding of
567 a key) and input is currently coming from the keyboard (not in
570 EXCLUDE_SUBRS_P non-zero means always return 0 if the function
571 called is a built-in. */
574 interactive_p (exclude_subrs_p
)
577 struct backtrace
*btp
;
583 btp
= backtrace_list
;
585 /* If this isn't a byte-compiled function, there may be a frame at
586 the top for Finteractive_p. If so, skip it. */
587 fun
= Findirect_function (*btp
->function
);
588 if (SUBRP (fun
) && XSUBR (fun
) == &Sinteractive_p
)
591 /* If we're running an Emacs 18-style byte-compiled function, there
592 may be a frame for Fbytecode. Now, given the strictest
593 definition, this function isn't really being called
594 interactively, but because that's the way Emacs 18 always builds
595 byte-compiled functions, we'll accept it for now. */
596 if (EQ (*btp
->function
, Qbytecode
))
599 /* If this isn't a byte-compiled function, then we may now be
600 looking at several frames for special forms. Skip past them. */
602 btp
->nargs
== UNEVALLED
)
605 /* btp now points at the frame of the innermost function that isn't
606 a special form, ignoring frames for Finteractive_p and/or
607 Fbytecode at the top. If this frame is for a built-in function
608 (such as load or eval-region) return nil. */
609 fun
= Findirect_function (*btp
->function
);
610 if (exclude_subrs_p
&& SUBRP (fun
))
613 /* btp points to the frame of a Lisp function that called interactive-p.
614 Return t if that function was called interactively. */
615 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
621 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
622 doc
: /* Define NAME as a function.
623 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
624 See also the function `interactive'.
625 usage: (defun NAME ARGLIST [DOCSTRING] BODY...) */)
629 register Lisp_Object fn_name
;
630 register Lisp_Object defn
;
632 fn_name
= Fcar (args
);
633 defn
= Fcons (Qlambda
, Fcdr (args
));
634 if (!NILP (Vpurify_flag
))
635 defn
= Fpurecopy (defn
);
636 Ffset (fn_name
, defn
);
637 LOADHIST_ATTACH (fn_name
);
641 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
642 doc
: /* Define NAME as a macro.
643 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).
644 When the macro is called, as in (NAME ARGS...),
645 the function (lambda ARGLIST BODY...) is applied to
646 the list ARGS... as it appears in the expression,
647 and the result should be a form to be evaluated instead of the original.
648 usage: (defmacro NAME ARGLIST [DOCSTRING] BODY...) */)
652 register Lisp_Object fn_name
;
653 register Lisp_Object defn
;
655 fn_name
= Fcar (args
);
656 defn
= Fcons (Qmacro
, Fcons (Qlambda
, Fcdr (args
)));
657 if (!NILP (Vpurify_flag
))
658 defn
= Fpurecopy (defn
);
659 Ffset (fn_name
, defn
);
660 LOADHIST_ATTACH (fn_name
);
665 DEFUN ("defvaralias", Fdefvaralias
, Sdefvaralias
, 2, 2, 0,
666 doc
: /* Make SYMBOL a variable alias for symbol ALIASED.
667 Setting the value of SYMBOL will subsequently set the value of ALIASED,
668 and getting the value of SYMBOL will return the value ALIASED has.
669 ALIASED nil means remove the alias; SYMBOL is unbound after that. */)
671 Lisp_Object symbol
, aliased
;
673 struct Lisp_Symbol
*sym
;
675 CHECK_SYMBOL (symbol
);
676 CHECK_SYMBOL (aliased
);
678 if (SYMBOL_CONSTANT_P (symbol
))
679 error ("Cannot make a constant an alias");
681 sym
= XSYMBOL (symbol
);
682 sym
->indirect_variable
= 1;
683 sym
->value
= aliased
;
684 sym
->constant
= SYMBOL_CONSTANT_P (aliased
);
685 LOADHIST_ATTACH (symbol
);
691 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
692 doc
: /* Define SYMBOL as a variable.
693 You are not required to define a variable in order to use it,
694 but the definition can supply documentation and an initial value
695 in a way that tags can recognize.
697 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.
698 If SYMBOL is buffer-local, its default value is what is set;
699 buffer-local values are not affected.
700 INITVALUE and DOCSTRING are optional.
701 If DOCSTRING starts with *, this variable is identified as a user option.
702 This means that M-x set-variable recognizes it.
703 See also `user-variable-p'.
704 If INITVALUE is missing, SYMBOL's value is not set.
705 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING) */)
709 register Lisp_Object sym
, tem
, tail
;
713 if (!NILP (Fcdr (Fcdr (tail
))))
714 error ("too many arguments");
716 tem
= Fdefault_boundp (sym
);
720 Fset_default (sym
, Feval (Fcar (tail
)));
722 if (!NILP (Fcar (tail
)))
725 if (!NILP (Vpurify_flag
))
726 tem
= Fpurecopy (tem
);
727 Fput (sym
, Qvariable_documentation
, tem
);
729 LOADHIST_ATTACH (sym
);
732 /* A (defvar <var>) should not take precedence in the load-history over
733 an earlier (defvar <var> <val>), so only add to history if the default
734 value is still unbound. */
736 LOADHIST_ATTACH (sym
);
741 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
742 doc
: /* Define SYMBOL as a constant variable.
743 The intent is that neither programs nor users should ever change this value.
744 Always sets the value of SYMBOL to the result of evalling INITVALUE.
745 If SYMBOL is buffer-local, its default value is what is set;
746 buffer-local values are not affected.
747 DOCSTRING is optional.
748 usage: (defconst SYMBOL INITVALUE [DOCSTRING]) */)
752 register Lisp_Object sym
, tem
;
755 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
756 error ("too many arguments");
758 tem
= Feval (Fcar (Fcdr (args
)));
759 if (!NILP (Vpurify_flag
))
760 tem
= Fpurecopy (tem
);
761 Fset_default (sym
, tem
);
762 tem
= Fcar (Fcdr (Fcdr (args
)));
765 if (!NILP (Vpurify_flag
))
766 tem
= Fpurecopy (tem
);
767 Fput (sym
, Qvariable_documentation
, tem
);
769 LOADHIST_ATTACH (sym
);
773 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
774 doc
: /* Returns t if VARIABLE is intended to be set and modified by users.
775 \(The alternative is a variable used internally in a Lisp program.)
776 Determined by whether the first character of the documentation
777 for the variable is `*' or if the variable is customizable (has a non-nil
778 value of any of `custom-type', `custom-loads' or `standard-value'
779 on its property list). */)
781 Lisp_Object variable
;
783 Lisp_Object documentation
;
785 if (!SYMBOLP (variable
))
788 documentation
= Fget (variable
, Qvariable_documentation
);
789 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
791 if (STRINGP (documentation
)
792 && ((unsigned char) XSTRING (documentation
)->data
[0] == '*'))
794 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
795 if (CONSP (documentation
)
796 && STRINGP (XCAR (documentation
))
797 && INTEGERP (XCDR (documentation
))
798 && XINT (XCDR (documentation
)) < 0)
801 if ((!NILP (Fget (variable
, intern ("custom-type"))))
802 || (!NILP (Fget (variable
, intern ("custom-loads"))))
803 || (!NILP (Fget (variable
, intern ("standard-value")))))
808 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
809 doc
: /* Bind variables according to VARLIST then eval BODY.
810 The value of the last form in BODY is returned.
811 Each element of VARLIST is a symbol (which is bound to nil)
812 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
813 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
814 usage: (let* VARLIST BODY...) */)
818 Lisp_Object varlist
, val
, elt
;
819 int count
= specpdl_ptr
- specpdl
;
820 struct gcpro gcpro1
, gcpro2
, gcpro3
;
822 GCPRO3 (args
, elt
, varlist
);
824 varlist
= Fcar (args
);
825 while (!NILP (varlist
))
828 elt
= Fcar (varlist
);
830 specbind (elt
, Qnil
);
831 else if (! NILP (Fcdr (Fcdr (elt
))))
833 Fcons (build_string ("`let' bindings can have only one value-form"),
837 val
= Feval (Fcar (Fcdr (elt
)));
838 specbind (Fcar (elt
), val
);
840 varlist
= Fcdr (varlist
);
843 val
= Fprogn (Fcdr (args
));
844 return unbind_to (count
, val
);
847 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
848 doc
: /* Bind variables according to VARLIST then eval BODY.
849 The value of the last form in BODY is returned.
850 Each element of VARLIST is a symbol (which is bound to nil)
851 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
852 All the VALUEFORMs are evalled before any symbols are bound.
853 usage: (let VARLIST BODY...) */)
857 Lisp_Object
*temps
, tem
;
858 register Lisp_Object elt
, varlist
;
859 int count
= specpdl_ptr
- specpdl
;
861 struct gcpro gcpro1
, gcpro2
;
863 varlist
= Fcar (args
);
865 /* Make space to hold the values to give the bound variables */
866 elt
= Flength (varlist
);
867 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
869 /* Compute the values and store them in `temps' */
871 GCPRO2 (args
, *temps
);
874 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
877 elt
= Fcar (varlist
);
879 temps
[argnum
++] = Qnil
;
880 else if (! NILP (Fcdr (Fcdr (elt
))))
882 Fcons (build_string ("`let' bindings can have only one value-form"),
885 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
886 gcpro2
.nvars
= argnum
;
890 varlist
= Fcar (args
);
891 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
893 elt
= Fcar (varlist
);
894 tem
= temps
[argnum
++];
898 specbind (Fcar (elt
), tem
);
901 elt
= Fprogn (Fcdr (args
));
902 return unbind_to (count
, elt
);
905 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
906 doc
: /* If TEST yields non-nil, eval BODY... and repeat.
907 The order of execution is thus TEST, BODY, TEST, BODY and so on
908 until TEST returns nil.
909 usage: (while TEST BODY...) */)
913 Lisp_Object test
, body
;
914 struct gcpro gcpro1
, gcpro2
;
920 while (!NILP (Feval (test
)))
930 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
931 doc
: /* Return result of expanding macros at top level of FORM.
932 If FORM is not a macro call, it is returned unchanged.
933 Otherwise, the macro is expanded and the expansion is considered
934 in place of FORM. When a non-macro-call results, it is returned.
936 The second optional arg ENVIRONMENT specifies an environment of macro
937 definitions to shadow the loaded ones for use in file byte-compilation. */)
940 Lisp_Object environment
;
942 /* With cleanups from Hallvard Furuseth. */
943 register Lisp_Object expander
, sym
, def
, tem
;
947 /* Come back here each time we expand a macro call,
948 in case it expands into another macro call. */
951 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
952 def
= sym
= XCAR (form
);
954 /* Trace symbols aliases to other symbols
955 until we get a symbol that is not an alias. */
956 while (SYMBOLP (def
))
960 tem
= Fassq (sym
, environment
);
963 def
= XSYMBOL (sym
)->function
;
964 if (!EQ (def
, Qunbound
))
969 /* Right now TEM is the result from SYM in ENVIRONMENT,
970 and if TEM is nil then DEF is SYM's function definition. */
973 /* SYM is not mentioned in ENVIRONMENT.
974 Look at its function definition. */
975 if (EQ (def
, Qunbound
) || !CONSP (def
))
976 /* Not defined or definition not suitable */
978 if (EQ (XCAR (def
), Qautoload
))
980 /* Autoloading function: will it be a macro when loaded? */
981 tem
= Fnth (make_number (4), def
);
982 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
983 /* Yes, load it and try again. */
987 do_autoload (def
, sym
);
994 else if (!EQ (XCAR (def
), Qmacro
))
996 else expander
= XCDR (def
);
1000 expander
= XCDR (tem
);
1001 if (NILP (expander
))
1004 form
= apply1 (expander
, XCDR (form
));
1009 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
1010 doc
: /* Eval BODY allowing nonlocal exits using `throw'.
1011 TAG is evalled to get the tag to use; it must not be nil.
1013 Then the BODY is executed.
1014 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.
1015 If no throw happens, `catch' returns the value of the last BODY form.
1016 If a throw happens, it specifies the value to return from `catch'.
1017 usage: (catch TAG BODY...) */)
1021 register Lisp_Object tag
;
1022 struct gcpro gcpro1
;
1025 tag
= Feval (Fcar (args
));
1027 return internal_catch (tag
, Fprogn
, Fcdr (args
));
1030 /* Set up a catch, then call C function FUNC on argument ARG.
1031 FUNC should return a Lisp_Object.
1032 This is how catches are done from within C code. */
1035 internal_catch (tag
, func
, arg
)
1037 Lisp_Object (*func
) ();
1040 /* This structure is made part of the chain `catchlist'. */
1043 /* Fill in the components of c, and put it on the list. */
1047 c
.backlist
= backtrace_list
;
1048 c
.handlerlist
= handlerlist
;
1049 c
.lisp_eval_depth
= lisp_eval_depth
;
1050 c
.pdlcount
= specpdl_ptr
- specpdl
;
1051 c
.poll_suppress_count
= poll_suppress_count
;
1052 c
.gcpro
= gcprolist
;
1053 c
.byte_stack
= byte_stack_list
;
1057 if (! _setjmp (c
.jmp
))
1058 c
.val
= (*func
) (arg
);
1060 /* Throw works by a longjmp that comes right here. */
1065 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1066 jump to that CATCH, returning VALUE as the value of that catch.
1068 This is the guts Fthrow and Fsignal; they differ only in the way
1069 they choose the catch tag to throw to. A catch tag for a
1070 condition-case form has a TAG of Qnil.
1072 Before each catch is discarded, unbind all special bindings and
1073 execute all unwind-protect clauses made above that catch. Unwind
1074 the handler stack as we go, so that the proper handlers are in
1075 effect for each unwind-protect clause we run. At the end, restore
1076 some static info saved in CATCH, and longjmp to the location
1079 This is used for correct unwinding in Fthrow and Fsignal. */
1082 unwind_to_catch (catch, value
)
1083 struct catchtag
*catch;
1086 register int last_time
;
1088 /* Save the value in the tag. */
1091 /* Restore the polling-suppression count. */
1092 set_poll_suppress_count (catch->poll_suppress_count
);
1096 last_time
= catchlist
== catch;
1098 /* Unwind the specpdl stack, and then restore the proper set of
1100 unbind_to (catchlist
->pdlcount
, Qnil
);
1101 handlerlist
= catchlist
->handlerlist
;
1102 catchlist
= catchlist
->next
;
1104 while (! last_time
);
1106 byte_stack_list
= catch->byte_stack
;
1107 gcprolist
= catch->gcpro
;
1110 gcpro_level
= gcprolist
->level
+ 1;
1114 backtrace_list
= catch->backlist
;
1115 lisp_eval_depth
= catch->lisp_eval_depth
;
1117 _longjmp (catch->jmp
, 1);
1120 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1121 doc
: /* Throw to the catch for TAG and return VALUE from it.
1122 Both TAG and VALUE are evalled. */)
1124 register Lisp_Object tag
, value
;
1126 register struct catchtag
*c
;
1131 for (c
= catchlist
; c
; c
= c
->next
)
1133 if (EQ (c
->tag
, tag
))
1134 unwind_to_catch (c
, value
);
1136 tag
= Fsignal (Qno_catch
, Fcons (tag
, Fcons (value
, Qnil
)));
1141 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1142 doc
: /* Do BODYFORM, protecting with UNWINDFORMS.
1143 If BODYFORM completes normally, its value is returned
1144 after executing the UNWINDFORMS.
1145 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1146 usage: (unwind-protect BODYFORM UNWINDFORMS...) */)
1151 int count
= specpdl_ptr
- specpdl
;
1153 record_unwind_protect (0, Fcdr (args
));
1154 val
= Feval (Fcar (args
));
1155 return unbind_to (count
, val
);
1158 /* Chain of condition handlers currently in effect.
1159 The elements of this chain are contained in the stack frames
1160 of Fcondition_case and internal_condition_case.
1161 When an error is signaled (by calling Fsignal, below),
1162 this chain is searched for an element that applies. */
1164 struct handler
*handlerlist
;
1166 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1167 doc
: /* Regain control when an error is signaled.
1168 Executes BODYFORM and returns its value if no error happens.
1169 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1170 where the BODY is made of Lisp expressions.
1172 A handler is applicable to an error
1173 if CONDITION-NAME is one of the error's condition names.
1174 If an error happens, the first applicable handler is run.
1176 The car of a handler may be a list of condition names
1177 instead of a single condition name.
1179 When a handler handles an error,
1180 control returns to the condition-case and the handler BODY... is executed
1181 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).
1182 VAR may be nil; then you do not get access to the signal information.
1184 The value of the last BODY form is returned from the condition-case.
1185 See also the function `signal' for more info.
1186 usage: (condition-case VAR BODYFORM HANDLERS...) */)
1193 register Lisp_Object bodyform
, handlers
;
1194 volatile Lisp_Object var
;
1197 bodyform
= Fcar (Fcdr (args
));
1198 handlers
= Fcdr (Fcdr (args
));
1201 for (val
= handlers
; ! NILP (val
); val
= Fcdr (val
))
1207 && (SYMBOLP (XCAR (tem
))
1208 || CONSP (XCAR (tem
))))))
1209 error ("Invalid condition handler", tem
);
1214 c
.backlist
= backtrace_list
;
1215 c
.handlerlist
= handlerlist
;
1216 c
.lisp_eval_depth
= lisp_eval_depth
;
1217 c
.pdlcount
= specpdl_ptr
- specpdl
;
1218 c
.poll_suppress_count
= poll_suppress_count
;
1219 c
.gcpro
= gcprolist
;
1220 c
.byte_stack
= byte_stack_list
;
1221 if (_setjmp (c
.jmp
))
1224 specbind (h
.var
, c
.val
);
1225 val
= Fprogn (Fcdr (h
.chosen_clause
));
1227 /* Note that this just undoes the binding of h.var; whoever
1228 longjumped to us unwound the stack to c.pdlcount before
1230 unbind_to (c
.pdlcount
, Qnil
);
1237 h
.handler
= handlers
;
1238 h
.next
= handlerlist
;
1242 val
= Feval (bodyform
);
1244 handlerlist
= h
.next
;
1248 /* Call the function BFUN with no arguments, catching errors within it
1249 according to HANDLERS. If there is an error, call HFUN with
1250 one argument which is the data that describes the error:
1253 HANDLERS can be a list of conditions to catch.
1254 If HANDLERS is Qt, catch all errors.
1255 If HANDLERS is Qerror, catch all errors
1256 but allow the debugger to run if that is enabled. */
1259 internal_condition_case (bfun
, handlers
, hfun
)
1260 Lisp_Object (*bfun
) ();
1261 Lisp_Object handlers
;
1262 Lisp_Object (*hfun
) ();
1268 #if 0 /* Can't do this check anymore because realize_basic_faces has
1269 to BLOCK_INPUT, and can call Lisp. What's really needed is a
1270 flag indicating that we're currently handling a signal. */
1271 /* Since Fsignal resets this to 0, it had better be 0 now
1272 or else we have a potential bug. */
1273 if (interrupt_input_blocked
!= 0)
1279 c
.backlist
= backtrace_list
;
1280 c
.handlerlist
= handlerlist
;
1281 c
.lisp_eval_depth
= lisp_eval_depth
;
1282 c
.pdlcount
= specpdl_ptr
- specpdl
;
1283 c
.poll_suppress_count
= poll_suppress_count
;
1284 c
.gcpro
= gcprolist
;
1285 c
.byte_stack
= byte_stack_list
;
1286 if (_setjmp (c
.jmp
))
1288 return (*hfun
) (c
.val
);
1292 h
.handler
= handlers
;
1294 h
.next
= handlerlist
;
1300 handlerlist
= h
.next
;
1304 /* Like internal_condition_case but call HFUN with ARG as its argument. */
1307 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1308 Lisp_Object (*bfun
) ();
1310 Lisp_Object handlers
;
1311 Lisp_Object (*hfun
) ();
1319 c
.backlist
= backtrace_list
;
1320 c
.handlerlist
= handlerlist
;
1321 c
.lisp_eval_depth
= lisp_eval_depth
;
1322 c
.pdlcount
= specpdl_ptr
- specpdl
;
1323 c
.poll_suppress_count
= poll_suppress_count
;
1324 c
.gcpro
= gcprolist
;
1325 c
.byte_stack
= byte_stack_list
;
1326 if (_setjmp (c
.jmp
))
1328 return (*hfun
) (c
.val
);
1332 h
.handler
= handlers
;
1334 h
.next
= handlerlist
;
1338 val
= (*bfun
) (arg
);
1340 handlerlist
= h
.next
;
1345 /* Like internal_condition_case but call HFUN with NARGS as first,
1346 and ARGS as second argument. */
1349 internal_condition_case_2 (bfun
, nargs
, args
, handlers
, hfun
)
1350 Lisp_Object (*bfun
) ();
1353 Lisp_Object handlers
;
1354 Lisp_Object (*hfun
) ();
1362 c
.backlist
= backtrace_list
;
1363 c
.handlerlist
= handlerlist
;
1364 c
.lisp_eval_depth
= lisp_eval_depth
;
1365 c
.pdlcount
= specpdl_ptr
- specpdl
;
1366 c
.poll_suppress_count
= poll_suppress_count
;
1367 c
.gcpro
= gcprolist
;
1368 c
.byte_stack
= byte_stack_list
;
1369 if (_setjmp (c
.jmp
))
1371 return (*hfun
) (c
.val
);
1375 h
.handler
= handlers
;
1377 h
.next
= handlerlist
;
1381 val
= (*bfun
) (nargs
, args
);
1383 handlerlist
= h
.next
;
1388 static Lisp_Object find_handler_clause
P_ ((Lisp_Object
, Lisp_Object
,
1389 Lisp_Object
, Lisp_Object
,
1392 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1393 doc
: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
1394 This function does not return.
1396 An error symbol is a symbol with an `error-conditions' property
1397 that is a list of condition names.
1398 A handler for any of those names will get to handle this signal.
1399 The symbol `error' should normally be one of them.
1401 DATA should be a list. Its elements are printed as part of the error message.
1402 If the signal is handled, DATA is made available to the handler.
1403 See also the function `condition-case'. */)
1404 (error_symbol
, data
)
1405 Lisp_Object error_symbol
, data
;
1407 /* When memory is full, ERROR-SYMBOL is nil,
1408 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA). */
1409 register struct handler
*allhandlers
= handlerlist
;
1410 Lisp_Object conditions
;
1411 extern int gc_in_progress
;
1412 extern int waiting_for_input
;
1413 Lisp_Object debugger_value
;
1415 Lisp_Object real_error_symbol
;
1416 extern int display_hourglass_p
;
1417 struct backtrace
*bp
;
1419 immediate_quit
= handling_signal
= 0;
1420 if (gc_in_progress
|| waiting_for_input
)
1423 TOTALLY_UNBLOCK_INPUT
;
1425 if (NILP (error_symbol
))
1426 real_error_symbol
= Fcar (data
);
1428 real_error_symbol
= error_symbol
;
1430 #ifdef HAVE_X_WINDOWS
1431 if (display_hourglass_p
)
1432 cancel_hourglass ();
1435 /* This hook is used by edebug. */
1436 if (! NILP (Vsignal_hook_function
))
1437 call2 (Vsignal_hook_function
, error_symbol
, data
);
1439 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1441 /* Remember from where signal was called. Skip over the frame for
1442 `signal' itself. If a frame for `error' follows, skip that,
1444 Vsignaling_function
= Qnil
;
1447 bp
= backtrace_list
->next
;
1448 if (bp
&& bp
->function
&& EQ (*bp
->function
, Qerror
))
1450 if (bp
&& bp
->function
)
1451 Vsignaling_function
= *bp
->function
;
1454 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1456 register Lisp_Object clause
;
1458 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1459 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1461 if (specpdl_size
+ 40 > max_specpdl_size
)
1462 max_specpdl_size
= specpdl_size
+ 40;
1464 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1465 error_symbol
, data
, &debugger_value
);
1467 #if 0 /* Most callers are not prepared to handle gc if this returns.
1468 So, since this feature is not very useful, take it out. */
1469 /* If have called debugger and user wants to continue,
1471 if (EQ (clause
, Qlambda
))
1472 return debugger_value
;
1474 if (EQ (clause
, Qlambda
))
1476 /* We can't return values to code which signaled an error, but we
1477 can continue code which has signaled a quit. */
1478 if (EQ (real_error_symbol
, Qquit
))
1481 error ("Cannot return from the debugger in an error");
1487 Lisp_Object unwind_data
;
1488 struct handler
*h
= handlerlist
;
1490 handlerlist
= allhandlers
;
1492 if (NILP (error_symbol
))
1495 unwind_data
= Fcons (error_symbol
, data
);
1496 h
->chosen_clause
= clause
;
1497 unwind_to_catch (h
->tag
, unwind_data
);
1501 handlerlist
= allhandlers
;
1502 /* If no handler is present now, try to run the debugger,
1503 and if that fails, throw to top level. */
1504 find_handler_clause (Qerror
, conditions
, error_symbol
, data
, &debugger_value
);
1506 Fthrow (Qtop_level
, Qt
);
1508 if (! NILP (error_symbol
))
1509 data
= Fcons (error_symbol
, data
);
1511 string
= Ferror_message_string (data
);
1512 fatal ("%s", XSTRING (string
)->data
, 0);
1515 /* Return nonzero iff LIST is a non-nil atom or
1516 a list containing one of CONDITIONS. */
1519 wants_debugger (list
, conditions
)
1520 Lisp_Object list
, conditions
;
1527 while (CONSP (conditions
))
1529 Lisp_Object
this, tail
;
1530 this = XCAR (conditions
);
1531 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1532 if (EQ (XCAR (tail
), this))
1534 conditions
= XCDR (conditions
);
1539 /* Return 1 if an error with condition-symbols CONDITIONS,
1540 and described by SIGNAL-DATA, should skip the debugger
1541 according to debugger-ignored-errors. */
1544 skip_debugger (conditions
, data
)
1545 Lisp_Object conditions
, data
;
1548 int first_string
= 1;
1549 Lisp_Object error_message
;
1551 error_message
= Qnil
;
1552 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1554 if (STRINGP (XCAR (tail
)))
1558 error_message
= Ferror_message_string (data
);
1562 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1567 Lisp_Object contail
;
1569 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1570 if (EQ (XCAR (tail
), XCAR (contail
)))
1578 /* Value of Qlambda means we have called debugger and user has continued.
1579 There are two ways to pass SIG and DATA:
1580 = SIG is the error symbol, and DATA is the rest of the data.
1581 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1582 This is for memory-full errors only.
1584 Store value returned from debugger into *DEBUGGER_VALUE_PTR. */
1587 find_handler_clause (handlers
, conditions
, sig
, data
, debugger_value_ptr
)
1588 Lisp_Object handlers
, conditions
, sig
, data
;
1589 Lisp_Object
*debugger_value_ptr
;
1591 register Lisp_Object h
;
1592 register Lisp_Object tem
;
1594 if (EQ (handlers
, Qt
)) /* t is used by handlers for all conditions, set up by C code. */
1596 /* error is used similarly, but means print an error message
1597 and run the debugger if that is enabled. */
1598 if (EQ (handlers
, Qerror
)
1599 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1600 there is a handler. */
1602 int count
= specpdl_ptr
- specpdl
;
1603 int debugger_called
= 0;
1604 Lisp_Object sig_symbol
, combined_data
;
1605 /* This is set to 1 if we are handling a memory-full error,
1606 because these must not run the debugger.
1607 (There is no room in memory to do that!) */
1608 int no_debugger
= 0;
1612 combined_data
= data
;
1613 sig_symbol
= Fcar (data
);
1618 combined_data
= Fcons (sig
, data
);
1622 if (wants_debugger (Vstack_trace_on_error
, conditions
))
1625 internal_with_output_to_temp_buffer ("*Backtrace*",
1626 (Lisp_Object (*) (Lisp_Object
)) Fbacktrace
,
1629 internal_with_output_to_temp_buffer ("*Backtrace*",
1634 && (EQ (sig_symbol
, Qquit
)
1636 : wants_debugger (Vdebug_on_error
, conditions
))
1637 && ! skip_debugger (conditions
, combined_data
)
1638 && when_entered_debugger
< num_nonmacro_input_events
)
1640 specbind (Qdebug_on_error
, Qnil
);
1642 = call_debugger (Fcons (Qerror
,
1643 Fcons (combined_data
, Qnil
)));
1644 debugger_called
= 1;
1646 /* If there is no handler, return saying whether we ran the debugger. */
1647 if (EQ (handlers
, Qerror
))
1649 if (debugger_called
)
1650 return unbind_to (count
, Qlambda
);
1654 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1656 Lisp_Object handler
, condit
;
1659 if (!CONSP (handler
))
1661 condit
= Fcar (handler
);
1662 /* Handle a single condition name in handler HANDLER. */
1663 if (SYMBOLP (condit
))
1665 tem
= Fmemq (Fcar (handler
), conditions
);
1669 /* Handle a list of condition names in handler HANDLER. */
1670 else if (CONSP (condit
))
1672 while (CONSP (condit
))
1674 tem
= Fmemq (Fcar (condit
), conditions
);
1677 condit
= XCDR (condit
);
1684 /* dump an error message; called like printf */
1688 error (m
, a1
, a2
, a3
)
1708 int used
= doprnt (buffer
, size
, m
, m
+ mlen
, 3, args
);
1713 buffer
= (char *) xrealloc (buffer
, size
);
1716 buffer
= (char *) xmalloc (size
);
1721 string
= build_string (buffer
);
1725 Fsignal (Qerror
, Fcons (string
, Qnil
));
1729 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 1, 0,
1730 doc
: /* Non-nil if FUNCTION makes provisions for interactive calling.
1731 This means it contains a description for how to read arguments to give it.
1732 The value is nil for an invalid function or a symbol with no function
1735 Interactively callable functions include strings and vectors (treated
1736 as keyboard macros), lambda-expressions that contain a top-level call
1737 to `interactive', autoload definitions made by `autoload' with non-nil
1738 fourth argument, and some of the built-in functions of Lisp.
1740 Also, a symbol satisfies `commandp' if its function definition does so. */)
1742 Lisp_Object function
;
1744 register Lisp_Object fun
;
1745 register Lisp_Object funcar
;
1749 fun
= indirect_function (fun
);
1750 if (EQ (fun
, Qunbound
))
1753 /* Emacs primitives are interactive if their DEFUN specifies an
1754 interactive spec. */
1757 if (XSUBR (fun
)->prompt
)
1763 /* Bytecode objects are interactive if they are long enough to
1764 have an element whose index is COMPILED_INTERACTIVE, which is
1765 where the interactive spec is stored. */
1766 else if (COMPILEDP (fun
))
1767 return ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
1770 /* Strings and vectors are keyboard macros. */
1771 if (STRINGP (fun
) || VECTORP (fun
))
1774 /* Lists may represent commands. */
1777 funcar
= Fcar (fun
);
1778 if (!SYMBOLP (funcar
))
1779 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1780 if (EQ (funcar
, Qlambda
))
1781 return Fassq (Qinteractive
, Fcdr (Fcdr (fun
)));
1782 if (EQ (funcar
, Qautoload
))
1783 return Fcar (Fcdr (Fcdr (Fcdr (fun
))));
1789 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1790 doc
: /* Define FUNCTION to autoload from FILE.
1791 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
1792 Third arg DOCSTRING is documentation for the function.
1793 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
1794 Fifth arg TYPE indicates the type of the object:
1795 nil or omitted says FUNCTION is a function,
1796 `keymap' says FUNCTION is really a keymap, and
1797 `macro' or t says FUNCTION is really a macro.
1798 Third through fifth args give info about the real definition.
1799 They default to nil.
1800 If FUNCTION is already defined other than as an autoload,
1801 this does nothing and returns nil. */)
1802 (function
, file
, docstring
, interactive
, type
)
1803 Lisp_Object function
, file
, docstring
, interactive
, type
;
1806 Lisp_Object args
[4];
1809 CHECK_SYMBOL (function
);
1810 CHECK_STRING (file
);
1812 /* If function is defined and not as an autoload, don't override */
1813 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
1814 && !(CONSP (XSYMBOL (function
)->function
)
1815 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
1818 if (NILP (Vpurify_flag
))
1819 /* Only add entries after dumping, because the ones before are
1820 not useful and else we get loads of them from the loaddefs.el. */
1821 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
1825 args
[1] = docstring
;
1826 args
[2] = interactive
;
1829 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
1830 #else /* NO_ARG_ARRAY */
1831 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
1832 #endif /* not NO_ARG_ARRAY */
1836 un_autoload (oldqueue
)
1837 Lisp_Object oldqueue
;
1839 register Lisp_Object queue
, first
, second
;
1841 /* Queue to unwind is current value of Vautoload_queue.
1842 oldqueue is the shadowed value to leave in Vautoload_queue. */
1843 queue
= Vautoload_queue
;
1844 Vautoload_queue
= oldqueue
;
1845 while (CONSP (queue
))
1847 first
= Fcar (queue
);
1848 second
= Fcdr (first
);
1849 first
= Fcar (first
);
1850 if (EQ (second
, Qnil
))
1853 Ffset (first
, second
);
1854 queue
= Fcdr (queue
);
1859 /* Load an autoloaded function.
1860 FUNNAME is the symbol which is the function's name.
1861 FUNDEF is the autoload definition (a list). */
1864 do_autoload (fundef
, funname
)
1865 Lisp_Object fundef
, funname
;
1867 int count
= specpdl_ptr
- specpdl
;
1868 Lisp_Object fun
, queue
, first
, second
;
1869 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1872 CHECK_SYMBOL (funname
);
1873 GCPRO3 (fun
, funname
, fundef
);
1875 /* Preserve the match data. */
1876 record_unwind_protect (Fset_match_data
, Fmatch_data (Qnil
, Qnil
));
1878 /* Value saved here is to be restored into Vautoload_queue. */
1879 record_unwind_protect (un_autoload
, Vautoload_queue
);
1880 Vautoload_queue
= Qt
;
1881 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
, Qt
);
1883 /* Save the old autoloads, in case we ever do an unload. */
1884 queue
= Vautoload_queue
;
1885 while (CONSP (queue
))
1887 first
= Fcar (queue
);
1888 second
= Fcdr (first
);
1889 first
= Fcar (first
);
1891 /* Note: This test is subtle. The cdr of an autoload-queue entry
1892 may be an atom if the autoload entry was generated by a defalias
1895 Fput (first
, Qautoload
, (Fcdr (second
)));
1897 queue
= Fcdr (queue
);
1900 /* Once loading finishes, don't undo it. */
1901 Vautoload_queue
= Qt
;
1902 unbind_to (count
, Qnil
);
1904 fun
= Findirect_function (fun
);
1906 if (!NILP (Fequal (fun
, fundef
)))
1907 error ("Autoloading failed to define function %s",
1908 XSYMBOL (funname
)->name
->data
);
1913 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
1914 doc
: /* Evaluate FORM and return its value. */)
1918 Lisp_Object fun
, val
, original_fun
, original_args
;
1920 struct backtrace backtrace
;
1921 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1923 if (handling_signal
)
1927 return Fsymbol_value (form
);
1932 if (consing_since_gc
> gc_cons_threshold
)
1935 Fgarbage_collect ();
1939 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1941 if (max_lisp_eval_depth
< 100)
1942 max_lisp_eval_depth
= 100;
1943 if (lisp_eval_depth
> max_lisp_eval_depth
)
1944 error ("Lisp nesting exceeds max-lisp-eval-depth");
1947 original_fun
= Fcar (form
);
1948 original_args
= Fcdr (form
);
1950 backtrace
.next
= backtrace_list
;
1951 backtrace_list
= &backtrace
;
1952 backtrace
.function
= &original_fun
; /* This also protects them from gc */
1953 backtrace
.args
= &original_args
;
1954 backtrace
.nargs
= UNEVALLED
;
1955 backtrace
.evalargs
= 1;
1956 backtrace
.debug_on_exit
= 0;
1958 if (debug_on_next_call
)
1959 do_debug_on_call (Qt
);
1961 /* At this point, only original_fun and original_args
1962 have values that will be used below */
1964 fun
= Findirect_function (original_fun
);
1968 Lisp_Object numargs
;
1969 Lisp_Object argvals
[8];
1970 Lisp_Object args_left
;
1971 register int i
, maxargs
;
1973 args_left
= original_args
;
1974 numargs
= Flength (args_left
);
1976 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
1977 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
1978 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1980 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1982 backtrace
.evalargs
= 0;
1983 val
= (*XSUBR (fun
)->function
) (args_left
);
1987 if (XSUBR (fun
)->max_args
== MANY
)
1989 /* Pass a vector of evaluated arguments */
1991 register int argnum
= 0;
1993 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1995 GCPRO3 (args_left
, fun
, fun
);
1999 while (!NILP (args_left
))
2001 vals
[argnum
++] = Feval (Fcar (args_left
));
2002 args_left
= Fcdr (args_left
);
2003 gcpro3
.nvars
= argnum
;
2006 backtrace
.args
= vals
;
2007 backtrace
.nargs
= XINT (numargs
);
2009 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
2014 GCPRO3 (args_left
, fun
, fun
);
2015 gcpro3
.var
= argvals
;
2018 maxargs
= XSUBR (fun
)->max_args
;
2019 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
2021 argvals
[i
] = Feval (Fcar (args_left
));
2027 backtrace
.args
= argvals
;
2028 backtrace
.nargs
= XINT (numargs
);
2033 val
= (*XSUBR (fun
)->function
) ();
2036 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
2039 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
2042 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2046 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2047 argvals
[2], argvals
[3]);
2050 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2051 argvals
[3], argvals
[4]);
2054 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2055 argvals
[3], argvals
[4], argvals
[5]);
2058 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2059 argvals
[3], argvals
[4], argvals
[5],
2064 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2065 argvals
[3], argvals
[4], argvals
[5],
2066 argvals
[6], argvals
[7]);
2070 /* Someone has created a subr that takes more arguments than
2071 is supported by this code. We need to either rewrite the
2072 subr to use a different argument protocol, or add more
2073 cases to this switch. */
2077 if (COMPILEDP (fun
))
2078 val
= apply_lambda (fun
, original_args
, 1);
2082 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2083 funcar
= Fcar (fun
);
2084 if (!SYMBOLP (funcar
))
2085 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2086 if (EQ (funcar
, Qautoload
))
2088 do_autoload (fun
, original_fun
);
2091 if (EQ (funcar
, Qmacro
))
2092 val
= Feval (apply1 (Fcdr (fun
), original_args
));
2093 else if (EQ (funcar
, Qlambda
))
2094 val
= apply_lambda (fun
, original_args
, 1);
2096 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2100 if (backtrace
.debug_on_exit
)
2101 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2102 backtrace_list
= backtrace
.next
;
2106 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
2107 doc
: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2108 Then return the value FUNCTION returns.
2109 Thus, (apply '+ 1 2 '(3 4)) returns 10.
2110 usage: (apply FUNCTION &rest ARGUMENTS) */)
2115 register int i
, numargs
;
2116 register Lisp_Object spread_arg
;
2117 register Lisp_Object
*funcall_args
;
2119 struct gcpro gcpro1
;
2123 spread_arg
= args
[nargs
- 1];
2124 CHECK_LIST (spread_arg
);
2126 numargs
= XINT (Flength (spread_arg
));
2129 return Ffuncall (nargs
- 1, args
);
2130 else if (numargs
== 1)
2132 args
[nargs
- 1] = XCAR (spread_arg
);
2133 return Ffuncall (nargs
, args
);
2136 numargs
+= nargs
- 2;
2138 fun
= indirect_function (fun
);
2139 if (EQ (fun
, Qunbound
))
2141 /* Let funcall get the error */
2148 if (numargs
< XSUBR (fun
)->min_args
2149 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2150 goto funcall
; /* Let funcall get the error */
2151 else if (XSUBR (fun
)->max_args
> numargs
)
2153 /* Avoid making funcall cons up a yet another new vector of arguments
2154 by explicitly supplying nil's for optional values */
2155 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
2156 * sizeof (Lisp_Object
));
2157 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2158 funcall_args
[++i
] = Qnil
;
2159 GCPRO1 (*funcall_args
);
2160 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2164 /* We add 1 to numargs because funcall_args includes the
2165 function itself as well as its arguments. */
2168 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
2169 * sizeof (Lisp_Object
));
2170 GCPRO1 (*funcall_args
);
2171 gcpro1
.nvars
= 1 + numargs
;
2174 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
2175 /* Spread the last arg we got. Its first element goes in
2176 the slot that it used to occupy, hence this value of I. */
2178 while (!NILP (spread_arg
))
2180 funcall_args
[i
++] = XCAR (spread_arg
);
2181 spread_arg
= XCDR (spread_arg
);
2184 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
2187 /* Run hook variables in various ways. */
2189 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
2190 static Lisp_Object run_hook_with_args
P_ ((int, Lisp_Object
*,
2191 enum run_hooks_condition
));
2193 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2194 doc
: /* Run each hook in HOOKS. Major mode functions use this.
2195 Each argument should be a symbol, a hook variable.
2196 These symbols are processed in the order specified.
2197 If a hook symbol has a non-nil value, that value may be a function
2198 or a list of functions to be called to run the hook.
2199 If the value is a function, it is called with no arguments.
2200 If it is a list, the elements are called, in order, with no arguments.
2202 Do not use `make-local-variable' to make a hook variable buffer-local.
2203 Instead, use `add-hook' and specify t for the LOCAL argument.
2204 usage: (run-hooks &rest HOOKS) */)
2209 Lisp_Object hook
[1];
2212 for (i
= 0; i
< nargs
; i
++)
2215 run_hook_with_args (1, hook
, to_completion
);
2221 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2222 Srun_hook_with_args
, 1, MANY
, 0,
2223 doc
: /* Run HOOK with the specified arguments ARGS.
2224 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
2225 value, that value may be a function or a list of functions to be
2226 called to run the hook. If the value is a function, it is called with
2227 the given arguments and its return value is returned. If it is a list
2228 of functions, those functions are called, in order,
2229 with the given arguments ARGS.
2230 It is best not to depend on the value return by `run-hook-with-args',
2233 Do not use `make-local-variable' to make a hook variable buffer-local.
2234 Instead, use `add-hook' and specify t for the LOCAL argument.
2235 usage: (run-hook-with-args HOOK &rest ARGS) */)
2240 return run_hook_with_args (nargs
, args
, to_completion
);
2243 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2244 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2245 doc
: /* Run HOOK with the specified arguments ARGS.
2246 HOOK should be a symbol, a hook variable. Its value should
2247 be a list of functions. We call those functions, one by one,
2248 passing arguments ARGS to each of them, until one of them
2249 returns a non-nil value. Then we return that value.
2250 If all the functions return nil, we return nil.
2252 Do not use `make-local-variable' to make a hook variable buffer-local.
2253 Instead, use `add-hook' and specify t for the LOCAL argument.
2254 usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
2259 return run_hook_with_args (nargs
, args
, until_success
);
2262 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2263 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2264 doc
: /* Run HOOK with the specified arguments ARGS.
2265 HOOK should be a symbol, a hook variable. Its value should
2266 be a list of functions. We call those functions, one by one,
2267 passing arguments ARGS to each of them, until one of them
2268 returns nil. Then we return nil.
2269 If all the functions return non-nil, we return non-nil.
2271 Do not use `make-local-variable' to make a hook variable buffer-local.
2272 Instead, use `add-hook' and specify t for the LOCAL argument.
2273 usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
2278 return run_hook_with_args (nargs
, args
, until_failure
);
2281 /* ARGS[0] should be a hook symbol.
2282 Call each of the functions in the hook value, passing each of them
2283 as arguments all the rest of ARGS (all NARGS - 1 elements).
2284 COND specifies a condition to test after each call
2285 to decide whether to stop.
2286 The caller (or its caller, etc) must gcpro all of ARGS,
2287 except that it isn't necessary to gcpro ARGS[0]. */
2290 run_hook_with_args (nargs
, args
, cond
)
2293 enum run_hooks_condition cond
;
2295 Lisp_Object sym
, val
, ret
;
2296 Lisp_Object globals
;
2297 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2299 /* If we are dying or still initializing,
2300 don't do anything--it would probably crash if we tried. */
2301 if (NILP (Vrun_hooks
))
2305 val
= find_symbol_value (sym
);
2306 ret
= (cond
== until_failure
? Qt
: Qnil
);
2308 if (EQ (val
, Qunbound
) || NILP (val
))
2310 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2313 return Ffuncall (nargs
, args
);
2318 GCPRO3 (sym
, val
, globals
);
2321 CONSP (val
) && ((cond
== to_completion
)
2322 || (cond
== until_success
? NILP (ret
)
2326 if (EQ (XCAR (val
), Qt
))
2328 /* t indicates this hook has a local binding;
2329 it means to run the global binding too. */
2331 for (globals
= Fdefault_value (sym
);
2332 CONSP (globals
) && ((cond
== to_completion
)
2333 || (cond
== until_success
? NILP (ret
)
2335 globals
= XCDR (globals
))
2337 args
[0] = XCAR (globals
);
2338 /* In a global value, t should not occur. If it does, we
2339 must ignore it to avoid an endless loop. */
2340 if (!EQ (args
[0], Qt
))
2341 ret
= Ffuncall (nargs
, args
);
2346 args
[0] = XCAR (val
);
2347 ret
= Ffuncall (nargs
, args
);
2356 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2357 present value of that symbol.
2358 Call each element of FUNLIST,
2359 passing each of them the rest of ARGS.
2360 The caller (or its caller, etc) must gcpro all of ARGS,
2361 except that it isn't necessary to gcpro ARGS[0]. */
2364 run_hook_list_with_args (funlist
, nargs
, args
)
2365 Lisp_Object funlist
;
2371 Lisp_Object globals
;
2372 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2376 GCPRO3 (sym
, val
, globals
);
2378 for (val
= funlist
; CONSP (val
); val
= XCDR (val
))
2380 if (EQ (XCAR (val
), Qt
))
2382 /* t indicates this hook has a local binding;
2383 it means to run the global binding too. */
2385 for (globals
= Fdefault_value (sym
);
2387 globals
= XCDR (globals
))
2389 args
[0] = XCAR (globals
);
2390 /* In a global value, t should not occur. If it does, we
2391 must ignore it to avoid an endless loop. */
2392 if (!EQ (args
[0], Qt
))
2393 Ffuncall (nargs
, args
);
2398 args
[0] = XCAR (val
);
2399 Ffuncall (nargs
, args
);
2406 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2409 run_hook_with_args_2 (hook
, arg1
, arg2
)
2410 Lisp_Object hook
, arg1
, arg2
;
2412 Lisp_Object temp
[3];
2417 Frun_hook_with_args (3, temp
);
2420 /* Apply fn to arg */
2423 Lisp_Object fn
, arg
;
2425 struct gcpro gcpro1
;
2429 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2433 Lisp_Object args
[2];
2437 RETURN_UNGCPRO (Fapply (2, args
));
2439 #else /* not NO_ARG_ARRAY */
2440 RETURN_UNGCPRO (Fapply (2, &fn
));
2441 #endif /* not NO_ARG_ARRAY */
2444 /* Call function fn on no arguments */
2449 struct gcpro gcpro1
;
2452 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2455 /* Call function fn with 1 argument arg1 */
2459 Lisp_Object fn
, arg1
;
2461 struct gcpro gcpro1
;
2463 Lisp_Object args
[2];
2469 RETURN_UNGCPRO (Ffuncall (2, args
));
2470 #else /* not NO_ARG_ARRAY */
2473 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2474 #endif /* not NO_ARG_ARRAY */
2477 /* Call function fn with 2 arguments arg1, arg2 */
2480 call2 (fn
, arg1
, arg2
)
2481 Lisp_Object fn
, arg1
, arg2
;
2483 struct gcpro gcpro1
;
2485 Lisp_Object args
[3];
2491 RETURN_UNGCPRO (Ffuncall (3, args
));
2492 #else /* not NO_ARG_ARRAY */
2495 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2496 #endif /* not NO_ARG_ARRAY */
2499 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2502 call3 (fn
, arg1
, arg2
, arg3
)
2503 Lisp_Object fn
, arg1
, arg2
, arg3
;
2505 struct gcpro gcpro1
;
2507 Lisp_Object args
[4];
2514 RETURN_UNGCPRO (Ffuncall (4, args
));
2515 #else /* not NO_ARG_ARRAY */
2518 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2519 #endif /* not NO_ARG_ARRAY */
2522 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2525 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2526 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2528 struct gcpro gcpro1
;
2530 Lisp_Object args
[5];
2538 RETURN_UNGCPRO (Ffuncall (5, args
));
2539 #else /* not NO_ARG_ARRAY */
2542 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2543 #endif /* not NO_ARG_ARRAY */
2546 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2549 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2550 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2552 struct gcpro gcpro1
;
2554 Lisp_Object args
[6];
2563 RETURN_UNGCPRO (Ffuncall (6, args
));
2564 #else /* not NO_ARG_ARRAY */
2567 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2568 #endif /* not NO_ARG_ARRAY */
2571 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2574 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2575 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2577 struct gcpro gcpro1
;
2579 Lisp_Object args
[7];
2589 RETURN_UNGCPRO (Ffuncall (7, args
));
2590 #else /* not NO_ARG_ARRAY */
2593 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2594 #endif /* not NO_ARG_ARRAY */
2597 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2598 doc
: /* Call first argument as a function, passing remaining arguments to it.
2599 Return the value that function returns.
2600 Thus, (funcall 'cons 'x 'y) returns (x . y).
2601 usage: (funcall FUNCTION &rest ARGUMENTS) */)
2608 int numargs
= nargs
- 1;
2609 Lisp_Object lisp_numargs
;
2611 struct backtrace backtrace
;
2612 register Lisp_Object
*internal_args
;
2616 if (consing_since_gc
> gc_cons_threshold
)
2617 Fgarbage_collect ();
2619 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2621 if (max_lisp_eval_depth
< 100)
2622 max_lisp_eval_depth
= 100;
2623 if (lisp_eval_depth
> max_lisp_eval_depth
)
2624 error ("Lisp nesting exceeds max-lisp-eval-depth");
2627 backtrace
.next
= backtrace_list
;
2628 backtrace_list
= &backtrace
;
2629 backtrace
.function
= &args
[0];
2630 backtrace
.args
= &args
[1];
2631 backtrace
.nargs
= nargs
- 1;
2632 backtrace
.evalargs
= 0;
2633 backtrace
.debug_on_exit
= 0;
2635 if (debug_on_next_call
)
2636 do_debug_on_call (Qlambda
);
2642 fun
= Findirect_function (fun
);
2646 if (numargs
< XSUBR (fun
)->min_args
2647 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2649 XSETFASTINT (lisp_numargs
, numargs
);
2650 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (lisp_numargs
, Qnil
)));
2653 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2654 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2656 if (XSUBR (fun
)->max_args
== MANY
)
2658 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
2662 if (XSUBR (fun
)->max_args
> numargs
)
2664 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2665 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
2666 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2667 internal_args
[i
] = Qnil
;
2670 internal_args
= args
+ 1;
2671 switch (XSUBR (fun
)->max_args
)
2674 val
= (*XSUBR (fun
)->function
) ();
2677 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
2680 val
= (*XSUBR (fun
)->function
) (internal_args
[0],
2684 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2688 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2693 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2694 internal_args
[2], internal_args
[3],
2698 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2699 internal_args
[2], internal_args
[3],
2700 internal_args
[4], internal_args
[5]);
2703 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2704 internal_args
[2], internal_args
[3],
2705 internal_args
[4], internal_args
[5],
2710 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2711 internal_args
[2], internal_args
[3],
2712 internal_args
[4], internal_args
[5],
2713 internal_args
[6], internal_args
[7]);
2718 /* If a subr takes more than 8 arguments without using MANY
2719 or UNEVALLED, we need to extend this function to support it.
2720 Until this is done, there is no way to call the function. */
2724 if (COMPILEDP (fun
))
2725 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2729 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2730 funcar
= Fcar (fun
);
2731 if (!SYMBOLP (funcar
))
2732 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2733 if (EQ (funcar
, Qlambda
))
2734 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2735 else if (EQ (funcar
, Qautoload
))
2737 do_autoload (fun
, args
[0]);
2741 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2745 if (backtrace
.debug_on_exit
)
2746 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2747 backtrace_list
= backtrace
.next
;
2752 apply_lambda (fun
, args
, eval_flag
)
2753 Lisp_Object fun
, args
;
2756 Lisp_Object args_left
;
2757 Lisp_Object numargs
;
2758 register Lisp_Object
*arg_vector
;
2759 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2761 register Lisp_Object tem
;
2763 numargs
= Flength (args
);
2764 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2767 GCPRO3 (*arg_vector
, args_left
, fun
);
2770 for (i
= 0; i
< XINT (numargs
);)
2772 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2773 if (eval_flag
) tem
= Feval (tem
);
2774 arg_vector
[i
++] = tem
;
2782 backtrace_list
->args
= arg_vector
;
2783 backtrace_list
->nargs
= i
;
2785 backtrace_list
->evalargs
= 0;
2786 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
2788 /* Do the debug-on-exit now, while arg_vector still exists. */
2789 if (backtrace_list
->debug_on_exit
)
2790 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
2791 /* Don't do it again when we return to eval. */
2792 backtrace_list
->debug_on_exit
= 0;
2796 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2797 and return the result of evaluation.
2798 FUN must be either a lambda-expression or a compiled-code object. */
2801 funcall_lambda (fun
, nargs
, arg_vector
)
2804 register Lisp_Object
*arg_vector
;
2806 Lisp_Object val
, syms_left
, next
;
2807 int count
= specpdl_ptr
- specpdl
;
2808 int i
, optional
, rest
;
2812 syms_left
= XCDR (fun
);
2813 if (CONSP (syms_left
))
2814 syms_left
= XCAR (syms_left
);
2816 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2818 else if (COMPILEDP (fun
))
2819 syms_left
= AREF (fun
, COMPILED_ARGLIST
);
2823 i
= optional
= rest
= 0;
2824 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
2828 next
= XCAR (syms_left
);
2829 while (!SYMBOLP (next
))
2830 next
= Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2832 if (EQ (next
, Qand_rest
))
2834 else if (EQ (next
, Qand_optional
))
2838 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
2842 specbind (next
, arg_vector
[i
++]);
2844 return Fsignal (Qwrong_number_of_arguments
,
2845 Fcons (fun
, Fcons (make_number (nargs
), Qnil
)));
2847 specbind (next
, Qnil
);
2850 if (!NILP (syms_left
))
2851 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2853 return Fsignal (Qwrong_number_of_arguments
,
2854 Fcons (fun
, Fcons (make_number (nargs
), Qnil
)));
2857 val
= Fprogn (XCDR (XCDR (fun
)));
2860 /* If we have not actually read the bytecode string
2861 and constants vector yet, fetch them from the file. */
2862 if (CONSP (AREF (fun
, COMPILED_BYTECODE
)))
2863 Ffetch_bytecode (fun
);
2864 val
= Fbyte_code (AREF (fun
, COMPILED_BYTECODE
),
2865 AREF (fun
, COMPILED_CONSTANTS
),
2866 AREF (fun
, COMPILED_STACK_DEPTH
));
2869 return unbind_to (count
, val
);
2872 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
2874 doc
: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
2880 if (COMPILEDP (object
) && CONSP (AREF (object
, COMPILED_BYTECODE
)))
2882 tem
= read_doc_string (AREF (object
, COMPILED_BYTECODE
));
2885 tem
= AREF (object
, COMPILED_BYTECODE
);
2886 if (CONSP (tem
) && STRINGP (XCAR (tem
)))
2887 error ("Invalid byte code in %s", XSTRING (XCAR (tem
))->data
);
2889 error ("Invalid byte code");
2891 AREF (object
, COMPILED_BYTECODE
) = XCAR (tem
);
2892 AREF (object
, COMPILED_CONSTANTS
) = XCDR (tem
);
2900 register int count
= specpdl_ptr
- specpdl
;
2901 if (specpdl_size
>= max_specpdl_size
)
2903 if (max_specpdl_size
< 400)
2904 max_specpdl_size
= 400;
2905 if (specpdl_size
>= max_specpdl_size
)
2907 if (!NILP (Vdebug_on_error
))
2908 /* Leave room for some specpdl in the debugger. */
2909 max_specpdl_size
= specpdl_size
+ 100;
2911 Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil
));
2915 if (specpdl_size
> max_specpdl_size
)
2916 specpdl_size
= max_specpdl_size
;
2917 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
2918 specpdl_ptr
= specpdl
+ count
;
2922 specbind (symbol
, value
)
2923 Lisp_Object symbol
, value
;
2926 Lisp_Object valcontents
;
2928 CHECK_SYMBOL (symbol
);
2929 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2932 /* The most common case is that of a non-constant symbol with a
2933 trivial value. Make that as fast as we can. */
2934 valcontents
= SYMBOL_VALUE (symbol
);
2935 if (!MISCP (valcontents
) && !SYMBOL_CONSTANT_P (symbol
))
2937 specpdl_ptr
->symbol
= symbol
;
2938 specpdl_ptr
->old_value
= valcontents
;
2939 specpdl_ptr
->func
= NULL
;
2941 SET_SYMBOL_VALUE (symbol
, value
);
2945 Lisp_Object valcontents
;
2947 ovalue
= find_symbol_value (symbol
);
2948 specpdl_ptr
->func
= 0;
2949 specpdl_ptr
->old_value
= ovalue
;
2951 valcontents
= XSYMBOL (symbol
)->value
;
2953 if (BUFFER_LOCAL_VALUEP (valcontents
)
2954 || SOME_BUFFER_LOCAL_VALUEP (valcontents
)
2955 || BUFFER_OBJFWDP (valcontents
))
2957 Lisp_Object where
, current_buffer
;
2959 current_buffer
= Fcurrent_buffer ();
2961 /* For a local variable, record both the symbol and which
2962 buffer's or frame's value we are saving. */
2963 if (!NILP (Flocal_variable_p (symbol
, Qnil
)))
2964 where
= current_buffer
;
2965 else if (!BUFFER_OBJFWDP (valcontents
)
2966 && XBUFFER_LOCAL_VALUE (valcontents
)->found_for_frame
)
2967 where
= XBUFFER_LOCAL_VALUE (valcontents
)->frame
;
2971 /* We're not using the `unused' slot in the specbinding
2972 structure because this would mean we have to do more
2973 work for simple variables. */
2974 specpdl_ptr
->symbol
= Fcons (symbol
, Fcons (where
, current_buffer
));
2976 /* If SYMBOL is a per-buffer variable which doesn't have a
2977 buffer-local value here, make the `let' change the global
2978 value by changing the value of SYMBOL in all buffers not
2979 having their own value. This is consistent with what
2980 happens with other buffer-local variables. */
2982 && BUFFER_OBJFWDP (valcontents
))
2985 Fset_default (symbol
, value
);
2990 specpdl_ptr
->symbol
= symbol
;
2993 if (BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
))
2994 store_symval_forwarding (symbol
, ovalue
, value
, NULL
);
2996 set_internal (symbol
, value
, 0, 1);
3001 record_unwind_protect (function
, arg
)
3002 Lisp_Object (*function
) P_ ((Lisp_Object
));
3005 if (specpdl_ptr
== specpdl
+ specpdl_size
)
3007 specpdl_ptr
->func
= function
;
3008 specpdl_ptr
->symbol
= Qnil
;
3009 specpdl_ptr
->old_value
= arg
;
3014 unbind_to (count
, value
)
3018 int quitf
= !NILP (Vquit_flag
);
3019 struct gcpro gcpro1
;
3024 while (specpdl_ptr
!= specpdl
+ count
)
3028 if (specpdl_ptr
->func
!= 0)
3029 (*specpdl_ptr
->func
) (specpdl_ptr
->old_value
);
3030 /* Note that a "binding" of nil is really an unwind protect,
3031 so in that case the "old value" is a list of forms to evaluate. */
3032 else if (NILP (specpdl_ptr
->symbol
))
3033 Fprogn (specpdl_ptr
->old_value
);
3034 /* If the symbol is a list, it is really (SYMBOL WHERE
3035 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3036 frame. If WHERE is a buffer or frame, this indicates we
3037 bound a variable that had a buffer-local or frame-local
3038 binding. WHERE nil means that the variable had the default
3039 value when it was bound. CURRENT-BUFFER is the buffer that
3040 was current when the variable was bound. */
3041 else if (CONSP (specpdl_ptr
->symbol
))
3043 Lisp_Object symbol
, where
;
3045 symbol
= XCAR (specpdl_ptr
->symbol
);
3046 where
= XCAR (XCDR (specpdl_ptr
->symbol
));
3049 Fset_default (symbol
, specpdl_ptr
->old_value
);
3050 else if (BUFFERP (where
))
3051 set_internal (symbol
, specpdl_ptr
->old_value
, XBUFFER (where
), 1);
3053 set_internal (symbol
, specpdl_ptr
->old_value
, NULL
, 1);
3057 /* If variable has a trivial value (no forwarding), we can
3058 just set it. No need to check for constant symbols here,
3059 since that was already done by specbind. */
3060 if (!MISCP (SYMBOL_VALUE (specpdl_ptr
->symbol
)))
3061 SET_SYMBOL_VALUE (specpdl_ptr
->symbol
, specpdl_ptr
->old_value
);
3063 set_internal (specpdl_ptr
->symbol
, specpdl_ptr
->old_value
, 0, 1);
3067 if (NILP (Vquit_flag
) && quitf
)
3074 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3075 doc
: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3076 The debugger is entered when that frame exits, if the flag is non-nil. */)
3078 Lisp_Object level
, flag
;
3080 register struct backtrace
*backlist
= backtrace_list
;
3083 CHECK_NUMBER (level
);
3085 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
3087 backlist
= backlist
->next
;
3091 backlist
->debug_on_exit
= !NILP (flag
);
3096 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3097 doc
: /* Print a trace of Lisp function calls currently active.
3098 Output stream used is value of `standard-output'. */)
3101 register struct backtrace
*backlist
= backtrace_list
;
3105 extern Lisp_Object Vprint_level
;
3106 struct gcpro gcpro1
;
3108 XSETFASTINT (Vprint_level
, 3);
3115 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
3116 if (backlist
->nargs
== UNEVALLED
)
3118 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
3119 write_string ("\n", -1);
3123 tem
= *backlist
->function
;
3124 Fprin1 (tem
, Qnil
); /* This can QUIT */
3125 write_string ("(", -1);
3126 if (backlist
->nargs
== MANY
)
3128 for (tail
= *backlist
->args
, i
= 0;
3130 tail
= Fcdr (tail
), i
++)
3132 if (i
) write_string (" ", -1);
3133 Fprin1 (Fcar (tail
), Qnil
);
3138 for (i
= 0; i
< backlist
->nargs
; i
++)
3140 if (i
) write_string (" ", -1);
3141 Fprin1 (backlist
->args
[i
], Qnil
);
3144 write_string (")\n", -1);
3146 backlist
= backlist
->next
;
3149 Vprint_level
= Qnil
;
3154 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, NULL
,
3155 doc
: /* Return the function and arguments NFRAMES up from current execution point.
3156 If that frame has not evaluated the arguments yet (or is a special form),
3157 the value is (nil FUNCTION ARG-FORMS...).
3158 If that frame has evaluated its arguments and called its function already,
3159 the value is (t FUNCTION ARG-VALUES...).
3160 A &rest arg is represented as the tail of the list ARG-VALUES.
3161 FUNCTION is whatever was supplied as car of evaluated list,
3162 or a lambda expression for macro calls.
3163 If NFRAMES is more than the number of frames, the value is nil. */)
3165 Lisp_Object nframes
;
3167 register struct backtrace
*backlist
= backtrace_list
;
3171 CHECK_NATNUM (nframes
);
3173 /* Find the frame requested. */
3174 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3175 backlist
= backlist
->next
;
3179 if (backlist
->nargs
== UNEVALLED
)
3180 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3183 if (backlist
->nargs
== MANY
)
3184 tem
= *backlist
->args
;
3186 tem
= Flist (backlist
->nargs
, backlist
->args
);
3188 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3196 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
3197 doc
: /* *Limit on number of Lisp variable bindings & unwind-protects.
3198 If Lisp code tries to make more than this many at once,
3199 an error is signaled. */);
3201 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
3202 doc
: /* *Limit on depth in `eval', `apply' and `funcall' before error.
3203 This limit is to catch infinite recursions for you before they cause
3204 actual stack overflow in C, which would be fatal for Emacs.
3205 You can safely make it considerably larger than its default value,
3206 if that proves inconveniently small. */);
3208 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
3209 doc
: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3210 Typing C-g sets `quit-flag' non-nil, regardless of `inhibit-quit'. */);
3213 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
3214 doc
: /* Non-nil inhibits C-g quitting from happening immediately.
3215 Note that `quit-flag' will still be set by typing C-g,
3216 so a quit will be signaled as soon as `inhibit-quit' is nil.
3217 To prevent this happening, set `quit-flag' to nil
3218 before making `inhibit-quit' nil. */);
3219 Vinhibit_quit
= Qnil
;
3221 Qinhibit_quit
= intern ("inhibit-quit");
3222 staticpro (&Qinhibit_quit
);
3224 Qautoload
= intern ("autoload");
3225 staticpro (&Qautoload
);
3227 Qdebug_on_error
= intern ("debug-on-error");
3228 staticpro (&Qdebug_on_error
);
3230 Qmacro
= intern ("macro");
3231 staticpro (&Qmacro
);
3233 /* Note that the process handling also uses Qexit, but we don't want
3234 to staticpro it twice, so we just do it here. */
3235 Qexit
= intern ("exit");
3238 Qinteractive
= intern ("interactive");
3239 staticpro (&Qinteractive
);
3241 Qcommandp
= intern ("commandp");
3242 staticpro (&Qcommandp
);
3244 Qdefun
= intern ("defun");
3245 staticpro (&Qdefun
);
3247 Qand_rest
= intern ("&rest");
3248 staticpro (&Qand_rest
);
3250 Qand_optional
= intern ("&optional");
3251 staticpro (&Qand_optional
);
3253 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
3254 doc
: /* *Non-nil means errors display a backtrace buffer.
3255 More precisely, this happens for any error that is handled
3256 by the editor command loop.
3257 If the value is a list, an error only means to display a backtrace
3258 if one of its condition symbols appears in the list. */);
3259 Vstack_trace_on_error
= Qnil
;
3261 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
3262 doc
: /* *Non-nil means enter debugger if an error is signaled.
3263 Does not apply to errors handled by `condition-case' or those
3264 matched by `debug-ignored-errors'.
3265 If the value is a list, an error only means to enter the debugger
3266 if one of its condition symbols appears in the list.
3267 When you evaluate an expression interactively, this variable
3268 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3269 See also variable `debug-on-quit'. */);
3270 Vdebug_on_error
= Qnil
;
3272 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
3273 doc
: /* *List of errors for which the debugger should not be called.
3274 Each element may be a condition-name or a regexp that matches error messages.
3275 If any element applies to a given error, that error skips the debugger
3276 and just returns to top level.
3277 This overrides the variable `debug-on-error'.
3278 It does not apply to errors handled by `condition-case'. */);
3279 Vdebug_ignored_errors
= Qnil
;
3281 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
3282 doc
: /* *Non-nil means enter debugger if quit is signaled (C-g, for example).
3283 Does not apply if quit is handled by a `condition-case'.
3284 When you evaluate an expression interactively, this variable
3285 is temporarily non-nil if `eval-expression-debug-on-quit' is non-nil. */);
3288 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
3289 doc
: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'. */);
3291 DEFVAR_BOOL ("debugger-may-continue", &debugger_may_continue
,
3292 doc
: /* Non-nil means debugger may continue execution.
3293 This is nil when the debugger is called under circumstances where it
3294 might not be safe to continue. */);
3295 debugger_may_continue
= 1;
3297 DEFVAR_LISP ("debugger", &Vdebugger
,
3298 doc
: /* Function to call to invoke debugger.
3299 If due to frame exit, args are `exit' and the value being returned;
3300 this function's value will be returned instead of that.
3301 If due to error, args are `error' and a list of the args to `signal'.
3302 If due to `apply' or `funcall' entry, one arg, `lambda'.
3303 If due to `eval' entry, one arg, t. */);
3306 DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function
,
3307 doc
: /* If non-nil, this is a function for `signal' to call.
3308 It receives the same arguments that `signal' was given.
3309 The Edebug package uses this to regain control. */);
3310 Vsignal_hook_function
= Qnil
;
3312 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal
,
3313 doc
: /* *Non-nil means call the debugger regardless of condition handlers.
3314 Note that `debug-on-error', `debug-on-quit' and friends
3315 still determine whether to handle the particular condition. */);
3316 Vdebug_on_signal
= Qnil
;
3318 Vrun_hooks
= intern ("run-hooks");
3319 staticpro (&Vrun_hooks
);
3321 staticpro (&Vautoload_queue
);
3322 Vautoload_queue
= Qnil
;
3323 staticpro (&Vsignaling_function
);
3324 Vsignaling_function
= Qnil
;
3335 defsubr (&Sfunction
);
3337 defsubr (&Sdefmacro
);
3339 defsubr (&Sdefvaralias
);
3340 defsubr (&Sdefconst
);
3341 defsubr (&Suser_variable_p
);
3345 defsubr (&Smacroexpand
);
3348 defsubr (&Sunwind_protect
);
3349 defsubr (&Scondition_case
);
3351 defsubr (&Sinteractive_p
);
3352 defsubr (&Scommandp
);
3353 defsubr (&Sautoload
);
3356 defsubr (&Sfuncall
);
3357 defsubr (&Srun_hooks
);
3358 defsubr (&Srun_hook_with_args
);
3359 defsubr (&Srun_hook_with_args_until_success
);
3360 defsubr (&Srun_hook_with_args_until_failure
);
3361 defsubr (&Sfetch_bytecode
);
3362 defsubr (&Sbacktrace_debug
);
3363 defsubr (&Sbacktrace
);
3364 defsubr (&Sbacktrace_frame
);