1 /* Evaluator for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 99, 2000, 2001
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
25 #include "blockinput.h"
28 #include "dispextern.h"
31 /* This definition is duplicated in alloc.c and keyboard.c */
32 /* Putting it in lisp.h makes cc bomb out! */
36 struct backtrace
*next
;
37 Lisp_Object
*function
;
38 Lisp_Object
*args
; /* Points to vector of args. */
39 int nargs
; /* Length of vector.
40 If nargs is UNEVALLED, args points to slot holding
41 list of unevalled args */
43 /* Nonzero means call value of debugger when done with this operation. */
47 struct backtrace
*backtrace_list
;
49 /* This structure helps implement the `catch' and `throw' control
50 structure. A struct catchtag contains all the information needed
51 to restore the state of the interpreter after a non-local jump.
53 Handlers for error conditions (represented by `struct handler'
54 structures) just point to a catch tag to do the cleanup required
57 catchtag structures are chained together in the C calling stack;
58 the `next' member points to the next outer catchtag.
60 A call like (throw TAG VAL) searches for a catchtag whose `tag'
61 member is TAG, and then unbinds to it. The `val' member is used to
62 hold VAL while the stack is unwound; `val' is returned as the value
65 All the other members are concerned with restoring the interpreter
72 struct catchtag
*next
;
75 struct backtrace
*backlist
;
76 struct handler
*handlerlist
;
79 int poll_suppress_count
;
80 struct byte_stack
*byte_stack
;
83 struct catchtag
*catchlist
;
86 /* Count levels of GCPRO to detect failure to UNGCPRO. */
90 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
91 Lisp_Object Qinhibit_quit
, Vinhibit_quit
, Vquit_flag
;
92 Lisp_Object Qmocklisp_arguments
, Vmocklisp_arguments
, Qmocklisp
;
93 Lisp_Object Qand_rest
, Qand_optional
;
94 Lisp_Object Qdebug_on_error
;
96 /* This holds either the symbol `run-hooks' or nil.
97 It is nil at an early stage of startup, and when Emacs
100 Lisp_Object Vrun_hooks
;
102 /* Non-nil means record all fset's and provide's, to be undone
103 if the file being autoloaded is not fully loaded.
104 They are recorded by being consed onto the front of Vautoload_queue:
105 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */
107 Lisp_Object Vautoload_queue
;
109 /* Current number of specbindings allocated in specpdl. */
113 /* Pointer to beginning of specpdl. */
115 struct specbinding
*specpdl
;
117 /* Pointer to first unused element in specpdl. */
119 struct specbinding
*specpdl_ptr
;
121 /* Maximum size allowed for specpdl allocation */
123 int max_specpdl_size
;
125 /* Depth in Lisp evaluations and function calls. */
129 /* Maximum allowed depth in Lisp evaluations and function calls. */
131 int max_lisp_eval_depth
;
133 /* Nonzero means enter debugger before next function call */
135 int debug_on_next_call
;
137 /* Non-zero means debuffer may continue. This is zero when the
138 debugger is called during redisplay, where it might not be safe to
139 continue the interrupted redisplay. */
141 int debugger_may_continue
;
143 /* List of conditions (non-nil atom means all) which cause a backtrace
144 if an error is handled by the command loop's error handler. */
146 Lisp_Object Vstack_trace_on_error
;
148 /* List of conditions (non-nil atom means all) which enter the debugger
149 if an error is handled by the command loop's error handler. */
151 Lisp_Object Vdebug_on_error
;
153 /* List of conditions and regexps specifying error messages which
154 do not enter the debugger even if Vdebug_on_errors says they should. */
156 Lisp_Object Vdebug_ignored_errors
;
158 /* Non-nil means call the debugger even if the error will be handled. */
160 Lisp_Object Vdebug_on_signal
;
162 /* Hook for edebug to use. */
164 Lisp_Object Vsignal_hook_function
;
166 /* Nonzero means enter debugger if a quit signal
167 is handled by the command loop's error handler. */
171 /* The value of num_nonmacro_input_events as of the last time we
172 started to enter the debugger. If we decide to enter the debugger
173 again when this is still equal to num_nonmacro_input_events, then we
174 know that the debugger itself has an error, and we should just
175 signal the error instead of entering an infinite loop of debugger
178 int when_entered_debugger
;
180 Lisp_Object Vdebugger
;
182 /* The function from which the last `signal' was called. Set in
185 Lisp_Object Vsignaling_function
;
187 /* Set to non-zero while processing X events. Checked in Feval to
188 make sure the Lisp interpreter isn't called from a signal handler,
189 which is unsafe because the interpreter isn't reentrant. */
193 void specbind (), record_unwind_protect ();
195 Lisp_Object
run_hook_with_args ();
197 Lisp_Object
funcall_lambda ();
198 extern Lisp_Object
ml_apply (); /* Apply a mocklisp function to unevaluated argument list */
204 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
205 specpdl_ptr
= specpdl
;
206 max_specpdl_size
= 600;
207 max_lisp_eval_depth
= 300;
215 specpdl_ptr
= specpdl
;
220 debug_on_next_call
= 0;
225 /* This is less than the initial value of num_nonmacro_input_events. */
226 when_entered_debugger
= -1;
233 int debug_while_redisplaying
;
234 int count
= specpdl_ptr
- specpdl
;
237 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
238 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
240 if (specpdl_size
+ 40 > max_specpdl_size
)
241 max_specpdl_size
= specpdl_size
+ 40;
243 #ifdef HAVE_X_WINDOWS
244 if (display_hourglass_p
)
248 debug_on_next_call
= 0;
249 when_entered_debugger
= num_nonmacro_input_events
;
251 /* Resetting redisplaying_p to 0 makes sure that debug output is
252 displayed if the debugger is invoked during redisplay. */
253 debug_while_redisplaying
= redisplaying_p
;
255 specbind (intern ("debugger-may-continue"),
256 debug_while_redisplaying
? Qnil
: Qt
);
257 specbind (Qinhibit_redisplay
, Qnil
);
258 specbind (Qinhibit_eval_during_redisplay
, Qt
);
260 val
= apply1 (Vdebugger
, arg
);
262 /* Interrupting redisplay and resuming it later is not safe under
263 all circumstances. So, when the debugger returns, abort the
264 interupted redisplay by going back to the top-level. */
265 if (debug_while_redisplaying
)
268 return unbind_to (count
, val
);
272 do_debug_on_call (code
)
275 debug_on_next_call
= 0;
276 backtrace_list
->debug_on_exit
= 1;
277 call_debugger (Fcons (code
, Qnil
));
280 /* NOTE!!! Every function that can call EVAL must protect its args
281 and temporaries from garbage collection while it needs them.
282 The definition of `For' shows what you have to do. */
284 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
285 "Eval args until one of them yields non-nil, then return that value.\n\
286 The remaining args are not evalled at all.\n\
287 If all args return nil, return nil.")
291 register Lisp_Object val
;
292 Lisp_Object args_left
;
303 val
= Feval (Fcar (args_left
));
306 args_left
= Fcdr (args_left
);
308 while (!NILP(args_left
));
314 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
315 "Eval args until one of them yields nil, then return nil.\n\
316 The remaining args are not evalled at all.\n\
317 If no arg yields nil, return the last arg's value.")
321 register Lisp_Object val
;
322 Lisp_Object args_left
;
333 val
= Feval (Fcar (args_left
));
336 args_left
= Fcdr (args_left
);
338 while (!NILP(args_left
));
344 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
345 "If COND yields non-nil, do THEN, else do ELSE...\n\
346 Returns the value of THEN or the value of the last of the ELSE's.\n\
347 THEN must be one expression, but ELSE... can be zero or more expressions.\n\
348 If COND yields nil, and there are no ELSE's, the value is nil.")
352 register Lisp_Object cond
;
356 cond
= Feval (Fcar (args
));
360 return Feval (Fcar (Fcdr (args
)));
361 return Fprogn (Fcdr (Fcdr (args
)));
364 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
365 "Try each clause until one succeeds.\n\
366 Each clause looks like (CONDITION BODY...). CONDITION is evaluated\n\
367 and, if the value is non-nil, this clause succeeds:\n\
368 then the expressions in BODY are evaluated and the last one's\n\
369 value is the value of the cond-form.\n\
370 If no clause succeeds, cond returns nil.\n\
371 If a clause has one element, as in (CONDITION),\n\
372 CONDITION's value if non-nil is returned from the cond-form.")
376 register Lisp_Object clause
, val
;
383 clause
= Fcar (args
);
384 val
= Feval (Fcar (clause
));
387 if (!EQ (XCDR (clause
), Qnil
))
388 val
= Fprogn (XCDR (clause
));
398 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
399 "Eval BODY forms sequentially and return value of last one.")
403 register Lisp_Object val
, tem
;
404 Lisp_Object args_left
;
407 /* In Mocklisp code, symbols at the front of the progn arglist
408 are to be bound to zero. */
409 if (!EQ (Vmocklisp_arguments
, Qt
))
411 val
= make_number (0);
412 while (!NILP (args
) && (tem
= Fcar (args
), SYMBOLP (tem
)))
415 specbind (tem
, val
), args
= Fcdr (args
);
427 val
= Feval (Fcar (args_left
));
428 args_left
= Fcdr (args_left
);
430 while (!NILP(args_left
));
436 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
437 "Eval FIRST and BODY sequentially; value from FIRST.\n\
438 The value of FIRST is saved during the evaluation of the remaining args,\n\
439 whose values are discarded.")
444 register Lisp_Object args_left
;
445 struct gcpro gcpro1
, gcpro2
;
446 register int argnum
= 0;
458 val
= Feval (Fcar (args_left
));
460 Feval (Fcar (args_left
));
461 args_left
= Fcdr (args_left
);
463 while (!NILP(args_left
));
469 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
470 "Eval X, Y and BODY sequentially; value from Y.\n\
471 The value of Y is saved during the evaluation of the remaining args,\n\
472 whose values are discarded.")
477 register Lisp_Object args_left
;
478 struct gcpro gcpro1
, gcpro2
;
479 register int argnum
= -1;
493 val
= Feval (Fcar (args_left
));
495 Feval (Fcar (args_left
));
496 args_left
= Fcdr (args_left
);
498 while (!NILP (args_left
));
504 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
505 "Set each SYM to the value of its VAL.\n\
506 The symbols SYM are variables; they are literal (not evaluated).\n\
507 The values VAL are expressions; they are evaluated.\n\
508 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.\n\
509 The second VAL is not computed until after the first SYM is set, and so on;\n\
510 each VAL can use the new value of variables set earlier in the `setq'.\n\
511 The return value of the `setq' form is the value of the last VAL.")
515 register Lisp_Object args_left
;
516 register Lisp_Object val
, sym
;
527 val
= Feval (Fcar (Fcdr (args_left
)));
528 sym
= Fcar (args_left
);
530 args_left
= Fcdr (Fcdr (args_left
));
532 while (!NILP(args_left
));
538 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
539 "Return the argument, without evaluating it. `(quote x)' yields `x'.")
546 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
547 "Like `quote', but preferred for objects which are functions.\n\
548 In byte compilation, `function' causes its argument to be compiled.\n\
549 `quote' cannot do that.")
557 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
558 "Return t if function in which this appears was called interactively.\n\
559 This means that the function was called with call-interactively (which\n\
560 includes being called as the binding of a key)\n\
561 and input is currently coming from the keyboard (not in keyboard macro).")
564 return interactive_p (1) ? Qt
: Qnil
;
568 /* Return 1 if function in which this appears was called
569 interactively. This means that the function was called with
570 call-interactively (which includes being called as the binding of
571 a key) and input is currently coming from the keyboard (not in
574 EXCLUDE_SUBRS_P non-zero means always return 0 if the function
575 called is a built-in. */
578 interactive_p (exclude_subrs_p
)
581 struct backtrace
*btp
;
587 btp
= backtrace_list
;
589 /* If this isn't a byte-compiled function, there may be a frame at
590 the top for Finteractive_p. If so, skip it. */
591 fun
= Findirect_function (*btp
->function
);
592 if (SUBRP (fun
) && XSUBR (fun
) == &Sinteractive_p
)
595 /* If we're running an Emacs 18-style byte-compiled function, there
596 may be a frame for Fbytecode. Now, given the strictest
597 definition, this function isn't really being called
598 interactively, but because that's the way Emacs 18 always builds
599 byte-compiled functions, we'll accept it for now. */
600 if (EQ (*btp
->function
, Qbytecode
))
603 /* If this isn't a byte-compiled function, then we may now be
604 looking at several frames for special forms. Skip past them. */
606 btp
->nargs
== UNEVALLED
)
609 /* btp now points at the frame of the innermost function that isn't
610 a special form, ignoring frames for Finteractive_p and/or
611 Fbytecode at the top. If this frame is for a built-in function
612 (such as load or eval-region) return nil. */
613 fun
= Findirect_function (*btp
->function
);
614 if (exclude_subrs_p
&& SUBRP (fun
))
617 /* btp points to the frame of a Lisp function that called interactive-p.
618 Return t if that function was called interactively. */
619 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
625 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
626 "Define NAME as a function.\n\
627 The definition is (lambda ARGLIST [DOCSTRING] BODY...).\n\
628 See also the function `interactive'.")
632 register Lisp_Object fn_name
;
633 register Lisp_Object defn
;
635 fn_name
= Fcar (args
);
636 defn
= Fcons (Qlambda
, Fcdr (args
));
637 if (!NILP (Vpurify_flag
))
638 defn
= Fpurecopy (defn
);
639 Ffset (fn_name
, defn
);
640 LOADHIST_ATTACH (fn_name
);
644 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
645 "Define NAME as a macro.\n\
646 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).\n\
647 When the macro is called, as in (NAME ARGS...),\n\
648 the function (lambda ARGLIST BODY...) is applied to\n\
649 the list ARGS... as it appears in the expression,\n\
650 and the result should be a form to be evaluated instead of the original.")
654 register Lisp_Object fn_name
;
655 register Lisp_Object defn
;
657 fn_name
= Fcar (args
);
658 defn
= Fcons (Qmacro
, Fcons (Qlambda
, Fcdr (args
)));
659 if (!NILP (Vpurify_flag
))
660 defn
= Fpurecopy (defn
);
661 Ffset (fn_name
, defn
);
662 LOADHIST_ATTACH (fn_name
);
666 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
667 "Define SYMBOL as a variable.\n\
668 You are not required to define a variable in order to use it,\n\
669 but the definition can supply documentation and an initial value\n\
670 in a way that tags can recognize.\n\n\
671 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.\n\
672 If SYMBOL is buffer-local, its default value is what is set;\n\
673 buffer-local values are not affected.\n\
674 INITVALUE and DOCSTRING are optional.\n\
675 If DOCSTRING starts with *, this variable is identified as a user option.\n\
676 This means that M-x set-variable recognizes it.\n\
677 See also `user-variable-p'.\n\
678 If INITVALUE is missing, SYMBOL's value is not set.")
682 register Lisp_Object sym
, tem
, tail
;
686 if (!NILP (Fcdr (Fcdr (tail
))))
687 error ("too many arguments");
691 tem
= Fdefault_boundp (sym
);
693 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
695 tail
= Fcdr (Fcdr (args
));
696 if (!NILP (Fcar (tail
)))
699 if (!NILP (Vpurify_flag
))
700 tem
= Fpurecopy (tem
);
701 Fput (sym
, Qvariable_documentation
, tem
);
703 LOADHIST_ATTACH (sym
);
707 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
708 "Define SYMBOL as a constant variable.\n\
709 The intent is that neither programs nor users should ever change this value.\n\
710 Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\
711 If SYMBOL is buffer-local, its default value is what is set;\n\
712 buffer-local values are not affected.\n\
713 DOCSTRING is optional.")
717 register Lisp_Object sym
, tem
;
720 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
721 error ("too many arguments");
723 tem
= Feval (Fcar (Fcdr (args
)));
724 if (!NILP (Vpurify_flag
))
725 tem
= Fpurecopy (tem
);
726 Fset_default (sym
, tem
);
727 tem
= Fcar (Fcdr (Fcdr (args
)));
730 if (!NILP (Vpurify_flag
))
731 tem
= Fpurecopy (tem
);
732 Fput (sym
, Qvariable_documentation
, tem
);
734 LOADHIST_ATTACH (sym
);
738 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
739 "Returns t if VARIABLE is intended to be set and modified by users.\n\
740 \(The alternative is a variable used internally in a Lisp program.)\n\
741 Determined by whether the first character of the documentation\n\
742 for the variable is `*' or if the variable is customizable (has a non-nil\n\
743 value of any of `custom-type', `custom-loads' or `standard-value'\n\
744 on its property list).")
746 Lisp_Object variable
;
748 Lisp_Object documentation
;
750 if (!SYMBOLP (variable
))
753 documentation
= Fget (variable
, Qvariable_documentation
);
754 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
756 if (STRINGP (documentation
)
757 && ((unsigned char) XSTRING (documentation
)->data
[0] == '*'))
759 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
760 if (CONSP (documentation
)
761 && STRINGP (XCAR (documentation
))
762 && INTEGERP (XCDR (documentation
))
763 && XINT (XCDR (documentation
)) < 0)
766 if ((!NILP (Fget (variable
, intern ("custom-type"))))
767 || (!NILP (Fget (variable
, intern ("custom-loads"))))
768 || (!NILP (Fget (variable
, intern ("standard-value")))))
773 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
774 "Bind variables according to VARLIST then eval BODY.\n\
775 The value of the last form in BODY is returned.\n\
776 Each element of VARLIST is a symbol (which is bound to nil)\n\
777 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
778 Each VALUEFORM can refer to the symbols already bound by this VARLIST.")
782 Lisp_Object varlist
, val
, elt
;
783 int count
= specpdl_ptr
- specpdl
;
784 struct gcpro gcpro1
, gcpro2
, gcpro3
;
786 GCPRO3 (args
, elt
, varlist
);
788 varlist
= Fcar (args
);
789 while (!NILP (varlist
))
792 elt
= Fcar (varlist
);
794 specbind (elt
, Qnil
);
795 else if (! NILP (Fcdr (Fcdr (elt
))))
797 Fcons (build_string ("`let' bindings can have only one value-form"),
801 val
= Feval (Fcar (Fcdr (elt
)));
802 specbind (Fcar (elt
), val
);
804 varlist
= Fcdr (varlist
);
807 val
= Fprogn (Fcdr (args
));
808 return unbind_to (count
, val
);
811 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
812 "Bind variables according to VARLIST then eval BODY.\n\
813 The value of the last form in BODY is returned.\n\
814 Each element of VARLIST is a symbol (which is bound to nil)\n\
815 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
816 All the VALUEFORMs are evalled before any symbols are bound.")
820 Lisp_Object
*temps
, tem
;
821 register Lisp_Object elt
, varlist
;
822 int count
= specpdl_ptr
- specpdl
;
824 struct gcpro gcpro1
, gcpro2
;
826 varlist
= Fcar (args
);
828 /* Make space to hold the values to give the bound variables */
829 elt
= Flength (varlist
);
830 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
832 /* Compute the values and store them in `temps' */
834 GCPRO2 (args
, *temps
);
837 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
840 elt
= Fcar (varlist
);
842 temps
[argnum
++] = Qnil
;
843 else if (! NILP (Fcdr (Fcdr (elt
))))
845 Fcons (build_string ("`let' bindings can have only one value-form"),
848 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
849 gcpro2
.nvars
= argnum
;
853 varlist
= Fcar (args
);
854 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
856 elt
= Fcar (varlist
);
857 tem
= temps
[argnum
++];
861 specbind (Fcar (elt
), tem
);
864 elt
= Fprogn (Fcdr (args
));
865 return unbind_to (count
, elt
);
868 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
869 "If TEST yields non-nil, eval BODY... and repeat.\n\
870 The order of execution is thus TEST, BODY, TEST, BODY and so on\n\
871 until TEST returns nil.")
875 Lisp_Object test
, body
, tem
;
876 struct gcpro gcpro1
, gcpro2
;
882 while (tem
= Feval (test
),
883 (!EQ (Vmocklisp_arguments
, Qt
) ? XINT (tem
) : !NILP (tem
)))
893 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
894 "Return result of expanding macros at top level of FORM.\n\
895 If FORM is not a macro call, it is returned unchanged.\n\
896 Otherwise, the macro is expanded and the expansion is considered\n\
897 in place of FORM. When a non-macro-call results, it is returned.\n\n\
898 The second optional arg ENVIRONMENT specifies an environment of macro\n\
899 definitions to shadow the loaded ones for use in file byte-compilation.")
902 Lisp_Object environment
;
904 /* With cleanups from Hallvard Furuseth. */
905 register Lisp_Object expander
, sym
, def
, tem
;
909 /* Come back here each time we expand a macro call,
910 in case it expands into another macro call. */
913 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
914 def
= sym
= XCAR (form
);
916 /* Trace symbols aliases to other symbols
917 until we get a symbol that is not an alias. */
918 while (SYMBOLP (def
))
922 tem
= Fassq (sym
, environment
);
925 def
= XSYMBOL (sym
)->function
;
926 if (!EQ (def
, Qunbound
))
931 /* Right now TEM is the result from SYM in ENVIRONMENT,
932 and if TEM is nil then DEF is SYM's function definition. */
935 /* SYM is not mentioned in ENVIRONMENT.
936 Look at its function definition. */
937 if (EQ (def
, Qunbound
) || !CONSP (def
))
938 /* Not defined or definition not suitable */
940 if (EQ (XCAR (def
), Qautoload
))
942 /* Autoloading function: will it be a macro when loaded? */
943 tem
= Fnth (make_number (4), def
);
944 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
945 /* Yes, load it and try again. */
949 do_autoload (def
, sym
);
956 else if (!EQ (XCAR (def
), Qmacro
))
958 else expander
= XCDR (def
);
962 expander
= XCDR (tem
);
966 form
= apply1 (expander
, XCDR (form
));
971 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
972 "Eval BODY allowing nonlocal exits using `throw'.\n\
973 TAG is evalled to get the tag to use; it must not be nil.\n\
975 Then the BODY is executed.\n\
976 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.\n\
977 If no throw happens, `catch' returns the value of the last BODY form.\n\
978 If a throw happens, it specifies the value to return from `catch'.")
982 register Lisp_Object tag
;
986 tag
= Feval (Fcar (args
));
988 return internal_catch (tag
, Fprogn
, Fcdr (args
));
991 /* Set up a catch, then call C function FUNC on argument ARG.
992 FUNC should return a Lisp_Object.
993 This is how catches are done from within C code. */
996 internal_catch (tag
, func
, arg
)
998 Lisp_Object (*func
) ();
1001 /* This structure is made part of the chain `catchlist'. */
1004 /* Fill in the components of c, and put it on the list. */
1008 c
.backlist
= backtrace_list
;
1009 c
.handlerlist
= handlerlist
;
1010 c
.lisp_eval_depth
= lisp_eval_depth
;
1011 c
.pdlcount
= specpdl_ptr
- specpdl
;
1012 c
.poll_suppress_count
= poll_suppress_count
;
1013 c
.gcpro
= gcprolist
;
1014 c
.byte_stack
= byte_stack_list
;
1018 if (! _setjmp (c
.jmp
))
1019 c
.val
= (*func
) (arg
);
1021 /* Throw works by a longjmp that comes right here. */
1026 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1027 jump to that CATCH, returning VALUE as the value of that catch.
1029 This is the guts Fthrow and Fsignal; they differ only in the way
1030 they choose the catch tag to throw to. A catch tag for a
1031 condition-case form has a TAG of Qnil.
1033 Before each catch is discarded, unbind all special bindings and
1034 execute all unwind-protect clauses made above that catch. Unwind
1035 the handler stack as we go, so that the proper handlers are in
1036 effect for each unwind-protect clause we run. At the end, restore
1037 some static info saved in CATCH, and longjmp to the location
1040 This is used for correct unwinding in Fthrow and Fsignal. */
1043 unwind_to_catch (catch, value
)
1044 struct catchtag
*catch;
1047 register int last_time
;
1049 /* Save the value in the tag. */
1052 /* Restore the polling-suppression count. */
1053 set_poll_suppress_count (catch->poll_suppress_count
);
1057 last_time
= catchlist
== catch;
1059 /* Unwind the specpdl stack, and then restore the proper set of
1061 unbind_to (catchlist
->pdlcount
, Qnil
);
1062 handlerlist
= catchlist
->handlerlist
;
1063 catchlist
= catchlist
->next
;
1065 while (! last_time
);
1067 byte_stack_list
= catch->byte_stack
;
1068 gcprolist
= catch->gcpro
;
1071 gcpro_level
= gcprolist
->level
+ 1;
1075 backtrace_list
= catch->backlist
;
1076 lisp_eval_depth
= catch->lisp_eval_depth
;
1078 _longjmp (catch->jmp
, 1);
1081 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1082 "Throw to the catch for TAG and return VALUE from it.\n\
1083 Both TAG and VALUE are evalled.")
1085 register Lisp_Object tag
, value
;
1087 register struct catchtag
*c
;
1092 for (c
= catchlist
; c
; c
= c
->next
)
1094 if (EQ (c
->tag
, tag
))
1095 unwind_to_catch (c
, value
);
1097 tag
= Fsignal (Qno_catch
, Fcons (tag
, Fcons (value
, Qnil
)));
1102 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1103 "Do BODYFORM, protecting with UNWINDFORMS.\n\
1104 If BODYFORM completes normally, its value is returned\n\
1105 after executing the UNWINDFORMS.\n\
1106 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.")
1111 int count
= specpdl_ptr
- specpdl
;
1113 record_unwind_protect (0, Fcdr (args
));
1114 val
= Feval (Fcar (args
));
1115 return unbind_to (count
, val
);
1118 /* Chain of condition handlers currently in effect.
1119 The elements of this chain are contained in the stack frames
1120 of Fcondition_case and internal_condition_case.
1121 When an error is signaled (by calling Fsignal, below),
1122 this chain is searched for an element that applies. */
1124 struct handler
*handlerlist
;
1126 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1127 "Regain control when an error is signaled.\n\
1128 executes BODYFORM and returns its value if no error happens.\n\
1129 Each element of HANDLERS looks like (CONDITION-NAME BODY...)\n\
1130 where the BODY is made of Lisp expressions.\n\n\
1131 A handler is applicable to an error\n\
1132 if CONDITION-NAME is one of the error's condition names.\n\
1133 If an error happens, the first applicable handler is run.\n\
1135 The car of a handler may be a list of condition names\n\
1136 instead of a single condition name.\n\
1138 When a handler handles an error,\n\
1139 control returns to the condition-case and the handler BODY... is executed\n\
1140 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\
1141 VAR may be nil; then you do not get access to the signal information.\n\
1143 The value of the last BODY form is returned from the condition-case.\n\
1144 See also the function `signal' for more info.")
1151 register Lisp_Object bodyform
, handlers
;
1152 volatile Lisp_Object var
;
1155 bodyform
= Fcar (Fcdr (args
));
1156 handlers
= Fcdr (Fcdr (args
));
1157 CHECK_SYMBOL (var
, 0);
1159 for (val
= handlers
; ! NILP (val
); val
= Fcdr (val
))
1165 && (SYMBOLP (XCAR (tem
))
1166 || CONSP (XCAR (tem
))))))
1167 error ("Invalid condition handler", tem
);
1172 c
.backlist
= backtrace_list
;
1173 c
.handlerlist
= handlerlist
;
1174 c
.lisp_eval_depth
= lisp_eval_depth
;
1175 c
.pdlcount
= specpdl_ptr
- specpdl
;
1176 c
.poll_suppress_count
= poll_suppress_count
;
1177 c
.gcpro
= gcprolist
;
1178 c
.byte_stack
= byte_stack_list
;
1179 if (_setjmp (c
.jmp
))
1182 specbind (h
.var
, c
.val
);
1183 val
= Fprogn (Fcdr (h
.chosen_clause
));
1185 /* Note that this just undoes the binding of h.var; whoever
1186 longjumped to us unwound the stack to c.pdlcount before
1188 unbind_to (c
.pdlcount
, Qnil
);
1195 h
.handler
= handlers
;
1196 h
.next
= handlerlist
;
1200 val
= Feval (bodyform
);
1202 handlerlist
= h
.next
;
1206 /* Call the function BFUN with no arguments, catching errors within it
1207 according to HANDLERS. If there is an error, call HFUN with
1208 one argument which is the data that describes the error:
1211 HANDLERS can be a list of conditions to catch.
1212 If HANDLERS is Qt, catch all errors.
1213 If HANDLERS is Qerror, catch all errors
1214 but allow the debugger to run if that is enabled. */
1217 internal_condition_case (bfun
, handlers
, hfun
)
1218 Lisp_Object (*bfun
) ();
1219 Lisp_Object handlers
;
1220 Lisp_Object (*hfun
) ();
1226 #if 0 /* Can't do this check anymore because realize_basic_faces has
1227 to BLOCK_INPUT, and can call Lisp. What's really needed is a
1228 flag indicating that we're currently handling a signal. */
1229 /* Since Fsignal resets this to 0, it had better be 0 now
1230 or else we have a potential bug. */
1231 if (interrupt_input_blocked
!= 0)
1237 c
.backlist
= backtrace_list
;
1238 c
.handlerlist
= handlerlist
;
1239 c
.lisp_eval_depth
= lisp_eval_depth
;
1240 c
.pdlcount
= specpdl_ptr
- specpdl
;
1241 c
.poll_suppress_count
= poll_suppress_count
;
1242 c
.gcpro
= gcprolist
;
1243 c
.byte_stack
= byte_stack_list
;
1244 if (_setjmp (c
.jmp
))
1246 return (*hfun
) (c
.val
);
1250 h
.handler
= handlers
;
1252 h
.next
= handlerlist
;
1258 handlerlist
= h
.next
;
1262 /* Like internal_condition_case but call HFUN with ARG as its argument. */
1265 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1266 Lisp_Object (*bfun
) ();
1268 Lisp_Object handlers
;
1269 Lisp_Object (*hfun
) ();
1277 c
.backlist
= backtrace_list
;
1278 c
.handlerlist
= handlerlist
;
1279 c
.lisp_eval_depth
= lisp_eval_depth
;
1280 c
.pdlcount
= specpdl_ptr
- specpdl
;
1281 c
.poll_suppress_count
= poll_suppress_count
;
1282 c
.gcpro
= gcprolist
;
1283 c
.byte_stack
= byte_stack_list
;
1284 if (_setjmp (c
.jmp
))
1286 return (*hfun
) (c
.val
);
1290 h
.handler
= handlers
;
1292 h
.next
= handlerlist
;
1296 val
= (*bfun
) (arg
);
1298 handlerlist
= h
.next
;
1303 /* Like internal_condition_case but call HFUN with NARGS as first,
1304 and ARGS as second argument. */
1307 internal_condition_case_2 (bfun
, nargs
, args
, handlers
, hfun
)
1308 Lisp_Object (*bfun
) ();
1311 Lisp_Object handlers
;
1312 Lisp_Object (*hfun
) ();
1320 c
.backlist
= backtrace_list
;
1321 c
.handlerlist
= handlerlist
;
1322 c
.lisp_eval_depth
= lisp_eval_depth
;
1323 c
.pdlcount
= specpdl_ptr
- specpdl
;
1324 c
.poll_suppress_count
= poll_suppress_count
;
1325 c
.gcpro
= gcprolist
;
1326 c
.byte_stack
= byte_stack_list
;
1327 if (_setjmp (c
.jmp
))
1329 return (*hfun
) (c
.val
);
1333 h
.handler
= handlers
;
1335 h
.next
= handlerlist
;
1339 val
= (*bfun
) (nargs
, args
);
1341 handlerlist
= h
.next
;
1346 static Lisp_Object
find_handler_clause ();
1348 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1349 "Signal an error. Args are ERROR-SYMBOL and associated DATA.\n\
1350 This function does not return.\n\n\
1351 An error symbol is a symbol with an `error-conditions' property\n\
1352 that is a list of condition names.\n\
1353 A handler for any of those names will get to handle this signal.\n\
1354 The symbol `error' should normally be one of them.\n\
1356 DATA should be a list. Its elements are printed as part of the error message.\n\
1357 If the signal is handled, DATA is made available to the handler.\n\
1358 See also the function `condition-case'.")
1359 (error_symbol
, data
)
1360 Lisp_Object error_symbol
, data
;
1362 /* When memory is full, ERROR-SYMBOL is nil,
1363 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA). */
1364 register struct handler
*allhandlers
= handlerlist
;
1365 Lisp_Object conditions
;
1366 extern int gc_in_progress
;
1367 extern int waiting_for_input
;
1368 Lisp_Object debugger_value
;
1370 Lisp_Object real_error_symbol
;
1371 extern int display_hourglass_p
;
1372 struct backtrace
*bp
;
1374 immediate_quit
= handling_signal
= 0;
1375 if (gc_in_progress
|| waiting_for_input
)
1378 TOTALLY_UNBLOCK_INPUT
;
1380 if (NILP (error_symbol
))
1381 real_error_symbol
= Fcar (data
);
1383 real_error_symbol
= error_symbol
;
1385 #ifdef HAVE_X_WINDOWS
1386 if (display_hourglass_p
)
1387 cancel_hourglass ();
1390 /* This hook is used by edebug. */
1391 if (! NILP (Vsignal_hook_function
))
1392 call2 (Vsignal_hook_function
, error_symbol
, data
);
1394 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1396 /* Remember from where signal was called. Skip over the frame for
1397 `signal' itself. If a frame for `error' follows, skip that,
1399 Vsignaling_function
= Qnil
;
1402 bp
= backtrace_list
->next
;
1403 if (bp
&& bp
->function
&& EQ (*bp
->function
, Qerror
))
1405 if (bp
&& bp
->function
)
1406 Vsignaling_function
= *bp
->function
;
1409 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1411 register Lisp_Object clause
;
1413 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1414 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1416 if (specpdl_size
+ 40 > max_specpdl_size
)
1417 max_specpdl_size
= specpdl_size
+ 40;
1419 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1420 error_symbol
, data
, &debugger_value
);
1422 #if 0 /* Most callers are not prepared to handle gc if this returns.
1423 So, since this feature is not very useful, take it out. */
1424 /* If have called debugger and user wants to continue,
1426 if (EQ (clause
, Qlambda
))
1427 return debugger_value
;
1429 if (EQ (clause
, Qlambda
))
1431 /* We can't return values to code which signaled an error, but we
1432 can continue code which has signaled a quit. */
1433 if (EQ (real_error_symbol
, Qquit
))
1436 error ("Cannot return from the debugger in an error");
1442 Lisp_Object unwind_data
;
1443 struct handler
*h
= handlerlist
;
1445 handlerlist
= allhandlers
;
1447 if (NILP (error_symbol
))
1450 unwind_data
= Fcons (error_symbol
, data
);
1451 h
->chosen_clause
= clause
;
1452 unwind_to_catch (h
->tag
, unwind_data
);
1456 handlerlist
= allhandlers
;
1457 /* If no handler is present now, try to run the debugger,
1458 and if that fails, throw to top level. */
1459 find_handler_clause (Qerror
, conditions
, error_symbol
, data
, &debugger_value
);
1461 Fthrow (Qtop_level
, Qt
);
1463 if (! NILP (error_symbol
))
1464 data
= Fcons (error_symbol
, data
);
1466 string
= Ferror_message_string (data
);
1467 fatal ("%s", XSTRING (string
)->data
, 0);
1470 /* Return nonzero iff LIST is a non-nil atom or
1471 a list containing one of CONDITIONS. */
1474 wants_debugger (list
, conditions
)
1475 Lisp_Object list
, conditions
;
1482 while (CONSP (conditions
))
1484 Lisp_Object
this, tail
;
1485 this = XCAR (conditions
);
1486 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1487 if (EQ (XCAR (tail
), this))
1489 conditions
= XCDR (conditions
);
1494 /* Return 1 if an error with condition-symbols CONDITIONS,
1495 and described by SIGNAL-DATA, should skip the debugger
1496 according to debugger-ignore-errors. */
1499 skip_debugger (conditions
, data
)
1500 Lisp_Object conditions
, data
;
1503 int first_string
= 1;
1504 Lisp_Object error_message
;
1506 error_message
= Qnil
;
1507 for (tail
= Vdebug_ignored_errors
; CONSP (tail
); tail
= XCDR (tail
))
1509 if (STRINGP (XCAR (tail
)))
1513 error_message
= Ferror_message_string (data
);
1517 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1522 Lisp_Object contail
;
1524 for (contail
= conditions
; CONSP (contail
); contail
= XCDR (contail
))
1525 if (EQ (XCAR (tail
), XCAR (contail
)))
1533 /* Value of Qlambda means we have called debugger and user has continued.
1534 There are two ways to pass SIG and DATA:
1535 = SIG is the error symbol, and DATA is the rest of the data.
1536 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1537 This is for memory-full errors only.
1539 Store value returned from debugger into *DEBUGGER_VALUE_PTR. */
1542 find_handler_clause (handlers
, conditions
, sig
, data
, debugger_value_ptr
)
1543 Lisp_Object handlers
, conditions
, sig
, data
;
1544 Lisp_Object
*debugger_value_ptr
;
1546 register Lisp_Object h
;
1547 register Lisp_Object tem
;
1549 if (EQ (handlers
, Qt
)) /* t is used by handlers for all conditions, set up by C code. */
1551 /* error is used similarly, but means print an error message
1552 and run the debugger if that is enabled. */
1553 if (EQ (handlers
, Qerror
)
1554 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1555 there is a handler. */
1557 int count
= specpdl_ptr
- specpdl
;
1558 int debugger_called
= 0;
1559 Lisp_Object sig_symbol
, combined_data
;
1560 /* This is set to 1 if we are handling a memory-full error,
1561 because these must not run the debugger.
1562 (There is no room in memory to do that!) */
1563 int no_debugger
= 0;
1567 combined_data
= data
;
1568 sig_symbol
= Fcar (data
);
1573 combined_data
= Fcons (sig
, data
);
1577 if (wants_debugger (Vstack_trace_on_error
, conditions
))
1580 internal_with_output_to_temp_buffer ("*Backtrace*",
1581 (Lisp_Object (*) (Lisp_Object
)) Fbacktrace
,
1584 internal_with_output_to_temp_buffer ("*Backtrace*",
1589 && (EQ (sig_symbol
, Qquit
)
1591 : wants_debugger (Vdebug_on_error
, conditions
))
1592 && ! skip_debugger (conditions
, combined_data
)
1593 && when_entered_debugger
< num_nonmacro_input_events
)
1595 specbind (Qdebug_on_error
, Qnil
);
1597 = call_debugger (Fcons (Qerror
,
1598 Fcons (combined_data
, Qnil
)));
1599 debugger_called
= 1;
1601 /* If there is no handler, return saying whether we ran the debugger. */
1602 if (EQ (handlers
, Qerror
))
1604 if (debugger_called
)
1605 return unbind_to (count
, Qlambda
);
1609 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1611 Lisp_Object handler
, condit
;
1614 if (!CONSP (handler
))
1616 condit
= Fcar (handler
);
1617 /* Handle a single condition name in handler HANDLER. */
1618 if (SYMBOLP (condit
))
1620 tem
= Fmemq (Fcar (handler
), conditions
);
1624 /* Handle a list of condition names in handler HANDLER. */
1625 else if (CONSP (condit
))
1627 while (CONSP (condit
))
1629 tem
= Fmemq (Fcar (condit
), conditions
);
1632 condit
= XCDR (condit
);
1639 /* dump an error message; called like printf */
1643 error (m
, a1
, a2
, a3
)
1663 int used
= doprnt (buffer
, size
, m
, m
+ mlen
, 3, args
);
1668 buffer
= (char *) xrealloc (buffer
, size
);
1671 buffer
= (char *) xmalloc (size
);
1676 string
= build_string (buffer
);
1680 Fsignal (Qerror
, Fcons (string
, Qnil
));
1684 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 1, 0,
1685 "T if FUNCTION makes provisions for interactive calling.\n\
1686 This means it contains a description for how to read arguments to give it.\n\
1687 The value is nil for an invalid function or a symbol with no function\n\
1690 Interactively callable functions include strings and vectors (treated\n\
1691 as keyboard macros), lambda-expressions that contain a top-level call\n\
1692 to `interactive', autoload definitions made by `autoload' with non-nil\n\
1693 fourth argument, and some of the built-in functions of Lisp.\n\
1695 Also, a symbol satisfies `commandp' if its function definition does so.")
1697 Lisp_Object function
;
1699 register Lisp_Object fun
;
1700 register Lisp_Object funcar
;
1704 fun
= indirect_function (fun
);
1705 if (EQ (fun
, Qunbound
))
1708 /* Emacs primitives are interactive if their DEFUN specifies an
1709 interactive spec. */
1712 if (XSUBR (fun
)->prompt
)
1718 /* Bytecode objects are interactive if they are long enough to
1719 have an element whose index is COMPILED_INTERACTIVE, which is
1720 where the interactive spec is stored. */
1721 else if (COMPILEDP (fun
))
1722 return ((XVECTOR (fun
)->size
& PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
1725 /* Strings and vectors are keyboard macros. */
1726 if (STRINGP (fun
) || VECTORP (fun
))
1729 /* Lists may represent commands. */
1732 funcar
= Fcar (fun
);
1733 if (!SYMBOLP (funcar
))
1734 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1735 if (EQ (funcar
, Qlambda
))
1736 return Fassq (Qinteractive
, Fcdr (Fcdr (fun
)));
1737 if (EQ (funcar
, Qmocklisp
))
1738 return Qt
; /* All mocklisp functions can be called interactively */
1739 if (EQ (funcar
, Qautoload
))
1740 return Fcar (Fcdr (Fcdr (Fcdr (fun
))));
1746 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1747 "Define FUNCTION to autoload from FILE.\n\
1748 FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\
1749 Third arg DOCSTRING is documentation for the function.\n\
1750 Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\
1751 Fifth arg TYPE indicates the type of the object:\n\
1752 nil or omitted says FUNCTION is a function,\n\
1753 `keymap' says FUNCTION is really a keymap, and\n\
1754 `macro' or t says FUNCTION is really a macro.\n\
1755 Third through fifth args give info about the real definition.\n\
1756 They default to nil.\n\
1757 If FUNCTION is already defined other than as an autoload,\n\
1758 this does nothing and returns nil.")
1759 (function
, file
, docstring
, interactive
, type
)
1760 Lisp_Object function
, file
, docstring
, interactive
, type
;
1763 Lisp_Object args
[4];
1766 CHECK_SYMBOL (function
, 0);
1767 CHECK_STRING (file
, 1);
1769 /* If function is defined and not as an autoload, don't override */
1770 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
1771 && !(CONSP (XSYMBOL (function
)->function
)
1772 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
1775 if (NILP (Vpurify_flag
))
1776 /* Only add entries after dumping, because the ones before are
1777 not useful and else we get loads of them from the loaddefs.el. */
1778 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
1782 args
[1] = docstring
;
1783 args
[2] = interactive
;
1786 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
1787 #else /* NO_ARG_ARRAY */
1788 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
1789 #endif /* not NO_ARG_ARRAY */
1793 un_autoload (oldqueue
)
1794 Lisp_Object oldqueue
;
1796 register Lisp_Object queue
, first
, second
;
1798 /* Queue to unwind is current value of Vautoload_queue.
1799 oldqueue is the shadowed value to leave in Vautoload_queue. */
1800 queue
= Vautoload_queue
;
1801 Vautoload_queue
= oldqueue
;
1802 while (CONSP (queue
))
1804 first
= Fcar (queue
);
1805 second
= Fcdr (first
);
1806 first
= Fcar (first
);
1807 if (EQ (second
, Qnil
))
1810 Ffset (first
, second
);
1811 queue
= Fcdr (queue
);
1816 /* Load an autoloaded function.
1817 FUNNAME is the symbol which is the function's name.
1818 FUNDEF is the autoload definition (a list). */
1821 do_autoload (fundef
, funname
)
1822 Lisp_Object fundef
, funname
;
1824 int count
= specpdl_ptr
- specpdl
;
1825 Lisp_Object fun
, queue
, first
, second
;
1826 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1829 CHECK_SYMBOL (funname
, 0);
1830 GCPRO3 (fun
, funname
, fundef
);
1832 /* Preserve the match data. */
1833 record_unwind_protect (Fset_match_data
, Fmatch_data (Qnil
, Qnil
));
1835 /* Value saved here is to be restored into Vautoload_queue. */
1836 record_unwind_protect (un_autoload
, Vautoload_queue
);
1837 Vautoload_queue
= Qt
;
1838 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
, Qt
);
1840 /* Save the old autoloads, in case we ever do an unload. */
1841 queue
= Vautoload_queue
;
1842 while (CONSP (queue
))
1844 first
= Fcar (queue
);
1845 second
= Fcdr (first
);
1846 first
= Fcar (first
);
1848 /* Note: This test is subtle. The cdr of an autoload-queue entry
1849 may be an atom if the autoload entry was generated by a defalias
1852 Fput (first
, Qautoload
, (Fcdr (second
)));
1854 queue
= Fcdr (queue
);
1857 /* Once loading finishes, don't undo it. */
1858 Vautoload_queue
= Qt
;
1859 unbind_to (count
, Qnil
);
1861 fun
= Findirect_function (fun
);
1863 if (!NILP (Fequal (fun
, fundef
)))
1864 error ("Autoloading failed to define function %s",
1865 XSYMBOL (funname
)->name
->data
);
1870 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
1871 "Evaluate FORM and return its value.")
1875 Lisp_Object fun
, val
, original_fun
, original_args
;
1877 struct backtrace backtrace
;
1878 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1880 if (handling_signal
)
1885 if (EQ (Vmocklisp_arguments
, Qt
))
1886 return Fsymbol_value (form
);
1887 val
= Fsymbol_value (form
);
1889 XSETFASTINT (val
, 0);
1890 else if (EQ (val
, Qt
))
1891 XSETFASTINT (val
, 1);
1898 if (consing_since_gc
> gc_cons_threshold
)
1901 Fgarbage_collect ();
1905 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1907 if (max_lisp_eval_depth
< 100)
1908 max_lisp_eval_depth
= 100;
1909 if (lisp_eval_depth
> max_lisp_eval_depth
)
1910 error ("Lisp nesting exceeds max-lisp-eval-depth");
1913 original_fun
= Fcar (form
);
1914 original_args
= Fcdr (form
);
1916 backtrace
.next
= backtrace_list
;
1917 backtrace_list
= &backtrace
;
1918 backtrace
.function
= &original_fun
; /* This also protects them from gc */
1919 backtrace
.args
= &original_args
;
1920 backtrace
.nargs
= UNEVALLED
;
1921 backtrace
.evalargs
= 1;
1922 backtrace
.debug_on_exit
= 0;
1924 if (debug_on_next_call
)
1925 do_debug_on_call (Qt
);
1927 /* At this point, only original_fun and original_args
1928 have values that will be used below */
1930 fun
= Findirect_function (original_fun
);
1934 Lisp_Object numargs
;
1935 Lisp_Object argvals
[8];
1936 Lisp_Object args_left
;
1937 register int i
, maxargs
;
1939 args_left
= original_args
;
1940 numargs
= Flength (args_left
);
1942 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
1943 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
1944 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1946 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1948 backtrace
.evalargs
= 0;
1949 val
= (*XSUBR (fun
)->function
) (args_left
);
1953 if (XSUBR (fun
)->max_args
== MANY
)
1955 /* Pass a vector of evaluated arguments */
1957 register int argnum
= 0;
1959 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1961 GCPRO3 (args_left
, fun
, fun
);
1965 while (!NILP (args_left
))
1967 vals
[argnum
++] = Feval (Fcar (args_left
));
1968 args_left
= Fcdr (args_left
);
1969 gcpro3
.nvars
= argnum
;
1972 backtrace
.args
= vals
;
1973 backtrace
.nargs
= XINT (numargs
);
1975 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
1980 GCPRO3 (args_left
, fun
, fun
);
1981 gcpro3
.var
= argvals
;
1984 maxargs
= XSUBR (fun
)->max_args
;
1985 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
1987 argvals
[i
] = Feval (Fcar (args_left
));
1993 backtrace
.args
= argvals
;
1994 backtrace
.nargs
= XINT (numargs
);
1999 val
= (*XSUBR (fun
)->function
) ();
2002 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
2005 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
2008 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2012 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
2013 argvals
[2], argvals
[3]);
2016 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2017 argvals
[3], argvals
[4]);
2020 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2021 argvals
[3], argvals
[4], argvals
[5]);
2024 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2025 argvals
[3], argvals
[4], argvals
[5],
2030 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2031 argvals
[3], argvals
[4], argvals
[5],
2032 argvals
[6], argvals
[7]);
2036 /* Someone has created a subr that takes more arguments than
2037 is supported by this code. We need to either rewrite the
2038 subr to use a different argument protocol, or add more
2039 cases to this switch. */
2043 if (COMPILEDP (fun
))
2044 val
= apply_lambda (fun
, original_args
, 1);
2048 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2049 funcar
= Fcar (fun
);
2050 if (!SYMBOLP (funcar
))
2051 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2052 if (EQ (funcar
, Qautoload
))
2054 do_autoload (fun
, original_fun
);
2057 if (EQ (funcar
, Qmacro
))
2058 val
= Feval (apply1 (Fcdr (fun
), original_args
));
2059 else if (EQ (funcar
, Qlambda
))
2060 val
= apply_lambda (fun
, original_args
, 1);
2061 else if (EQ (funcar
, Qmocklisp
))
2062 val
= ml_apply (fun
, original_args
);
2064 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2067 if (!EQ (Vmocklisp_arguments
, Qt
))
2070 XSETFASTINT (val
, 0);
2071 else if (EQ (val
, Qt
))
2072 XSETFASTINT (val
, 1);
2075 if (backtrace
.debug_on_exit
)
2076 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2077 backtrace_list
= backtrace
.next
;
2081 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
2082 "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
2083 Then return the value FUNCTION returns.\n\
2084 Thus, (apply '+ 1 2 '(3 4)) returns 10.")
2089 register int i
, numargs
;
2090 register Lisp_Object spread_arg
;
2091 register Lisp_Object
*funcall_args
;
2093 struct gcpro gcpro1
;
2097 spread_arg
= args
[nargs
- 1];
2098 CHECK_LIST (spread_arg
, nargs
);
2100 numargs
= XINT (Flength (spread_arg
));
2103 return Ffuncall (nargs
- 1, args
);
2104 else if (numargs
== 1)
2106 args
[nargs
- 1] = XCAR (spread_arg
);
2107 return Ffuncall (nargs
, args
);
2110 numargs
+= nargs
- 2;
2112 fun
= indirect_function (fun
);
2113 if (EQ (fun
, Qunbound
))
2115 /* Let funcall get the error */
2122 if (numargs
< XSUBR (fun
)->min_args
2123 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2124 goto funcall
; /* Let funcall get the error */
2125 else if (XSUBR (fun
)->max_args
> numargs
)
2127 /* Avoid making funcall cons up a yet another new vector of arguments
2128 by explicitly supplying nil's for optional values */
2129 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
2130 * sizeof (Lisp_Object
));
2131 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2132 funcall_args
[++i
] = Qnil
;
2133 GCPRO1 (*funcall_args
);
2134 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2138 /* We add 1 to numargs because funcall_args includes the
2139 function itself as well as its arguments. */
2142 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
2143 * sizeof (Lisp_Object
));
2144 GCPRO1 (*funcall_args
);
2145 gcpro1
.nvars
= 1 + numargs
;
2148 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
2149 /* Spread the last arg we got. Its first element goes in
2150 the slot that it used to occupy, hence this value of I. */
2152 while (!NILP (spread_arg
))
2154 funcall_args
[i
++] = XCAR (spread_arg
);
2155 spread_arg
= XCDR (spread_arg
);
2158 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
2161 /* Run hook variables in various ways. */
2163 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
2165 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 0, MANY
, 0,
2166 "Run each hook in HOOKS. Major mode functions use this.\n\
2167 Each argument should be a symbol, a hook variable.\n\
2168 These symbols are processed in the order specified.\n\
2169 If a hook symbol has a non-nil value, that value may be a function\n\
2170 or a list of functions to be called to run the hook.\n\
2171 If the value is a function, it is called with no arguments.\n\
2172 If it is a list, the elements are called, in order, with no arguments.\n\
2174 To make a hook variable buffer-local, use `make-local-hook',\n\
2175 not `make-local-variable'.")
2180 Lisp_Object hook
[1];
2183 for (i
= 0; i
< nargs
; i
++)
2186 run_hook_with_args (1, hook
, to_completion
);
2192 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2193 Srun_hook_with_args
, 1, MANY
, 0,
2194 "Run HOOK with the specified arguments ARGS.\n\
2195 HOOK should be a symbol, a hook variable. If HOOK has a non-nil\n\
2196 value, that value may be a function or a list of functions to be\n\
2197 called to run the hook. If the value is a function, it is called with\n\
2198 the given arguments and its return value is returned. If it is a list\n\
2199 of functions, those functions are called, in order,\n\
2200 with the given arguments ARGS.\n\
2201 It is best not to depend on the value return by `run-hook-with-args',\n\
2202 as that may change.\n\
2204 To make a hook variable buffer-local, use `make-local-hook',\n\
2205 not `make-local-variable'.")
2210 return run_hook_with_args (nargs
, args
, to_completion
);
2213 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2214 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2215 "Run HOOK with the specified arguments ARGS.\n\
2216 HOOK should be a symbol, a hook variable. Its value should\n\
2217 be a list of functions. We call those functions, one by one,\n\
2218 passing arguments ARGS to each of them, until one of them\n\
2219 returns a non-nil value. Then we return that value.\n\
2220 If all the functions return nil, we return nil.\n\
2222 To make a hook variable buffer-local, use `make-local-hook',\n\
2223 not `make-local-variable'.")
2228 return run_hook_with_args (nargs
, args
, until_success
);
2231 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2232 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2233 "Run HOOK with the specified arguments ARGS.\n\
2234 HOOK should be a symbol, a hook variable. Its value should\n\
2235 be a list of functions. We call those functions, one by one,\n\
2236 passing arguments ARGS to each of them, until one of them\n\
2237 returns nil. Then we return nil.\n\
2238 If all the functions return non-nil, we return non-nil.\n\
2240 To make a hook variable buffer-local, use `make-local-hook',\n\
2241 not `make-local-variable'.")
2246 return run_hook_with_args (nargs
, args
, until_failure
);
2249 /* ARGS[0] should be a hook symbol.
2250 Call each of the functions in the hook value, passing each of them
2251 as arguments all the rest of ARGS (all NARGS - 1 elements).
2252 COND specifies a condition to test after each call
2253 to decide whether to stop.
2254 The caller (or its caller, etc) must gcpro all of ARGS,
2255 except that it isn't necessary to gcpro ARGS[0]. */
2258 run_hook_with_args (nargs
, args
, cond
)
2261 enum run_hooks_condition cond
;
2263 Lisp_Object sym
, val
, ret
;
2264 Lisp_Object globals
;
2265 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2267 /* If we are dying or still initializing,
2268 don't do anything--it would probably crash if we tried. */
2269 if (NILP (Vrun_hooks
))
2273 val
= find_symbol_value (sym
);
2274 ret
= (cond
== until_failure
? Qt
: Qnil
);
2276 if (EQ (val
, Qunbound
) || NILP (val
))
2278 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2281 return Ffuncall (nargs
, args
);
2286 GCPRO3 (sym
, val
, globals
);
2289 CONSP (val
) && ((cond
== to_completion
)
2290 || (cond
== until_success
? NILP (ret
)
2294 if (EQ (XCAR (val
), Qt
))
2296 /* t indicates this hook has a local binding;
2297 it means to run the global binding too. */
2299 for (globals
= Fdefault_value (sym
);
2300 CONSP (globals
) && ((cond
== to_completion
)
2301 || (cond
== until_success
? NILP (ret
)
2303 globals
= XCDR (globals
))
2305 args
[0] = XCAR (globals
);
2306 /* In a global value, t should not occur. If it does, we
2307 must ignore it to avoid an endless loop. */
2308 if (!EQ (args
[0], Qt
))
2309 ret
= Ffuncall (nargs
, args
);
2314 args
[0] = XCAR (val
);
2315 ret
= Ffuncall (nargs
, args
);
2324 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2325 present value of that symbol.
2326 Call each element of FUNLIST,
2327 passing each of them the rest of ARGS.
2328 The caller (or its caller, etc) must gcpro all of ARGS,
2329 except that it isn't necessary to gcpro ARGS[0]. */
2332 run_hook_list_with_args (funlist
, nargs
, args
)
2333 Lisp_Object funlist
;
2339 Lisp_Object globals
;
2340 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2344 GCPRO3 (sym
, val
, globals
);
2346 for (val
= funlist
; CONSP (val
); val
= XCDR (val
))
2348 if (EQ (XCAR (val
), Qt
))
2350 /* t indicates this hook has a local binding;
2351 it means to run the global binding too. */
2353 for (globals
= Fdefault_value (sym
);
2355 globals
= XCDR (globals
))
2357 args
[0] = XCAR (globals
);
2358 /* In a global value, t should not occur. If it does, we
2359 must ignore it to avoid an endless loop. */
2360 if (!EQ (args
[0], Qt
))
2361 Ffuncall (nargs
, args
);
2366 args
[0] = XCAR (val
);
2367 Ffuncall (nargs
, args
);
2374 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2377 run_hook_with_args_2 (hook
, arg1
, arg2
)
2378 Lisp_Object hook
, arg1
, arg2
;
2380 Lisp_Object temp
[3];
2385 Frun_hook_with_args (3, temp
);
2388 /* Apply fn to arg */
2391 Lisp_Object fn
, arg
;
2393 struct gcpro gcpro1
;
2397 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2401 Lisp_Object args
[2];
2405 RETURN_UNGCPRO (Fapply (2, args
));
2407 #else /* not NO_ARG_ARRAY */
2408 RETURN_UNGCPRO (Fapply (2, &fn
));
2409 #endif /* not NO_ARG_ARRAY */
2412 /* Call function fn on no arguments */
2417 struct gcpro gcpro1
;
2420 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2423 /* Call function fn with 1 argument arg1 */
2427 Lisp_Object fn
, arg1
;
2429 struct gcpro gcpro1
;
2431 Lisp_Object args
[2];
2437 RETURN_UNGCPRO (Ffuncall (2, args
));
2438 #else /* not NO_ARG_ARRAY */
2441 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2442 #endif /* not NO_ARG_ARRAY */
2445 /* Call function fn with 2 arguments arg1, arg2 */
2448 call2 (fn
, arg1
, arg2
)
2449 Lisp_Object fn
, arg1
, arg2
;
2451 struct gcpro gcpro1
;
2453 Lisp_Object args
[3];
2459 RETURN_UNGCPRO (Ffuncall (3, args
));
2460 #else /* not NO_ARG_ARRAY */
2463 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2464 #endif /* not NO_ARG_ARRAY */
2467 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2470 call3 (fn
, arg1
, arg2
, arg3
)
2471 Lisp_Object fn
, arg1
, arg2
, arg3
;
2473 struct gcpro gcpro1
;
2475 Lisp_Object args
[4];
2482 RETURN_UNGCPRO (Ffuncall (4, args
));
2483 #else /* not NO_ARG_ARRAY */
2486 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2487 #endif /* not NO_ARG_ARRAY */
2490 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2493 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2494 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2496 struct gcpro gcpro1
;
2498 Lisp_Object args
[5];
2506 RETURN_UNGCPRO (Ffuncall (5, args
));
2507 #else /* not NO_ARG_ARRAY */
2510 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2511 #endif /* not NO_ARG_ARRAY */
2514 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2517 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2518 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2520 struct gcpro gcpro1
;
2522 Lisp_Object args
[6];
2531 RETURN_UNGCPRO (Ffuncall (6, args
));
2532 #else /* not NO_ARG_ARRAY */
2535 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2536 #endif /* not NO_ARG_ARRAY */
2539 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2542 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2543 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2545 struct gcpro gcpro1
;
2547 Lisp_Object args
[7];
2557 RETURN_UNGCPRO (Ffuncall (7, args
));
2558 #else /* not NO_ARG_ARRAY */
2561 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2562 #endif /* not NO_ARG_ARRAY */
2565 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2566 "Call first argument as a function, passing remaining arguments to it.\n\
2567 Return the value that function returns.\n\
2568 Thus, (funcall 'cons 'x 'y) returns (x . y).")
2575 int numargs
= nargs
- 1;
2576 Lisp_Object lisp_numargs
;
2578 struct backtrace backtrace
;
2579 register Lisp_Object
*internal_args
;
2583 if (consing_since_gc
> gc_cons_threshold
)
2584 Fgarbage_collect ();
2586 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2588 if (max_lisp_eval_depth
< 100)
2589 max_lisp_eval_depth
= 100;
2590 if (lisp_eval_depth
> max_lisp_eval_depth
)
2591 error ("Lisp nesting exceeds max-lisp-eval-depth");
2594 backtrace
.next
= backtrace_list
;
2595 backtrace_list
= &backtrace
;
2596 backtrace
.function
= &args
[0];
2597 backtrace
.args
= &args
[1];
2598 backtrace
.nargs
= nargs
- 1;
2599 backtrace
.evalargs
= 0;
2600 backtrace
.debug_on_exit
= 0;
2602 if (debug_on_next_call
)
2603 do_debug_on_call (Qlambda
);
2609 fun
= Findirect_function (fun
);
2613 if (numargs
< XSUBR (fun
)->min_args
2614 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2616 XSETFASTINT (lisp_numargs
, numargs
);
2617 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (lisp_numargs
, Qnil
)));
2620 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2621 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2623 if (XSUBR (fun
)->max_args
== MANY
)
2625 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
2629 if (XSUBR (fun
)->max_args
> numargs
)
2631 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2632 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
2633 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2634 internal_args
[i
] = Qnil
;
2637 internal_args
= args
+ 1;
2638 switch (XSUBR (fun
)->max_args
)
2641 val
= (*XSUBR (fun
)->function
) ();
2644 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
2647 val
= (*XSUBR (fun
)->function
) (internal_args
[0],
2651 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2655 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2660 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2661 internal_args
[2], internal_args
[3],
2665 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2666 internal_args
[2], internal_args
[3],
2667 internal_args
[4], internal_args
[5]);
2670 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2671 internal_args
[2], internal_args
[3],
2672 internal_args
[4], internal_args
[5],
2677 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2678 internal_args
[2], internal_args
[3],
2679 internal_args
[4], internal_args
[5],
2680 internal_args
[6], internal_args
[7]);
2685 /* If a subr takes more than 8 arguments without using MANY
2686 or UNEVALLED, we need to extend this function to support it.
2687 Until this is done, there is no way to call the function. */
2691 if (COMPILEDP (fun
))
2692 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2696 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2697 funcar
= Fcar (fun
);
2698 if (!SYMBOLP (funcar
))
2699 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2700 if (EQ (funcar
, Qlambda
))
2701 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2702 else if (EQ (funcar
, Qmocklisp
))
2703 val
= ml_apply (fun
, Flist (numargs
, args
+ 1));
2704 else if (EQ (funcar
, Qautoload
))
2706 do_autoload (fun
, args
[0]);
2710 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2714 if (backtrace
.debug_on_exit
)
2715 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2716 backtrace_list
= backtrace
.next
;
2721 apply_lambda (fun
, args
, eval_flag
)
2722 Lisp_Object fun
, args
;
2725 Lisp_Object args_left
;
2726 Lisp_Object numargs
;
2727 register Lisp_Object
*arg_vector
;
2728 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2730 register Lisp_Object tem
;
2732 numargs
= Flength (args
);
2733 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2736 GCPRO3 (*arg_vector
, args_left
, fun
);
2739 for (i
= 0; i
< XINT (numargs
);)
2741 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2742 if (eval_flag
) tem
= Feval (tem
);
2743 arg_vector
[i
++] = tem
;
2751 backtrace_list
->args
= arg_vector
;
2752 backtrace_list
->nargs
= i
;
2754 backtrace_list
->evalargs
= 0;
2755 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
2757 /* Do the debug-on-exit now, while arg_vector still exists. */
2758 if (backtrace_list
->debug_on_exit
)
2759 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
2760 /* Don't do it again when we return to eval. */
2761 backtrace_list
->debug_on_exit
= 0;
2765 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2766 and return the result of evaluation.
2767 FUN must be either a lambda-expression or a compiled-code object. */
2770 funcall_lambda (fun
, nargs
, arg_vector
)
2773 register Lisp_Object
*arg_vector
;
2775 Lisp_Object val
, syms_left
, next
;
2776 int count
= specpdl_ptr
- specpdl
;
2777 int i
, optional
, rest
;
2779 if (NILP (Vmocklisp_arguments
))
2780 specbind (Qmocklisp_arguments
, Qt
); /* t means NOT mocklisp! */
2784 syms_left
= XCDR (fun
);
2785 if (CONSP (syms_left
))
2786 syms_left
= XCAR (syms_left
);
2788 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2790 else if (COMPILEDP (fun
))
2791 syms_left
= XVECTOR (fun
)->contents
[COMPILED_ARGLIST
];
2795 i
= optional
= rest
= 0;
2796 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
2800 next
= XCAR (syms_left
);
2801 while (!SYMBOLP (next
))
2802 next
= Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2804 if (EQ (next
, Qand_rest
))
2806 else if (EQ (next
, Qand_optional
))
2810 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
2814 specbind (next
, arg_vector
[i
++]);
2816 return Fsignal (Qwrong_number_of_arguments
,
2817 Fcons (fun
, Fcons (make_number (nargs
), Qnil
)));
2819 specbind (next
, Qnil
);
2822 if (!NILP (syms_left
))
2823 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2825 return Fsignal (Qwrong_number_of_arguments
,
2826 Fcons (fun
, Fcons (make_number (nargs
), Qnil
)));
2829 val
= Fprogn (XCDR (XCDR (fun
)));
2832 /* If we have not actually read the bytecode string
2833 and constants vector yet, fetch them from the file. */
2834 if (CONSP (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
]))
2835 Ffetch_bytecode (fun
);
2836 val
= Fbyte_code (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
],
2837 XVECTOR (fun
)->contents
[COMPILED_CONSTANTS
],
2838 XVECTOR (fun
)->contents
[COMPILED_STACK_DEPTH
]);
2841 return unbind_to (count
, val
);
2844 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
2846 "If byte-compiled OBJECT is lazy-loaded, fetch it now.")
2852 if (COMPILEDP (object
)
2853 && CONSP (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]))
2855 tem
= read_doc_string (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]);
2857 error ("invalid byte code");
2858 XVECTOR (object
)->contents
[COMPILED_BYTECODE
] = XCAR (tem
);
2859 XVECTOR (object
)->contents
[COMPILED_CONSTANTS
] = XCDR (tem
);
2867 register int count
= specpdl_ptr
- specpdl
;
2868 if (specpdl_size
>= max_specpdl_size
)
2870 if (max_specpdl_size
< 400)
2871 max_specpdl_size
= 400;
2872 if (specpdl_size
>= max_specpdl_size
)
2874 if (!NILP (Vdebug_on_error
))
2875 /* Leave room for some specpdl in the debugger. */
2876 max_specpdl_size
= specpdl_size
+ 100;
2878 Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil
));
2882 if (specpdl_size
> max_specpdl_size
)
2883 specpdl_size
= max_specpdl_size
;
2884 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
2885 specpdl_ptr
= specpdl
+ count
;
2889 specbind (symbol
, value
)
2890 Lisp_Object symbol
, value
;
2894 CHECK_SYMBOL (symbol
, 0);
2895 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2898 /* The most common case is that a non-constant symbol with a trivial
2899 value. Make that as fast as we can. */
2900 if (!MISCP (XSYMBOL (symbol
)->value
)
2901 && !EQ (symbol
, Qnil
)
2903 && !(XSYMBOL (symbol
)->name
->data
[0] == ':'
2904 && EQ (XSYMBOL (symbol
)->obarray
, initial_obarray
)
2905 && !EQ (value
, symbol
)))
2907 specpdl_ptr
->symbol
= symbol
;
2908 specpdl_ptr
->old_value
= XSYMBOL (symbol
)->value
;
2909 specpdl_ptr
->func
= NULL
;
2911 XSYMBOL (symbol
)->value
= value
;
2915 ovalue
= find_symbol_value (symbol
);
2916 specpdl_ptr
->func
= 0;
2917 specpdl_ptr
->old_value
= ovalue
;
2919 if (BUFFER_LOCAL_VALUEP (XSYMBOL (symbol
)->value
)
2920 || SOME_BUFFER_LOCAL_VALUEP (XSYMBOL (symbol
)->value
)
2921 || BUFFER_OBJFWDP (XSYMBOL (symbol
)->value
))
2923 Lisp_Object current_buffer
, binding_buffer
;
2925 /* For a local variable, record both the symbol and which
2926 buffer's value we are saving. */
2927 current_buffer
= Fcurrent_buffer ();
2928 binding_buffer
= current_buffer
;
2930 /* If the variable is not local in this buffer,
2931 we are saving the global value, so restore that. */
2932 if (NILP (Flocal_variable_p (symbol
, binding_buffer
)))
2933 binding_buffer
= Qnil
;
2935 = Fcons (symbol
, Fcons (binding_buffer
, current_buffer
));
2937 /* If SYMBOL is a per-buffer variable which doesn't have a
2938 buffer-local value here, make the `let' change the global
2939 value by changing the value of SYMBOL in all buffers not
2940 having their own value. This is consistent with what
2941 happens with other buffer-local variables. */
2942 if (NILP (binding_buffer
)
2943 && BUFFER_OBJFWDP (XSYMBOL (symbol
)->value
))
2946 Fset_default (symbol
, value
);
2951 specpdl_ptr
->symbol
= symbol
;
2954 if (BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
))
2955 store_symval_forwarding (symbol
, ovalue
, value
, NULL
);
2957 set_internal (symbol
, value
, 0, 1);
2962 record_unwind_protect (function
, arg
)
2963 Lisp_Object (*function
) P_ ((Lisp_Object
));
2966 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2968 specpdl_ptr
->func
= function
;
2969 specpdl_ptr
->symbol
= Qnil
;
2970 specpdl_ptr
->old_value
= arg
;
2975 unbind_to (count
, value
)
2979 int quitf
= !NILP (Vquit_flag
);
2980 struct gcpro gcpro1
;
2985 while (specpdl_ptr
!= specpdl
+ count
)
2989 if (specpdl_ptr
->func
!= 0)
2990 (*specpdl_ptr
->func
) (specpdl_ptr
->old_value
);
2991 /* Note that a "binding" of nil is really an unwind protect,
2992 so in that case the "old value" is a list of forms to evaluate. */
2993 else if (NILP (specpdl_ptr
->symbol
))
2994 Fprogn (specpdl_ptr
->old_value
);
2995 /* If the symbol is a list, it is really (SYMBOL BINDING_BUFFER
2996 . CURRENT_BUFFER) and it indicates we bound a variable that
2997 has buffer-local bindings. BINDING_BUFFER nil means that the
2998 variable had the default value when it was bound. */
2999 else if (CONSP (specpdl_ptr
->symbol
))
3001 Lisp_Object symbol
, buffer
;
3003 symbol
= XCAR (specpdl_ptr
->symbol
);
3004 buffer
= XCAR (XCDR (specpdl_ptr
->symbol
));
3006 /* Handle restoring a default value. */
3008 Fset_default (symbol
, specpdl_ptr
->old_value
);
3009 /* Handle restoring a value saved from a live buffer. */
3011 set_internal (symbol
, specpdl_ptr
->old_value
, XBUFFER (buffer
), 1);
3015 /* If variable has a trivial value (no forwarding), we can
3016 just set it. No need to check for constant symbols here,
3017 since that was already done by specbind. */
3018 if (!MISCP (XSYMBOL (specpdl_ptr
->symbol
)->value
))
3019 XSYMBOL (specpdl_ptr
->symbol
)->value
= specpdl_ptr
->old_value
;
3021 set_internal (specpdl_ptr
->symbol
, specpdl_ptr
->old_value
, 0, 1);
3025 if (NILP (Vquit_flag
) && quitf
)
3034 /* Get the value of symbol's global binding, even if that binding
3035 is not now dynamically visible. */
3038 top_level_value (symbol
)
3041 register struct specbinding
*ptr
= specpdl
;
3043 CHECK_SYMBOL (symbol
, 0);
3044 for (; ptr
!= specpdl_ptr
; ptr
++)
3046 if (EQ (ptr
->symbol
, symbol
))
3047 return ptr
->old_value
;
3049 return Fsymbol_value (symbol
);
3053 top_level_set (symbol
, newval
)
3054 Lisp_Object symbol
, newval
;
3056 register struct specbinding
*ptr
= specpdl
;
3058 CHECK_SYMBOL (symbol
, 0);
3059 for (; ptr
!= specpdl_ptr
; ptr
++)
3061 if (EQ (ptr
->symbol
, symbol
))
3063 ptr
->old_value
= newval
;
3067 return Fset (symbol
, newval
);
3072 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3073 "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\
3074 The debugger is entered when that frame exits, if the flag is non-nil.")
3076 Lisp_Object level
, flag
;
3078 register struct backtrace
*backlist
= backtrace_list
;
3081 CHECK_NUMBER (level
, 0);
3083 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
3085 backlist
= backlist
->next
;
3089 backlist
->debug_on_exit
= !NILP (flag
);
3094 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3095 "Print a trace of Lisp function calls currently active.\n\
3096 Output stream used is value of `standard-output'.")
3099 register struct backtrace
*backlist
= backtrace_list
;
3103 extern Lisp_Object Vprint_level
;
3104 struct gcpro gcpro1
;
3106 XSETFASTINT (Vprint_level
, 3);
3113 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
3114 if (backlist
->nargs
== UNEVALLED
)
3116 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
3117 write_string ("\n", -1);
3121 tem
= *backlist
->function
;
3122 Fprin1 (tem
, Qnil
); /* This can QUIT */
3123 write_string ("(", -1);
3124 if (backlist
->nargs
== MANY
)
3126 for (tail
= *backlist
->args
, i
= 0;
3128 tail
= Fcdr (tail
), i
++)
3130 if (i
) write_string (" ", -1);
3131 Fprin1 (Fcar (tail
), Qnil
);
3136 for (i
= 0; i
< backlist
->nargs
; i
++)
3138 if (i
) write_string (" ", -1);
3139 Fprin1 (backlist
->args
[i
], Qnil
);
3142 write_string (")\n", -1);
3144 backlist
= backlist
->next
;
3147 Vprint_level
= Qnil
;
3152 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, NULL
,
3153 "Return the function and arguments NFRAMES up from current execution point.\n\
3154 If that frame has not evaluated the arguments yet (or is a special form),\n\
3155 the value is (nil FUNCTION ARG-FORMS...).\n\
3156 If that frame has evaluated its arguments and called its function already,\n\
3157 the value is (t FUNCTION ARG-VALUES...).\n\
3158 A &rest arg is represented as the tail of the list ARG-VALUES.\n\
3159 FUNCTION is whatever was supplied as car of evaluated list,\n\
3160 or a lambda expression for macro calls.\n\
3161 If NFRAMES is more than the number of frames, the value is nil.")
3163 Lisp_Object nframes
;
3165 register struct backtrace
*backlist
= backtrace_list
;
3169 CHECK_NATNUM (nframes
, 0);
3171 /* Find the frame requested. */
3172 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3173 backlist
= backlist
->next
;
3177 if (backlist
->nargs
== UNEVALLED
)
3178 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3181 if (backlist
->nargs
== MANY
)
3182 tem
= *backlist
->args
;
3184 tem
= Flist (backlist
->nargs
, backlist
->args
);
3186 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3194 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
3195 "*Limit on number of Lisp variable bindings & unwind-protects.\n\
3196 If Lisp code tries to make more than this many at once,\n\
3197 an error is signaled.");
3199 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
3200 "*Limit on depth in `eval', `apply' and `funcall' before error.\n\
3201 This limit is to catch infinite recursions for you before they cause\n\
3202 actual stack overflow in C, which would be fatal for Emacs.\n\
3203 You can safely make it considerably larger than its default value,\n\
3204 if that proves inconveniently small.");
3206 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
3207 "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
3208 Typing C-g sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
3211 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
3212 "Non-nil inhibits C-g quitting from happening immediately.\n\
3213 Note that `quit-flag' will still be set by typing C-g,\n\
3214 so a quit will be signaled as soon as `inhibit-quit' is nil.\n\
3215 To prevent this happening, set `quit-flag' to nil\n\
3216 before making `inhibit-quit' nil.");
3217 Vinhibit_quit
= Qnil
;
3219 Qinhibit_quit
= intern ("inhibit-quit");
3220 staticpro (&Qinhibit_quit
);
3222 Qautoload
= intern ("autoload");
3223 staticpro (&Qautoload
);
3225 Qdebug_on_error
= intern ("debug-on-error");
3226 staticpro (&Qdebug_on_error
);
3228 Qmacro
= intern ("macro");
3229 staticpro (&Qmacro
);
3231 /* Note that the process handling also uses Qexit, but we don't want
3232 to staticpro it twice, so we just do it here. */
3233 Qexit
= intern ("exit");
3236 Qinteractive
= intern ("interactive");
3237 staticpro (&Qinteractive
);
3239 Qcommandp
= intern ("commandp");
3240 staticpro (&Qcommandp
);
3242 Qdefun
= intern ("defun");
3243 staticpro (&Qdefun
);
3245 Qand_rest
= intern ("&rest");
3246 staticpro (&Qand_rest
);
3248 Qand_optional
= intern ("&optional");
3249 staticpro (&Qand_optional
);
3251 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
3252 "*Non-nil means automatically display a backtrace buffer\n\
3253 after any error that is handled by the editor command loop.\n\
3254 If the value is a list, an error only means to display a backtrace\n\
3255 if one of its condition symbols appears in the list.");
3256 Vstack_trace_on_error
= Qnil
;
3258 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
3259 "*Non-nil means enter debugger if an error is signaled.\n\
3260 Does not apply to errors handled by `condition-case' or those\n\
3261 matched by `debug-ignored-errors'.\n\
3262 If the value is a list, an error only means to enter the debugger\n\
3263 if one of its condition symbols appears in the list.\n\
3264 See also variable `debug-on-quit'.");
3265 Vdebug_on_error
= Qnil
;
3267 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
3268 "*List of errors for which the debugger should not be called.\n\
3269 Each element may be a condition-name or a regexp that matches error messages.\n\
3270 If any element applies to a given error, that error skips the debugger\n\
3271 and just returns to top level.\n\
3272 This overrides the variable `debug-on-error'.\n\
3273 It does not apply to errors handled by `condition-case'.");
3274 Vdebug_ignored_errors
= Qnil
;
3276 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
3277 "*Non-nil means enter debugger if quit is signaled (C-g, for example).\n\
3278 Does not apply if quit is handled by a `condition-case'.");
3281 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
3282 "Non-nil means enter debugger before next `eval', `apply' or `funcall'.");
3284 DEFVAR_BOOL ("debugger-may-continue", &debugger_may_continue
,
3285 "Non-nil means debugger may continue execution.\n\
3286 This is nil when the debugger is called under circumstances where it\n\
3287 might not be safe to continue.");
3288 debugger_may_continue
= 1;
3290 DEFVAR_LISP ("debugger", &Vdebugger
,
3291 "Function to call to invoke debugger.\n\
3292 If due to frame exit, args are `exit' and the value being returned;\n\
3293 this function's value will be returned instead of that.\n\
3294 If due to error, args are `error' and a list of the args to `signal'.\n\
3295 If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
3296 If due to `eval' entry, one arg, t.");
3299 DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function
,
3300 "If non-nil, this is a function for `signal' to call.\n\
3301 It receives the same arguments that `signal' was given.\n\
3302 The Edebug package uses this to regain control.");
3303 Vsignal_hook_function
= Qnil
;
3305 Qmocklisp_arguments
= intern ("mocklisp-arguments");
3306 staticpro (&Qmocklisp_arguments
);
3307 DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments
,
3308 "While in a mocklisp function, the list of its unevaluated args.");
3309 Vmocklisp_arguments
= Qt
;
3311 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal
,
3312 "*Non-nil means call the debugger regardless of condition handlers.\n\
3313 Note that `debug-on-error', `debug-on-quit' and friends\n\
3314 still determine whether to handle the particular condition.");
3315 Vdebug_on_signal
= Qnil
;
3317 Vrun_hooks
= intern ("run-hooks");
3318 staticpro (&Vrun_hooks
);
3320 staticpro (&Vautoload_queue
);
3321 Vautoload_queue
= Qnil
;
3322 staticpro (&Vsignaling_function
);
3323 Vsignaling_function
= Qnil
;
3334 defsubr (&Sfunction
);
3336 defsubr (&Sdefmacro
);
3338 defsubr (&Sdefconst
);
3339 defsubr (&Suser_variable_p
);
3343 defsubr (&Smacroexpand
);
3346 defsubr (&Sunwind_protect
);
3347 defsubr (&Scondition_case
);
3349 defsubr (&Sinteractive_p
);
3350 defsubr (&Scommandp
);
3351 defsubr (&Sautoload
);
3354 defsubr (&Sfuncall
);
3355 defsubr (&Srun_hooks
);
3356 defsubr (&Srun_hook_with_args
);
3357 defsubr (&Srun_hook_with_args_until_success
);
3358 defsubr (&Srun_hook_with_args_until_failure
);
3359 defsubr (&Sfetch_bytecode
);
3360 defsubr (&Sbacktrace_debug
);
3361 defsubr (&Sbacktrace
);
3362 defsubr (&Sbacktrace_frame
);