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 #if 0 /* Can't do this check anymore because realize_basic_faces has
1176 to BLOCK_INPUT, and can call Lisp. What's really needed is a
1177 flag indicating that we're currently handling a signal. */
1178 /* Since Fsignal resets this to 0, it had better be 0 now
1179 or else we have a potential bug. */
1180 if (interrupt_input_blocked
!= 0)
1186 c
.backlist
= backtrace_list
;
1187 c
.handlerlist
= handlerlist
;
1188 c
.lisp_eval_depth
= lisp_eval_depth
;
1189 c
.pdlcount
= specpdl_ptr
- specpdl
;
1190 c
.poll_suppress_count
= poll_suppress_count
;
1191 c
.gcpro
= gcprolist
;
1192 c
.byte_stack
= byte_stack_list
;
1193 if (_setjmp (c
.jmp
))
1195 return (*hfun
) (c
.val
);
1199 h
.handler
= handlers
;
1201 h
.next
= handlerlist
;
1207 handlerlist
= h
.next
;
1211 /* Like internal_condition_case but call HFUN with ARG as its argument. */
1214 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1215 Lisp_Object (*bfun
) ();
1217 Lisp_Object handlers
;
1218 Lisp_Object (*hfun
) ();
1226 c
.backlist
= backtrace_list
;
1227 c
.handlerlist
= handlerlist
;
1228 c
.lisp_eval_depth
= lisp_eval_depth
;
1229 c
.pdlcount
= specpdl_ptr
- specpdl
;
1230 c
.poll_suppress_count
= poll_suppress_count
;
1231 c
.gcpro
= gcprolist
;
1232 c
.byte_stack
= byte_stack_list
;
1233 if (_setjmp (c
.jmp
))
1235 return (*hfun
) (c
.val
);
1239 h
.handler
= handlers
;
1241 h
.next
= handlerlist
;
1245 val
= (*bfun
) (arg
);
1247 handlerlist
= h
.next
;
1251 static Lisp_Object
find_handler_clause ();
1253 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1254 "Signal an error. Args are ERROR-SYMBOL and associated DATA.\n\
1255 This function does not return.\n\n\
1256 An error symbol is a symbol with an `error-conditions' property\n\
1257 that is a list of condition names.\n\
1258 A handler for any of those names will get to handle this signal.\n\
1259 The symbol `error' should normally be one of them.\n\
1261 DATA should be a list. Its elements are printed as part of the error message.\n\
1262 If the signal is handled, DATA is made available to the handler.\n\
1263 See also the function `condition-case'.")
1264 (error_symbol
, data
)
1265 Lisp_Object error_symbol
, data
;
1267 /* When memory is full, ERROR-SYMBOL is nil,
1268 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA). */
1269 register struct handler
*allhandlers
= handlerlist
;
1270 Lisp_Object conditions
;
1271 extern int gc_in_progress
;
1272 extern int waiting_for_input
;
1273 Lisp_Object debugger_value
;
1275 Lisp_Object real_error_symbol
;
1276 extern int display_busy_cursor_p
;
1279 if (gc_in_progress
|| waiting_for_input
)
1282 TOTALLY_UNBLOCK_INPUT
;
1284 if (NILP (error_symbol
))
1285 real_error_symbol
= Fcar (data
);
1287 real_error_symbol
= error_symbol
;
1289 #ifdef HAVE_X_WINDOWS
1290 if (display_busy_cursor_p
)
1291 cancel_busy_cursor ();
1294 /* This hook is used by edebug. */
1295 if (! NILP (Vsignal_hook_function
))
1296 call2 (Vsignal_hook_function
, error_symbol
, data
);
1298 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1300 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1302 register Lisp_Object clause
;
1304 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1305 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1307 if (specpdl_size
+ 40 > max_specpdl_size
)
1308 max_specpdl_size
= specpdl_size
+ 40;
1310 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1311 error_symbol
, data
, &debugger_value
);
1313 #if 0 /* Most callers are not prepared to handle gc if this returns.
1314 So, since this feature is not very useful, take it out. */
1315 /* If have called debugger and user wants to continue,
1317 if (EQ (clause
, Qlambda
))
1318 return debugger_value
;
1320 if (EQ (clause
, Qlambda
))
1322 /* We can't return values to code which signaled an error, but we
1323 can continue code which has signaled a quit. */
1324 if (EQ (real_error_symbol
, Qquit
))
1327 error ("Cannot return from the debugger in an error");
1333 Lisp_Object unwind_data
;
1334 struct handler
*h
= handlerlist
;
1336 handlerlist
= allhandlers
;
1338 if (NILP (error_symbol
))
1341 unwind_data
= Fcons (error_symbol
, data
);
1342 h
->chosen_clause
= clause
;
1343 unwind_to_catch (h
->tag
, unwind_data
);
1347 handlerlist
= allhandlers
;
1348 /* If no handler is present now, try to run the debugger,
1349 and if that fails, throw to top level. */
1350 find_handler_clause (Qerror
, conditions
, error_symbol
, data
, &debugger_value
);
1352 Fthrow (Qtop_level
, Qt
);
1354 if (! NILP (error_symbol
))
1355 data
= Fcons (error_symbol
, data
);
1357 string
= Ferror_message_string (data
);
1358 fatal ("%s", XSTRING (string
)->data
, 0);
1361 /* Return nonzero iff LIST is a non-nil atom or
1362 a list containing one of CONDITIONS. */
1365 wants_debugger (list
, conditions
)
1366 Lisp_Object list
, conditions
;
1373 while (CONSP (conditions
))
1375 Lisp_Object
this, tail
;
1376 this = XCAR (conditions
);
1377 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1378 if (EQ (XCAR (tail
), this))
1380 conditions
= XCDR (conditions
);
1385 /* Return 1 if an error with condition-symbols CONDITIONS,
1386 and described by SIGNAL-DATA, should skip the debugger
1387 according to debugger-ignore-errors. */
1390 skip_debugger (conditions
, data
)
1391 Lisp_Object conditions
, data
;
1394 int first_string
= 1;
1395 Lisp_Object error_message
;
1397 for (tail
= Vdebug_ignored_errors
; CONSP (tail
);
1400 if (STRINGP (XCAR (tail
)))
1404 error_message
= Ferror_message_string (data
);
1407 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1412 Lisp_Object contail
;
1414 for (contail
= conditions
; CONSP (contail
);
1415 contail
= XCDR (contail
))
1416 if (EQ (XCAR (tail
), XCAR (contail
)))
1424 /* Value of Qlambda means we have called debugger and user has continued.
1425 There are two ways to pass SIG and DATA:
1426 = SIG is the error symbol, and DATA is the rest of the data.
1427 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1428 This is for memory-full errors only.
1430 Store value returned from debugger into *DEBUGGER_VALUE_PTR. */
1433 find_handler_clause (handlers
, conditions
, sig
, data
, debugger_value_ptr
)
1434 Lisp_Object handlers
, conditions
, sig
, data
;
1435 Lisp_Object
*debugger_value_ptr
;
1437 register Lisp_Object h
;
1438 register Lisp_Object tem
;
1440 if (EQ (handlers
, Qt
)) /* t is used by handlers for all conditions, set up by C code. */
1442 /* error is used similarly, but means print an error message
1443 and run the debugger if that is enabled. */
1444 if (EQ (handlers
, Qerror
)
1445 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1446 there is a handler. */
1448 int count
= specpdl_ptr
- specpdl
;
1449 int debugger_called
= 0;
1450 Lisp_Object sig_symbol
, combined_data
;
1451 /* This is set to 1 if we are handling a memory-full error,
1452 because these must not run the debugger.
1453 (There is no room in memory to do that!) */
1454 int no_debugger
= 0;
1458 combined_data
= data
;
1459 sig_symbol
= Fcar (data
);
1464 combined_data
= Fcons (sig
, data
);
1468 if (wants_debugger (Vstack_trace_on_error
, conditions
))
1471 internal_with_output_to_temp_buffer ("*Backtrace*",
1472 (Lisp_Object (*) (Lisp_Object
)) Fbacktrace
,
1475 internal_with_output_to_temp_buffer ("*Backtrace*",
1480 && (EQ (sig_symbol
, Qquit
)
1482 : wants_debugger (Vdebug_on_error
, conditions
))
1483 && ! skip_debugger (conditions
, combined_data
)
1484 && when_entered_debugger
< num_nonmacro_input_events
)
1486 specbind (Qdebug_on_error
, Qnil
);
1488 = call_debugger (Fcons (Qerror
,
1489 Fcons (combined_data
, Qnil
)));
1490 debugger_called
= 1;
1492 /* If there is no handler, return saying whether we ran the debugger. */
1493 if (EQ (handlers
, Qerror
))
1495 if (debugger_called
)
1496 return unbind_to (count
, Qlambda
);
1500 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1502 Lisp_Object handler
, condit
;
1505 if (!CONSP (handler
))
1507 condit
= Fcar (handler
);
1508 /* Handle a single condition name in handler HANDLER. */
1509 if (SYMBOLP (condit
))
1511 tem
= Fmemq (Fcar (handler
), conditions
);
1515 /* Handle a list of condition names in handler HANDLER. */
1516 else if (CONSP (condit
))
1518 while (CONSP (condit
))
1520 tem
= Fmemq (Fcar (condit
), conditions
);
1523 condit
= XCDR (condit
);
1530 /* dump an error message; called like printf */
1534 error (m
, a1
, a2
, a3
)
1554 int used
= doprnt (buffer
, size
, m
, m
+ mlen
, 3, args
);
1559 buffer
= (char *) xrealloc (buffer
, size
);
1562 buffer
= (char *) xmalloc (size
);
1567 string
= build_string (buffer
);
1571 Fsignal (Qerror
, Fcons (string
, Qnil
));
1574 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 1, 0,
1575 "T if FUNCTION makes provisions for interactive calling.\n\
1576 This means it contains a description for how to read arguments to give it.\n\
1577 The value is nil for an invalid function or a symbol with no function\n\
1580 Interactively callable functions include strings and vectors (treated\n\
1581 as keyboard macros), lambda-expressions that contain a top-level call\n\
1582 to `interactive', autoload definitions made by `autoload' with non-nil\n\
1583 fourth argument, and some of the built-in functions of Lisp.\n\
1585 Also, a symbol satisfies `commandp' if its function definition does so.")
1587 Lisp_Object function
;
1589 register Lisp_Object fun
;
1590 register Lisp_Object funcar
;
1594 fun
= indirect_function (fun
);
1595 if (EQ (fun
, Qunbound
))
1598 /* Emacs primitives are interactive if their DEFUN specifies an
1599 interactive spec. */
1602 if (XSUBR (fun
)->prompt
)
1608 /* Bytecode objects are interactive if they are long enough to
1609 have an element whose index is COMPILED_INTERACTIVE, which is
1610 where the interactive spec is stored. */
1611 else if (COMPILEDP (fun
))
1612 return ((XVECTOR (fun
)->size
& PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
1615 /* Strings and vectors are keyboard macros. */
1616 if (STRINGP (fun
) || VECTORP (fun
))
1619 /* Lists may represent commands. */
1622 funcar
= Fcar (fun
);
1623 if (!SYMBOLP (funcar
))
1624 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1625 if (EQ (funcar
, Qlambda
))
1626 return Fassq (Qinteractive
, Fcdr (Fcdr (fun
)));
1627 if (EQ (funcar
, Qmocklisp
))
1628 return Qt
; /* All mocklisp functions can be called interactively */
1629 if (EQ (funcar
, Qautoload
))
1630 return Fcar (Fcdr (Fcdr (Fcdr (fun
))));
1636 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1637 "Define FUNCTION to autoload from FILE.\n\
1638 FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\
1639 Third arg DOCSTRING is documentation for the function.\n\
1640 Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\
1641 Fifth arg TYPE indicates the type of the object:\n\
1642 nil or omitted says FUNCTION is a function,\n\
1643 `keymap' says FUNCTION is really a keymap, and\n\
1644 `macro' or t says FUNCTION is really a macro.\n\
1645 Third through fifth args give info about the real definition.\n\
1646 They default to nil.\n\
1647 If FUNCTION is already defined other than as an autoload,\n\
1648 this does nothing and returns nil.")
1649 (function
, file
, docstring
, interactive
, type
)
1650 Lisp_Object function
, file
, docstring
, interactive
, type
;
1653 Lisp_Object args
[4];
1656 CHECK_SYMBOL (function
, 0);
1657 CHECK_STRING (file
, 1);
1659 /* If function is defined and not as an autoload, don't override */
1660 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
1661 && !(CONSP (XSYMBOL (function
)->function
)
1662 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
1665 if (NILP (Vpurify_flag
))
1666 /* Only add entries after dumping, because the ones before are
1667 not useful and else we get loads of them from the loaddefs.el. */
1668 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
1672 args
[1] = docstring
;
1673 args
[2] = interactive
;
1676 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
1677 #else /* NO_ARG_ARRAY */
1678 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
1679 #endif /* not NO_ARG_ARRAY */
1683 un_autoload (oldqueue
)
1684 Lisp_Object oldqueue
;
1686 register Lisp_Object queue
, first
, second
;
1688 /* Queue to unwind is current value of Vautoload_queue.
1689 oldqueue is the shadowed value to leave in Vautoload_queue. */
1690 queue
= Vautoload_queue
;
1691 Vautoload_queue
= oldqueue
;
1692 while (CONSP (queue
))
1694 first
= Fcar (queue
);
1695 second
= Fcdr (first
);
1696 first
= Fcar (first
);
1697 if (EQ (second
, Qnil
))
1700 Ffset (first
, second
);
1701 queue
= Fcdr (queue
);
1706 /* Load an autoloaded function.
1707 FUNNAME is the symbol which is the function's name.
1708 FUNDEF is the autoload definition (a list). */
1711 do_autoload (fundef
, funname
)
1712 Lisp_Object fundef
, funname
;
1714 int count
= specpdl_ptr
- specpdl
;
1715 Lisp_Object fun
, queue
, first
, second
;
1716 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1719 CHECK_SYMBOL (funname
, 0);
1720 GCPRO3 (fun
, funname
, fundef
);
1722 /* Preserve the match data. */
1723 record_unwind_protect (Fset_match_data
, Fmatch_data (Qnil
, Qnil
));
1725 /* Value saved here is to be restored into Vautoload_queue. */
1726 record_unwind_protect (un_autoload
, Vautoload_queue
);
1727 Vautoload_queue
= Qt
;
1728 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
, Qt
);
1730 /* Save the old autoloads, in case we ever do an unload. */
1731 queue
= Vautoload_queue
;
1732 while (CONSP (queue
))
1734 first
= Fcar (queue
);
1735 second
= Fcdr (first
);
1736 first
= Fcar (first
);
1738 /* Note: This test is subtle. The cdr of an autoload-queue entry
1739 may be an atom if the autoload entry was generated by a defalias
1742 Fput (first
, Qautoload
, (Fcdr (second
)));
1744 queue
= Fcdr (queue
);
1747 /* Once loading finishes, don't undo it. */
1748 Vautoload_queue
= Qt
;
1749 unbind_to (count
, Qnil
);
1751 fun
= Findirect_function (fun
);
1753 if (!NILP (Fequal (fun
, fundef
)))
1754 error ("Autoloading failed to define function %s",
1755 XSYMBOL (funname
)->name
->data
);
1759 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
1760 "Evaluate FORM and return its value.")
1764 Lisp_Object fun
, val
, original_fun
, original_args
;
1766 struct backtrace backtrace
;
1767 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1769 #if 0 /* Can't do this check anymore because realize_basic_faces has
1770 to BLOCK_INPUT, and can call Lisp. What's really needed is a
1771 flag indicating that we're currently handling a signal. */
1772 /* Since Fsignal resets this to 0, it had better be 0 now
1773 or else we have a potential bug. */
1774 if (interrupt_input_blocked
!= 0)
1780 if (EQ (Vmocklisp_arguments
, Qt
))
1781 return Fsymbol_value (form
);
1782 val
= Fsymbol_value (form
);
1784 XSETFASTINT (val
, 0);
1785 else if (EQ (val
, Qt
))
1786 XSETFASTINT (val
, 1);
1793 if (consing_since_gc
> gc_cons_threshold
)
1796 Fgarbage_collect ();
1800 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1802 if (max_lisp_eval_depth
< 100)
1803 max_lisp_eval_depth
= 100;
1804 if (lisp_eval_depth
> max_lisp_eval_depth
)
1805 error ("Lisp nesting exceeds max-lisp-eval-depth");
1808 original_fun
= Fcar (form
);
1809 original_args
= Fcdr (form
);
1811 backtrace
.next
= backtrace_list
;
1812 backtrace_list
= &backtrace
;
1813 backtrace
.function
= &original_fun
; /* This also protects them from gc */
1814 backtrace
.args
= &original_args
;
1815 backtrace
.nargs
= UNEVALLED
;
1816 backtrace
.evalargs
= 1;
1817 backtrace
.debug_on_exit
= 0;
1819 if (debug_on_next_call
)
1820 do_debug_on_call (Qt
);
1822 /* At this point, only original_fun and original_args
1823 have values that will be used below */
1825 fun
= Findirect_function (original_fun
);
1829 Lisp_Object numargs
;
1830 Lisp_Object argvals
[8];
1831 Lisp_Object args_left
;
1832 register int i
, maxargs
;
1834 args_left
= original_args
;
1835 numargs
= Flength (args_left
);
1837 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
1838 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
1839 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1841 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1843 backtrace
.evalargs
= 0;
1844 val
= (*XSUBR (fun
)->function
) (args_left
);
1848 if (XSUBR (fun
)->max_args
== MANY
)
1850 /* Pass a vector of evaluated arguments */
1852 register int argnum
= 0;
1854 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1856 GCPRO3 (args_left
, fun
, fun
);
1860 while (!NILP (args_left
))
1862 vals
[argnum
++] = Feval (Fcar (args_left
));
1863 args_left
= Fcdr (args_left
);
1864 gcpro3
.nvars
= argnum
;
1867 backtrace
.args
= vals
;
1868 backtrace
.nargs
= XINT (numargs
);
1870 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
1875 GCPRO3 (args_left
, fun
, fun
);
1876 gcpro3
.var
= argvals
;
1879 maxargs
= XSUBR (fun
)->max_args
;
1880 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
1882 argvals
[i
] = Feval (Fcar (args_left
));
1888 backtrace
.args
= argvals
;
1889 backtrace
.nargs
= XINT (numargs
);
1894 val
= (*XSUBR (fun
)->function
) ();
1897 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
1900 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
1903 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1907 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1908 argvals
[2], argvals
[3]);
1911 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1912 argvals
[3], argvals
[4]);
1915 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1916 argvals
[3], argvals
[4], argvals
[5]);
1919 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1920 argvals
[3], argvals
[4], argvals
[5],
1925 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1926 argvals
[3], argvals
[4], argvals
[5],
1927 argvals
[6], argvals
[7]);
1931 /* Someone has created a subr that takes more arguments than
1932 is supported by this code. We need to either rewrite the
1933 subr to use a different argument protocol, or add more
1934 cases to this switch. */
1938 if (COMPILEDP (fun
))
1939 val
= apply_lambda (fun
, original_args
, 1);
1943 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1944 funcar
= Fcar (fun
);
1945 if (!SYMBOLP (funcar
))
1946 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1947 if (EQ (funcar
, Qautoload
))
1949 do_autoload (fun
, original_fun
);
1952 if (EQ (funcar
, Qmacro
))
1953 val
= Feval (apply1 (Fcdr (fun
), original_args
));
1954 else if (EQ (funcar
, Qlambda
))
1955 val
= apply_lambda (fun
, original_args
, 1);
1956 else if (EQ (funcar
, Qmocklisp
))
1957 val
= ml_apply (fun
, original_args
);
1959 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1962 if (!EQ (Vmocklisp_arguments
, Qt
))
1965 XSETFASTINT (val
, 0);
1966 else if (EQ (val
, Qt
))
1967 XSETFASTINT (val
, 1);
1970 if (backtrace
.debug_on_exit
)
1971 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
1972 backtrace_list
= backtrace
.next
;
1976 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
1977 "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
1978 Then return the value FUNCTION returns.\n\
1979 Thus, (apply '+ 1 2 '(3 4)) returns 10.")
1984 register int i
, numargs
;
1985 register Lisp_Object spread_arg
;
1986 register Lisp_Object
*funcall_args
;
1988 struct gcpro gcpro1
;
1992 spread_arg
= args
[nargs
- 1];
1993 CHECK_LIST (spread_arg
, nargs
);
1995 numargs
= XINT (Flength (spread_arg
));
1998 return Ffuncall (nargs
- 1, args
);
1999 else if (numargs
== 1)
2001 args
[nargs
- 1] = XCAR (spread_arg
);
2002 return Ffuncall (nargs
, args
);
2005 numargs
+= nargs
- 2;
2007 fun
= indirect_function (fun
);
2008 if (EQ (fun
, Qunbound
))
2010 /* Let funcall get the error */
2017 if (numargs
< XSUBR (fun
)->min_args
2018 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2019 goto funcall
; /* Let funcall get the error */
2020 else if (XSUBR (fun
)->max_args
> numargs
)
2022 /* Avoid making funcall cons up a yet another new vector of arguments
2023 by explicitly supplying nil's for optional values */
2024 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
2025 * sizeof (Lisp_Object
));
2026 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2027 funcall_args
[++i
] = Qnil
;
2028 GCPRO1 (*funcall_args
);
2029 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2033 /* We add 1 to numargs because funcall_args includes the
2034 function itself as well as its arguments. */
2037 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
2038 * sizeof (Lisp_Object
));
2039 GCPRO1 (*funcall_args
);
2040 gcpro1
.nvars
= 1 + numargs
;
2043 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
2044 /* Spread the last arg we got. Its first element goes in
2045 the slot that it used to occupy, hence this value of I. */
2047 while (!NILP (spread_arg
))
2049 funcall_args
[i
++] = XCAR (spread_arg
);
2050 spread_arg
= XCDR (spread_arg
);
2053 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
2056 /* Run hook variables in various ways. */
2058 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
2060 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 1, MANY
, 0,
2061 "Run each hook in HOOKS. Major mode functions use this.\n\
2062 Each argument should be a symbol, a hook variable.\n\
2063 These symbols are processed in the order specified.\n\
2064 If a hook symbol has a non-nil value, that value may be a function\n\
2065 or a list of functions to be called to run the hook.\n\
2066 If the value is a function, it is called with no arguments.\n\
2067 If it is a list, the elements are called, in order, with no arguments.\n\
2069 To make a hook variable buffer-local, use `make-local-hook',\n\
2070 not `make-local-variable'.")
2075 Lisp_Object hook
[1];
2078 for (i
= 0; i
< nargs
; i
++)
2081 run_hook_with_args (1, hook
, to_completion
);
2087 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2088 Srun_hook_with_args
, 1, MANY
, 0,
2089 "Run HOOK with the specified arguments ARGS.\n\
2090 HOOK should be a symbol, a hook variable. If HOOK has a non-nil\n\
2091 value, that value may be a function or a list of functions to be\n\
2092 called to run the hook. If the value is a function, it is called with\n\
2093 the given arguments and its return value is returned. If it is a list\n\
2094 of functions, those functions are called, in order,\n\
2095 with the given arguments ARGS.\n\
2096 It is best not to depend on the value return by `run-hook-with-args',\n\
2097 as that may change.\n\
2099 To make a hook variable buffer-local, use `make-local-hook',\n\
2100 not `make-local-variable'.")
2105 return run_hook_with_args (nargs
, args
, to_completion
);
2108 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2109 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2110 "Run HOOK with the specified arguments ARGS.\n\
2111 HOOK should be a symbol, a hook variable. Its value should\n\
2112 be a list of functions. We call those functions, one by one,\n\
2113 passing arguments ARGS to each of them, until one of them\n\
2114 returns a non-nil value. Then we return that value.\n\
2115 If all the functions return nil, we return nil.\n\
2117 To make a hook variable buffer-local, use `make-local-hook',\n\
2118 not `make-local-variable'.")
2123 return run_hook_with_args (nargs
, args
, until_success
);
2126 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2127 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2128 "Run HOOK with the specified arguments ARGS.\n\
2129 HOOK should be a symbol, a hook variable. Its value should\n\
2130 be a list of functions. We call those functions, one by one,\n\
2131 passing arguments ARGS to each of them, until one of them\n\
2132 returns nil. Then we return nil.\n\
2133 If all the functions return non-nil, we return non-nil.\n\
2135 To make a hook variable buffer-local, use `make-local-hook',\n\
2136 not `make-local-variable'.")
2141 return run_hook_with_args (nargs
, args
, until_failure
);
2144 /* ARGS[0] should be a hook symbol.
2145 Call each of the functions in the hook value, passing each of them
2146 as arguments all the rest of ARGS (all NARGS - 1 elements).
2147 COND specifies a condition to test after each call
2148 to decide whether to stop.
2149 The caller (or its caller, etc) must gcpro all of ARGS,
2150 except that it isn't necessary to gcpro ARGS[0]. */
2153 run_hook_with_args (nargs
, args
, cond
)
2156 enum run_hooks_condition cond
;
2158 Lisp_Object sym
, val
, ret
;
2159 Lisp_Object globals
;
2160 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2162 /* If we are dying or still initializing,
2163 don't do anything--it would probably crash if we tried. */
2164 if (NILP (Vrun_hooks
))
2168 val
= find_symbol_value (sym
);
2169 ret
= (cond
== until_failure
? Qt
: Qnil
);
2171 if (EQ (val
, Qunbound
) || NILP (val
))
2173 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2176 return Ffuncall (nargs
, args
);
2181 GCPRO3 (sym
, val
, globals
);
2184 CONSP (val
) && ((cond
== to_completion
)
2185 || (cond
== until_success
? NILP (ret
)
2189 if (EQ (XCAR (val
), Qt
))
2191 /* t indicates this hook has a local binding;
2192 it means to run the global binding too. */
2194 for (globals
= Fdefault_value (sym
);
2195 CONSP (globals
) && ((cond
== to_completion
)
2196 || (cond
== until_success
? NILP (ret
)
2198 globals
= XCDR (globals
))
2200 args
[0] = XCAR (globals
);
2201 /* In a global value, t should not occur. If it does, we
2202 must ignore it to avoid an endless loop. */
2203 if (!EQ (args
[0], Qt
))
2204 ret
= Ffuncall (nargs
, args
);
2209 args
[0] = XCAR (val
);
2210 ret
= Ffuncall (nargs
, args
);
2219 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2220 present value of that symbol.
2221 Call each element of FUNLIST,
2222 passing each of them the rest of ARGS.
2223 The caller (or its caller, etc) must gcpro all of ARGS,
2224 except that it isn't necessary to gcpro ARGS[0]. */
2227 run_hook_list_with_args (funlist
, nargs
, args
)
2228 Lisp_Object funlist
;
2234 Lisp_Object globals
;
2235 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2239 GCPRO3 (sym
, val
, globals
);
2241 for (val
= funlist
; CONSP (val
); val
= XCDR (val
))
2243 if (EQ (XCAR (val
), Qt
))
2245 /* t indicates this hook has a local binding;
2246 it means to run the global binding too. */
2248 for (globals
= Fdefault_value (sym
);
2250 globals
= XCDR (globals
))
2252 args
[0] = XCAR (globals
);
2253 /* In a global value, t should not occur. If it does, we
2254 must ignore it to avoid an endless loop. */
2255 if (!EQ (args
[0], Qt
))
2256 Ffuncall (nargs
, args
);
2261 args
[0] = XCAR (val
);
2262 Ffuncall (nargs
, args
);
2269 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2272 run_hook_with_args_2 (hook
, arg1
, arg2
)
2273 Lisp_Object hook
, arg1
, arg2
;
2275 Lisp_Object temp
[3];
2280 Frun_hook_with_args (3, temp
);
2283 /* Apply fn to arg */
2286 Lisp_Object fn
, arg
;
2288 struct gcpro gcpro1
;
2292 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2296 Lisp_Object args
[2];
2300 RETURN_UNGCPRO (Fapply (2, args
));
2302 #else /* not NO_ARG_ARRAY */
2303 RETURN_UNGCPRO (Fapply (2, &fn
));
2304 #endif /* not NO_ARG_ARRAY */
2307 /* Call function fn on no arguments */
2312 struct gcpro gcpro1
;
2315 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2318 /* Call function fn with 1 argument arg1 */
2322 Lisp_Object fn
, arg1
;
2324 struct gcpro gcpro1
;
2326 Lisp_Object args
[2];
2332 RETURN_UNGCPRO (Ffuncall (2, args
));
2333 #else /* not NO_ARG_ARRAY */
2336 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2337 #endif /* not NO_ARG_ARRAY */
2340 /* Call function fn with 2 arguments arg1, arg2 */
2343 call2 (fn
, arg1
, arg2
)
2344 Lisp_Object fn
, arg1
, arg2
;
2346 struct gcpro gcpro1
;
2348 Lisp_Object args
[3];
2354 RETURN_UNGCPRO (Ffuncall (3, args
));
2355 #else /* not NO_ARG_ARRAY */
2358 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2359 #endif /* not NO_ARG_ARRAY */
2362 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2365 call3 (fn
, arg1
, arg2
, arg3
)
2366 Lisp_Object fn
, arg1
, arg2
, arg3
;
2368 struct gcpro gcpro1
;
2370 Lisp_Object args
[4];
2377 RETURN_UNGCPRO (Ffuncall (4, args
));
2378 #else /* not NO_ARG_ARRAY */
2381 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2382 #endif /* not NO_ARG_ARRAY */
2385 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2388 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2389 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2391 struct gcpro gcpro1
;
2393 Lisp_Object args
[5];
2401 RETURN_UNGCPRO (Ffuncall (5, args
));
2402 #else /* not NO_ARG_ARRAY */
2405 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2406 #endif /* not NO_ARG_ARRAY */
2409 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2412 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2413 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2415 struct gcpro gcpro1
;
2417 Lisp_Object args
[6];
2426 RETURN_UNGCPRO (Ffuncall (6, args
));
2427 #else /* not NO_ARG_ARRAY */
2430 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2431 #endif /* not NO_ARG_ARRAY */
2434 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2437 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2438 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2440 struct gcpro gcpro1
;
2442 Lisp_Object args
[7];
2452 RETURN_UNGCPRO (Ffuncall (7, args
));
2453 #else /* not NO_ARG_ARRAY */
2456 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2457 #endif /* not NO_ARG_ARRAY */
2460 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2461 "Call first argument as a function, passing remaining arguments to it.\n\
2462 Return the value that function returns.\n\
2463 Thus, (funcall 'cons 'x 'y) returns (x . y).")
2470 int numargs
= nargs
- 1;
2471 Lisp_Object lisp_numargs
;
2473 struct backtrace backtrace
;
2474 register Lisp_Object
*internal_args
;
2478 if (consing_since_gc
> gc_cons_threshold
)
2479 Fgarbage_collect ();
2481 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2483 if (max_lisp_eval_depth
< 100)
2484 max_lisp_eval_depth
= 100;
2485 if (lisp_eval_depth
> max_lisp_eval_depth
)
2486 error ("Lisp nesting exceeds max-lisp-eval-depth");
2489 backtrace
.next
= backtrace_list
;
2490 backtrace_list
= &backtrace
;
2491 backtrace
.function
= &args
[0];
2492 backtrace
.args
= &args
[1];
2493 backtrace
.nargs
= nargs
- 1;
2494 backtrace
.evalargs
= 0;
2495 backtrace
.debug_on_exit
= 0;
2497 if (debug_on_next_call
)
2498 do_debug_on_call (Qlambda
);
2504 fun
= Findirect_function (fun
);
2508 if (numargs
< XSUBR (fun
)->min_args
2509 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2511 XSETFASTINT (lisp_numargs
, numargs
);
2512 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (lisp_numargs
, Qnil
)));
2515 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2516 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2518 if (XSUBR (fun
)->max_args
== MANY
)
2520 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
2524 if (XSUBR (fun
)->max_args
> numargs
)
2526 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2527 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
2528 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2529 internal_args
[i
] = Qnil
;
2532 internal_args
= args
+ 1;
2533 switch (XSUBR (fun
)->max_args
)
2536 val
= (*XSUBR (fun
)->function
) ();
2539 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
2542 val
= (*XSUBR (fun
)->function
) (internal_args
[0],
2546 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2550 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2555 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2556 internal_args
[2], internal_args
[3],
2560 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2561 internal_args
[2], internal_args
[3],
2562 internal_args
[4], internal_args
[5]);
2565 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2566 internal_args
[2], internal_args
[3],
2567 internal_args
[4], internal_args
[5],
2572 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2573 internal_args
[2], internal_args
[3],
2574 internal_args
[4], internal_args
[5],
2575 internal_args
[6], internal_args
[7]);
2580 /* If a subr takes more than 8 arguments without using MANY
2581 or UNEVALLED, we need to extend this function to support it.
2582 Until this is done, there is no way to call the function. */
2586 if (COMPILEDP (fun
))
2587 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2591 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2592 funcar
= Fcar (fun
);
2593 if (!SYMBOLP (funcar
))
2594 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2595 if (EQ (funcar
, Qlambda
))
2596 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2597 else if (EQ (funcar
, Qmocklisp
))
2598 val
= ml_apply (fun
, Flist (numargs
, args
+ 1));
2599 else if (EQ (funcar
, Qautoload
))
2601 do_autoload (fun
, args
[0]);
2605 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2609 if (backtrace
.debug_on_exit
)
2610 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2611 backtrace_list
= backtrace
.next
;
2616 apply_lambda (fun
, args
, eval_flag
)
2617 Lisp_Object fun
, args
;
2620 Lisp_Object args_left
;
2621 Lisp_Object numargs
;
2622 register Lisp_Object
*arg_vector
;
2623 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2625 register Lisp_Object tem
;
2627 numargs
= Flength (args
);
2628 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2631 GCPRO3 (*arg_vector
, args_left
, fun
);
2634 for (i
= 0; i
< XINT (numargs
);)
2636 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2637 if (eval_flag
) tem
= Feval (tem
);
2638 arg_vector
[i
++] = tem
;
2646 backtrace_list
->args
= arg_vector
;
2647 backtrace_list
->nargs
= i
;
2649 backtrace_list
->evalargs
= 0;
2650 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
2652 /* Do the debug-on-exit now, while arg_vector still exists. */
2653 if (backtrace_list
->debug_on_exit
)
2654 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
2655 /* Don't do it again when we return to eval. */
2656 backtrace_list
->debug_on_exit
= 0;
2660 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2661 and return the result of evaluation.
2662 FUN must be either a lambda-expression or a compiled-code object. */
2665 funcall_lambda (fun
, nargs
, arg_vector
)
2668 register Lisp_Object
*arg_vector
;
2670 Lisp_Object val
, syms_left
, next
;
2671 int count
= specpdl_ptr
- specpdl
;
2672 int i
, optional
, rest
;
2674 if (NILP (Vmocklisp_arguments
))
2675 specbind (Qmocklisp_arguments
, Qt
); /* t means NOT mocklisp! */
2679 syms_left
= XCDR (fun
);
2680 if (CONSP (syms_left
))
2681 syms_left
= XCAR (syms_left
);
2683 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2685 else if (COMPILEDP (fun
))
2686 syms_left
= XVECTOR (fun
)->contents
[COMPILED_ARGLIST
];
2690 i
= optional
= rest
= 0;
2691 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
2695 next
= XCAR (syms_left
);
2696 while (!SYMBOLP (next
))
2697 next
= Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2699 if (EQ (next
, Qand_rest
))
2701 else if (EQ (next
, Qand_optional
))
2705 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
2709 specbind (next
, arg_vector
[i
++]);
2711 return Fsignal (Qwrong_number_of_arguments
,
2712 Fcons (fun
, Fcons (make_number (nargs
), Qnil
)));
2714 specbind (next
, Qnil
);
2717 if (!NILP (syms_left
))
2718 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2720 return Fsignal (Qwrong_number_of_arguments
,
2721 Fcons (fun
, Fcons (make_number (nargs
), Qnil
)));
2724 val
= Fprogn (XCDR (XCDR (fun
)));
2727 /* If we have not actually read the bytecode string
2728 and constants vector yet, fetch them from the file. */
2729 if (CONSP (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
]))
2730 Ffetch_bytecode (fun
);
2731 val
= Fbyte_code (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
],
2732 XVECTOR (fun
)->contents
[COMPILED_CONSTANTS
],
2733 XVECTOR (fun
)->contents
[COMPILED_STACK_DEPTH
]);
2736 return unbind_to (count
, val
);
2739 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
2741 "If byte-compiled OBJECT is lazy-loaded, fetch it now.")
2747 if (COMPILEDP (object
)
2748 && CONSP (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]))
2750 tem
= read_doc_string (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]);
2752 error ("invalid byte code");
2753 XVECTOR (object
)->contents
[COMPILED_BYTECODE
] = XCAR (tem
);
2754 XVECTOR (object
)->contents
[COMPILED_CONSTANTS
] = XCDR (tem
);
2762 register int count
= specpdl_ptr
- specpdl
;
2763 if (specpdl_size
>= max_specpdl_size
)
2765 if (max_specpdl_size
< 400)
2766 max_specpdl_size
= 400;
2767 if (specpdl_size
>= max_specpdl_size
)
2769 if (!NILP (Vdebug_on_error
))
2770 /* Leave room for some specpdl in the debugger. */
2771 max_specpdl_size
= specpdl_size
+ 100;
2773 Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil
));
2777 if (specpdl_size
> max_specpdl_size
)
2778 specpdl_size
= max_specpdl_size
;
2779 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
2780 specpdl_ptr
= specpdl
+ count
;
2784 specbind (symbol
, value
)
2785 Lisp_Object symbol
, value
;
2789 CHECK_SYMBOL (symbol
, 0);
2790 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2793 /* The most common case is that a non-constant symbol with a trivial
2794 value. Make that as fast as we can. */
2795 if (!MISCP (XSYMBOL (symbol
)->value
)
2796 && !EQ (symbol
, Qnil
)
2798 && !(XSYMBOL (symbol
)->name
->data
[0] == ':'
2799 && EQ (XSYMBOL (symbol
)->obarray
, initial_obarray
)
2800 && !EQ (value
, symbol
)))
2802 specpdl_ptr
->symbol
= symbol
;
2803 specpdl_ptr
->old_value
= XSYMBOL (symbol
)->value
;
2804 specpdl_ptr
->func
= NULL
;
2806 XSYMBOL (symbol
)->value
= value
;
2810 ovalue
= find_symbol_value (symbol
);
2811 specpdl_ptr
->func
= 0;
2812 specpdl_ptr
->old_value
= ovalue
;
2814 if (BUFFER_LOCAL_VALUEP (XSYMBOL (symbol
)->value
)
2815 || SOME_BUFFER_LOCAL_VALUEP (XSYMBOL (symbol
)->value
)
2816 || BUFFER_OBJFWDP (XSYMBOL (symbol
)->value
))
2818 Lisp_Object current_buffer
, binding_buffer
;
2819 /* For a local variable, record both the symbol and which
2820 buffer's value we are saving. */
2821 current_buffer
= Fcurrent_buffer ();
2822 binding_buffer
= current_buffer
;
2823 /* If the variable is not local in this buffer,
2824 we are saving the global value, so restore that. */
2825 if (NILP (Flocal_variable_p (symbol
, binding_buffer
)))
2826 binding_buffer
= Qnil
;
2828 = Fcons (symbol
, Fcons (binding_buffer
, current_buffer
));
2831 specpdl_ptr
->symbol
= symbol
;
2834 if (BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
))
2835 store_symval_forwarding (symbol
, ovalue
, value
);
2837 set_internal (symbol
, value
, 0, 1);
2842 record_unwind_protect (function
, arg
)
2843 Lisp_Object (*function
) P_ ((Lisp_Object
));
2846 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2848 specpdl_ptr
->func
= function
;
2849 specpdl_ptr
->symbol
= Qnil
;
2850 specpdl_ptr
->old_value
= arg
;
2855 unbind_to (count
, value
)
2859 int quitf
= !NILP (Vquit_flag
);
2860 struct gcpro gcpro1
;
2865 while (specpdl_ptr
!= specpdl
+ count
)
2869 if (specpdl_ptr
->func
!= 0)
2870 (*specpdl_ptr
->func
) (specpdl_ptr
->old_value
);
2871 /* Note that a "binding" of nil is really an unwind protect,
2872 so in that case the "old value" is a list of forms to evaluate. */
2873 else if (NILP (specpdl_ptr
->symbol
))
2874 Fprogn (specpdl_ptr
->old_value
);
2875 /* If the symbol is a list, it is really
2876 (SYMBOL BINDING_BUFFER . CURRENT_BUFFER)
2877 and it indicates we bound a variable that has
2878 buffer-local bindings. */
2879 else if (CONSP (specpdl_ptr
->symbol
))
2881 Lisp_Object symbol
, buffer
;
2883 symbol
= XCAR (specpdl_ptr
->symbol
);
2884 buffer
= XCAR (XCDR (specpdl_ptr
->symbol
));
2886 /* Handle restoring a default value. */
2888 Fset_default (symbol
, specpdl_ptr
->old_value
);
2889 /* Handle restoring a value saved from a live buffer. */
2891 set_internal (symbol
, specpdl_ptr
->old_value
, XBUFFER (buffer
), 1);
2895 /* If variable has a trivial value (no forwarding), we can
2896 just set it. No need to check for constant symbols here,
2897 since that was already done by specbind. */
2898 if (!MISCP (XSYMBOL (specpdl_ptr
->symbol
)->value
))
2899 XSYMBOL (specpdl_ptr
->symbol
)->value
= specpdl_ptr
->old_value
;
2901 set_internal (specpdl_ptr
->symbol
, specpdl_ptr
->old_value
, 0, 1);
2905 if (NILP (Vquit_flag
) && quitf
)
2914 /* Get the value of symbol's global binding, even if that binding
2915 is not now dynamically visible. */
2918 top_level_value (symbol
)
2921 register struct specbinding
*ptr
= specpdl
;
2923 CHECK_SYMBOL (symbol
, 0);
2924 for (; ptr
!= specpdl_ptr
; ptr
++)
2926 if (EQ (ptr
->symbol
, symbol
))
2927 return ptr
->old_value
;
2929 return Fsymbol_value (symbol
);
2933 top_level_set (symbol
, newval
)
2934 Lisp_Object symbol
, newval
;
2936 register struct specbinding
*ptr
= specpdl
;
2938 CHECK_SYMBOL (symbol
, 0);
2939 for (; ptr
!= specpdl_ptr
; ptr
++)
2941 if (EQ (ptr
->symbol
, symbol
))
2943 ptr
->old_value
= newval
;
2947 return Fset (symbol
, newval
);
2952 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
2953 "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\
2954 The debugger is entered when that frame exits, if the flag is non-nil.")
2956 Lisp_Object level
, flag
;
2958 register struct backtrace
*backlist
= backtrace_list
;
2961 CHECK_NUMBER (level
, 0);
2963 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
2965 backlist
= backlist
->next
;
2969 backlist
->debug_on_exit
= !NILP (flag
);
2974 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
2975 "Print a trace of Lisp function calls currently active.\n\
2976 Output stream used is value of `standard-output'.")
2979 register struct backtrace
*backlist
= backtrace_list
;
2983 extern Lisp_Object Vprint_level
;
2984 struct gcpro gcpro1
;
2986 XSETFASTINT (Vprint_level
, 3);
2993 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
2994 if (backlist
->nargs
== UNEVALLED
)
2996 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
2997 write_string ("\n", -1);
3001 tem
= *backlist
->function
;
3002 Fprin1 (tem
, Qnil
); /* This can QUIT */
3003 write_string ("(", -1);
3004 if (backlist
->nargs
== MANY
)
3006 for (tail
= *backlist
->args
, i
= 0;
3008 tail
= Fcdr (tail
), i
++)
3010 if (i
) write_string (" ", -1);
3011 Fprin1 (Fcar (tail
), Qnil
);
3016 for (i
= 0; i
< backlist
->nargs
; i
++)
3018 if (i
) write_string (" ", -1);
3019 Fprin1 (backlist
->args
[i
], Qnil
);
3022 write_string (")\n", -1);
3024 backlist
= backlist
->next
;
3027 Vprint_level
= Qnil
;
3032 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, "",
3033 "Return the function and arguments NFRAMES up from current execution point.\n\
3034 If that frame has not evaluated the arguments yet (or is a special form),\n\
3035 the value is (nil FUNCTION ARG-FORMS...).\n\
3036 If that frame has evaluated its arguments and called its function already,\n\
3037 the value is (t FUNCTION ARG-VALUES...).\n\
3038 A &rest arg is represented as the tail of the list ARG-VALUES.\n\
3039 FUNCTION is whatever was supplied as car of evaluated list,\n\
3040 or a lambda expression for macro calls.\n\
3041 If NFRAMES is more than the number of frames, the value is nil.")
3043 Lisp_Object nframes
;
3045 register struct backtrace
*backlist
= backtrace_list
;
3049 CHECK_NATNUM (nframes
, 0);
3051 /* Find the frame requested. */
3052 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3053 backlist
= backlist
->next
;
3057 if (backlist
->nargs
== UNEVALLED
)
3058 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3061 if (backlist
->nargs
== MANY
)
3062 tem
= *backlist
->args
;
3064 tem
= Flist (backlist
->nargs
, backlist
->args
);
3066 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3073 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
3074 "*Limit on number of Lisp variable bindings & unwind-protects.\n\
3075 If Lisp code tries to make more than this many at once,\n\
3076 an error is signaled.");
3078 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
3079 "*Limit on depth in `eval', `apply' and `funcall' before error.\n\
3080 This limit is to catch infinite recursions for you before they cause\n\
3081 actual stack overflow in C, which would be fatal for Emacs.\n\
3082 You can safely make it considerably larger than its default value,\n\
3083 if that proves inconveniently small.");
3085 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
3086 "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
3087 Typing C-g sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
3090 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
3091 "Non-nil inhibits C-g quitting from happening immediately.\n\
3092 Note that `quit-flag' will still be set by typing C-g,\n\
3093 so a quit will be signaled as soon as `inhibit-quit' is nil.\n\
3094 To prevent this happening, set `quit-flag' to nil\n\
3095 before making `inhibit-quit' nil.");
3096 Vinhibit_quit
= Qnil
;
3098 Qinhibit_quit
= intern ("inhibit-quit");
3099 staticpro (&Qinhibit_quit
);
3101 Qautoload
= intern ("autoload");
3102 staticpro (&Qautoload
);
3104 Qdebug_on_error
= intern ("debug-on-error");
3105 staticpro (&Qdebug_on_error
);
3107 Qmacro
= intern ("macro");
3108 staticpro (&Qmacro
);
3110 /* Note that the process handling also uses Qexit, but we don't want
3111 to staticpro it twice, so we just do it here. */
3112 Qexit
= intern ("exit");
3115 Qinteractive
= intern ("interactive");
3116 staticpro (&Qinteractive
);
3118 Qcommandp
= intern ("commandp");
3119 staticpro (&Qcommandp
);
3121 Qdefun
= intern ("defun");
3122 staticpro (&Qdefun
);
3124 Qand_rest
= intern ("&rest");
3125 staticpro (&Qand_rest
);
3127 Qand_optional
= intern ("&optional");
3128 staticpro (&Qand_optional
);
3130 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
3131 "*Non-nil means automatically display a backtrace buffer\n\
3132 after any error that is handled by the editor command loop.\n\
3133 If the value is a list, an error only means to display a backtrace\n\
3134 if one of its condition symbols appears in the list.");
3135 Vstack_trace_on_error
= Qnil
;
3137 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
3138 "*Non-nil means enter debugger if an error is signaled.\n\
3139 Does not apply to errors handled by `condition-case'.\n\
3140 If the value is a list, an error only means to enter the debugger\n\
3141 if one of its condition symbols appears in the list.\n\
3142 See also variable `debug-on-quit'.");
3143 Vdebug_on_error
= Qnil
;
3145 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
3146 "*List of errors for which the debugger should not be called.\n\
3147 Each element may be a condition-name or a regexp that matches error messages.\n\
3148 If any element applies to a given error, that error skips the debugger\n\
3149 and just returns to top level.\n\
3150 This overrides the variable `debug-on-error'.\n\
3151 It does not apply to errors handled by `condition-case'.");
3152 Vdebug_ignored_errors
= Qnil
;
3154 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
3155 "*Non-nil means enter debugger if quit is signaled (C-g, for example).\n\
3156 Does not apply if quit is handled by a `condition-case'.");
3159 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
3160 "Non-nil means enter debugger before next `eval', `apply' or `funcall'.");
3162 DEFVAR_BOOL ("debugger-may-continue", &debugger_may_continue
,
3163 "Non-nil means debugger may continue execution.\n\
3164 This is nil when the debugger is called under circumstances where it\n\
3165 might not be safe to continue.");
3166 debugger_may_continue
= 1;
3168 DEFVAR_LISP ("debugger", &Vdebugger
,
3169 "Function to call to invoke debugger.\n\
3170 If due to frame exit, args are `exit' and the value being returned;\n\
3171 this function's value will be returned instead of that.\n\
3172 If due to error, args are `error' and a list of the args to `signal'.\n\
3173 If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
3174 If due to `eval' entry, one arg, t.");
3177 DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function
,
3178 "If non-nil, this is a function for `signal' to call.\n\
3179 It receives the same arguments that `signal' was given.\n\
3180 The Edebug package uses this to regain control.");
3181 Vsignal_hook_function
= Qnil
;
3183 Qmocklisp_arguments
= intern ("mocklisp-arguments");
3184 staticpro (&Qmocklisp_arguments
);
3185 DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments
,
3186 "While in a mocklisp function, the list of its unevaluated args.");
3187 Vmocklisp_arguments
= Qt
;
3189 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal
,
3190 "*Non-nil means call the debugger regardless of condition handlers.\n\
3191 Note that `debug-on-error', `debug-on-quit' and friends\n\
3192 still determine whether to handle the particular condition.");
3193 Vdebug_on_signal
= Qnil
;
3195 Vrun_hooks
= intern ("run-hooks");
3196 staticpro (&Vrun_hooks
);
3198 staticpro (&Vautoload_queue
);
3199 Vautoload_queue
= Qnil
;
3210 defsubr (&Sfunction
);
3212 defsubr (&Sdefmacro
);
3214 defsubr (&Sdefconst
);
3215 defsubr (&Suser_variable_p
);
3219 defsubr (&Smacroexpand
);
3222 defsubr (&Sunwind_protect
);
3223 defsubr (&Scondition_case
);
3225 defsubr (&Sinteractive_p
);
3226 defsubr (&Scommandp
);
3227 defsubr (&Sautoload
);
3230 defsubr (&Sfuncall
);
3231 defsubr (&Srun_hooks
);
3232 defsubr (&Srun_hook_with_args
);
3233 defsubr (&Srun_hook_with_args_until_success
);
3234 defsubr (&Srun_hook_with_args_until_failure
);
3235 defsubr (&Sfetch_bytecode
);
3236 defsubr (&Sbacktrace_debug
);
3237 defsubr (&Sbacktrace
);
3238 defsubr (&Sbacktrace_frame
);