1 /* Evaluator for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 99, 2000
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
71 struct catchtag
*next
;
74 struct backtrace
*backlist
;
75 struct handler
*handlerlist
;
78 int poll_suppress_count
;
79 struct byte_stack
*byte_stack
;
82 struct catchtag
*catchlist
;
85 /* Count levels of GCPRO to detect failure to UNGCPRO. */
89 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
90 Lisp_Object Qinhibit_quit
, Vinhibit_quit
, Vquit_flag
;
91 Lisp_Object Qmocklisp_arguments
, Vmocklisp_arguments
, Qmocklisp
;
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
98 Lisp_Object Vrun_hooks
;
100 /* Non-nil means record all fset's and provide's, to be undone
101 if the file being autoloaded is not fully loaded.
102 They are recorded by being consed onto the front of Vautoload_queue:
103 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */
105 Lisp_Object Vautoload_queue
;
107 /* Current number of specbindings allocated in specpdl. */
110 /* Pointer to beginning of specpdl. */
111 struct specbinding
*specpdl
;
113 /* Pointer to first unused element in specpdl. */
114 struct specbinding
*specpdl_ptr
;
116 /* Maximum size allowed for specpdl allocation */
117 int max_specpdl_size
;
119 /* Depth in Lisp evaluations and function calls. */
122 /* Maximum allowed depth in Lisp evaluations and function calls. */
123 int max_lisp_eval_depth
;
125 /* Nonzero means enter debugger before next function call */
126 int debug_on_next_call
;
128 /* Non-zero means debuffer may continue. This is zero when the
129 debugger is called during redisplay, where it might not be safe to
130 continue the interrupted redisplay. */
132 int debugger_may_continue
;
134 /* List of conditions (non-nil atom means all) which cause a backtrace
135 if an error is handled by the command loop's error handler. */
136 Lisp_Object Vstack_trace_on_error
;
138 /* List of conditions (non-nil atom means all) which enter the debugger
139 if an error is handled by the command loop's error handler. */
140 Lisp_Object Vdebug_on_error
;
142 /* List of conditions and regexps specifying error messages which
143 do not enter the debugger even if Vdebug_on_errors says they should. */
144 Lisp_Object Vdebug_ignored_errors
;
146 /* Non-nil means call the debugger even if the error will be handled. */
147 Lisp_Object Vdebug_on_signal
;
149 /* Hook for edebug to use. */
150 Lisp_Object Vsignal_hook_function
;
152 /* Nonzero means enter debugger if a quit signal
153 is handled by the command loop's error handler. */
156 /* The value of num_nonmacro_input_events as of the last time we
157 started to enter the debugger. If we decide to enter the debugger
158 again when this is still equal to num_nonmacro_input_events, then we
159 know that the debugger itself has an error, and we should just
160 signal the error instead of entering an infinite loop of debugger
162 int when_entered_debugger
;
164 Lisp_Object Vdebugger
;
166 void specbind (), record_unwind_protect ();
168 Lisp_Object
run_hook_with_args ();
170 Lisp_Object
funcall_lambda ();
171 extern Lisp_Object
ml_apply (); /* Apply a mocklisp function to unevaluated argument list */
177 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
178 specpdl_ptr
= specpdl
;
179 max_specpdl_size
= 600;
180 max_lisp_eval_depth
= 300;
188 specpdl_ptr
= specpdl
;
193 debug_on_next_call
= 0;
198 /* This is less than the initial value of num_nonmacro_input_events. */
199 when_entered_debugger
= -1;
206 int debug_while_redisplaying
;
207 int count
= specpdl_ptr
- specpdl
;
210 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
211 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
213 if (specpdl_size
+ 40 > max_specpdl_size
)
214 max_specpdl_size
= specpdl_size
+ 40;
216 #ifdef HAVE_X_WINDOWS
217 if (display_busy_cursor_p
)
218 cancel_busy_cursor ();
221 debug_on_next_call
= 0;
222 when_entered_debugger
= num_nonmacro_input_events
;
224 /* Resetting redisplaying_p to 0 makes sure that debug output is
225 displayed if the debugger is invoked during redisplay. */
226 debug_while_redisplaying
= redisplaying_p
;
228 specbind (intern ("debugger-may-continue"),
229 debug_while_redisplaying
? Qnil
: Qt
);
231 val
= apply1 (Vdebugger
, arg
);
233 /* Interrupting redisplay and resuming it later is not safe under
234 all circumstances. So, when the debugger returns, abort the
235 interupted redisplay by going back to the top-level. */
236 if (debug_while_redisplaying
)
239 return unbind_to (count
, val
);
243 do_debug_on_call (code
)
246 debug_on_next_call
= 0;
247 backtrace_list
->debug_on_exit
= 1;
248 call_debugger (Fcons (code
, Qnil
));
251 /* NOTE!!! Every function that can call EVAL must protect its args
252 and temporaries from garbage collection while it needs them.
253 The definition of `For' shows what you have to do. */
255 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
256 "Eval args until one of them yields non-nil, then return that value.\n\
257 The remaining args are not evalled at all.\n\
258 If all args return nil, return nil.")
262 register Lisp_Object val
;
263 Lisp_Object args_left
;
274 val
= Feval (Fcar (args_left
));
277 args_left
= Fcdr (args_left
);
279 while (!NILP(args_left
));
285 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
286 "Eval args until one of them yields nil, then return nil.\n\
287 The remaining args are not evalled at all.\n\
288 If no arg yields nil, return the last arg's value.")
292 register Lisp_Object val
;
293 Lisp_Object args_left
;
304 val
= Feval (Fcar (args_left
));
307 args_left
= Fcdr (args_left
);
309 while (!NILP(args_left
));
315 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
316 "If COND yields non-nil, do THEN, else do ELSE...\n\
317 Returns the value of THEN or the value of the last of the ELSE's.\n\
318 THEN must be one expression, but ELSE... can be zero or more expressions.\n\
319 If COND yields nil, and there are no ELSE's, the value is nil.")
323 register Lisp_Object cond
;
327 cond
= Feval (Fcar (args
));
331 return Feval (Fcar (Fcdr (args
)));
332 return Fprogn (Fcdr (Fcdr (args
)));
335 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
336 "Try each clause until one succeeds.\n\
337 Each clause looks like (CONDITION BODY...). CONDITION is evaluated\n\
338 and, if the value is non-nil, this clause succeeds:\n\
339 then the expressions in BODY are evaluated and the last one's\n\
340 value is the value of the cond-form.\n\
341 If no clause succeeds, cond returns nil.\n\
342 If a clause has one element, as in (CONDITION),\n\
343 CONDITION's value if non-nil is returned from the cond-form.")
347 register Lisp_Object clause
, val
;
354 clause
= Fcar (args
);
355 val
= Feval (Fcar (clause
));
358 if (!EQ (XCDR (clause
), Qnil
))
359 val
= Fprogn (XCDR (clause
));
369 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
370 "Eval BODY forms sequentially and return value of last one.")
374 register Lisp_Object val
, tem
;
375 Lisp_Object args_left
;
378 /* In Mocklisp code, symbols at the front of the progn arglist
379 are to be bound to zero. */
380 if (!EQ (Vmocklisp_arguments
, Qt
))
382 val
= make_number (0);
383 while (!NILP (args
) && (tem
= Fcar (args
), SYMBOLP (tem
)))
386 specbind (tem
, val
), args
= Fcdr (args
);
398 val
= Feval (Fcar (args_left
));
399 args_left
= Fcdr (args_left
);
401 while (!NILP(args_left
));
407 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
408 "Eval FIRST and BODY sequentially; value from FIRST.\n\
409 The value of FIRST is saved during the evaluation of the remaining args,\n\
410 whose values are discarded.")
415 register Lisp_Object args_left
;
416 struct gcpro gcpro1
, gcpro2
;
417 register int argnum
= 0;
429 val
= Feval (Fcar (args_left
));
431 Feval (Fcar (args_left
));
432 args_left
= Fcdr (args_left
);
434 while (!NILP(args_left
));
440 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
441 "Eval X, Y and BODY sequentially; value from Y.\n\
442 The value of Y is saved during the evaluation of the remaining args,\n\
443 whose values are discarded.")
448 register Lisp_Object args_left
;
449 struct gcpro gcpro1
, gcpro2
;
450 register int argnum
= -1;
464 val
= Feval (Fcar (args_left
));
466 Feval (Fcar (args_left
));
467 args_left
= Fcdr (args_left
);
469 while (!NILP (args_left
));
475 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
476 "Set each SYM to the value of its VAL.\n\
477 The symbols SYM are variables; they are literal (not evaluated).\n\
478 The values VAL are expressions; they are evaluated.\n\
479 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.\n\
480 The second VAL is not computed until after the first SYM is set, and so on;\n\
481 each VAL can use the new value of variables set earlier in the `setq'.\n\
482 The return value of the `setq' form is the value of the last VAL.")
486 register Lisp_Object args_left
;
487 register Lisp_Object val
, sym
;
498 val
= Feval (Fcar (Fcdr (args_left
)));
499 sym
= Fcar (args_left
);
501 args_left
= Fcdr (Fcdr (args_left
));
503 while (!NILP(args_left
));
509 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
510 "Return the argument, without evaluating it. `(quote x)' yields `x'.")
517 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
518 "Like `quote', but preferred for objects which are functions.\n\
519 In byte compilation, `function' causes its argument to be compiled.\n\
520 `quote' cannot do that.")
527 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
528 "Return t if function in which this appears was called interactively.\n\
529 This means that the function was called with call-interactively (which\n\
530 includes being called as the binding of a key)\n\
531 and input is currently coming from the keyboard (not in keyboard macro).")
534 register struct backtrace
*btp
;
535 register Lisp_Object fun
;
540 btp
= backtrace_list
;
542 /* If this isn't a byte-compiled function, there may be a frame at
543 the top for Finteractive_p itself. If so, skip it. */
544 fun
= Findirect_function (*btp
->function
);
545 if (SUBRP (fun
) && XSUBR (fun
) == &Sinteractive_p
)
548 /* If we're running an Emacs 18-style byte-compiled function, there
549 may be a frame for Fbytecode. Now, given the strictest
550 definition, this function isn't really being called
551 interactively, but because that's the way Emacs 18 always builds
552 byte-compiled functions, we'll accept it for now. */
553 if (EQ (*btp
->function
, Qbytecode
))
556 /* If this isn't a byte-compiled function, then we may now be
557 looking at several frames for special forms. Skip past them. */
559 btp
->nargs
== UNEVALLED
)
562 /* btp now points at the frame of the innermost function that isn't
563 a special form, ignoring frames for Finteractive_p and/or
564 Fbytecode at the top. If this frame is for a built-in function
565 (such as load or eval-region) return nil. */
566 fun
= Findirect_function (*btp
->function
);
569 /* btp points to the frame of a Lisp function that called interactive-p.
570 Return t if that function was called interactively. */
571 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
576 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
577 "Define NAME as a function.\n\
578 The definition is (lambda ARGLIST [DOCSTRING] BODY...).\n\
579 See also the function `interactive'.")
583 register Lisp_Object fn_name
;
584 register Lisp_Object defn
;
586 fn_name
= Fcar (args
);
587 defn
= Fcons (Qlambda
, Fcdr (args
));
588 if (!NILP (Vpurify_flag
))
589 defn
= Fpurecopy (defn
);
590 Ffset (fn_name
, defn
);
591 LOADHIST_ATTACH (fn_name
);
595 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
596 "Define NAME as a macro.\n\
597 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).\n\
598 When the macro is called, as in (NAME ARGS...),\n\
599 the function (lambda ARGLIST BODY...) is applied to\n\
600 the list ARGS... as it appears in the expression,\n\
601 and the result should be a form to be evaluated instead of the original.")
605 register Lisp_Object fn_name
;
606 register Lisp_Object defn
;
608 fn_name
= Fcar (args
);
609 defn
= Fcons (Qmacro
, Fcons (Qlambda
, Fcdr (args
)));
610 if (!NILP (Vpurify_flag
))
611 defn
= Fpurecopy (defn
);
612 Ffset (fn_name
, defn
);
613 LOADHIST_ATTACH (fn_name
);
617 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
618 "Define SYMBOL as a variable.\n\
619 You are not required to define a variable in order to use it,\n\
620 but the definition can supply documentation and an initial value\n\
621 in a way that tags can recognize.\n\n\
622 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.\n\
623 If SYMBOL is buffer-local, its default value is what is set;\n\
624 buffer-local values are not affected.\n\
625 INITVALUE and DOCSTRING are optional.\n\
626 If DOCSTRING starts with *, this variable is identified as a user option.\n\
627 This means that M-x set-variable and M-x edit-options recognize it.\n\
628 If INITVALUE is missing, SYMBOL's value is not set.")
632 register Lisp_Object sym
, tem
, tail
;
636 if (!NILP (Fcdr (Fcdr (tail
))))
637 error ("too many arguments");
641 tem
= Fdefault_boundp (sym
);
643 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
645 tail
= Fcdr (Fcdr (args
));
646 if (!NILP (Fcar (tail
)))
649 if (!NILP (Vpurify_flag
))
650 tem
= Fpurecopy (tem
);
651 Fput (sym
, Qvariable_documentation
, tem
);
653 LOADHIST_ATTACH (sym
);
657 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
658 "Define SYMBOL as a constant variable.\n\
659 The intent is that neither programs nor users should ever change this value.\n\
660 Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\
661 If SYMBOL is buffer-local, its default value is what is set;\n\
662 buffer-local values are not affected.\n\
663 DOCSTRING is optional.")
667 register Lisp_Object sym
, tem
;
670 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
671 error ("too many arguments");
673 tem
= Feval (Fcar (Fcdr (args
)));
674 if (!NILP (Vpurify_flag
))
675 tem
= Fpurecopy (tem
);
676 Fset_default (sym
, tem
);
677 tem
= Fcar (Fcdr (Fcdr (args
)));
680 if (!NILP (Vpurify_flag
))
681 tem
= Fpurecopy (tem
);
682 Fput (sym
, Qvariable_documentation
, tem
);
684 LOADHIST_ATTACH (sym
);
688 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
689 "Returns t if VARIABLE is intended to be set and modified by users.\n\
690 \(The alternative is a variable used internally in a Lisp program.)\n\
691 Determined by whether the first character of the documentation\n\
692 for the variable is `*' or if the variable is customizable (has a non-nil\n\
693 value of any of `custom-type', `custom-loads' or `standard-value'\n\
694 on its property list).")
696 Lisp_Object variable
;
698 Lisp_Object documentation
;
700 if (!SYMBOLP (variable
))
703 documentation
= Fget (variable
, Qvariable_documentation
);
704 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
706 if (STRINGP (documentation
)
707 && ((unsigned char) XSTRING (documentation
)->data
[0] == '*'))
709 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
710 if (CONSP (documentation
)
711 && STRINGP (XCAR (documentation
))
712 && INTEGERP (XCDR (documentation
))
713 && XINT (XCDR (documentation
)) < 0)
716 if ((!NILP (Fget (variable
, intern ("custom-type"))))
717 || (!NILP (Fget (variable
, intern ("custom-loads"))))
718 || (!NILP (Fget (variable
, intern ("standard-value")))))
723 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
724 "Bind variables according to VARLIST then eval BODY.\n\
725 The value of the last form in BODY is returned.\n\
726 Each element of VARLIST is a symbol (which is bound to nil)\n\
727 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
728 Each VALUEFORM can refer to the symbols already bound by this VARLIST.")
732 Lisp_Object varlist
, val
, elt
;
733 int count
= specpdl_ptr
- specpdl
;
734 struct gcpro gcpro1
, gcpro2
, gcpro3
;
736 GCPRO3 (args
, elt
, varlist
);
738 varlist
= Fcar (args
);
739 while (!NILP (varlist
))
742 elt
= Fcar (varlist
);
744 specbind (elt
, Qnil
);
745 else if (! NILP (Fcdr (Fcdr (elt
))))
747 Fcons (build_string ("`let' bindings can have only one value-form"),
751 val
= Feval (Fcar (Fcdr (elt
)));
752 specbind (Fcar (elt
), val
);
754 varlist
= Fcdr (varlist
);
757 val
= Fprogn (Fcdr (args
));
758 return unbind_to (count
, val
);
761 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
762 "Bind variables according to VARLIST then eval BODY.\n\
763 The value of the last form in BODY is returned.\n\
764 Each element of VARLIST is a symbol (which is bound to nil)\n\
765 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
766 All the VALUEFORMs are evalled before any symbols are bound.")
770 Lisp_Object
*temps
, tem
;
771 register Lisp_Object elt
, varlist
;
772 int count
= specpdl_ptr
- specpdl
;
774 struct gcpro gcpro1
, gcpro2
;
776 varlist
= Fcar (args
);
778 /* Make space to hold the values to give the bound variables */
779 elt
= Flength (varlist
);
780 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
782 /* Compute the values and store them in `temps' */
784 GCPRO2 (args
, *temps
);
787 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
790 elt
= Fcar (varlist
);
792 temps
[argnum
++] = Qnil
;
793 else if (! NILP (Fcdr (Fcdr (elt
))))
795 Fcons (build_string ("`let' bindings can have only one value-form"),
798 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
799 gcpro2
.nvars
= argnum
;
803 varlist
= Fcar (args
);
804 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
806 elt
= Fcar (varlist
);
807 tem
= temps
[argnum
++];
811 specbind (Fcar (elt
), tem
);
814 elt
= Fprogn (Fcdr (args
));
815 return unbind_to (count
, elt
);
818 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
819 "If TEST yields non-nil, eval BODY... and repeat.\n\
820 The order of execution is thus TEST, BODY, TEST, BODY and so on\n\
821 until TEST returns nil.")
825 Lisp_Object test
, body
, tem
;
826 struct gcpro gcpro1
, gcpro2
;
832 while (tem
= Feval (test
),
833 (!EQ (Vmocklisp_arguments
, Qt
) ? XINT (tem
) : !NILP (tem
)))
843 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
844 "Return result of expanding macros at top level of FORM.\n\
845 If FORM is not a macro call, it is returned unchanged.\n\
846 Otherwise, the macro is expanded and the expansion is considered\n\
847 in place of FORM. When a non-macro-call results, it is returned.\n\n\
848 The second optional arg ENVIRONMENT species an environment of macro\n\
849 definitions to shadow the loaded ones for use in file byte-compilation.")
852 Lisp_Object environment
;
854 /* With cleanups from Hallvard Furuseth. */
855 register Lisp_Object expander
, sym
, def
, tem
;
859 /* Come back here each time we expand a macro call,
860 in case it expands into another macro call. */
863 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
864 def
= sym
= XCAR (form
);
866 /* Trace symbols aliases to other symbols
867 until we get a symbol that is not an alias. */
868 while (SYMBOLP (def
))
872 tem
= Fassq (sym
, environment
);
875 def
= XSYMBOL (sym
)->function
;
876 if (!EQ (def
, Qunbound
))
881 /* Right now TEM is the result from SYM in ENVIRONMENT,
882 and if TEM is nil then DEF is SYM's function definition. */
885 /* SYM is not mentioned in ENVIRONMENT.
886 Look at its function definition. */
887 if (EQ (def
, Qunbound
) || !CONSP (def
))
888 /* Not defined or definition not suitable */
890 if (EQ (XCAR (def
), Qautoload
))
892 /* Autoloading function: will it be a macro when loaded? */
893 tem
= Fnth (make_number (4), def
);
894 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
895 /* Yes, load it and try again. */
899 do_autoload (def
, sym
);
906 else if (!EQ (XCAR (def
), Qmacro
))
908 else expander
= XCDR (def
);
912 expander
= XCDR (tem
);
916 form
= apply1 (expander
, XCDR (form
));
921 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
922 "Eval BODY allowing nonlocal exits using `throw'.\n\
923 TAG is evalled to get the tag to use; it must not be nil.\n\
925 Then the BODY is executed.\n\
926 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.\n\
927 If no throw happens, `catch' returns the value of the last BODY form.\n\
928 If a throw happens, it specifies the value to return from `catch'.")
932 register Lisp_Object tag
;
936 tag
= Feval (Fcar (args
));
938 return internal_catch (tag
, Fprogn
, Fcdr (args
));
941 /* Set up a catch, then call C function FUNC on argument ARG.
942 FUNC should return a Lisp_Object.
943 This is how catches are done from within C code. */
946 internal_catch (tag
, func
, arg
)
948 Lisp_Object (*func
) ();
951 /* This structure is made part of the chain `catchlist'. */
954 /* Fill in the components of c, and put it on the list. */
958 c
.backlist
= backtrace_list
;
959 c
.handlerlist
= handlerlist
;
960 c
.lisp_eval_depth
= lisp_eval_depth
;
961 c
.pdlcount
= specpdl_ptr
- specpdl
;
962 c
.poll_suppress_count
= poll_suppress_count
;
964 c
.byte_stack
= byte_stack_list
;
968 if (! _setjmp (c
.jmp
))
969 c
.val
= (*func
) (arg
);
971 /* Throw works by a longjmp that comes right here. */
976 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
977 jump to that CATCH, returning VALUE as the value of that catch.
979 This is the guts Fthrow and Fsignal; they differ only in the way
980 they choose the catch tag to throw to. A catch tag for a
981 condition-case form has a TAG of Qnil.
983 Before each catch is discarded, unbind all special bindings and
984 execute all unwind-protect clauses made above that catch. Unwind
985 the handler stack as we go, so that the proper handlers are in
986 effect for each unwind-protect clause we run. At the end, restore
987 some static info saved in CATCH, and longjmp to the location
990 This is used for correct unwinding in Fthrow and Fsignal. */
993 unwind_to_catch (catch, value
)
994 struct catchtag
*catch;
997 register int last_time
;
999 /* Save the value in the tag. */
1002 /* Restore the polling-suppression count. */
1003 set_poll_suppress_count (catch->poll_suppress_count
);
1007 last_time
= catchlist
== catch;
1009 /* Unwind the specpdl stack, and then restore the proper set of
1011 unbind_to (catchlist
->pdlcount
, Qnil
);
1012 handlerlist
= catchlist
->handlerlist
;
1013 catchlist
= catchlist
->next
;
1015 while (! last_time
);
1017 byte_stack_list
= catch->byte_stack
;
1018 gcprolist
= catch->gcpro
;
1021 gcpro_level
= gcprolist
->level
+ 1;
1025 backtrace_list
= catch->backlist
;
1026 lisp_eval_depth
= catch->lisp_eval_depth
;
1028 _longjmp (catch->jmp
, 1);
1031 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1032 "Throw to the catch for TAG and return VALUE from it.\n\
1033 Both TAG and VALUE are evalled.")
1035 register Lisp_Object tag
, value
;
1037 register struct catchtag
*c
;
1042 for (c
= catchlist
; c
; c
= c
->next
)
1044 if (EQ (c
->tag
, tag
))
1045 unwind_to_catch (c
, value
);
1047 tag
= Fsignal (Qno_catch
, Fcons (tag
, Fcons (value
, Qnil
)));
1052 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1053 "Do BODYFORM, protecting with UNWINDFORMS.\n\
1054 If BODYFORM completes normally, its value is returned\n\
1055 after executing the UNWINDFORMS.\n\
1056 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.")
1061 int count
= specpdl_ptr
- specpdl
;
1063 record_unwind_protect (0, Fcdr (args
));
1064 val
= Feval (Fcar (args
));
1065 return unbind_to (count
, val
);
1068 /* Chain of condition handlers currently in effect.
1069 The elements of this chain are contained in the stack frames
1070 of Fcondition_case and internal_condition_case.
1071 When an error is signaled (by calling Fsignal, below),
1072 this chain is searched for an element that applies. */
1074 struct handler
*handlerlist
;
1076 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1077 "Regain control when an error is signaled.\n\
1078 executes BODYFORM and returns its value if no error happens.\n\
1079 Each element of HANDLERS looks like (CONDITION-NAME BODY...)\n\
1080 where the BODY is made of Lisp expressions.\n\n\
1081 A handler is applicable to an error\n\
1082 if CONDITION-NAME is one of the error's condition names.\n\
1083 If an error happens, the first applicable handler is run.\n\
1085 The car of a handler may be a list of condition names\n\
1086 instead of a single condition name.\n\
1088 When a handler handles an error,\n\
1089 control returns to the condition-case and the handler BODY... is executed\n\
1090 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\
1091 VAR may be nil; then you do not get access to the signal information.\n\
1093 The value of the last BODY form is returned from the condition-case.\n\
1094 See also the function `signal' for more info.")
1101 register Lisp_Object var
, bodyform
, handlers
;
1104 bodyform
= Fcar (Fcdr (args
));
1105 handlers
= Fcdr (Fcdr (args
));
1106 CHECK_SYMBOL (var
, 0);
1108 for (val
= handlers
; ! NILP (val
); val
= Fcdr (val
))
1114 && (SYMBOLP (XCAR (tem
))
1115 || CONSP (XCAR (tem
))))))
1116 error ("Invalid condition handler", tem
);
1121 c
.backlist
= backtrace_list
;
1122 c
.handlerlist
= handlerlist
;
1123 c
.lisp_eval_depth
= lisp_eval_depth
;
1124 c
.pdlcount
= specpdl_ptr
- specpdl
;
1125 c
.poll_suppress_count
= poll_suppress_count
;
1126 c
.gcpro
= gcprolist
;
1127 c
.byte_stack
= byte_stack_list
;
1128 if (_setjmp (c
.jmp
))
1131 specbind (h
.var
, c
.val
);
1132 val
= Fprogn (Fcdr (h
.chosen_clause
));
1134 /* Note that this just undoes the binding of h.var; whoever
1135 longjumped to us unwound the stack to c.pdlcount before
1137 unbind_to (c
.pdlcount
, Qnil
);
1144 h
.handler
= handlers
;
1145 h
.next
= handlerlist
;
1149 val
= Feval (bodyform
);
1151 handlerlist
= h
.next
;
1155 /* Call the function BFUN with no arguments, catching errors within it
1156 according to HANDLERS. If there is an error, call HFUN with
1157 one argument which is the data that describes the error:
1160 HANDLERS can be a list of conditions to catch.
1161 If HANDLERS is Qt, catch all errors.
1162 If HANDLERS is Qerror, catch all errors
1163 but allow the debugger to run if that is enabled. */
1166 internal_condition_case (bfun
, handlers
, hfun
)
1167 Lisp_Object (*bfun
) ();
1168 Lisp_Object handlers
;
1169 Lisp_Object (*hfun
) ();
1175 /* Since Fsignal resets this to 0, it had better be 0 now
1176 or else we have a potential bug. */
1177 if (interrupt_input_blocked
!= 0)
1182 c
.backlist
= backtrace_list
;
1183 c
.handlerlist
= handlerlist
;
1184 c
.lisp_eval_depth
= lisp_eval_depth
;
1185 c
.pdlcount
= specpdl_ptr
- specpdl
;
1186 c
.poll_suppress_count
= poll_suppress_count
;
1187 c
.gcpro
= gcprolist
;
1188 c
.byte_stack
= byte_stack_list
;
1189 if (_setjmp (c
.jmp
))
1191 return (*hfun
) (c
.val
);
1195 h
.handler
= handlers
;
1197 h
.next
= handlerlist
;
1203 handlerlist
= h
.next
;
1207 /* Like internal_condition_case but call HFUN with ARG as its argument. */
1210 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1211 Lisp_Object (*bfun
) ();
1213 Lisp_Object handlers
;
1214 Lisp_Object (*hfun
) ();
1222 c
.backlist
= backtrace_list
;
1223 c
.handlerlist
= handlerlist
;
1224 c
.lisp_eval_depth
= lisp_eval_depth
;
1225 c
.pdlcount
= specpdl_ptr
- specpdl
;
1226 c
.poll_suppress_count
= poll_suppress_count
;
1227 c
.gcpro
= gcprolist
;
1228 c
.byte_stack
= byte_stack_list
;
1229 if (_setjmp (c
.jmp
))
1231 return (*hfun
) (c
.val
);
1235 h
.handler
= handlers
;
1237 h
.next
= handlerlist
;
1241 val
= (*bfun
) (arg
);
1243 handlerlist
= h
.next
;
1247 static Lisp_Object
find_handler_clause ();
1249 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1250 "Signal an error. Args are ERROR-SYMBOL and associated DATA.\n\
1251 This function does not return.\n\n\
1252 An error symbol is a symbol with an `error-conditions' property\n\
1253 that is a list of condition names.\n\
1254 A handler for any of those names will get to handle this signal.\n\
1255 The symbol `error' should normally be one of them.\n\
1257 DATA should be a list. Its elements are printed as part of the error message.\n\
1258 If the signal is handled, DATA is made available to the handler.\n\
1259 See also the function `condition-case'.")
1260 (error_symbol
, data
)
1261 Lisp_Object error_symbol
, data
;
1263 /* When memory is full, ERROR-SYMBOL is nil,
1264 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA). */
1265 register struct handler
*allhandlers
= handlerlist
;
1266 Lisp_Object conditions
;
1267 extern int gc_in_progress
;
1268 extern int waiting_for_input
;
1269 Lisp_Object debugger_value
;
1271 Lisp_Object real_error_symbol
;
1272 extern int display_busy_cursor_p
;
1275 if (gc_in_progress
|| waiting_for_input
)
1278 TOTALLY_UNBLOCK_INPUT
;
1280 if (NILP (error_symbol
))
1281 real_error_symbol
= Fcar (data
);
1283 real_error_symbol
= error_symbol
;
1285 #ifdef HAVE_X_WINDOWS
1286 if (display_busy_cursor_p
)
1287 cancel_busy_cursor ();
1290 /* This hook is used by edebug. */
1291 if (! NILP (Vsignal_hook_function
))
1292 call2 (Vsignal_hook_function
, error_symbol
, data
);
1294 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1296 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1298 register Lisp_Object clause
;
1299 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1300 error_symbol
, data
, &debugger_value
);
1302 #if 0 /* Most callers are not prepared to handle gc if this returns.
1303 So, since this feature is not very useful, take it out. */
1304 /* If have called debugger and user wants to continue,
1306 if (EQ (clause
, Qlambda
))
1307 return debugger_value
;
1309 if (EQ (clause
, Qlambda
))
1311 /* We can't return values to code which signaled an error, but we
1312 can continue code which has signaled a quit. */
1313 if (EQ (real_error_symbol
, Qquit
))
1316 error ("Cannot return from the debugger in an error");
1322 Lisp_Object unwind_data
;
1323 struct handler
*h
= handlerlist
;
1325 handlerlist
= allhandlers
;
1327 if (NILP (error_symbol
))
1330 unwind_data
= Fcons (error_symbol
, data
);
1331 h
->chosen_clause
= clause
;
1332 unwind_to_catch (h
->tag
, unwind_data
);
1336 handlerlist
= allhandlers
;
1337 /* If no handler is present now, try to run the debugger,
1338 and if that fails, throw to top level. */
1339 find_handler_clause (Qerror
, conditions
, error_symbol
, data
, &debugger_value
);
1341 Fthrow (Qtop_level
, Qt
);
1343 if (! NILP (error_symbol
))
1344 data
= Fcons (error_symbol
, data
);
1346 string
= Ferror_message_string (data
);
1347 fatal ("%s", XSTRING (string
)->data
, 0);
1350 /* Return nonzero iff LIST is a non-nil atom or
1351 a list containing one of CONDITIONS. */
1354 wants_debugger (list
, conditions
)
1355 Lisp_Object list
, conditions
;
1362 while (CONSP (conditions
))
1364 Lisp_Object
this, tail
;
1365 this = XCAR (conditions
);
1366 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1367 if (EQ (XCAR (tail
), this))
1369 conditions
= XCDR (conditions
);
1374 /* Return 1 if an error with condition-symbols CONDITIONS,
1375 and described by SIGNAL-DATA, should skip the debugger
1376 according to debugger-ignore-errors. */
1379 skip_debugger (conditions
, data
)
1380 Lisp_Object conditions
, data
;
1383 int first_string
= 1;
1384 Lisp_Object error_message
;
1386 for (tail
= Vdebug_ignored_errors
; CONSP (tail
);
1389 if (STRINGP (XCAR (tail
)))
1393 error_message
= Ferror_message_string (data
);
1396 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1401 Lisp_Object contail
;
1403 for (contail
= conditions
; CONSP (contail
);
1404 contail
= XCDR (contail
))
1405 if (EQ (XCAR (tail
), XCAR (contail
)))
1413 /* Value of Qlambda means we have called debugger and user has continued.
1414 There are two ways to pass SIG and DATA:
1415 = SIG is the error symbol, and DATA is the rest of the data.
1416 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1417 This is for memory-full errors only.
1419 Store value returned from debugger into *DEBUGGER_VALUE_PTR. */
1422 find_handler_clause (handlers
, conditions
, sig
, data
, debugger_value_ptr
)
1423 Lisp_Object handlers
, conditions
, sig
, data
;
1424 Lisp_Object
*debugger_value_ptr
;
1426 register Lisp_Object h
;
1427 register Lisp_Object tem
;
1429 if (EQ (handlers
, Qt
)) /* t is used by handlers for all conditions, set up by C code. */
1431 /* error is used similarly, but means print an error message
1432 and run the debugger if that is enabled. */
1433 if (EQ (handlers
, Qerror
)
1434 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1435 there is a handler. */
1437 int count
= specpdl_ptr
- specpdl
;
1438 int debugger_called
= 0;
1439 Lisp_Object sig_symbol
, combined_data
;
1440 /* This is set to 1 if we are handling a memory-full error,
1441 because these must not run the debugger.
1442 (There is no room in memory to do that!) */
1443 int no_debugger
= 0;
1447 combined_data
= data
;
1448 sig_symbol
= Fcar (data
);
1453 combined_data
= Fcons (sig
, data
);
1457 if (wants_debugger (Vstack_trace_on_error
, conditions
))
1460 internal_with_output_to_temp_buffer ("*Backtrace*",
1461 (Lisp_Object (*) (Lisp_Object
)) Fbacktrace
,
1464 internal_with_output_to_temp_buffer ("*Backtrace*",
1469 && (EQ (sig_symbol
, Qquit
)
1471 : wants_debugger (Vdebug_on_error
, conditions
))
1472 && ! skip_debugger (conditions
, combined_data
)
1473 && when_entered_debugger
< num_nonmacro_input_events
)
1475 specbind (Qdebug_on_error
, Qnil
);
1477 = call_debugger (Fcons (Qerror
,
1478 Fcons (combined_data
, Qnil
)));
1479 debugger_called
= 1;
1481 /* If there is no handler, return saying whether we ran the debugger. */
1482 if (EQ (handlers
, Qerror
))
1484 if (debugger_called
)
1485 return unbind_to (count
, Qlambda
);
1489 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1491 Lisp_Object handler
, condit
;
1494 if (!CONSP (handler
))
1496 condit
= Fcar (handler
);
1497 /* Handle a single condition name in handler HANDLER. */
1498 if (SYMBOLP (condit
))
1500 tem
= Fmemq (Fcar (handler
), conditions
);
1504 /* Handle a list of condition names in handler HANDLER. */
1505 else if (CONSP (condit
))
1507 while (CONSP (condit
))
1509 tem
= Fmemq (Fcar (condit
), conditions
);
1512 condit
= XCDR (condit
);
1519 /* dump an error message; called like printf */
1523 error (m
, a1
, a2
, a3
)
1543 int used
= doprnt (buffer
, size
, m
, m
+ mlen
, 3, args
);
1548 buffer
= (char *) xrealloc (buffer
, size
);
1551 buffer
= (char *) xmalloc (size
);
1556 string
= build_string (buffer
);
1560 Fsignal (Qerror
, Fcons (string
, Qnil
));
1563 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 1, 0,
1564 "T if FUNCTION makes provisions for interactive calling.\n\
1565 This means it contains a description for how to read arguments to give it.\n\
1566 The value is nil for an invalid function or a symbol with no function\n\
1569 Interactively callable functions include strings and vectors (treated\n\
1570 as keyboard macros), lambda-expressions that contain a top-level call\n\
1571 to `interactive', autoload definitions made by `autoload' with non-nil\n\
1572 fourth argument, and some of the built-in functions of Lisp.\n\
1574 Also, a symbol satisfies `commandp' if its function definition does so.")
1576 Lisp_Object function
;
1578 register Lisp_Object fun
;
1579 register Lisp_Object funcar
;
1583 fun
= indirect_function (fun
);
1584 if (EQ (fun
, Qunbound
))
1587 /* Emacs primitives are interactive if their DEFUN specifies an
1588 interactive spec. */
1591 if (XSUBR (fun
)->prompt
)
1597 /* Bytecode objects are interactive if they are long enough to
1598 have an element whose index is COMPILED_INTERACTIVE, which is
1599 where the interactive spec is stored. */
1600 else if (COMPILEDP (fun
))
1601 return ((XVECTOR (fun
)->size
& PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
1604 /* Strings and vectors are keyboard macros. */
1605 if (STRINGP (fun
) || VECTORP (fun
))
1608 /* Lists may represent commands. */
1611 funcar
= Fcar (fun
);
1612 if (!SYMBOLP (funcar
))
1613 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1614 if (EQ (funcar
, Qlambda
))
1615 return Fassq (Qinteractive
, Fcdr (Fcdr (fun
)));
1616 if (EQ (funcar
, Qmocklisp
))
1617 return Qt
; /* All mocklisp functions can be called interactively */
1618 if (EQ (funcar
, Qautoload
))
1619 return Fcar (Fcdr (Fcdr (Fcdr (fun
))));
1625 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1626 "Define FUNCTION to autoload from FILE.\n\
1627 FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\
1628 Third arg DOCSTRING is documentation for the function.\n\
1629 Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\
1630 Fifth arg TYPE indicates the type of the object:\n\
1631 nil or omitted says FUNCTION is a function,\n\
1632 `keymap' says FUNCTION is really a keymap, and\n\
1633 `macro' or t says FUNCTION is really a macro.\n\
1634 Third through fifth args give info about the real definition.\n\
1635 They default to nil.\n\
1636 If FUNCTION is already defined other than as an autoload,\n\
1637 this does nothing and returns nil.")
1638 (function
, file
, docstring
, interactive
, type
)
1639 Lisp_Object function
, file
, docstring
, interactive
, type
;
1642 Lisp_Object args
[4];
1645 CHECK_SYMBOL (function
, 0);
1646 CHECK_STRING (file
, 1);
1648 /* If function is defined and not as an autoload, don't override */
1649 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
1650 && !(CONSP (XSYMBOL (function
)->function
)
1651 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
1654 if (NILP (Vpurify_flag
))
1655 /* Only add entries after dumping, because the ones before are
1656 not useful and else we get loads of them from the loaddefs.el. */
1657 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
1661 args
[1] = docstring
;
1662 args
[2] = interactive
;
1665 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
1666 #else /* NO_ARG_ARRAY */
1667 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
1668 #endif /* not NO_ARG_ARRAY */
1672 un_autoload (oldqueue
)
1673 Lisp_Object oldqueue
;
1675 register Lisp_Object queue
, first
, second
;
1677 /* Queue to unwind is current value of Vautoload_queue.
1678 oldqueue is the shadowed value to leave in Vautoload_queue. */
1679 queue
= Vautoload_queue
;
1680 Vautoload_queue
= oldqueue
;
1681 while (CONSP (queue
))
1683 first
= Fcar (queue
);
1684 second
= Fcdr (first
);
1685 first
= Fcar (first
);
1686 if (EQ (second
, Qnil
))
1689 Ffset (first
, second
);
1690 queue
= Fcdr (queue
);
1695 /* Load an autoloaded function.
1696 FUNNAME is the symbol which is the function's name.
1697 FUNDEF is the autoload definition (a list). */
1700 do_autoload (fundef
, funname
)
1701 Lisp_Object fundef
, funname
;
1703 int count
= specpdl_ptr
- specpdl
;
1704 Lisp_Object fun
, queue
, first
, second
;
1705 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1708 CHECK_SYMBOL (funname
, 0);
1709 GCPRO3 (fun
, funname
, fundef
);
1711 /* Preserve the match data. */
1712 record_unwind_protect (Fset_match_data
, Fmatch_data (Qnil
, Qnil
));
1714 /* Value saved here is to be restored into Vautoload_queue. */
1715 record_unwind_protect (un_autoload
, Vautoload_queue
);
1716 Vautoload_queue
= Qt
;
1717 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
, Qt
);
1719 /* Save the old autoloads, in case we ever do an unload. */
1720 queue
= Vautoload_queue
;
1721 while (CONSP (queue
))
1723 first
= Fcar (queue
);
1724 second
= Fcdr (first
);
1725 first
= Fcar (first
);
1727 /* Note: This test is subtle. The cdr of an autoload-queue entry
1728 may be an atom if the autoload entry was generated by a defalias
1731 Fput (first
, Qautoload
, (Fcdr (second
)));
1733 queue
= Fcdr (queue
);
1736 /* Once loading finishes, don't undo it. */
1737 Vautoload_queue
= Qt
;
1738 unbind_to (count
, Qnil
);
1740 fun
= Findirect_function (fun
);
1742 if (!NILP (Fequal (fun
, fundef
)))
1743 error ("Autoloading failed to define function %s",
1744 XSYMBOL (funname
)->name
->data
);
1748 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
1749 "Evaluate FORM and return its value.")
1753 Lisp_Object fun
, val
, original_fun
, original_args
;
1755 struct backtrace backtrace
;
1756 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1758 /* Since Fsignal resets this to 0, it had better be 0 now
1759 or else we have a potential bug. */
1760 if (interrupt_input_blocked
!= 0)
1765 if (EQ (Vmocklisp_arguments
, Qt
))
1766 return Fsymbol_value (form
);
1767 val
= Fsymbol_value (form
);
1769 XSETFASTINT (val
, 0);
1770 else if (EQ (val
, Qt
))
1771 XSETFASTINT (val
, 1);
1778 if (consing_since_gc
> gc_cons_threshold
)
1781 Fgarbage_collect ();
1785 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1787 if (max_lisp_eval_depth
< 100)
1788 max_lisp_eval_depth
= 100;
1789 if (lisp_eval_depth
> max_lisp_eval_depth
)
1790 error ("Lisp nesting exceeds max-lisp-eval-depth");
1793 original_fun
= Fcar (form
);
1794 original_args
= Fcdr (form
);
1796 backtrace
.next
= backtrace_list
;
1797 backtrace_list
= &backtrace
;
1798 backtrace
.function
= &original_fun
; /* This also protects them from gc */
1799 backtrace
.args
= &original_args
;
1800 backtrace
.nargs
= UNEVALLED
;
1801 backtrace
.evalargs
= 1;
1802 backtrace
.debug_on_exit
= 0;
1804 if (debug_on_next_call
)
1805 do_debug_on_call (Qt
);
1807 /* At this point, only original_fun and original_args
1808 have values that will be used below */
1810 fun
= Findirect_function (original_fun
);
1814 Lisp_Object numargs
;
1815 Lisp_Object argvals
[8];
1816 Lisp_Object args_left
;
1817 register int i
, maxargs
;
1819 args_left
= original_args
;
1820 numargs
= Flength (args_left
);
1822 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
1823 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
1824 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1826 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1828 backtrace
.evalargs
= 0;
1829 val
= (*XSUBR (fun
)->function
) (args_left
);
1833 if (XSUBR (fun
)->max_args
== MANY
)
1835 /* Pass a vector of evaluated arguments */
1837 register int argnum
= 0;
1839 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1841 GCPRO3 (args_left
, fun
, fun
);
1845 while (!NILP (args_left
))
1847 vals
[argnum
++] = Feval (Fcar (args_left
));
1848 args_left
= Fcdr (args_left
);
1849 gcpro3
.nvars
= argnum
;
1852 backtrace
.args
= vals
;
1853 backtrace
.nargs
= XINT (numargs
);
1855 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
1860 GCPRO3 (args_left
, fun
, fun
);
1861 gcpro3
.var
= argvals
;
1864 maxargs
= XSUBR (fun
)->max_args
;
1865 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
1867 argvals
[i
] = Feval (Fcar (args_left
));
1873 backtrace
.args
= argvals
;
1874 backtrace
.nargs
= XINT (numargs
);
1879 val
= (*XSUBR (fun
)->function
) ();
1882 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
1885 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
1888 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1892 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1893 argvals
[2], argvals
[3]);
1896 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1897 argvals
[3], argvals
[4]);
1900 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1901 argvals
[3], argvals
[4], argvals
[5]);
1904 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1905 argvals
[3], argvals
[4], argvals
[5],
1910 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1911 argvals
[3], argvals
[4], argvals
[5],
1912 argvals
[6], argvals
[7]);
1916 /* Someone has created a subr that takes more arguments than
1917 is supported by this code. We need to either rewrite the
1918 subr to use a different argument protocol, or add more
1919 cases to this switch. */
1923 if (COMPILEDP (fun
))
1924 val
= apply_lambda (fun
, original_args
, 1);
1928 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1929 funcar
= Fcar (fun
);
1930 if (!SYMBOLP (funcar
))
1931 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1932 if (EQ (funcar
, Qautoload
))
1934 do_autoload (fun
, original_fun
);
1937 if (EQ (funcar
, Qmacro
))
1938 val
= Feval (apply1 (Fcdr (fun
), original_args
));
1939 else if (EQ (funcar
, Qlambda
))
1940 val
= apply_lambda (fun
, original_args
, 1);
1941 else if (EQ (funcar
, Qmocklisp
))
1942 val
= ml_apply (fun
, original_args
);
1944 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1947 if (!EQ (Vmocklisp_arguments
, Qt
))
1950 XSETFASTINT (val
, 0);
1951 else if (EQ (val
, Qt
))
1952 XSETFASTINT (val
, 1);
1955 if (backtrace
.debug_on_exit
)
1956 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
1957 backtrace_list
= backtrace
.next
;
1961 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
1962 "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
1963 Then return the value FUNCTION returns.\n\
1964 Thus, (apply '+ 1 2 '(3 4)) returns 10.")
1969 register int i
, numargs
;
1970 register Lisp_Object spread_arg
;
1971 register Lisp_Object
*funcall_args
;
1973 struct gcpro gcpro1
;
1977 spread_arg
= args
[nargs
- 1];
1978 CHECK_LIST (spread_arg
, nargs
);
1980 numargs
= XINT (Flength (spread_arg
));
1983 return Ffuncall (nargs
- 1, args
);
1984 else if (numargs
== 1)
1986 args
[nargs
- 1] = XCAR (spread_arg
);
1987 return Ffuncall (nargs
, args
);
1990 numargs
+= nargs
- 2;
1992 fun
= indirect_function (fun
);
1993 if (EQ (fun
, Qunbound
))
1995 /* Let funcall get the error */
2002 if (numargs
< XSUBR (fun
)->min_args
2003 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2004 goto funcall
; /* Let funcall get the error */
2005 else if (XSUBR (fun
)->max_args
> numargs
)
2007 /* Avoid making funcall cons up a yet another new vector of arguments
2008 by explicitly supplying nil's for optional values */
2009 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
2010 * sizeof (Lisp_Object
));
2011 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2012 funcall_args
[++i
] = Qnil
;
2013 GCPRO1 (*funcall_args
);
2014 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2018 /* We add 1 to numargs because funcall_args includes the
2019 function itself as well as its arguments. */
2022 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
2023 * sizeof (Lisp_Object
));
2024 GCPRO1 (*funcall_args
);
2025 gcpro1
.nvars
= 1 + numargs
;
2028 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
2029 /* Spread the last arg we got. Its first element goes in
2030 the slot that it used to occupy, hence this value of I. */
2032 while (!NILP (spread_arg
))
2034 funcall_args
[i
++] = XCAR (spread_arg
);
2035 spread_arg
= XCDR (spread_arg
);
2038 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
2041 /* Run hook variables in various ways. */
2043 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
2045 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 1, MANY
, 0,
2046 "Run each hook in HOOKS. Major mode functions use this.\n\
2047 Each argument should be a symbol, a hook variable.\n\
2048 These symbols are processed in the order specified.\n\
2049 If a hook symbol has a non-nil value, that value may be a function\n\
2050 or a list of functions to be called to run the hook.\n\
2051 If the value is a function, it is called with no arguments.\n\
2052 If it is a list, the elements are called, in order, with no arguments.\n\
2054 To make a hook variable buffer-local, use `make-local-hook',\n\
2055 not `make-local-variable'.")
2060 Lisp_Object hook
[1];
2063 for (i
= 0; i
< nargs
; i
++)
2066 run_hook_with_args (1, hook
, to_completion
);
2072 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2073 Srun_hook_with_args
, 1, MANY
, 0,
2074 "Run HOOK with the specified arguments ARGS.\n\
2075 HOOK should be a symbol, a hook variable. If HOOK has a non-nil\n\
2076 value, that value may be a function or a list of functions to be\n\
2077 called to run the hook. If the value is a function, it is called with\n\
2078 the given arguments and its return value is returned. If it is a list\n\
2079 of functions, those functions are called, in order,\n\
2080 with the given arguments ARGS.\n\
2081 It is best not to depend on the value return by `run-hook-with-args',\n\
2082 as that may change.\n\
2084 To make a hook variable buffer-local, use `make-local-hook',\n\
2085 not `make-local-variable'.")
2090 return run_hook_with_args (nargs
, args
, to_completion
);
2093 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2094 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2095 "Run HOOK with the specified arguments ARGS.\n\
2096 HOOK should be a symbol, a hook variable. Its value should\n\
2097 be a list of functions. We call those functions, one by one,\n\
2098 passing arguments ARGS to each of them, until one of them\n\
2099 returns a non-nil value. Then we return that value.\n\
2100 If all the functions return nil, we return nil.\n\
2102 To make a hook variable buffer-local, use `make-local-hook',\n\
2103 not `make-local-variable'.")
2108 return run_hook_with_args (nargs
, args
, until_success
);
2111 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2112 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2113 "Run HOOK with the specified arguments ARGS.\n\
2114 HOOK should be a symbol, a hook variable. Its value should\n\
2115 be a list of functions. We call those functions, one by one,\n\
2116 passing arguments ARGS to each of them, until one of them\n\
2117 returns nil. Then we return nil.\n\
2118 If all the functions return non-nil, we return non-nil.\n\
2120 To make a hook variable buffer-local, use `make-local-hook',\n\
2121 not `make-local-variable'.")
2126 return run_hook_with_args (nargs
, args
, until_failure
);
2129 /* ARGS[0] should be a hook symbol.
2130 Call each of the functions in the hook value, passing each of them
2131 as arguments all the rest of ARGS (all NARGS - 1 elements).
2132 COND specifies a condition to test after each call
2133 to decide whether to stop.
2134 The caller (or its caller, etc) must gcpro all of ARGS,
2135 except that it isn't necessary to gcpro ARGS[0]. */
2138 run_hook_with_args (nargs
, args
, cond
)
2141 enum run_hooks_condition cond
;
2143 Lisp_Object sym
, val
, ret
;
2144 Lisp_Object globals
;
2145 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2147 /* If we are dying or still initializing,
2148 don't do anything--it would probably crash if we tried. */
2149 if (NILP (Vrun_hooks
))
2153 val
= find_symbol_value (sym
);
2154 ret
= (cond
== until_failure
? Qt
: Qnil
);
2156 if (EQ (val
, Qunbound
) || NILP (val
))
2158 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2161 return Ffuncall (nargs
, args
);
2166 GCPRO3 (sym
, val
, globals
);
2169 CONSP (val
) && ((cond
== to_completion
)
2170 || (cond
== until_success
? NILP (ret
)
2174 if (EQ (XCAR (val
), Qt
))
2176 /* t indicates this hook has a local binding;
2177 it means to run the global binding too. */
2179 for (globals
= Fdefault_value (sym
);
2180 CONSP (globals
) && ((cond
== to_completion
)
2181 || (cond
== until_success
? NILP (ret
)
2183 globals
= XCDR (globals
))
2185 args
[0] = XCAR (globals
);
2186 /* In a global value, t should not occur. If it does, we
2187 must ignore it to avoid an endless loop. */
2188 if (!EQ (args
[0], Qt
))
2189 ret
= Ffuncall (nargs
, args
);
2194 args
[0] = XCAR (val
);
2195 ret
= Ffuncall (nargs
, args
);
2204 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2205 present value of that symbol.
2206 Call each element of FUNLIST,
2207 passing each of them the rest of ARGS.
2208 The caller (or its caller, etc) must gcpro all of ARGS,
2209 except that it isn't necessary to gcpro ARGS[0]. */
2212 run_hook_list_with_args (funlist
, nargs
, args
)
2213 Lisp_Object funlist
;
2219 Lisp_Object globals
;
2220 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2224 GCPRO3 (sym
, val
, globals
);
2226 for (val
= funlist
; CONSP (val
); val
= XCDR (val
))
2228 if (EQ (XCAR (val
), Qt
))
2230 /* t indicates this hook has a local binding;
2231 it means to run the global binding too. */
2233 for (globals
= Fdefault_value (sym
);
2235 globals
= XCDR (globals
))
2237 args
[0] = XCAR (globals
);
2238 /* In a global value, t should not occur. If it does, we
2239 must ignore it to avoid an endless loop. */
2240 if (!EQ (args
[0], Qt
))
2241 Ffuncall (nargs
, args
);
2246 args
[0] = XCAR (val
);
2247 Ffuncall (nargs
, args
);
2254 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2257 run_hook_with_args_2 (hook
, arg1
, arg2
)
2258 Lisp_Object hook
, arg1
, arg2
;
2260 Lisp_Object temp
[3];
2265 Frun_hook_with_args (3, temp
);
2268 /* Apply fn to arg */
2271 Lisp_Object fn
, arg
;
2273 struct gcpro gcpro1
;
2277 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2281 Lisp_Object args
[2];
2285 RETURN_UNGCPRO (Fapply (2, args
));
2287 #else /* not NO_ARG_ARRAY */
2288 RETURN_UNGCPRO (Fapply (2, &fn
));
2289 #endif /* not NO_ARG_ARRAY */
2292 /* Call function fn on no arguments */
2297 struct gcpro gcpro1
;
2300 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2303 /* Call function fn with 1 argument arg1 */
2307 Lisp_Object fn
, arg1
;
2309 struct gcpro gcpro1
;
2311 Lisp_Object args
[2];
2317 RETURN_UNGCPRO (Ffuncall (2, args
));
2318 #else /* not NO_ARG_ARRAY */
2321 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2322 #endif /* not NO_ARG_ARRAY */
2325 /* Call function fn with 2 arguments arg1, arg2 */
2328 call2 (fn
, arg1
, arg2
)
2329 Lisp_Object fn
, arg1
, arg2
;
2331 struct gcpro gcpro1
;
2333 Lisp_Object args
[3];
2339 RETURN_UNGCPRO (Ffuncall (3, args
));
2340 #else /* not NO_ARG_ARRAY */
2343 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2344 #endif /* not NO_ARG_ARRAY */
2347 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2350 call3 (fn
, arg1
, arg2
, arg3
)
2351 Lisp_Object fn
, arg1
, arg2
, arg3
;
2353 struct gcpro gcpro1
;
2355 Lisp_Object args
[4];
2362 RETURN_UNGCPRO (Ffuncall (4, args
));
2363 #else /* not NO_ARG_ARRAY */
2366 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2367 #endif /* not NO_ARG_ARRAY */
2370 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2373 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2374 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2376 struct gcpro gcpro1
;
2378 Lisp_Object args
[5];
2386 RETURN_UNGCPRO (Ffuncall (5, args
));
2387 #else /* not NO_ARG_ARRAY */
2390 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2391 #endif /* not NO_ARG_ARRAY */
2394 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2397 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2398 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2400 struct gcpro gcpro1
;
2402 Lisp_Object args
[6];
2411 RETURN_UNGCPRO (Ffuncall (6, args
));
2412 #else /* not NO_ARG_ARRAY */
2415 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2416 #endif /* not NO_ARG_ARRAY */
2419 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2422 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2423 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2425 struct gcpro gcpro1
;
2427 Lisp_Object args
[7];
2437 RETURN_UNGCPRO (Ffuncall (7, args
));
2438 #else /* not NO_ARG_ARRAY */
2441 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2442 #endif /* not NO_ARG_ARRAY */
2445 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2446 "Call first argument as a function, passing remaining arguments to it.\n\
2447 Return the value that function returns.\n\
2448 Thus, (funcall 'cons 'x 'y) returns (x . y).")
2455 int numargs
= nargs
- 1;
2456 Lisp_Object lisp_numargs
;
2458 struct backtrace backtrace
;
2459 register Lisp_Object
*internal_args
;
2463 if (consing_since_gc
> gc_cons_threshold
)
2464 Fgarbage_collect ();
2466 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2468 if (max_lisp_eval_depth
< 100)
2469 max_lisp_eval_depth
= 100;
2470 if (lisp_eval_depth
> max_lisp_eval_depth
)
2471 error ("Lisp nesting exceeds max-lisp-eval-depth");
2474 backtrace
.next
= backtrace_list
;
2475 backtrace_list
= &backtrace
;
2476 backtrace
.function
= &args
[0];
2477 backtrace
.args
= &args
[1];
2478 backtrace
.nargs
= nargs
- 1;
2479 backtrace
.evalargs
= 0;
2480 backtrace
.debug_on_exit
= 0;
2482 if (debug_on_next_call
)
2483 do_debug_on_call (Qlambda
);
2489 fun
= Findirect_function (fun
);
2493 if (numargs
< XSUBR (fun
)->min_args
2494 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2496 XSETFASTINT (lisp_numargs
, numargs
);
2497 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (lisp_numargs
, Qnil
)));
2500 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2501 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2503 if (XSUBR (fun
)->max_args
== MANY
)
2505 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
2509 if (XSUBR (fun
)->max_args
> numargs
)
2511 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2512 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
2513 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2514 internal_args
[i
] = Qnil
;
2517 internal_args
= args
+ 1;
2518 switch (XSUBR (fun
)->max_args
)
2521 val
= (*XSUBR (fun
)->function
) ();
2524 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
2527 val
= (*XSUBR (fun
)->function
) (internal_args
[0],
2531 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2535 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2540 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2541 internal_args
[2], internal_args
[3],
2545 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2546 internal_args
[2], internal_args
[3],
2547 internal_args
[4], internal_args
[5]);
2550 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2551 internal_args
[2], internal_args
[3],
2552 internal_args
[4], internal_args
[5],
2557 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2558 internal_args
[2], internal_args
[3],
2559 internal_args
[4], internal_args
[5],
2560 internal_args
[6], internal_args
[7]);
2565 /* If a subr takes more than 8 arguments without using MANY
2566 or UNEVALLED, we need to extend this function to support it.
2567 Until this is done, there is no way to call the function. */
2571 if (COMPILEDP (fun
))
2572 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2576 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2577 funcar
= Fcar (fun
);
2578 if (!SYMBOLP (funcar
))
2579 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2580 if (EQ (funcar
, Qlambda
))
2581 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2582 else if (EQ (funcar
, Qmocklisp
))
2583 val
= ml_apply (fun
, Flist (numargs
, args
+ 1));
2584 else if (EQ (funcar
, Qautoload
))
2586 do_autoload (fun
, args
[0]);
2590 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2594 if (backtrace
.debug_on_exit
)
2595 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2596 backtrace_list
= backtrace
.next
;
2601 apply_lambda (fun
, args
, eval_flag
)
2602 Lisp_Object fun
, args
;
2605 Lisp_Object args_left
;
2606 Lisp_Object numargs
;
2607 register Lisp_Object
*arg_vector
;
2608 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2610 register Lisp_Object tem
;
2612 numargs
= Flength (args
);
2613 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2616 GCPRO3 (*arg_vector
, args_left
, fun
);
2619 for (i
= 0; i
< XINT (numargs
);)
2621 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2622 if (eval_flag
) tem
= Feval (tem
);
2623 arg_vector
[i
++] = tem
;
2631 backtrace_list
->args
= arg_vector
;
2632 backtrace_list
->nargs
= i
;
2634 backtrace_list
->evalargs
= 0;
2635 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
2637 /* Do the debug-on-exit now, while arg_vector still exists. */
2638 if (backtrace_list
->debug_on_exit
)
2639 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
2640 /* Don't do it again when we return to eval. */
2641 backtrace_list
->debug_on_exit
= 0;
2645 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2646 and return the result of evaluation.
2647 FUN must be either a lambda-expression or a compiled-code object. */
2650 funcall_lambda (fun
, nargs
, arg_vector
)
2653 register Lisp_Object
*arg_vector
;
2655 Lisp_Object val
, syms_left
, next
;
2656 int count
= specpdl_ptr
- specpdl
;
2657 int i
, optional
, rest
;
2659 if (NILP (Vmocklisp_arguments
))
2660 specbind (Qmocklisp_arguments
, Qt
); /* t means NOT mocklisp! */
2664 syms_left
= XCDR (fun
);
2665 if (CONSP (syms_left
))
2666 syms_left
= XCAR (syms_left
);
2668 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2670 else if (COMPILEDP (fun
))
2671 syms_left
= XVECTOR (fun
)->contents
[COMPILED_ARGLIST
];
2675 i
= optional
= rest
= 0;
2676 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
2680 next
= XCAR (syms_left
);
2681 while (!SYMBOLP (next
))
2682 next
= Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2684 if (EQ (next
, Qand_rest
))
2686 else if (EQ (next
, Qand_optional
))
2690 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
2694 specbind (next
, arg_vector
[i
++]);
2696 return Fsignal (Qwrong_number_of_arguments
,
2697 Fcons (fun
, Fcons (make_number (nargs
), Qnil
)));
2699 specbind (next
, Qnil
);
2702 if (!NILP (syms_left
))
2703 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2705 return Fsignal (Qwrong_number_of_arguments
,
2706 Fcons (fun
, Fcons (make_number (nargs
), Qnil
)));
2709 val
= Fprogn (XCDR (XCDR (fun
)));
2712 /* If we have not actually read the bytecode string
2713 and constants vector yet, fetch them from the file. */
2714 if (CONSP (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
]))
2715 Ffetch_bytecode (fun
);
2716 val
= Fbyte_code (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
],
2717 XVECTOR (fun
)->contents
[COMPILED_CONSTANTS
],
2718 XVECTOR (fun
)->contents
[COMPILED_STACK_DEPTH
]);
2721 return unbind_to (count
, val
);
2724 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
2726 "If byte-compiled OBJECT is lazy-loaded, fetch it now.")
2732 if (COMPILEDP (object
)
2733 && CONSP (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]))
2735 tem
= read_doc_string (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]);
2737 error ("invalid byte code");
2738 XVECTOR (object
)->contents
[COMPILED_BYTECODE
] = XCAR (tem
);
2739 XVECTOR (object
)->contents
[COMPILED_CONSTANTS
] = XCDR (tem
);
2747 register int count
= specpdl_ptr
- specpdl
;
2748 if (specpdl_size
>= max_specpdl_size
)
2750 if (max_specpdl_size
< 400)
2751 max_specpdl_size
= 400;
2752 if (specpdl_size
>= max_specpdl_size
)
2754 if (!NILP (Vdebug_on_error
))
2755 /* Leave room for some specpdl in the debugger. */
2756 max_specpdl_size
= specpdl_size
+ 100;
2758 Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil
));
2762 if (specpdl_size
> max_specpdl_size
)
2763 specpdl_size
= max_specpdl_size
;
2764 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
2765 specpdl_ptr
= specpdl
+ count
;
2769 specbind (symbol
, value
)
2770 Lisp_Object symbol
, value
;
2774 CHECK_SYMBOL (symbol
, 0);
2775 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2778 /* The most common case is that a non-constant symbol with a trivial
2779 value. Make that as fast as we can. */
2780 if (!MISCP (XSYMBOL (symbol
)->value
)
2781 && !EQ (symbol
, Qnil
)
2783 && !(XSYMBOL (symbol
)->name
->data
[0] == ':'
2784 && EQ (XSYMBOL (symbol
)->obarray
, initial_obarray
)
2785 && !EQ (value
, symbol
)))
2787 specpdl_ptr
->symbol
= symbol
;
2788 specpdl_ptr
->old_value
= XSYMBOL (symbol
)->value
;
2789 specpdl_ptr
->func
= NULL
;
2791 XSYMBOL (symbol
)->value
= value
;
2795 ovalue
= find_symbol_value (symbol
);
2796 specpdl_ptr
->func
= 0;
2797 specpdl_ptr
->old_value
= ovalue
;
2799 if (BUFFER_LOCAL_VALUEP (XSYMBOL (symbol
)->value
)
2800 || SOME_BUFFER_LOCAL_VALUEP (XSYMBOL (symbol
)->value
)
2801 || BUFFER_OBJFWDP (XSYMBOL (symbol
)->value
))
2803 Lisp_Object current_buffer
, binding_buffer
;
2804 /* For a local variable, record both the symbol and which
2805 buffer's value we are saving. */
2806 current_buffer
= Fcurrent_buffer ();
2807 binding_buffer
= current_buffer
;
2808 /* If the variable is not local in this buffer,
2809 we are saving the global value, so restore that. */
2810 if (NILP (Flocal_variable_p (symbol
, binding_buffer
)))
2811 binding_buffer
= Qnil
;
2813 = Fcons (symbol
, Fcons (binding_buffer
, current_buffer
));
2816 specpdl_ptr
->symbol
= symbol
;
2819 if (BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
))
2820 store_symval_forwarding (symbol
, ovalue
, value
);
2822 set_internal (symbol
, value
, 0, 1);
2827 record_unwind_protect (function
, arg
)
2828 Lisp_Object (*function
) P_ ((Lisp_Object
));
2831 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2833 specpdl_ptr
->func
= function
;
2834 specpdl_ptr
->symbol
= Qnil
;
2835 specpdl_ptr
->old_value
= arg
;
2840 unbind_to (count
, value
)
2844 int quitf
= !NILP (Vquit_flag
);
2845 struct gcpro gcpro1
;
2850 while (specpdl_ptr
!= specpdl
+ count
)
2854 if (specpdl_ptr
->func
!= 0)
2855 (*specpdl_ptr
->func
) (specpdl_ptr
->old_value
);
2856 /* Note that a "binding" of nil is really an unwind protect,
2857 so in that case the "old value" is a list of forms to evaluate. */
2858 else if (NILP (specpdl_ptr
->symbol
))
2859 Fprogn (specpdl_ptr
->old_value
);
2860 /* If the symbol is a list, it is really
2861 (SYMBOL BINDING_BUFFER . CURRENT_BUFFER)
2862 and it indicates we bound a variable that has
2863 buffer-local bindings. */
2864 else if (CONSP (specpdl_ptr
->symbol
))
2866 Lisp_Object symbol
, buffer
;
2868 symbol
= XCAR (specpdl_ptr
->symbol
);
2869 buffer
= XCAR (XCDR (specpdl_ptr
->symbol
));
2871 /* Handle restoring a default value. */
2873 Fset_default (symbol
, specpdl_ptr
->old_value
);
2874 /* Handle restoring a value saved from a live buffer. */
2876 set_internal (symbol
, specpdl_ptr
->old_value
, XBUFFER (buffer
), 1);
2880 /* If variable has a trivial value (no forwarding), we can
2881 just set it. No need to check for constant symbols here,
2882 since that was already done by specbind. */
2883 if (!MISCP (XSYMBOL (specpdl_ptr
->symbol
)->value
))
2884 XSYMBOL (specpdl_ptr
->symbol
)->value
= specpdl_ptr
->old_value
;
2886 set_internal (specpdl_ptr
->symbol
, specpdl_ptr
->old_value
, 0, 1);
2890 if (NILP (Vquit_flag
) && quitf
)
2899 /* Get the value of symbol's global binding, even if that binding
2900 is not now dynamically visible. */
2903 top_level_value (symbol
)
2906 register struct specbinding
*ptr
= specpdl
;
2908 CHECK_SYMBOL (symbol
, 0);
2909 for (; ptr
!= specpdl_ptr
; ptr
++)
2911 if (EQ (ptr
->symbol
, symbol
))
2912 return ptr
->old_value
;
2914 return Fsymbol_value (symbol
);
2918 top_level_set (symbol
, newval
)
2919 Lisp_Object symbol
, newval
;
2921 register struct specbinding
*ptr
= specpdl
;
2923 CHECK_SYMBOL (symbol
, 0);
2924 for (; ptr
!= specpdl_ptr
; ptr
++)
2926 if (EQ (ptr
->symbol
, symbol
))
2928 ptr
->old_value
= newval
;
2932 return Fset (symbol
, newval
);
2937 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
2938 "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\
2939 The debugger is entered when that frame exits, if the flag is non-nil.")
2941 Lisp_Object level
, flag
;
2943 register struct backtrace
*backlist
= backtrace_list
;
2946 CHECK_NUMBER (level
, 0);
2948 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
2950 backlist
= backlist
->next
;
2954 backlist
->debug_on_exit
= !NILP (flag
);
2959 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
2960 "Print a trace of Lisp function calls currently active.\n\
2961 Output stream used is value of `standard-output'.")
2964 register struct backtrace
*backlist
= backtrace_list
;
2968 extern Lisp_Object Vprint_level
;
2969 struct gcpro gcpro1
;
2971 XSETFASTINT (Vprint_level
, 3);
2978 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
2979 if (backlist
->nargs
== UNEVALLED
)
2981 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
2982 write_string ("\n", -1);
2986 tem
= *backlist
->function
;
2987 Fprin1 (tem
, Qnil
); /* This can QUIT */
2988 write_string ("(", -1);
2989 if (backlist
->nargs
== MANY
)
2991 for (tail
= *backlist
->args
, i
= 0;
2993 tail
= Fcdr (tail
), i
++)
2995 if (i
) write_string (" ", -1);
2996 Fprin1 (Fcar (tail
), Qnil
);
3001 for (i
= 0; i
< backlist
->nargs
; i
++)
3003 if (i
) write_string (" ", -1);
3004 Fprin1 (backlist
->args
[i
], Qnil
);
3007 write_string (")\n", -1);
3009 backlist
= backlist
->next
;
3012 Vprint_level
= Qnil
;
3017 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, "",
3018 "Return the function and arguments NFRAMES up from current execution point.\n\
3019 If that frame has not evaluated the arguments yet (or is a special form),\n\
3020 the value is (nil FUNCTION ARG-FORMS...).\n\
3021 If that frame has evaluated its arguments and called its function already,\n\
3022 the value is (t FUNCTION ARG-VALUES...).\n\
3023 A &rest arg is represented as the tail of the list ARG-VALUES.\n\
3024 FUNCTION is whatever was supplied as car of evaluated list,\n\
3025 or a lambda expression for macro calls.\n\
3026 If NFRAMES is more than the number of frames, the value is nil.")
3028 Lisp_Object nframes
;
3030 register struct backtrace
*backlist
= backtrace_list
;
3034 CHECK_NATNUM (nframes
, 0);
3036 /* Find the frame requested. */
3037 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3038 backlist
= backlist
->next
;
3042 if (backlist
->nargs
== UNEVALLED
)
3043 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3046 if (backlist
->nargs
== MANY
)
3047 tem
= *backlist
->args
;
3049 tem
= Flist (backlist
->nargs
, backlist
->args
);
3051 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3058 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
3059 "*Limit on number of Lisp variable bindings & unwind-protects.\n\
3060 If Lisp code tries to make more than this many at once,\n\
3061 an error is signaled.");
3063 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
3064 "*Limit on depth in `eval', `apply' and `funcall' before error.\n\
3065 This limit is to catch infinite recursions for you before they cause\n\
3066 actual stack overflow in C, which would be fatal for Emacs.\n\
3067 You can safely make it considerably larger than its default value,\n\
3068 if that proves inconveniently small.");
3070 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
3071 "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
3072 Typing C-g sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
3075 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
3076 "Non-nil inhibits C-g quitting from happening immediately.\n\
3077 Note that `quit-flag' will still be set by typing C-g,\n\
3078 so a quit will be signaled as soon as `inhibit-quit' is nil.\n\
3079 To prevent this happening, set `quit-flag' to nil\n\
3080 before making `inhibit-quit' nil.");
3081 Vinhibit_quit
= Qnil
;
3083 Qinhibit_quit
= intern ("inhibit-quit");
3084 staticpro (&Qinhibit_quit
);
3086 Qautoload
= intern ("autoload");
3087 staticpro (&Qautoload
);
3089 Qdebug_on_error
= intern ("debug-on-error");
3090 staticpro (&Qdebug_on_error
);
3092 Qmacro
= intern ("macro");
3093 staticpro (&Qmacro
);
3095 /* Note that the process handling also uses Qexit, but we don't want
3096 to staticpro it twice, so we just do it here. */
3097 Qexit
= intern ("exit");
3100 Qinteractive
= intern ("interactive");
3101 staticpro (&Qinteractive
);
3103 Qcommandp
= intern ("commandp");
3104 staticpro (&Qcommandp
);
3106 Qdefun
= intern ("defun");
3107 staticpro (&Qdefun
);
3109 Qand_rest
= intern ("&rest");
3110 staticpro (&Qand_rest
);
3112 Qand_optional
= intern ("&optional");
3113 staticpro (&Qand_optional
);
3115 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
3116 "*Non-nil means automatically display a backtrace buffer\n\
3117 after any error that is handled by the editor command loop.\n\
3118 If the value is a list, an error only means to display a backtrace\n\
3119 if one of its condition symbols appears in the list.");
3120 Vstack_trace_on_error
= Qnil
;
3122 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
3123 "*Non-nil means enter debugger if an error is signaled.\n\
3124 Does not apply to errors handled by `condition-case'.\n\
3125 If the value is a list, an error only means to enter the debugger\n\
3126 if one of its condition symbols appears in the list.\n\
3127 See also variable `debug-on-quit'.");
3128 Vdebug_on_error
= Qnil
;
3130 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
3131 "*List of errors for which the debugger should not be called.\n\
3132 Each element may be a condition-name or a regexp that matches error messages.\n\
3133 If any element applies to a given error, that error skips the debugger\n\
3134 and just returns to top level.\n\
3135 This overrides the variable `debug-on-error'.\n\
3136 It does not apply to errors handled by `condition-case'.");
3137 Vdebug_ignored_errors
= Qnil
;
3139 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
3140 "*Non-nil means enter debugger if quit is signaled (C-g, for example).\n\
3141 Does not apply if quit is handled by a `condition-case'.");
3144 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
3145 "Non-nil means enter debugger before next `eval', `apply' or `funcall'.");
3147 DEFVAR_BOOL ("debugger-may-continue", &debugger_may_continue
,
3148 "Non-nil means debugger may continue execution.\n\
3149 This is nil when the debugger is called under circumstances where it\n\
3150 might not be safe to continue.");
3151 debugger_may_continue
= 1;
3153 DEFVAR_LISP ("debugger", &Vdebugger
,
3154 "Function to call to invoke debugger.\n\
3155 If due to frame exit, args are `exit' and the value being returned;\n\
3156 this function's value will be returned instead of that.\n\
3157 If due to error, args are `error' and a list of the args to `signal'.\n\
3158 If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
3159 If due to `eval' entry, one arg, t.");
3162 DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function
,
3163 "If non-nil, this is a function for `signal' to call.\n\
3164 It receives the same arguments that `signal' was given.\n\
3165 The Edebug package uses this to regain control.");
3166 Vsignal_hook_function
= Qnil
;
3168 Qmocklisp_arguments
= intern ("mocklisp-arguments");
3169 staticpro (&Qmocklisp_arguments
);
3170 DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments
,
3171 "While in a mocklisp function, the list of its unevaluated args.");
3172 Vmocklisp_arguments
= Qt
;
3174 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal
,
3175 "*Non-nil means call the debugger regardless of condition handlers.\n\
3176 Note that `debug-on-error', `debug-on-quit' and friends\n\
3177 still determine whether to handle the particular condition.");
3178 Vdebug_on_signal
= Qnil
;
3180 Vrun_hooks
= intern ("run-hooks");
3181 staticpro (&Vrun_hooks
);
3183 staticpro (&Vautoload_queue
);
3184 Vautoload_queue
= Qnil
;
3195 defsubr (&Sfunction
);
3197 defsubr (&Sdefmacro
);
3199 defsubr (&Sdefconst
);
3200 defsubr (&Suser_variable_p
);
3204 defsubr (&Smacroexpand
);
3207 defsubr (&Sunwind_protect
);
3208 defsubr (&Scondition_case
);
3210 defsubr (&Sinteractive_p
);
3211 defsubr (&Scommandp
);
3212 defsubr (&Sautoload
);
3215 defsubr (&Sfuncall
);
3216 defsubr (&Srun_hooks
);
3217 defsubr (&Srun_hook_with_args
);
3218 defsubr (&Srun_hook_with_args_until_success
);
3219 defsubr (&Srun_hook_with_args_until_failure
);
3220 defsubr (&Sfetch_bytecode
);
3221 defsubr (&Sbacktrace_debug
);
3222 defsubr (&Sbacktrace
);
3223 defsubr (&Sbacktrace_frame
);