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
;
1300 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1301 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1303 if (specpdl_size
+ 40 > max_specpdl_size
)
1304 max_specpdl_size
= specpdl_size
+ 40;
1306 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1307 error_symbol
, data
, &debugger_value
);
1309 #if 0 /* Most callers are not prepared to handle gc if this returns.
1310 So, since this feature is not very useful, take it out. */
1311 /* If have called debugger and user wants to continue,
1313 if (EQ (clause
, Qlambda
))
1314 return debugger_value
;
1316 if (EQ (clause
, Qlambda
))
1318 /* We can't return values to code which signaled an error, but we
1319 can continue code which has signaled a quit. */
1320 if (EQ (real_error_symbol
, Qquit
))
1323 error ("Cannot return from the debugger in an error");
1329 Lisp_Object unwind_data
;
1330 struct handler
*h
= handlerlist
;
1332 handlerlist
= allhandlers
;
1334 if (NILP (error_symbol
))
1337 unwind_data
= Fcons (error_symbol
, data
);
1338 h
->chosen_clause
= clause
;
1339 unwind_to_catch (h
->tag
, unwind_data
);
1343 handlerlist
= allhandlers
;
1344 /* If no handler is present now, try to run the debugger,
1345 and if that fails, throw to top level. */
1346 find_handler_clause (Qerror
, conditions
, error_symbol
, data
, &debugger_value
);
1348 Fthrow (Qtop_level
, Qt
);
1350 if (! NILP (error_symbol
))
1351 data
= Fcons (error_symbol
, data
);
1353 string
= Ferror_message_string (data
);
1354 fatal ("%s", XSTRING (string
)->data
, 0);
1357 /* Return nonzero iff LIST is a non-nil atom or
1358 a list containing one of CONDITIONS. */
1361 wants_debugger (list
, conditions
)
1362 Lisp_Object list
, conditions
;
1369 while (CONSP (conditions
))
1371 Lisp_Object
this, tail
;
1372 this = XCAR (conditions
);
1373 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1374 if (EQ (XCAR (tail
), this))
1376 conditions
= XCDR (conditions
);
1381 /* Return 1 if an error with condition-symbols CONDITIONS,
1382 and described by SIGNAL-DATA, should skip the debugger
1383 according to debugger-ignore-errors. */
1386 skip_debugger (conditions
, data
)
1387 Lisp_Object conditions
, data
;
1390 int first_string
= 1;
1391 Lisp_Object error_message
;
1393 for (tail
= Vdebug_ignored_errors
; CONSP (tail
);
1396 if (STRINGP (XCAR (tail
)))
1400 error_message
= Ferror_message_string (data
);
1403 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1408 Lisp_Object contail
;
1410 for (contail
= conditions
; CONSP (contail
);
1411 contail
= XCDR (contail
))
1412 if (EQ (XCAR (tail
), XCAR (contail
)))
1420 /* Value of Qlambda means we have called debugger and user has continued.
1421 There are two ways to pass SIG and DATA:
1422 = SIG is the error symbol, and DATA is the rest of the data.
1423 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1424 This is for memory-full errors only.
1426 Store value returned from debugger into *DEBUGGER_VALUE_PTR. */
1429 find_handler_clause (handlers
, conditions
, sig
, data
, debugger_value_ptr
)
1430 Lisp_Object handlers
, conditions
, sig
, data
;
1431 Lisp_Object
*debugger_value_ptr
;
1433 register Lisp_Object h
;
1434 register Lisp_Object tem
;
1436 if (EQ (handlers
, Qt
)) /* t is used by handlers for all conditions, set up by C code. */
1438 /* error is used similarly, but means print an error message
1439 and run the debugger if that is enabled. */
1440 if (EQ (handlers
, Qerror
)
1441 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1442 there is a handler. */
1444 int count
= specpdl_ptr
- specpdl
;
1445 int debugger_called
= 0;
1446 Lisp_Object sig_symbol
, combined_data
;
1447 /* This is set to 1 if we are handling a memory-full error,
1448 because these must not run the debugger.
1449 (There is no room in memory to do that!) */
1450 int no_debugger
= 0;
1454 combined_data
= data
;
1455 sig_symbol
= Fcar (data
);
1460 combined_data
= Fcons (sig
, data
);
1464 if (wants_debugger (Vstack_trace_on_error
, conditions
))
1467 internal_with_output_to_temp_buffer ("*Backtrace*",
1468 (Lisp_Object (*) (Lisp_Object
)) Fbacktrace
,
1471 internal_with_output_to_temp_buffer ("*Backtrace*",
1476 && (EQ (sig_symbol
, Qquit
)
1478 : wants_debugger (Vdebug_on_error
, conditions
))
1479 && ! skip_debugger (conditions
, combined_data
)
1480 && when_entered_debugger
< num_nonmacro_input_events
)
1482 specbind (Qdebug_on_error
, Qnil
);
1484 = call_debugger (Fcons (Qerror
,
1485 Fcons (combined_data
, Qnil
)));
1486 debugger_called
= 1;
1488 /* If there is no handler, return saying whether we ran the debugger. */
1489 if (EQ (handlers
, Qerror
))
1491 if (debugger_called
)
1492 return unbind_to (count
, Qlambda
);
1496 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1498 Lisp_Object handler
, condit
;
1501 if (!CONSP (handler
))
1503 condit
= Fcar (handler
);
1504 /* Handle a single condition name in handler HANDLER. */
1505 if (SYMBOLP (condit
))
1507 tem
= Fmemq (Fcar (handler
), conditions
);
1511 /* Handle a list of condition names in handler HANDLER. */
1512 else if (CONSP (condit
))
1514 while (CONSP (condit
))
1516 tem
= Fmemq (Fcar (condit
), conditions
);
1519 condit
= XCDR (condit
);
1526 /* dump an error message; called like printf */
1530 error (m
, a1
, a2
, a3
)
1550 int used
= doprnt (buffer
, size
, m
, m
+ mlen
, 3, args
);
1555 buffer
= (char *) xrealloc (buffer
, size
);
1558 buffer
= (char *) xmalloc (size
);
1563 string
= build_string (buffer
);
1567 Fsignal (Qerror
, Fcons (string
, Qnil
));
1570 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 1, 0,
1571 "T if FUNCTION makes provisions for interactive calling.\n\
1572 This means it contains a description for how to read arguments to give it.\n\
1573 The value is nil for an invalid function or a symbol with no function\n\
1576 Interactively callable functions include strings and vectors (treated\n\
1577 as keyboard macros), lambda-expressions that contain a top-level call\n\
1578 to `interactive', autoload definitions made by `autoload' with non-nil\n\
1579 fourth argument, and some of the built-in functions of Lisp.\n\
1581 Also, a symbol satisfies `commandp' if its function definition does so.")
1583 Lisp_Object function
;
1585 register Lisp_Object fun
;
1586 register Lisp_Object funcar
;
1590 fun
= indirect_function (fun
);
1591 if (EQ (fun
, Qunbound
))
1594 /* Emacs primitives are interactive if their DEFUN specifies an
1595 interactive spec. */
1598 if (XSUBR (fun
)->prompt
)
1604 /* Bytecode objects are interactive if they are long enough to
1605 have an element whose index is COMPILED_INTERACTIVE, which is
1606 where the interactive spec is stored. */
1607 else if (COMPILEDP (fun
))
1608 return ((XVECTOR (fun
)->size
& PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
1611 /* Strings and vectors are keyboard macros. */
1612 if (STRINGP (fun
) || VECTORP (fun
))
1615 /* Lists may represent commands. */
1618 funcar
= Fcar (fun
);
1619 if (!SYMBOLP (funcar
))
1620 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1621 if (EQ (funcar
, Qlambda
))
1622 return Fassq (Qinteractive
, Fcdr (Fcdr (fun
)));
1623 if (EQ (funcar
, Qmocklisp
))
1624 return Qt
; /* All mocklisp functions can be called interactively */
1625 if (EQ (funcar
, Qautoload
))
1626 return Fcar (Fcdr (Fcdr (Fcdr (fun
))));
1632 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1633 "Define FUNCTION to autoload from FILE.\n\
1634 FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\
1635 Third arg DOCSTRING is documentation for the function.\n\
1636 Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\
1637 Fifth arg TYPE indicates the type of the object:\n\
1638 nil or omitted says FUNCTION is a function,\n\
1639 `keymap' says FUNCTION is really a keymap, and\n\
1640 `macro' or t says FUNCTION is really a macro.\n\
1641 Third through fifth args give info about the real definition.\n\
1642 They default to nil.\n\
1643 If FUNCTION is already defined other than as an autoload,\n\
1644 this does nothing and returns nil.")
1645 (function
, file
, docstring
, interactive
, type
)
1646 Lisp_Object function
, file
, docstring
, interactive
, type
;
1649 Lisp_Object args
[4];
1652 CHECK_SYMBOL (function
, 0);
1653 CHECK_STRING (file
, 1);
1655 /* If function is defined and not as an autoload, don't override */
1656 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
1657 && !(CONSP (XSYMBOL (function
)->function
)
1658 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
1661 if (NILP (Vpurify_flag
))
1662 /* Only add entries after dumping, because the ones before are
1663 not useful and else we get loads of them from the loaddefs.el. */
1664 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
1668 args
[1] = docstring
;
1669 args
[2] = interactive
;
1672 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
1673 #else /* NO_ARG_ARRAY */
1674 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
1675 #endif /* not NO_ARG_ARRAY */
1679 un_autoload (oldqueue
)
1680 Lisp_Object oldqueue
;
1682 register Lisp_Object queue
, first
, second
;
1684 /* Queue to unwind is current value of Vautoload_queue.
1685 oldqueue is the shadowed value to leave in Vautoload_queue. */
1686 queue
= Vautoload_queue
;
1687 Vautoload_queue
= oldqueue
;
1688 while (CONSP (queue
))
1690 first
= Fcar (queue
);
1691 second
= Fcdr (first
);
1692 first
= Fcar (first
);
1693 if (EQ (second
, Qnil
))
1696 Ffset (first
, second
);
1697 queue
= Fcdr (queue
);
1702 /* Load an autoloaded function.
1703 FUNNAME is the symbol which is the function's name.
1704 FUNDEF is the autoload definition (a list). */
1707 do_autoload (fundef
, funname
)
1708 Lisp_Object fundef
, funname
;
1710 int count
= specpdl_ptr
- specpdl
;
1711 Lisp_Object fun
, queue
, first
, second
;
1712 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1715 CHECK_SYMBOL (funname
, 0);
1716 GCPRO3 (fun
, funname
, fundef
);
1718 /* Preserve the match data. */
1719 record_unwind_protect (Fset_match_data
, Fmatch_data (Qnil
, Qnil
));
1721 /* Value saved here is to be restored into Vautoload_queue. */
1722 record_unwind_protect (un_autoload
, Vautoload_queue
);
1723 Vautoload_queue
= Qt
;
1724 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
, Qt
);
1726 /* Save the old autoloads, in case we ever do an unload. */
1727 queue
= Vautoload_queue
;
1728 while (CONSP (queue
))
1730 first
= Fcar (queue
);
1731 second
= Fcdr (first
);
1732 first
= Fcar (first
);
1734 /* Note: This test is subtle. The cdr of an autoload-queue entry
1735 may be an atom if the autoload entry was generated by a defalias
1738 Fput (first
, Qautoload
, (Fcdr (second
)));
1740 queue
= Fcdr (queue
);
1743 /* Once loading finishes, don't undo it. */
1744 Vautoload_queue
= Qt
;
1745 unbind_to (count
, Qnil
);
1747 fun
= Findirect_function (fun
);
1749 if (!NILP (Fequal (fun
, fundef
)))
1750 error ("Autoloading failed to define function %s",
1751 XSYMBOL (funname
)->name
->data
);
1755 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
1756 "Evaluate FORM and return its value.")
1760 Lisp_Object fun
, val
, original_fun
, original_args
;
1762 struct backtrace backtrace
;
1763 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1765 #if 0 /* Can't do this check anymore because realize_basic_faces has
1766 to BLOCK_INPUT, and can call Lisp. What's really needed is a
1767 flag indicating that we're currently handling a signal. */
1768 /* Since Fsignal resets this to 0, it had better be 0 now
1769 or else we have a potential bug. */
1770 if (interrupt_input_blocked
!= 0)
1776 if (EQ (Vmocklisp_arguments
, Qt
))
1777 return Fsymbol_value (form
);
1778 val
= Fsymbol_value (form
);
1780 XSETFASTINT (val
, 0);
1781 else if (EQ (val
, Qt
))
1782 XSETFASTINT (val
, 1);
1789 if (consing_since_gc
> gc_cons_threshold
)
1792 Fgarbage_collect ();
1796 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1798 if (max_lisp_eval_depth
< 100)
1799 max_lisp_eval_depth
= 100;
1800 if (lisp_eval_depth
> max_lisp_eval_depth
)
1801 error ("Lisp nesting exceeds max-lisp-eval-depth");
1804 original_fun
= Fcar (form
);
1805 original_args
= Fcdr (form
);
1807 backtrace
.next
= backtrace_list
;
1808 backtrace_list
= &backtrace
;
1809 backtrace
.function
= &original_fun
; /* This also protects them from gc */
1810 backtrace
.args
= &original_args
;
1811 backtrace
.nargs
= UNEVALLED
;
1812 backtrace
.evalargs
= 1;
1813 backtrace
.debug_on_exit
= 0;
1815 if (debug_on_next_call
)
1816 do_debug_on_call (Qt
);
1818 /* At this point, only original_fun and original_args
1819 have values that will be used below */
1821 fun
= Findirect_function (original_fun
);
1825 Lisp_Object numargs
;
1826 Lisp_Object argvals
[8];
1827 Lisp_Object args_left
;
1828 register int i
, maxargs
;
1830 args_left
= original_args
;
1831 numargs
= Flength (args_left
);
1833 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
1834 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
1835 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1837 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1839 backtrace
.evalargs
= 0;
1840 val
= (*XSUBR (fun
)->function
) (args_left
);
1844 if (XSUBR (fun
)->max_args
== MANY
)
1846 /* Pass a vector of evaluated arguments */
1848 register int argnum
= 0;
1850 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1852 GCPRO3 (args_left
, fun
, fun
);
1856 while (!NILP (args_left
))
1858 vals
[argnum
++] = Feval (Fcar (args_left
));
1859 args_left
= Fcdr (args_left
);
1860 gcpro3
.nvars
= argnum
;
1863 backtrace
.args
= vals
;
1864 backtrace
.nargs
= XINT (numargs
);
1866 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
1871 GCPRO3 (args_left
, fun
, fun
);
1872 gcpro3
.var
= argvals
;
1875 maxargs
= XSUBR (fun
)->max_args
;
1876 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
1878 argvals
[i
] = Feval (Fcar (args_left
));
1884 backtrace
.args
= argvals
;
1885 backtrace
.nargs
= XINT (numargs
);
1890 val
= (*XSUBR (fun
)->function
) ();
1893 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
1896 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
1899 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1903 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1904 argvals
[2], argvals
[3]);
1907 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1908 argvals
[3], argvals
[4]);
1911 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1912 argvals
[3], argvals
[4], argvals
[5]);
1915 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1916 argvals
[3], argvals
[4], argvals
[5],
1921 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1922 argvals
[3], argvals
[4], argvals
[5],
1923 argvals
[6], argvals
[7]);
1927 /* Someone has created a subr that takes more arguments than
1928 is supported by this code. We need to either rewrite the
1929 subr to use a different argument protocol, or add more
1930 cases to this switch. */
1934 if (COMPILEDP (fun
))
1935 val
= apply_lambda (fun
, original_args
, 1);
1939 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1940 funcar
= Fcar (fun
);
1941 if (!SYMBOLP (funcar
))
1942 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1943 if (EQ (funcar
, Qautoload
))
1945 do_autoload (fun
, original_fun
);
1948 if (EQ (funcar
, Qmacro
))
1949 val
= Feval (apply1 (Fcdr (fun
), original_args
));
1950 else if (EQ (funcar
, Qlambda
))
1951 val
= apply_lambda (fun
, original_args
, 1);
1952 else if (EQ (funcar
, Qmocklisp
))
1953 val
= ml_apply (fun
, original_args
);
1955 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1958 if (!EQ (Vmocklisp_arguments
, Qt
))
1961 XSETFASTINT (val
, 0);
1962 else if (EQ (val
, Qt
))
1963 XSETFASTINT (val
, 1);
1966 if (backtrace
.debug_on_exit
)
1967 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
1968 backtrace_list
= backtrace
.next
;
1972 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
1973 "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
1974 Then return the value FUNCTION returns.\n\
1975 Thus, (apply '+ 1 2 '(3 4)) returns 10.")
1980 register int i
, numargs
;
1981 register Lisp_Object spread_arg
;
1982 register Lisp_Object
*funcall_args
;
1984 struct gcpro gcpro1
;
1988 spread_arg
= args
[nargs
- 1];
1989 CHECK_LIST (spread_arg
, nargs
);
1991 numargs
= XINT (Flength (spread_arg
));
1994 return Ffuncall (nargs
- 1, args
);
1995 else if (numargs
== 1)
1997 args
[nargs
- 1] = XCAR (spread_arg
);
1998 return Ffuncall (nargs
, args
);
2001 numargs
+= nargs
- 2;
2003 fun
= indirect_function (fun
);
2004 if (EQ (fun
, Qunbound
))
2006 /* Let funcall get the error */
2013 if (numargs
< XSUBR (fun
)->min_args
2014 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2015 goto funcall
; /* Let funcall get the error */
2016 else if (XSUBR (fun
)->max_args
> numargs
)
2018 /* Avoid making funcall cons up a yet another new vector of arguments
2019 by explicitly supplying nil's for optional values */
2020 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
2021 * sizeof (Lisp_Object
));
2022 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2023 funcall_args
[++i
] = Qnil
;
2024 GCPRO1 (*funcall_args
);
2025 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2029 /* We add 1 to numargs because funcall_args includes the
2030 function itself as well as its arguments. */
2033 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
2034 * sizeof (Lisp_Object
));
2035 GCPRO1 (*funcall_args
);
2036 gcpro1
.nvars
= 1 + numargs
;
2039 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
2040 /* Spread the last arg we got. Its first element goes in
2041 the slot that it used to occupy, hence this value of I. */
2043 while (!NILP (spread_arg
))
2045 funcall_args
[i
++] = XCAR (spread_arg
);
2046 spread_arg
= XCDR (spread_arg
);
2049 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
2052 /* Run hook variables in various ways. */
2054 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
2056 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 1, MANY
, 0,
2057 "Run each hook in HOOKS. Major mode functions use this.\n\
2058 Each argument should be a symbol, a hook variable.\n\
2059 These symbols are processed in the order specified.\n\
2060 If a hook symbol has a non-nil value, that value may be a function\n\
2061 or a list of functions to be called to run the hook.\n\
2062 If the value is a function, it is called with no arguments.\n\
2063 If it is a list, the elements are called, in order, with no arguments.\n\
2065 To make a hook variable buffer-local, use `make-local-hook',\n\
2066 not `make-local-variable'.")
2071 Lisp_Object hook
[1];
2074 for (i
= 0; i
< nargs
; i
++)
2077 run_hook_with_args (1, hook
, to_completion
);
2083 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2084 Srun_hook_with_args
, 1, MANY
, 0,
2085 "Run HOOK with the specified arguments ARGS.\n\
2086 HOOK should be a symbol, a hook variable. If HOOK has a non-nil\n\
2087 value, that value may be a function or a list of functions to be\n\
2088 called to run the hook. If the value is a function, it is called with\n\
2089 the given arguments and its return value is returned. If it is a list\n\
2090 of functions, those functions are called, in order,\n\
2091 with the given arguments ARGS.\n\
2092 It is best not to depend on the value return by `run-hook-with-args',\n\
2093 as that may change.\n\
2095 To make a hook variable buffer-local, use `make-local-hook',\n\
2096 not `make-local-variable'.")
2101 return run_hook_with_args (nargs
, args
, to_completion
);
2104 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2105 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2106 "Run HOOK with the specified arguments ARGS.\n\
2107 HOOK should be a symbol, a hook variable. Its value should\n\
2108 be a list of functions. We call those functions, one by one,\n\
2109 passing arguments ARGS to each of them, until one of them\n\
2110 returns a non-nil value. Then we return that value.\n\
2111 If all the functions return nil, we return nil.\n\
2113 To make a hook variable buffer-local, use `make-local-hook',\n\
2114 not `make-local-variable'.")
2119 return run_hook_with_args (nargs
, args
, until_success
);
2122 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2123 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2124 "Run HOOK with the specified arguments ARGS.\n\
2125 HOOK should be a symbol, a hook variable. Its value should\n\
2126 be a list of functions. We call those functions, one by one,\n\
2127 passing arguments ARGS to each of them, until one of them\n\
2128 returns nil. Then we return nil.\n\
2129 If all the functions return non-nil, we return non-nil.\n\
2131 To make a hook variable buffer-local, use `make-local-hook',\n\
2132 not `make-local-variable'.")
2137 return run_hook_with_args (nargs
, args
, until_failure
);
2140 /* ARGS[0] should be a hook symbol.
2141 Call each of the functions in the hook value, passing each of them
2142 as arguments all the rest of ARGS (all NARGS - 1 elements).
2143 COND specifies a condition to test after each call
2144 to decide whether to stop.
2145 The caller (or its caller, etc) must gcpro all of ARGS,
2146 except that it isn't necessary to gcpro ARGS[0]. */
2149 run_hook_with_args (nargs
, args
, cond
)
2152 enum run_hooks_condition cond
;
2154 Lisp_Object sym
, val
, ret
;
2155 Lisp_Object globals
;
2156 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2158 /* If we are dying or still initializing,
2159 don't do anything--it would probably crash if we tried. */
2160 if (NILP (Vrun_hooks
))
2164 val
= find_symbol_value (sym
);
2165 ret
= (cond
== until_failure
? Qt
: Qnil
);
2167 if (EQ (val
, Qunbound
) || NILP (val
))
2169 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2172 return Ffuncall (nargs
, args
);
2177 GCPRO3 (sym
, val
, globals
);
2180 CONSP (val
) && ((cond
== to_completion
)
2181 || (cond
== until_success
? NILP (ret
)
2185 if (EQ (XCAR (val
), Qt
))
2187 /* t indicates this hook has a local binding;
2188 it means to run the global binding too. */
2190 for (globals
= Fdefault_value (sym
);
2191 CONSP (globals
) && ((cond
== to_completion
)
2192 || (cond
== until_success
? NILP (ret
)
2194 globals
= XCDR (globals
))
2196 args
[0] = XCAR (globals
);
2197 /* In a global value, t should not occur. If it does, we
2198 must ignore it to avoid an endless loop. */
2199 if (!EQ (args
[0], Qt
))
2200 ret
= Ffuncall (nargs
, args
);
2205 args
[0] = XCAR (val
);
2206 ret
= Ffuncall (nargs
, args
);
2215 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2216 present value of that symbol.
2217 Call each element of FUNLIST,
2218 passing each of them the rest of ARGS.
2219 The caller (or its caller, etc) must gcpro all of ARGS,
2220 except that it isn't necessary to gcpro ARGS[0]. */
2223 run_hook_list_with_args (funlist
, nargs
, args
)
2224 Lisp_Object funlist
;
2230 Lisp_Object globals
;
2231 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2235 GCPRO3 (sym
, val
, globals
);
2237 for (val
= funlist
; CONSP (val
); val
= XCDR (val
))
2239 if (EQ (XCAR (val
), Qt
))
2241 /* t indicates this hook has a local binding;
2242 it means to run the global binding too. */
2244 for (globals
= Fdefault_value (sym
);
2246 globals
= XCDR (globals
))
2248 args
[0] = XCAR (globals
);
2249 /* In a global value, t should not occur. If it does, we
2250 must ignore it to avoid an endless loop. */
2251 if (!EQ (args
[0], Qt
))
2252 Ffuncall (nargs
, args
);
2257 args
[0] = XCAR (val
);
2258 Ffuncall (nargs
, args
);
2265 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2268 run_hook_with_args_2 (hook
, arg1
, arg2
)
2269 Lisp_Object hook
, arg1
, arg2
;
2271 Lisp_Object temp
[3];
2276 Frun_hook_with_args (3, temp
);
2279 /* Apply fn to arg */
2282 Lisp_Object fn
, arg
;
2284 struct gcpro gcpro1
;
2288 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2292 Lisp_Object args
[2];
2296 RETURN_UNGCPRO (Fapply (2, args
));
2298 #else /* not NO_ARG_ARRAY */
2299 RETURN_UNGCPRO (Fapply (2, &fn
));
2300 #endif /* not NO_ARG_ARRAY */
2303 /* Call function fn on no arguments */
2308 struct gcpro gcpro1
;
2311 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2314 /* Call function fn with 1 argument arg1 */
2318 Lisp_Object fn
, arg1
;
2320 struct gcpro gcpro1
;
2322 Lisp_Object args
[2];
2328 RETURN_UNGCPRO (Ffuncall (2, args
));
2329 #else /* not NO_ARG_ARRAY */
2332 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2333 #endif /* not NO_ARG_ARRAY */
2336 /* Call function fn with 2 arguments arg1, arg2 */
2339 call2 (fn
, arg1
, arg2
)
2340 Lisp_Object fn
, arg1
, arg2
;
2342 struct gcpro gcpro1
;
2344 Lisp_Object args
[3];
2350 RETURN_UNGCPRO (Ffuncall (3, args
));
2351 #else /* not NO_ARG_ARRAY */
2354 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2355 #endif /* not NO_ARG_ARRAY */
2358 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2361 call3 (fn
, arg1
, arg2
, arg3
)
2362 Lisp_Object fn
, arg1
, arg2
, arg3
;
2364 struct gcpro gcpro1
;
2366 Lisp_Object args
[4];
2373 RETURN_UNGCPRO (Ffuncall (4, args
));
2374 #else /* not NO_ARG_ARRAY */
2377 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2378 #endif /* not NO_ARG_ARRAY */
2381 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2384 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2385 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2387 struct gcpro gcpro1
;
2389 Lisp_Object args
[5];
2397 RETURN_UNGCPRO (Ffuncall (5, args
));
2398 #else /* not NO_ARG_ARRAY */
2401 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2402 #endif /* not NO_ARG_ARRAY */
2405 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2408 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2409 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2411 struct gcpro gcpro1
;
2413 Lisp_Object args
[6];
2422 RETURN_UNGCPRO (Ffuncall (6, args
));
2423 #else /* not NO_ARG_ARRAY */
2426 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2427 #endif /* not NO_ARG_ARRAY */
2430 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2433 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2434 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2436 struct gcpro gcpro1
;
2438 Lisp_Object args
[7];
2448 RETURN_UNGCPRO (Ffuncall (7, args
));
2449 #else /* not NO_ARG_ARRAY */
2452 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2453 #endif /* not NO_ARG_ARRAY */
2456 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2457 "Call first argument as a function, passing remaining arguments to it.\n\
2458 Return the value that function returns.\n\
2459 Thus, (funcall 'cons 'x 'y) returns (x . y).")
2466 int numargs
= nargs
- 1;
2467 Lisp_Object lisp_numargs
;
2469 struct backtrace backtrace
;
2470 register Lisp_Object
*internal_args
;
2474 if (consing_since_gc
> gc_cons_threshold
)
2475 Fgarbage_collect ();
2477 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2479 if (max_lisp_eval_depth
< 100)
2480 max_lisp_eval_depth
= 100;
2481 if (lisp_eval_depth
> max_lisp_eval_depth
)
2482 error ("Lisp nesting exceeds max-lisp-eval-depth");
2485 backtrace
.next
= backtrace_list
;
2486 backtrace_list
= &backtrace
;
2487 backtrace
.function
= &args
[0];
2488 backtrace
.args
= &args
[1];
2489 backtrace
.nargs
= nargs
- 1;
2490 backtrace
.evalargs
= 0;
2491 backtrace
.debug_on_exit
= 0;
2493 if (debug_on_next_call
)
2494 do_debug_on_call (Qlambda
);
2500 fun
= Findirect_function (fun
);
2504 if (numargs
< XSUBR (fun
)->min_args
2505 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2507 XSETFASTINT (lisp_numargs
, numargs
);
2508 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (lisp_numargs
, Qnil
)));
2511 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2512 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2514 if (XSUBR (fun
)->max_args
== MANY
)
2516 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
2520 if (XSUBR (fun
)->max_args
> numargs
)
2522 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2523 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
2524 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2525 internal_args
[i
] = Qnil
;
2528 internal_args
= args
+ 1;
2529 switch (XSUBR (fun
)->max_args
)
2532 val
= (*XSUBR (fun
)->function
) ();
2535 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
2538 val
= (*XSUBR (fun
)->function
) (internal_args
[0],
2542 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2546 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2551 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2552 internal_args
[2], internal_args
[3],
2556 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2557 internal_args
[2], internal_args
[3],
2558 internal_args
[4], internal_args
[5]);
2561 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2562 internal_args
[2], internal_args
[3],
2563 internal_args
[4], internal_args
[5],
2568 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2569 internal_args
[2], internal_args
[3],
2570 internal_args
[4], internal_args
[5],
2571 internal_args
[6], internal_args
[7]);
2576 /* If a subr takes more than 8 arguments without using MANY
2577 or UNEVALLED, we need to extend this function to support it.
2578 Until this is done, there is no way to call the function. */
2582 if (COMPILEDP (fun
))
2583 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2587 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2588 funcar
= Fcar (fun
);
2589 if (!SYMBOLP (funcar
))
2590 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2591 if (EQ (funcar
, Qlambda
))
2592 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2593 else if (EQ (funcar
, Qmocklisp
))
2594 val
= ml_apply (fun
, Flist (numargs
, args
+ 1));
2595 else if (EQ (funcar
, Qautoload
))
2597 do_autoload (fun
, args
[0]);
2601 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2605 if (backtrace
.debug_on_exit
)
2606 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2607 backtrace_list
= backtrace
.next
;
2612 apply_lambda (fun
, args
, eval_flag
)
2613 Lisp_Object fun
, args
;
2616 Lisp_Object args_left
;
2617 Lisp_Object numargs
;
2618 register Lisp_Object
*arg_vector
;
2619 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2621 register Lisp_Object tem
;
2623 numargs
= Flength (args
);
2624 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2627 GCPRO3 (*arg_vector
, args_left
, fun
);
2630 for (i
= 0; i
< XINT (numargs
);)
2632 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2633 if (eval_flag
) tem
= Feval (tem
);
2634 arg_vector
[i
++] = tem
;
2642 backtrace_list
->args
= arg_vector
;
2643 backtrace_list
->nargs
= i
;
2645 backtrace_list
->evalargs
= 0;
2646 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
2648 /* Do the debug-on-exit now, while arg_vector still exists. */
2649 if (backtrace_list
->debug_on_exit
)
2650 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
2651 /* Don't do it again when we return to eval. */
2652 backtrace_list
->debug_on_exit
= 0;
2656 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2657 and return the result of evaluation.
2658 FUN must be either a lambda-expression or a compiled-code object. */
2661 funcall_lambda (fun
, nargs
, arg_vector
)
2664 register Lisp_Object
*arg_vector
;
2666 Lisp_Object val
, syms_left
, next
;
2667 int count
= specpdl_ptr
- specpdl
;
2668 int i
, optional
, rest
;
2670 if (NILP (Vmocklisp_arguments
))
2671 specbind (Qmocklisp_arguments
, Qt
); /* t means NOT mocklisp! */
2675 syms_left
= XCDR (fun
);
2676 if (CONSP (syms_left
))
2677 syms_left
= XCAR (syms_left
);
2679 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2681 else if (COMPILEDP (fun
))
2682 syms_left
= XVECTOR (fun
)->contents
[COMPILED_ARGLIST
];
2686 i
= optional
= rest
= 0;
2687 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
2691 next
= XCAR (syms_left
);
2692 while (!SYMBOLP (next
))
2693 next
= Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2695 if (EQ (next
, Qand_rest
))
2697 else if (EQ (next
, Qand_optional
))
2701 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
2705 specbind (next
, arg_vector
[i
++]);
2707 return Fsignal (Qwrong_number_of_arguments
,
2708 Fcons (fun
, Fcons (make_number (nargs
), Qnil
)));
2710 specbind (next
, Qnil
);
2713 if (!NILP (syms_left
))
2714 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2716 return Fsignal (Qwrong_number_of_arguments
,
2717 Fcons (fun
, Fcons (make_number (nargs
), Qnil
)));
2720 val
= Fprogn (XCDR (XCDR (fun
)));
2723 /* If we have not actually read the bytecode string
2724 and constants vector yet, fetch them from the file. */
2725 if (CONSP (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
]))
2726 Ffetch_bytecode (fun
);
2727 val
= Fbyte_code (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
],
2728 XVECTOR (fun
)->contents
[COMPILED_CONSTANTS
],
2729 XVECTOR (fun
)->contents
[COMPILED_STACK_DEPTH
]);
2732 return unbind_to (count
, val
);
2735 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
2737 "If byte-compiled OBJECT is lazy-loaded, fetch it now.")
2743 if (COMPILEDP (object
)
2744 && CONSP (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]))
2746 tem
= read_doc_string (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]);
2748 error ("invalid byte code");
2749 XVECTOR (object
)->contents
[COMPILED_BYTECODE
] = XCAR (tem
);
2750 XVECTOR (object
)->contents
[COMPILED_CONSTANTS
] = XCDR (tem
);
2758 register int count
= specpdl_ptr
- specpdl
;
2759 if (specpdl_size
>= max_specpdl_size
)
2761 if (max_specpdl_size
< 400)
2762 max_specpdl_size
= 400;
2763 if (specpdl_size
>= max_specpdl_size
)
2765 if (!NILP (Vdebug_on_error
))
2766 /* Leave room for some specpdl in the debugger. */
2767 max_specpdl_size
= specpdl_size
+ 100;
2769 Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil
));
2773 if (specpdl_size
> max_specpdl_size
)
2774 specpdl_size
= max_specpdl_size
;
2775 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
2776 specpdl_ptr
= specpdl
+ count
;
2780 specbind (symbol
, value
)
2781 Lisp_Object symbol
, value
;
2785 CHECK_SYMBOL (symbol
, 0);
2786 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2789 /* The most common case is that a non-constant symbol with a trivial
2790 value. Make that as fast as we can. */
2791 if (!MISCP (XSYMBOL (symbol
)->value
)
2792 && !EQ (symbol
, Qnil
)
2794 && !(XSYMBOL (symbol
)->name
->data
[0] == ':'
2795 && EQ (XSYMBOL (symbol
)->obarray
, initial_obarray
)
2796 && !EQ (value
, symbol
)))
2798 specpdl_ptr
->symbol
= symbol
;
2799 specpdl_ptr
->old_value
= XSYMBOL (symbol
)->value
;
2800 specpdl_ptr
->func
= NULL
;
2802 XSYMBOL (symbol
)->value
= value
;
2806 ovalue
= find_symbol_value (symbol
);
2807 specpdl_ptr
->func
= 0;
2808 specpdl_ptr
->old_value
= ovalue
;
2810 if (BUFFER_LOCAL_VALUEP (XSYMBOL (symbol
)->value
)
2811 || SOME_BUFFER_LOCAL_VALUEP (XSYMBOL (symbol
)->value
)
2812 || BUFFER_OBJFWDP (XSYMBOL (symbol
)->value
))
2814 Lisp_Object current_buffer
, binding_buffer
;
2815 /* For a local variable, record both the symbol and which
2816 buffer's value we are saving. */
2817 current_buffer
= Fcurrent_buffer ();
2818 binding_buffer
= current_buffer
;
2819 /* If the variable is not local in this buffer,
2820 we are saving the global value, so restore that. */
2821 if (NILP (Flocal_variable_p (symbol
, binding_buffer
)))
2822 binding_buffer
= Qnil
;
2824 = Fcons (symbol
, Fcons (binding_buffer
, current_buffer
));
2827 specpdl_ptr
->symbol
= symbol
;
2830 if (BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
))
2831 store_symval_forwarding (symbol
, ovalue
, value
);
2833 set_internal (symbol
, value
, 0, 1);
2838 record_unwind_protect (function
, arg
)
2839 Lisp_Object (*function
) P_ ((Lisp_Object
));
2842 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2844 specpdl_ptr
->func
= function
;
2845 specpdl_ptr
->symbol
= Qnil
;
2846 specpdl_ptr
->old_value
= arg
;
2851 unbind_to (count
, value
)
2855 int quitf
= !NILP (Vquit_flag
);
2856 struct gcpro gcpro1
;
2861 while (specpdl_ptr
!= specpdl
+ count
)
2865 if (specpdl_ptr
->func
!= 0)
2866 (*specpdl_ptr
->func
) (specpdl_ptr
->old_value
);
2867 /* Note that a "binding" of nil is really an unwind protect,
2868 so in that case the "old value" is a list of forms to evaluate. */
2869 else if (NILP (specpdl_ptr
->symbol
))
2870 Fprogn (specpdl_ptr
->old_value
);
2871 /* If the symbol is a list, it is really
2872 (SYMBOL BINDING_BUFFER . CURRENT_BUFFER)
2873 and it indicates we bound a variable that has
2874 buffer-local bindings. */
2875 else if (CONSP (specpdl_ptr
->symbol
))
2877 Lisp_Object symbol
, buffer
;
2879 symbol
= XCAR (specpdl_ptr
->symbol
);
2880 buffer
= XCAR (XCDR (specpdl_ptr
->symbol
));
2882 /* Handle restoring a default value. */
2884 Fset_default (symbol
, specpdl_ptr
->old_value
);
2885 /* Handle restoring a value saved from a live buffer. */
2887 set_internal (symbol
, specpdl_ptr
->old_value
, XBUFFER (buffer
), 1);
2891 /* If variable has a trivial value (no forwarding), we can
2892 just set it. No need to check for constant symbols here,
2893 since that was already done by specbind. */
2894 if (!MISCP (XSYMBOL (specpdl_ptr
->symbol
)->value
))
2895 XSYMBOL (specpdl_ptr
->symbol
)->value
= specpdl_ptr
->old_value
;
2897 set_internal (specpdl_ptr
->symbol
, specpdl_ptr
->old_value
, 0, 1);
2901 if (NILP (Vquit_flag
) && quitf
)
2910 /* Get the value of symbol's global binding, even if that binding
2911 is not now dynamically visible. */
2914 top_level_value (symbol
)
2917 register struct specbinding
*ptr
= specpdl
;
2919 CHECK_SYMBOL (symbol
, 0);
2920 for (; ptr
!= specpdl_ptr
; ptr
++)
2922 if (EQ (ptr
->symbol
, symbol
))
2923 return ptr
->old_value
;
2925 return Fsymbol_value (symbol
);
2929 top_level_set (symbol
, newval
)
2930 Lisp_Object symbol
, newval
;
2932 register struct specbinding
*ptr
= specpdl
;
2934 CHECK_SYMBOL (symbol
, 0);
2935 for (; ptr
!= specpdl_ptr
; ptr
++)
2937 if (EQ (ptr
->symbol
, symbol
))
2939 ptr
->old_value
= newval
;
2943 return Fset (symbol
, newval
);
2948 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
2949 "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\
2950 The debugger is entered when that frame exits, if the flag is non-nil.")
2952 Lisp_Object level
, flag
;
2954 register struct backtrace
*backlist
= backtrace_list
;
2957 CHECK_NUMBER (level
, 0);
2959 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
2961 backlist
= backlist
->next
;
2965 backlist
->debug_on_exit
= !NILP (flag
);
2970 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
2971 "Print a trace of Lisp function calls currently active.\n\
2972 Output stream used is value of `standard-output'.")
2975 register struct backtrace
*backlist
= backtrace_list
;
2979 extern Lisp_Object Vprint_level
;
2980 struct gcpro gcpro1
;
2982 XSETFASTINT (Vprint_level
, 3);
2989 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
2990 if (backlist
->nargs
== UNEVALLED
)
2992 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
2993 write_string ("\n", -1);
2997 tem
= *backlist
->function
;
2998 Fprin1 (tem
, Qnil
); /* This can QUIT */
2999 write_string ("(", -1);
3000 if (backlist
->nargs
== MANY
)
3002 for (tail
= *backlist
->args
, i
= 0;
3004 tail
= Fcdr (tail
), i
++)
3006 if (i
) write_string (" ", -1);
3007 Fprin1 (Fcar (tail
), Qnil
);
3012 for (i
= 0; i
< backlist
->nargs
; i
++)
3014 if (i
) write_string (" ", -1);
3015 Fprin1 (backlist
->args
[i
], Qnil
);
3018 write_string (")\n", -1);
3020 backlist
= backlist
->next
;
3023 Vprint_level
= Qnil
;
3028 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, "",
3029 "Return the function and arguments NFRAMES up from current execution point.\n\
3030 If that frame has not evaluated the arguments yet (or is a special form),\n\
3031 the value is (nil FUNCTION ARG-FORMS...).\n\
3032 If that frame has evaluated its arguments and called its function already,\n\
3033 the value is (t FUNCTION ARG-VALUES...).\n\
3034 A &rest arg is represented as the tail of the list ARG-VALUES.\n\
3035 FUNCTION is whatever was supplied as car of evaluated list,\n\
3036 or a lambda expression for macro calls.\n\
3037 If NFRAMES is more than the number of frames, the value is nil.")
3039 Lisp_Object nframes
;
3041 register struct backtrace
*backlist
= backtrace_list
;
3045 CHECK_NATNUM (nframes
, 0);
3047 /* Find the frame requested. */
3048 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3049 backlist
= backlist
->next
;
3053 if (backlist
->nargs
== UNEVALLED
)
3054 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3057 if (backlist
->nargs
== MANY
)
3058 tem
= *backlist
->args
;
3060 tem
= Flist (backlist
->nargs
, backlist
->args
);
3062 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3069 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
3070 "*Limit on number of Lisp variable bindings & unwind-protects.\n\
3071 If Lisp code tries to make more than this many at once,\n\
3072 an error is signaled.");
3074 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
3075 "*Limit on depth in `eval', `apply' and `funcall' before error.\n\
3076 This limit is to catch infinite recursions for you before they cause\n\
3077 actual stack overflow in C, which would be fatal for Emacs.\n\
3078 You can safely make it considerably larger than its default value,\n\
3079 if that proves inconveniently small.");
3081 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
3082 "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
3083 Typing C-g sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
3086 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
3087 "Non-nil inhibits C-g quitting from happening immediately.\n\
3088 Note that `quit-flag' will still be set by typing C-g,\n\
3089 so a quit will be signaled as soon as `inhibit-quit' is nil.\n\
3090 To prevent this happening, set `quit-flag' to nil\n\
3091 before making `inhibit-quit' nil.");
3092 Vinhibit_quit
= Qnil
;
3094 Qinhibit_quit
= intern ("inhibit-quit");
3095 staticpro (&Qinhibit_quit
);
3097 Qautoload
= intern ("autoload");
3098 staticpro (&Qautoload
);
3100 Qdebug_on_error
= intern ("debug-on-error");
3101 staticpro (&Qdebug_on_error
);
3103 Qmacro
= intern ("macro");
3104 staticpro (&Qmacro
);
3106 /* Note that the process handling also uses Qexit, but we don't want
3107 to staticpro it twice, so we just do it here. */
3108 Qexit
= intern ("exit");
3111 Qinteractive
= intern ("interactive");
3112 staticpro (&Qinteractive
);
3114 Qcommandp
= intern ("commandp");
3115 staticpro (&Qcommandp
);
3117 Qdefun
= intern ("defun");
3118 staticpro (&Qdefun
);
3120 Qand_rest
= intern ("&rest");
3121 staticpro (&Qand_rest
);
3123 Qand_optional
= intern ("&optional");
3124 staticpro (&Qand_optional
);
3126 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
3127 "*Non-nil means automatically display a backtrace buffer\n\
3128 after any error that is handled by the editor command loop.\n\
3129 If the value is a list, an error only means to display a backtrace\n\
3130 if one of its condition symbols appears in the list.");
3131 Vstack_trace_on_error
= Qnil
;
3133 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
3134 "*Non-nil means enter debugger if an error is signaled.\n\
3135 Does not apply to errors handled by `condition-case'.\n\
3136 If the value is a list, an error only means to enter the debugger\n\
3137 if one of its condition symbols appears in the list.\n\
3138 See also variable `debug-on-quit'.");
3139 Vdebug_on_error
= Qnil
;
3141 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
3142 "*List of errors for which the debugger should not be called.\n\
3143 Each element may be a condition-name or a regexp that matches error messages.\n\
3144 If any element applies to a given error, that error skips the debugger\n\
3145 and just returns to top level.\n\
3146 This overrides the variable `debug-on-error'.\n\
3147 It does not apply to errors handled by `condition-case'.");
3148 Vdebug_ignored_errors
= Qnil
;
3150 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
3151 "*Non-nil means enter debugger if quit is signaled (C-g, for example).\n\
3152 Does not apply if quit is handled by a `condition-case'.");
3155 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
3156 "Non-nil means enter debugger before next `eval', `apply' or `funcall'.");
3158 DEFVAR_BOOL ("debugger-may-continue", &debugger_may_continue
,
3159 "Non-nil means debugger may continue execution.\n\
3160 This is nil when the debugger is called under circumstances where it\n\
3161 might not be safe to continue.");
3162 debugger_may_continue
= 1;
3164 DEFVAR_LISP ("debugger", &Vdebugger
,
3165 "Function to call to invoke debugger.\n\
3166 If due to frame exit, args are `exit' and the value being returned;\n\
3167 this function's value will be returned instead of that.\n\
3168 If due to error, args are `error' and a list of the args to `signal'.\n\
3169 If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
3170 If due to `eval' entry, one arg, t.");
3173 DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function
,
3174 "If non-nil, this is a function for `signal' to call.\n\
3175 It receives the same arguments that `signal' was given.\n\
3176 The Edebug package uses this to regain control.");
3177 Vsignal_hook_function
= Qnil
;
3179 Qmocklisp_arguments
= intern ("mocklisp-arguments");
3180 staticpro (&Qmocklisp_arguments
);
3181 DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments
,
3182 "While in a mocklisp function, the list of its unevaluated args.");
3183 Vmocklisp_arguments
= Qt
;
3185 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal
,
3186 "*Non-nil means call the debugger regardless of condition handlers.\n\
3187 Note that `debug-on-error', `debug-on-quit' and friends\n\
3188 still determine whether to handle the particular condition.");
3189 Vdebug_on_signal
= Qnil
;
3191 Vrun_hooks
= intern ("run-hooks");
3192 staticpro (&Vrun_hooks
);
3194 staticpro (&Vautoload_queue
);
3195 Vautoload_queue
= Qnil
;
3206 defsubr (&Sfunction
);
3208 defsubr (&Sdefmacro
);
3210 defsubr (&Sdefconst
);
3211 defsubr (&Suser_variable_p
);
3215 defsubr (&Smacroexpand
);
3218 defsubr (&Sunwind_protect
);
3219 defsubr (&Scondition_case
);
3221 defsubr (&Sinteractive_p
);
3222 defsubr (&Scommandp
);
3223 defsubr (&Sautoload
);
3226 defsubr (&Sfuncall
);
3227 defsubr (&Srun_hooks
);
3228 defsubr (&Srun_hook_with_args
);
3229 defsubr (&Srun_hook_with_args_until_success
);
3230 defsubr (&Srun_hook_with_args_until_failure
);
3231 defsubr (&Sfetch_bytecode
);
3232 defsubr (&Sbacktrace_debug
);
3233 defsubr (&Sbacktrace
);
3234 defsubr (&Sbacktrace_frame
);