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
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_busy_cursor_p
)
245 cancel_busy_cursor ();
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
);
258 val
= apply1 (Vdebugger
, arg
);
260 /* Interrupting redisplay and resuming it later is not safe under
261 all circumstances. So, when the debugger returns, abort the
262 interupted redisplay by going back to the top-level. */
263 if (debug_while_redisplaying
)
266 return unbind_to (count
, val
);
270 do_debug_on_call (code
)
273 debug_on_next_call
= 0;
274 backtrace_list
->debug_on_exit
= 1;
275 call_debugger (Fcons (code
, Qnil
));
278 /* NOTE!!! Every function that can call EVAL must protect its args
279 and temporaries from garbage collection while it needs them.
280 The definition of `For' shows what you have to do. */
282 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
283 "Eval args until one of them yields non-nil, then return that value.\n\
284 The remaining args are not evalled at all.\n\
285 If all args return nil, return nil.")
289 register Lisp_Object val
;
290 Lisp_Object args_left
;
301 val
= Feval (Fcar (args_left
));
304 args_left
= Fcdr (args_left
);
306 while (!NILP(args_left
));
312 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
313 "Eval args until one of them yields nil, then return nil.\n\
314 The remaining args are not evalled at all.\n\
315 If no arg yields nil, return the last arg's value.")
319 register Lisp_Object val
;
320 Lisp_Object args_left
;
331 val
= Feval (Fcar (args_left
));
334 args_left
= Fcdr (args_left
);
336 while (!NILP(args_left
));
342 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
343 "If COND yields non-nil, do THEN, else do ELSE...\n\
344 Returns the value of THEN or the value of the last of the ELSE's.\n\
345 THEN must be one expression, but ELSE... can be zero or more expressions.\n\
346 If COND yields nil, and there are no ELSE's, the value is nil.")
350 register Lisp_Object cond
;
354 cond
= Feval (Fcar (args
));
358 return Feval (Fcar (Fcdr (args
)));
359 return Fprogn (Fcdr (Fcdr (args
)));
362 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
363 "Try each clause until one succeeds.\n\
364 Each clause looks like (CONDITION BODY...). CONDITION is evaluated\n\
365 and, if the value is non-nil, this clause succeeds:\n\
366 then the expressions in BODY are evaluated and the last one's\n\
367 value is the value of the cond-form.\n\
368 If no clause succeeds, cond returns nil.\n\
369 If a clause has one element, as in (CONDITION),\n\
370 CONDITION's value if non-nil is returned from the cond-form.")
374 register Lisp_Object clause
, val
;
381 clause
= Fcar (args
);
382 val
= Feval (Fcar (clause
));
385 if (!EQ (XCDR (clause
), Qnil
))
386 val
= Fprogn (XCDR (clause
));
396 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
397 "Eval BODY forms sequentially and return value of last one.")
401 register Lisp_Object val
, tem
;
402 Lisp_Object args_left
;
405 /* In Mocklisp code, symbols at the front of the progn arglist
406 are to be bound to zero. */
407 if (!EQ (Vmocklisp_arguments
, Qt
))
409 val
= make_number (0);
410 while (!NILP (args
) && (tem
= Fcar (args
), SYMBOLP (tem
)))
413 specbind (tem
, val
), args
= Fcdr (args
);
425 val
= Feval (Fcar (args_left
));
426 args_left
= Fcdr (args_left
);
428 while (!NILP(args_left
));
434 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
435 "Eval FIRST and BODY sequentially; value from FIRST.\n\
436 The value of FIRST is saved during the evaluation of the remaining args,\n\
437 whose values are discarded.")
442 register Lisp_Object args_left
;
443 struct gcpro gcpro1
, gcpro2
;
444 register int argnum
= 0;
456 val
= Feval (Fcar (args_left
));
458 Feval (Fcar (args_left
));
459 args_left
= Fcdr (args_left
);
461 while (!NILP(args_left
));
467 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
468 "Eval X, Y and BODY sequentially; value from Y.\n\
469 The value of Y is saved during the evaluation of the remaining args,\n\
470 whose values are discarded.")
475 register Lisp_Object args_left
;
476 struct gcpro gcpro1
, gcpro2
;
477 register int argnum
= -1;
491 val
= Feval (Fcar (args_left
));
493 Feval (Fcar (args_left
));
494 args_left
= Fcdr (args_left
);
496 while (!NILP (args_left
));
502 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
503 "Set each SYM to the value of its VAL.\n\
504 The symbols SYM are variables; they are literal (not evaluated).\n\
505 The values VAL are expressions; they are evaluated.\n\
506 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.\n\
507 The second VAL is not computed until after the first SYM is set, and so on;\n\
508 each VAL can use the new value of variables set earlier in the `setq'.\n\
509 The return value of the `setq' form is the value of the last VAL.")
513 register Lisp_Object args_left
;
514 register Lisp_Object val
, sym
;
525 val
= Feval (Fcar (Fcdr (args_left
)));
526 sym
= Fcar (args_left
);
528 args_left
= Fcdr (Fcdr (args_left
));
530 while (!NILP(args_left
));
536 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
537 "Return the argument, without evaluating it. `(quote x)' yields `x'.")
544 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
545 "Like `quote', but preferred for objects which are functions.\n\
546 In byte compilation, `function' causes its argument to be compiled.\n\
547 `quote' cannot do that.")
554 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
555 "Return t if function in which this appears was called interactively.\n\
556 This means that the function was called with call-interactively (which\n\
557 includes being called as the binding of a key)\n\
558 and input is currently coming from the keyboard (not in keyboard macro).")
561 register struct backtrace
*btp
;
562 register Lisp_Object fun
;
567 btp
= backtrace_list
;
569 /* If this isn't a byte-compiled function, there may be a frame at
570 the top for Finteractive_p itself. If so, skip it. */
571 fun
= Findirect_function (*btp
->function
);
572 if (SUBRP (fun
) && XSUBR (fun
) == &Sinteractive_p
)
575 /* If we're running an Emacs 18-style byte-compiled function, there
576 may be a frame for Fbytecode. Now, given the strictest
577 definition, this function isn't really being called
578 interactively, but because that's the way Emacs 18 always builds
579 byte-compiled functions, we'll accept it for now. */
580 if (EQ (*btp
->function
, Qbytecode
))
583 /* If this isn't a byte-compiled function, then we may now be
584 looking at several frames for special forms. Skip past them. */
586 btp
->nargs
== UNEVALLED
)
589 /* btp now points at the frame of the innermost function that isn't
590 a special form, ignoring frames for Finteractive_p and/or
591 Fbytecode at the top. If this frame is for a built-in function
592 (such as load or eval-region) return nil. */
593 fun
= Findirect_function (*btp
->function
);
596 /* btp points to the frame of a Lisp function that called interactive-p.
597 Return t if that function was called interactively. */
598 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
603 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
604 "Define NAME as a function.\n\
605 The definition is (lambda ARGLIST [DOCSTRING] BODY...).\n\
606 See also the function `interactive'.")
610 register Lisp_Object fn_name
;
611 register Lisp_Object defn
;
613 fn_name
= Fcar (args
);
614 defn
= Fcons (Qlambda
, Fcdr (args
));
615 if (!NILP (Vpurify_flag
))
616 defn
= Fpurecopy (defn
);
617 Ffset (fn_name
, defn
);
618 LOADHIST_ATTACH (fn_name
);
622 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
623 "Define NAME as a macro.\n\
624 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).\n\
625 When the macro is called, as in (NAME ARGS...),\n\
626 the function (lambda ARGLIST BODY...) is applied to\n\
627 the list ARGS... as it appears in the expression,\n\
628 and the result should be a form to be evaluated instead of the original.")
632 register Lisp_Object fn_name
;
633 register Lisp_Object defn
;
635 fn_name
= Fcar (args
);
636 defn
= Fcons (Qmacro
, 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 ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
645 "Define SYMBOL as a variable.\n\
646 You are not required to define a variable in order to use it,\n\
647 but the definition can supply documentation and an initial value\n\
648 in a way that tags can recognize.\n\n\
649 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.\n\
650 If SYMBOL is buffer-local, its default value is what is set;\n\
651 buffer-local values are not affected.\n\
652 INITVALUE and DOCSTRING are optional.\n\
653 If DOCSTRING starts with *, this variable is identified as a user option.\n\
654 This means that M-x set-variable recognizes it.\n\
655 See also `user-variable-p'.\n\
656 If INITVALUE is missing, SYMBOL's value is not set.")
660 register Lisp_Object sym
, tem
, tail
;
664 if (!NILP (Fcdr (Fcdr (tail
))))
665 error ("too many arguments");
669 tem
= Fdefault_boundp (sym
);
671 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
673 tail
= Fcdr (Fcdr (args
));
674 if (!NILP (Fcar (tail
)))
677 if (!NILP (Vpurify_flag
))
678 tem
= Fpurecopy (tem
);
679 Fput (sym
, Qvariable_documentation
, tem
);
681 LOADHIST_ATTACH (sym
);
685 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
686 "Define SYMBOL as a constant variable.\n\
687 The intent is that neither programs nor users should ever change this value.\n\
688 Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\
689 If SYMBOL is buffer-local, its default value is what is set;\n\
690 buffer-local values are not affected.\n\
691 DOCSTRING is optional.")
695 register Lisp_Object sym
, tem
;
698 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
699 error ("too many arguments");
701 tem
= Feval (Fcar (Fcdr (args
)));
702 if (!NILP (Vpurify_flag
))
703 tem
= Fpurecopy (tem
);
704 Fset_default (sym
, tem
);
705 tem
= Fcar (Fcdr (Fcdr (args
)));
708 if (!NILP (Vpurify_flag
))
709 tem
= Fpurecopy (tem
);
710 Fput (sym
, Qvariable_documentation
, tem
);
712 LOADHIST_ATTACH (sym
);
716 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
717 "Returns t if VARIABLE is intended to be set and modified by users.\n\
718 \(The alternative is a variable used internally in a Lisp program.)\n\
719 Determined by whether the first character of the documentation\n\
720 for the variable is `*' or if the variable is customizable (has a non-nil\n\
721 value of any of `custom-type', `custom-loads' or `standard-value'\n\
722 on its property list).")
724 Lisp_Object variable
;
726 Lisp_Object documentation
;
728 if (!SYMBOLP (variable
))
731 documentation
= Fget (variable
, Qvariable_documentation
);
732 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
734 if (STRINGP (documentation
)
735 && ((unsigned char) XSTRING (documentation
)->data
[0] == '*'))
737 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
738 if (CONSP (documentation
)
739 && STRINGP (XCAR (documentation
))
740 && INTEGERP (XCDR (documentation
))
741 && XINT (XCDR (documentation
)) < 0)
744 if ((!NILP (Fget (variable
, intern ("custom-type"))))
745 || (!NILP (Fget (variable
, intern ("custom-loads"))))
746 || (!NILP (Fget (variable
, intern ("standard-value")))))
751 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
752 "Bind variables according to VARLIST then eval BODY.\n\
753 The value of the last form in BODY is returned.\n\
754 Each element of VARLIST is a symbol (which is bound to nil)\n\
755 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
756 Each VALUEFORM can refer to the symbols already bound by this VARLIST.")
760 Lisp_Object varlist
, val
, elt
;
761 int count
= specpdl_ptr
- specpdl
;
762 struct gcpro gcpro1
, gcpro2
, gcpro3
;
764 GCPRO3 (args
, elt
, varlist
);
766 varlist
= Fcar (args
);
767 while (!NILP (varlist
))
770 elt
= Fcar (varlist
);
772 specbind (elt
, Qnil
);
773 else if (! NILP (Fcdr (Fcdr (elt
))))
775 Fcons (build_string ("`let' bindings can have only one value-form"),
779 val
= Feval (Fcar (Fcdr (elt
)));
780 specbind (Fcar (elt
), val
);
782 varlist
= Fcdr (varlist
);
785 val
= Fprogn (Fcdr (args
));
786 return unbind_to (count
, val
);
789 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
790 "Bind variables according to VARLIST then eval BODY.\n\
791 The value of the last form in BODY is returned.\n\
792 Each element of VARLIST is a symbol (which is bound to nil)\n\
793 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
794 All the VALUEFORMs are evalled before any symbols are bound.")
798 Lisp_Object
*temps
, tem
;
799 register Lisp_Object elt
, varlist
;
800 int count
= specpdl_ptr
- specpdl
;
802 struct gcpro gcpro1
, gcpro2
;
804 varlist
= Fcar (args
);
806 /* Make space to hold the values to give the bound variables */
807 elt
= Flength (varlist
);
808 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
810 /* Compute the values and store them in `temps' */
812 GCPRO2 (args
, *temps
);
815 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
818 elt
= Fcar (varlist
);
820 temps
[argnum
++] = Qnil
;
821 else if (! NILP (Fcdr (Fcdr (elt
))))
823 Fcons (build_string ("`let' bindings can have only one value-form"),
826 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
827 gcpro2
.nvars
= argnum
;
831 varlist
= Fcar (args
);
832 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
834 elt
= Fcar (varlist
);
835 tem
= temps
[argnum
++];
839 specbind (Fcar (elt
), tem
);
842 elt
= Fprogn (Fcdr (args
));
843 return unbind_to (count
, elt
);
846 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
847 "If TEST yields non-nil, eval BODY... and repeat.\n\
848 The order of execution is thus TEST, BODY, TEST, BODY and so on\n\
849 until TEST returns nil.")
853 Lisp_Object test
, body
, tem
;
854 struct gcpro gcpro1
, gcpro2
;
860 while (tem
= Feval (test
),
861 (!EQ (Vmocklisp_arguments
, Qt
) ? XINT (tem
) : !NILP (tem
)))
871 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
872 "Return result of expanding macros at top level of FORM.\n\
873 If FORM is not a macro call, it is returned unchanged.\n\
874 Otherwise, the macro is expanded and the expansion is considered\n\
875 in place of FORM. When a non-macro-call results, it is returned.\n\n\
876 The second optional arg ENVIRONMENT specifies an environment of macro\n\
877 definitions to shadow the loaded ones for use in file byte-compilation.")
880 Lisp_Object environment
;
882 /* With cleanups from Hallvard Furuseth. */
883 register Lisp_Object expander
, sym
, def
, tem
;
887 /* Come back here each time we expand a macro call,
888 in case it expands into another macro call. */
891 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
892 def
= sym
= XCAR (form
);
894 /* Trace symbols aliases to other symbols
895 until we get a symbol that is not an alias. */
896 while (SYMBOLP (def
))
900 tem
= Fassq (sym
, environment
);
903 def
= XSYMBOL (sym
)->function
;
904 if (!EQ (def
, Qunbound
))
909 /* Right now TEM is the result from SYM in ENVIRONMENT,
910 and if TEM is nil then DEF is SYM's function definition. */
913 /* SYM is not mentioned in ENVIRONMENT.
914 Look at its function definition. */
915 if (EQ (def
, Qunbound
) || !CONSP (def
))
916 /* Not defined or definition not suitable */
918 if (EQ (XCAR (def
), Qautoload
))
920 /* Autoloading function: will it be a macro when loaded? */
921 tem
= Fnth (make_number (4), def
);
922 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
923 /* Yes, load it and try again. */
927 do_autoload (def
, sym
);
934 else if (!EQ (XCAR (def
), Qmacro
))
936 else expander
= XCDR (def
);
940 expander
= XCDR (tem
);
944 form
= apply1 (expander
, XCDR (form
));
949 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
950 "Eval BODY allowing nonlocal exits using `throw'.\n\
951 TAG is evalled to get the tag to use; it must not be nil.\n\
953 Then the BODY is executed.\n\
954 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.\n\
955 If no throw happens, `catch' returns the value of the last BODY form.\n\
956 If a throw happens, it specifies the value to return from `catch'.")
960 register Lisp_Object tag
;
964 tag
= Feval (Fcar (args
));
966 return internal_catch (tag
, Fprogn
, Fcdr (args
));
969 /* Set up a catch, then call C function FUNC on argument ARG.
970 FUNC should return a Lisp_Object.
971 This is how catches are done from within C code. */
974 internal_catch (tag
, func
, arg
)
976 Lisp_Object (*func
) ();
979 /* This structure is made part of the chain `catchlist'. */
982 /* Fill in the components of c, and put it on the list. */
986 c
.backlist
= backtrace_list
;
987 c
.handlerlist
= handlerlist
;
988 c
.lisp_eval_depth
= lisp_eval_depth
;
989 c
.pdlcount
= specpdl_ptr
- specpdl
;
990 c
.poll_suppress_count
= poll_suppress_count
;
992 c
.byte_stack
= byte_stack_list
;
996 if (! _setjmp (c
.jmp
))
997 c
.val
= (*func
) (arg
);
999 /* Throw works by a longjmp that comes right here. */
1004 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1005 jump to that CATCH, returning VALUE as the value of that catch.
1007 This is the guts Fthrow and Fsignal; they differ only in the way
1008 they choose the catch tag to throw to. A catch tag for a
1009 condition-case form has a TAG of Qnil.
1011 Before each catch is discarded, unbind all special bindings and
1012 execute all unwind-protect clauses made above that catch. Unwind
1013 the handler stack as we go, so that the proper handlers are in
1014 effect for each unwind-protect clause we run. At the end, restore
1015 some static info saved in CATCH, and longjmp to the location
1018 This is used for correct unwinding in Fthrow and Fsignal. */
1021 unwind_to_catch (catch, value
)
1022 struct catchtag
*catch;
1025 register int last_time
;
1027 /* Save the value in the tag. */
1030 /* Restore the polling-suppression count. */
1031 set_poll_suppress_count (catch->poll_suppress_count
);
1035 last_time
= catchlist
== catch;
1037 /* Unwind the specpdl stack, and then restore the proper set of
1039 unbind_to (catchlist
->pdlcount
, Qnil
);
1040 handlerlist
= catchlist
->handlerlist
;
1041 catchlist
= catchlist
->next
;
1043 while (! last_time
);
1045 byte_stack_list
= catch->byte_stack
;
1046 gcprolist
= catch->gcpro
;
1049 gcpro_level
= gcprolist
->level
+ 1;
1053 backtrace_list
= catch->backlist
;
1054 lisp_eval_depth
= catch->lisp_eval_depth
;
1056 _longjmp (catch->jmp
, 1);
1059 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1060 "Throw to the catch for TAG and return VALUE from it.\n\
1061 Both TAG and VALUE are evalled.")
1063 register Lisp_Object tag
, value
;
1065 register struct catchtag
*c
;
1070 for (c
= catchlist
; c
; c
= c
->next
)
1072 if (EQ (c
->tag
, tag
))
1073 unwind_to_catch (c
, value
);
1075 tag
= Fsignal (Qno_catch
, Fcons (tag
, Fcons (value
, Qnil
)));
1080 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1081 "Do BODYFORM, protecting with UNWINDFORMS.\n\
1082 If BODYFORM completes normally, its value is returned\n\
1083 after executing the UNWINDFORMS.\n\
1084 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.")
1089 int count
= specpdl_ptr
- specpdl
;
1091 record_unwind_protect (0, Fcdr (args
));
1092 val
= Feval (Fcar (args
));
1093 return unbind_to (count
, val
);
1096 /* Chain of condition handlers currently in effect.
1097 The elements of this chain are contained in the stack frames
1098 of Fcondition_case and internal_condition_case.
1099 When an error is signaled (by calling Fsignal, below),
1100 this chain is searched for an element that applies. */
1102 struct handler
*handlerlist
;
1104 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1105 "Regain control when an error is signaled.\n\
1106 executes BODYFORM and returns its value if no error happens.\n\
1107 Each element of HANDLERS looks like (CONDITION-NAME BODY...)\n\
1108 where the BODY is made of Lisp expressions.\n\n\
1109 A handler is applicable to an error\n\
1110 if CONDITION-NAME is one of the error's condition names.\n\
1111 If an error happens, the first applicable handler is run.\n\
1113 The car of a handler may be a list of condition names\n\
1114 instead of a single condition name.\n\
1116 When a handler handles an error,\n\
1117 control returns to the condition-case and the handler BODY... is executed\n\
1118 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\
1119 VAR may be nil; then you do not get access to the signal information.\n\
1121 The value of the last BODY form is returned from the condition-case.\n\
1122 See also the function `signal' for more info.")
1129 register Lisp_Object var
, bodyform
, handlers
;
1132 bodyform
= Fcar (Fcdr (args
));
1133 handlers
= Fcdr (Fcdr (args
));
1134 CHECK_SYMBOL (var
, 0);
1136 for (val
= handlers
; ! NILP (val
); val
= Fcdr (val
))
1142 && (SYMBOLP (XCAR (tem
))
1143 || CONSP (XCAR (tem
))))))
1144 error ("Invalid condition handler", tem
);
1149 c
.backlist
= backtrace_list
;
1150 c
.handlerlist
= handlerlist
;
1151 c
.lisp_eval_depth
= lisp_eval_depth
;
1152 c
.pdlcount
= specpdl_ptr
- specpdl
;
1153 c
.poll_suppress_count
= poll_suppress_count
;
1154 c
.gcpro
= gcprolist
;
1155 c
.byte_stack
= byte_stack_list
;
1156 if (_setjmp (c
.jmp
))
1159 specbind (h
.var
, c
.val
);
1160 val
= Fprogn (Fcdr (h
.chosen_clause
));
1162 /* Note that this just undoes the binding of h.var; whoever
1163 longjumped to us unwound the stack to c.pdlcount before
1165 unbind_to (c
.pdlcount
, Qnil
);
1172 h
.handler
= handlers
;
1173 h
.next
= handlerlist
;
1177 val
= Feval (bodyform
);
1179 handlerlist
= h
.next
;
1183 /* Call the function BFUN with no arguments, catching errors within it
1184 according to HANDLERS. If there is an error, call HFUN with
1185 one argument which is the data that describes the error:
1188 HANDLERS can be a list of conditions to catch.
1189 If HANDLERS is Qt, catch all errors.
1190 If HANDLERS is Qerror, catch all errors
1191 but allow the debugger to run if that is enabled. */
1194 internal_condition_case (bfun
, handlers
, hfun
)
1195 Lisp_Object (*bfun
) ();
1196 Lisp_Object handlers
;
1197 Lisp_Object (*hfun
) ();
1203 #if 0 /* Can't do this check anymore because realize_basic_faces has
1204 to BLOCK_INPUT, and can call Lisp. What's really needed is a
1205 flag indicating that we're currently handling a signal. */
1206 /* Since Fsignal resets this to 0, it had better be 0 now
1207 or else we have a potential bug. */
1208 if (interrupt_input_blocked
!= 0)
1214 c
.backlist
= backtrace_list
;
1215 c
.handlerlist
= handlerlist
;
1216 c
.lisp_eval_depth
= lisp_eval_depth
;
1217 c
.pdlcount
= specpdl_ptr
- specpdl
;
1218 c
.poll_suppress_count
= poll_suppress_count
;
1219 c
.gcpro
= gcprolist
;
1220 c
.byte_stack
= byte_stack_list
;
1221 if (_setjmp (c
.jmp
))
1223 return (*hfun
) (c
.val
);
1227 h
.handler
= handlers
;
1229 h
.next
= handlerlist
;
1235 handlerlist
= h
.next
;
1239 /* Like internal_condition_case but call HFUN with ARG as its argument. */
1242 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1243 Lisp_Object (*bfun
) ();
1245 Lisp_Object handlers
;
1246 Lisp_Object (*hfun
) ();
1254 c
.backlist
= backtrace_list
;
1255 c
.handlerlist
= handlerlist
;
1256 c
.lisp_eval_depth
= lisp_eval_depth
;
1257 c
.pdlcount
= specpdl_ptr
- specpdl
;
1258 c
.poll_suppress_count
= poll_suppress_count
;
1259 c
.gcpro
= gcprolist
;
1260 c
.byte_stack
= byte_stack_list
;
1261 if (_setjmp (c
.jmp
))
1263 return (*hfun
) (c
.val
);
1267 h
.handler
= handlers
;
1269 h
.next
= handlerlist
;
1273 val
= (*bfun
) (arg
);
1275 handlerlist
= h
.next
;
1280 /* Like internal_condition_case but call HFUN with NARGS as first,
1281 and ARGS as second argument. */
1284 internal_condition_case_2 (bfun
, nargs
, args
, handlers
, hfun
)
1285 Lisp_Object (*bfun
) ();
1288 Lisp_Object handlers
;
1289 Lisp_Object (*hfun
) ();
1297 c
.backlist
= backtrace_list
;
1298 c
.handlerlist
= handlerlist
;
1299 c
.lisp_eval_depth
= lisp_eval_depth
;
1300 c
.pdlcount
= specpdl_ptr
- specpdl
;
1301 c
.poll_suppress_count
= poll_suppress_count
;
1302 c
.gcpro
= gcprolist
;
1303 c
.byte_stack
= byte_stack_list
;
1304 if (_setjmp (c
.jmp
))
1306 return (*hfun
) (c
.val
);
1310 h
.handler
= handlers
;
1312 h
.next
= handlerlist
;
1316 val
= (*bfun
) (nargs
, args
);
1318 handlerlist
= h
.next
;
1323 static Lisp_Object
find_handler_clause ();
1325 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1326 "Signal an error. Args are ERROR-SYMBOL and associated DATA.\n\
1327 This function does not return.\n\n\
1328 An error symbol is a symbol with an `error-conditions' property\n\
1329 that is a list of condition names.\n\
1330 A handler for any of those names will get to handle this signal.\n\
1331 The symbol `error' should normally be one of them.\n\
1333 DATA should be a list. Its elements are printed as part of the error message.\n\
1334 If the signal is handled, DATA is made available to the handler.\n\
1335 See also the function `condition-case'.")
1336 (error_symbol
, data
)
1337 Lisp_Object error_symbol
, data
;
1339 /* When memory is full, ERROR-SYMBOL is nil,
1340 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA). */
1341 register struct handler
*allhandlers
= handlerlist
;
1342 Lisp_Object conditions
;
1343 extern int gc_in_progress
;
1344 extern int waiting_for_input
;
1345 Lisp_Object debugger_value
;
1347 Lisp_Object real_error_symbol
;
1348 extern int display_busy_cursor_p
;
1349 struct backtrace
*bp
;
1352 if (gc_in_progress
|| waiting_for_input
)
1355 TOTALLY_UNBLOCK_INPUT
;
1357 if (NILP (error_symbol
))
1358 real_error_symbol
= Fcar (data
);
1360 real_error_symbol
= error_symbol
;
1362 #ifdef HAVE_X_WINDOWS
1363 if (display_busy_cursor_p
)
1364 cancel_busy_cursor ();
1367 /* This hook is used by edebug. */
1368 if (! NILP (Vsignal_hook_function
))
1369 call2 (Vsignal_hook_function
, error_symbol
, data
);
1371 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1373 /* Remember from where signal was called. Skip over the frame for
1374 `signal' itself. If a frame for `error' follows, skip that,
1376 Vsignaling_function
= Qnil
;
1379 bp
= backtrace_list
->next
;
1380 if (bp
&& bp
->function
&& EQ (*bp
->function
, Qerror
))
1382 if (bp
&& bp
->function
)
1383 Vsignaling_function
= *bp
->function
;
1386 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1388 register Lisp_Object clause
;
1390 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
1391 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
1393 if (specpdl_size
+ 40 > max_specpdl_size
)
1394 max_specpdl_size
= specpdl_size
+ 40;
1396 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1397 error_symbol
, data
, &debugger_value
);
1399 #if 0 /* Most callers are not prepared to handle gc if this returns.
1400 So, since this feature is not very useful, take it out. */
1401 /* If have called debugger and user wants to continue,
1403 if (EQ (clause
, Qlambda
))
1404 return debugger_value
;
1406 if (EQ (clause
, Qlambda
))
1408 /* We can't return values to code which signaled an error, but we
1409 can continue code which has signaled a quit. */
1410 if (EQ (real_error_symbol
, Qquit
))
1413 error ("Cannot return from the debugger in an error");
1419 Lisp_Object unwind_data
;
1420 struct handler
*h
= handlerlist
;
1422 handlerlist
= allhandlers
;
1424 if (NILP (error_symbol
))
1427 unwind_data
= Fcons (error_symbol
, data
);
1428 h
->chosen_clause
= clause
;
1429 unwind_to_catch (h
->tag
, unwind_data
);
1433 handlerlist
= allhandlers
;
1434 /* If no handler is present now, try to run the debugger,
1435 and if that fails, throw to top level. */
1436 find_handler_clause (Qerror
, conditions
, error_symbol
, data
, &debugger_value
);
1438 Fthrow (Qtop_level
, Qt
);
1440 if (! NILP (error_symbol
))
1441 data
= Fcons (error_symbol
, data
);
1443 string
= Ferror_message_string (data
);
1444 fatal ("%s", XSTRING (string
)->data
, 0);
1447 /* Return nonzero iff LIST is a non-nil atom or
1448 a list containing one of CONDITIONS. */
1451 wants_debugger (list
, conditions
)
1452 Lisp_Object list
, conditions
;
1459 while (CONSP (conditions
))
1461 Lisp_Object
this, tail
;
1462 this = XCAR (conditions
);
1463 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1464 if (EQ (XCAR (tail
), this))
1466 conditions
= XCDR (conditions
);
1471 /* Return 1 if an error with condition-symbols CONDITIONS,
1472 and described by SIGNAL-DATA, should skip the debugger
1473 according to debugger-ignore-errors. */
1476 skip_debugger (conditions
, data
)
1477 Lisp_Object conditions
, data
;
1480 int first_string
= 1;
1481 Lisp_Object error_message
;
1483 for (tail
= Vdebug_ignored_errors
; CONSP (tail
);
1486 if (STRINGP (XCAR (tail
)))
1490 error_message
= Ferror_message_string (data
);
1493 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1498 Lisp_Object contail
;
1500 for (contail
= conditions
; CONSP (contail
);
1501 contail
= XCDR (contail
))
1502 if (EQ (XCAR (tail
), XCAR (contail
)))
1510 /* Value of Qlambda means we have called debugger and user has continued.
1511 There are two ways to pass SIG and DATA:
1512 = SIG is the error symbol, and DATA is the rest of the data.
1513 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1514 This is for memory-full errors only.
1516 Store value returned from debugger into *DEBUGGER_VALUE_PTR. */
1519 find_handler_clause (handlers
, conditions
, sig
, data
, debugger_value_ptr
)
1520 Lisp_Object handlers
, conditions
, sig
, data
;
1521 Lisp_Object
*debugger_value_ptr
;
1523 register Lisp_Object h
;
1524 register Lisp_Object tem
;
1526 if (EQ (handlers
, Qt
)) /* t is used by handlers for all conditions, set up by C code. */
1528 /* error is used similarly, but means print an error message
1529 and run the debugger if that is enabled. */
1530 if (EQ (handlers
, Qerror
)
1531 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1532 there is a handler. */
1534 int count
= specpdl_ptr
- specpdl
;
1535 int debugger_called
= 0;
1536 Lisp_Object sig_symbol
, combined_data
;
1537 /* This is set to 1 if we are handling a memory-full error,
1538 because these must not run the debugger.
1539 (There is no room in memory to do that!) */
1540 int no_debugger
= 0;
1544 combined_data
= data
;
1545 sig_symbol
= Fcar (data
);
1550 combined_data
= Fcons (sig
, data
);
1554 if (wants_debugger (Vstack_trace_on_error
, conditions
))
1557 internal_with_output_to_temp_buffer ("*Backtrace*",
1558 (Lisp_Object (*) (Lisp_Object
)) Fbacktrace
,
1561 internal_with_output_to_temp_buffer ("*Backtrace*",
1566 && (EQ (sig_symbol
, Qquit
)
1568 : wants_debugger (Vdebug_on_error
, conditions
))
1569 && ! skip_debugger (conditions
, combined_data
)
1570 && when_entered_debugger
< num_nonmacro_input_events
)
1572 specbind (Qdebug_on_error
, Qnil
);
1574 = call_debugger (Fcons (Qerror
,
1575 Fcons (combined_data
, Qnil
)));
1576 debugger_called
= 1;
1578 /* If there is no handler, return saying whether we ran the debugger. */
1579 if (EQ (handlers
, Qerror
))
1581 if (debugger_called
)
1582 return unbind_to (count
, Qlambda
);
1586 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1588 Lisp_Object handler
, condit
;
1591 if (!CONSP (handler
))
1593 condit
= Fcar (handler
);
1594 /* Handle a single condition name in handler HANDLER. */
1595 if (SYMBOLP (condit
))
1597 tem
= Fmemq (Fcar (handler
), conditions
);
1601 /* Handle a list of condition names in handler HANDLER. */
1602 else if (CONSP (condit
))
1604 while (CONSP (condit
))
1606 tem
= Fmemq (Fcar (condit
), conditions
);
1609 condit
= XCDR (condit
);
1616 /* dump an error message; called like printf */
1620 error (m
, a1
, a2
, a3
)
1640 int used
= doprnt (buffer
, size
, m
, m
+ mlen
, 3, args
);
1645 buffer
= (char *) xrealloc (buffer
, size
);
1648 buffer
= (char *) xmalloc (size
);
1653 string
= build_string (buffer
);
1657 Fsignal (Qerror
, Fcons (string
, Qnil
));
1660 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 1, 0,
1661 "T if FUNCTION makes provisions for interactive calling.\n\
1662 This means it contains a description for how to read arguments to give it.\n\
1663 The value is nil for an invalid function or a symbol with no function\n\
1666 Interactively callable functions include strings and vectors (treated\n\
1667 as keyboard macros), lambda-expressions that contain a top-level call\n\
1668 to `interactive', autoload definitions made by `autoload' with non-nil\n\
1669 fourth argument, and some of the built-in functions of Lisp.\n\
1671 Also, a symbol satisfies `commandp' if its function definition does so.")
1673 Lisp_Object function
;
1675 register Lisp_Object fun
;
1676 register Lisp_Object funcar
;
1680 fun
= indirect_function (fun
);
1681 if (EQ (fun
, Qunbound
))
1684 /* Emacs primitives are interactive if their DEFUN specifies an
1685 interactive spec. */
1688 if (XSUBR (fun
)->prompt
)
1694 /* Bytecode objects are interactive if they are long enough to
1695 have an element whose index is COMPILED_INTERACTIVE, which is
1696 where the interactive spec is stored. */
1697 else if (COMPILEDP (fun
))
1698 return ((XVECTOR (fun
)->size
& PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
1701 /* Strings and vectors are keyboard macros. */
1702 if (STRINGP (fun
) || VECTORP (fun
))
1705 /* Lists may represent commands. */
1708 funcar
= Fcar (fun
);
1709 if (!SYMBOLP (funcar
))
1710 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1711 if (EQ (funcar
, Qlambda
))
1712 return Fassq (Qinteractive
, Fcdr (Fcdr (fun
)));
1713 if (EQ (funcar
, Qmocklisp
))
1714 return Qt
; /* All mocklisp functions can be called interactively */
1715 if (EQ (funcar
, Qautoload
))
1716 return Fcar (Fcdr (Fcdr (Fcdr (fun
))));
1722 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1723 "Define FUNCTION to autoload from FILE.\n\
1724 FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\
1725 Third arg DOCSTRING is documentation for the function.\n\
1726 Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\
1727 Fifth arg TYPE indicates the type of the object:\n\
1728 nil or omitted says FUNCTION is a function,\n\
1729 `keymap' says FUNCTION is really a keymap, and\n\
1730 `macro' or t says FUNCTION is really a macro.\n\
1731 Third through fifth args give info about the real definition.\n\
1732 They default to nil.\n\
1733 If FUNCTION is already defined other than as an autoload,\n\
1734 this does nothing and returns nil.")
1735 (function
, file
, docstring
, interactive
, type
)
1736 Lisp_Object function
, file
, docstring
, interactive
, type
;
1739 Lisp_Object args
[4];
1742 CHECK_SYMBOL (function
, 0);
1743 CHECK_STRING (file
, 1);
1745 /* If function is defined and not as an autoload, don't override */
1746 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
1747 && !(CONSP (XSYMBOL (function
)->function
)
1748 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
1751 if (NILP (Vpurify_flag
))
1752 /* Only add entries after dumping, because the ones before are
1753 not useful and else we get loads of them from the loaddefs.el. */
1754 LOADHIST_ATTACH (Fcons (Qautoload
, function
));
1758 args
[1] = docstring
;
1759 args
[2] = interactive
;
1762 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
1763 #else /* NO_ARG_ARRAY */
1764 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
1765 #endif /* not NO_ARG_ARRAY */
1769 un_autoload (oldqueue
)
1770 Lisp_Object oldqueue
;
1772 register Lisp_Object queue
, first
, second
;
1774 /* Queue to unwind is current value of Vautoload_queue.
1775 oldqueue is the shadowed value to leave in Vautoload_queue. */
1776 queue
= Vautoload_queue
;
1777 Vautoload_queue
= oldqueue
;
1778 while (CONSP (queue
))
1780 first
= Fcar (queue
);
1781 second
= Fcdr (first
);
1782 first
= Fcar (first
);
1783 if (EQ (second
, Qnil
))
1786 Ffset (first
, second
);
1787 queue
= Fcdr (queue
);
1792 /* Load an autoloaded function.
1793 FUNNAME is the symbol which is the function's name.
1794 FUNDEF is the autoload definition (a list). */
1797 do_autoload (fundef
, funname
)
1798 Lisp_Object fundef
, funname
;
1800 int count
= specpdl_ptr
- specpdl
;
1801 Lisp_Object fun
, queue
, first
, second
;
1802 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1805 CHECK_SYMBOL (funname
, 0);
1806 GCPRO3 (fun
, funname
, fundef
);
1808 /* Preserve the match data. */
1809 record_unwind_protect (Fset_match_data
, Fmatch_data (Qnil
, Qnil
));
1811 /* Value saved here is to be restored into Vautoload_queue. */
1812 record_unwind_protect (un_autoload
, Vautoload_queue
);
1813 Vautoload_queue
= Qt
;
1814 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
, Qt
);
1816 /* Save the old autoloads, in case we ever do an unload. */
1817 queue
= Vautoload_queue
;
1818 while (CONSP (queue
))
1820 first
= Fcar (queue
);
1821 second
= Fcdr (first
);
1822 first
= Fcar (first
);
1824 /* Note: This test is subtle. The cdr of an autoload-queue entry
1825 may be an atom if the autoload entry was generated by a defalias
1828 Fput (first
, Qautoload
, (Fcdr (second
)));
1830 queue
= Fcdr (queue
);
1833 /* Once loading finishes, don't undo it. */
1834 Vautoload_queue
= Qt
;
1835 unbind_to (count
, Qnil
);
1837 fun
= Findirect_function (fun
);
1839 if (!NILP (Fequal (fun
, fundef
)))
1840 error ("Autoloading failed to define function %s",
1841 XSYMBOL (funname
)->name
->data
);
1846 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
1847 "Evaluate FORM and return its value.")
1851 Lisp_Object fun
, val
, original_fun
, original_args
;
1853 struct backtrace backtrace
;
1854 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1856 if (handling_signal
)
1861 if (EQ (Vmocklisp_arguments
, Qt
))
1862 return Fsymbol_value (form
);
1863 val
= Fsymbol_value (form
);
1865 XSETFASTINT (val
, 0);
1866 else if (EQ (val
, Qt
))
1867 XSETFASTINT (val
, 1);
1874 if (consing_since_gc
> gc_cons_threshold
)
1877 Fgarbage_collect ();
1881 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1883 if (max_lisp_eval_depth
< 100)
1884 max_lisp_eval_depth
= 100;
1885 if (lisp_eval_depth
> max_lisp_eval_depth
)
1886 error ("Lisp nesting exceeds max-lisp-eval-depth");
1889 original_fun
= Fcar (form
);
1890 original_args
= Fcdr (form
);
1892 backtrace
.next
= backtrace_list
;
1893 backtrace_list
= &backtrace
;
1894 backtrace
.function
= &original_fun
; /* This also protects them from gc */
1895 backtrace
.args
= &original_args
;
1896 backtrace
.nargs
= UNEVALLED
;
1897 backtrace
.evalargs
= 1;
1898 backtrace
.debug_on_exit
= 0;
1900 if (debug_on_next_call
)
1901 do_debug_on_call (Qt
);
1903 /* At this point, only original_fun and original_args
1904 have values that will be used below */
1906 fun
= Findirect_function (original_fun
);
1910 Lisp_Object numargs
;
1911 Lisp_Object argvals
[8];
1912 Lisp_Object args_left
;
1913 register int i
, maxargs
;
1915 args_left
= original_args
;
1916 numargs
= Flength (args_left
);
1918 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
1919 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
1920 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1922 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1924 backtrace
.evalargs
= 0;
1925 val
= (*XSUBR (fun
)->function
) (args_left
);
1929 if (XSUBR (fun
)->max_args
== MANY
)
1931 /* Pass a vector of evaluated arguments */
1933 register int argnum
= 0;
1935 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1937 GCPRO3 (args_left
, fun
, fun
);
1941 while (!NILP (args_left
))
1943 vals
[argnum
++] = Feval (Fcar (args_left
));
1944 args_left
= Fcdr (args_left
);
1945 gcpro3
.nvars
= argnum
;
1948 backtrace
.args
= vals
;
1949 backtrace
.nargs
= XINT (numargs
);
1951 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
1956 GCPRO3 (args_left
, fun
, fun
);
1957 gcpro3
.var
= argvals
;
1960 maxargs
= XSUBR (fun
)->max_args
;
1961 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
1963 argvals
[i
] = Feval (Fcar (args_left
));
1969 backtrace
.args
= argvals
;
1970 backtrace
.nargs
= XINT (numargs
);
1975 val
= (*XSUBR (fun
)->function
) ();
1978 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
1981 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
1984 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1988 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1989 argvals
[2], argvals
[3]);
1992 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1993 argvals
[3], argvals
[4]);
1996 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1997 argvals
[3], argvals
[4], argvals
[5]);
2000 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2001 argvals
[3], argvals
[4], argvals
[5],
2006 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
2007 argvals
[3], argvals
[4], argvals
[5],
2008 argvals
[6], argvals
[7]);
2012 /* Someone has created a subr that takes more arguments than
2013 is supported by this code. We need to either rewrite the
2014 subr to use a different argument protocol, or add more
2015 cases to this switch. */
2019 if (COMPILEDP (fun
))
2020 val
= apply_lambda (fun
, original_args
, 1);
2024 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2025 funcar
= Fcar (fun
);
2026 if (!SYMBOLP (funcar
))
2027 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2028 if (EQ (funcar
, Qautoload
))
2030 do_autoload (fun
, original_fun
);
2033 if (EQ (funcar
, Qmacro
))
2034 val
= Feval (apply1 (Fcdr (fun
), original_args
));
2035 else if (EQ (funcar
, Qlambda
))
2036 val
= apply_lambda (fun
, original_args
, 1);
2037 else if (EQ (funcar
, Qmocklisp
))
2038 val
= ml_apply (fun
, original_args
);
2040 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2043 if (!EQ (Vmocklisp_arguments
, Qt
))
2046 XSETFASTINT (val
, 0);
2047 else if (EQ (val
, Qt
))
2048 XSETFASTINT (val
, 1);
2051 if (backtrace
.debug_on_exit
)
2052 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2053 backtrace_list
= backtrace
.next
;
2057 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
2058 "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
2059 Then return the value FUNCTION returns.\n\
2060 Thus, (apply '+ 1 2 '(3 4)) returns 10.")
2065 register int i
, numargs
;
2066 register Lisp_Object spread_arg
;
2067 register Lisp_Object
*funcall_args
;
2069 struct gcpro gcpro1
;
2073 spread_arg
= args
[nargs
- 1];
2074 CHECK_LIST (spread_arg
, nargs
);
2076 numargs
= XINT (Flength (spread_arg
));
2079 return Ffuncall (nargs
- 1, args
);
2080 else if (numargs
== 1)
2082 args
[nargs
- 1] = XCAR (spread_arg
);
2083 return Ffuncall (nargs
, args
);
2086 numargs
+= nargs
- 2;
2088 fun
= indirect_function (fun
);
2089 if (EQ (fun
, Qunbound
))
2091 /* Let funcall get the error */
2098 if (numargs
< XSUBR (fun
)->min_args
2099 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2100 goto funcall
; /* Let funcall get the error */
2101 else if (XSUBR (fun
)->max_args
> numargs
)
2103 /* Avoid making funcall cons up a yet another new vector of arguments
2104 by explicitly supplying nil's for optional values */
2105 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
2106 * sizeof (Lisp_Object
));
2107 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
2108 funcall_args
[++i
] = Qnil
;
2109 GCPRO1 (*funcall_args
);
2110 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
2114 /* We add 1 to numargs because funcall_args includes the
2115 function itself as well as its arguments. */
2118 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
2119 * sizeof (Lisp_Object
));
2120 GCPRO1 (*funcall_args
);
2121 gcpro1
.nvars
= 1 + numargs
;
2124 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
2125 /* Spread the last arg we got. Its first element goes in
2126 the slot that it used to occupy, hence this value of I. */
2128 while (!NILP (spread_arg
))
2130 funcall_args
[i
++] = XCAR (spread_arg
);
2131 spread_arg
= XCDR (spread_arg
);
2134 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
2137 /* Run hook variables in various ways. */
2139 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
2141 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 1, MANY
, 0,
2142 "Run each hook in HOOKS. Major mode functions use this.\n\
2143 Each argument should be a symbol, a hook variable.\n\
2144 These symbols are processed in the order specified.\n\
2145 If a hook symbol has a non-nil value, that value may be a function\n\
2146 or a list of functions to be called to run the hook.\n\
2147 If the value is a function, it is called with no arguments.\n\
2148 If it is a list, the elements are called, in order, with no arguments.\n\
2150 To make a hook variable buffer-local, use `make-local-hook',\n\
2151 not `make-local-variable'.")
2156 Lisp_Object hook
[1];
2159 for (i
= 0; i
< nargs
; i
++)
2162 run_hook_with_args (1, hook
, to_completion
);
2168 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2169 Srun_hook_with_args
, 1, MANY
, 0,
2170 "Run HOOK with the specified arguments ARGS.\n\
2171 HOOK should be a symbol, a hook variable. If HOOK has a non-nil\n\
2172 value, that value may be a function or a list of functions to be\n\
2173 called to run the hook. If the value is a function, it is called with\n\
2174 the given arguments and its return value is returned. If it is a list\n\
2175 of functions, those functions are called, in order,\n\
2176 with the given arguments ARGS.\n\
2177 It is best not to depend on the value return by `run-hook-with-args',\n\
2178 as that may change.\n\
2180 To make a hook variable buffer-local, use `make-local-hook',\n\
2181 not `make-local-variable'.")
2186 return run_hook_with_args (nargs
, args
, to_completion
);
2189 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2190 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2191 "Run HOOK with the specified arguments ARGS.\n\
2192 HOOK should be a symbol, a hook variable. Its value should\n\
2193 be a list of functions. We call those functions, one by one,\n\
2194 passing arguments ARGS to each of them, until one of them\n\
2195 returns a non-nil value. Then we return that value.\n\
2196 If all the functions return nil, we return nil.\n\
2198 To make a hook variable buffer-local, use `make-local-hook',\n\
2199 not `make-local-variable'.")
2204 return run_hook_with_args (nargs
, args
, until_success
);
2207 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2208 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2209 "Run HOOK with the specified arguments ARGS.\n\
2210 HOOK should be a symbol, a hook variable. Its value should\n\
2211 be a list of functions. We call those functions, one by one,\n\
2212 passing arguments ARGS to each of them, until one of them\n\
2213 returns nil. Then we return nil.\n\
2214 If all the functions return non-nil, we return non-nil.\n\
2216 To make a hook variable buffer-local, use `make-local-hook',\n\
2217 not `make-local-variable'.")
2222 return run_hook_with_args (nargs
, args
, until_failure
);
2225 /* ARGS[0] should be a hook symbol.
2226 Call each of the functions in the hook value, passing each of them
2227 as arguments all the rest of ARGS (all NARGS - 1 elements).
2228 COND specifies a condition to test after each call
2229 to decide whether to stop.
2230 The caller (or its caller, etc) must gcpro all of ARGS,
2231 except that it isn't necessary to gcpro ARGS[0]. */
2234 run_hook_with_args (nargs
, args
, cond
)
2237 enum run_hooks_condition cond
;
2239 Lisp_Object sym
, val
, ret
;
2240 Lisp_Object globals
;
2241 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2243 /* If we are dying or still initializing,
2244 don't do anything--it would probably crash if we tried. */
2245 if (NILP (Vrun_hooks
))
2249 val
= find_symbol_value (sym
);
2250 ret
= (cond
== until_failure
? Qt
: Qnil
);
2252 if (EQ (val
, Qunbound
) || NILP (val
))
2254 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2257 return Ffuncall (nargs
, args
);
2262 GCPRO3 (sym
, val
, globals
);
2265 CONSP (val
) && ((cond
== to_completion
)
2266 || (cond
== until_success
? NILP (ret
)
2270 if (EQ (XCAR (val
), Qt
))
2272 /* t indicates this hook has a local binding;
2273 it means to run the global binding too. */
2275 for (globals
= Fdefault_value (sym
);
2276 CONSP (globals
) && ((cond
== to_completion
)
2277 || (cond
== until_success
? NILP (ret
)
2279 globals
= XCDR (globals
))
2281 args
[0] = XCAR (globals
);
2282 /* In a global value, t should not occur. If it does, we
2283 must ignore it to avoid an endless loop. */
2284 if (!EQ (args
[0], Qt
))
2285 ret
= Ffuncall (nargs
, args
);
2290 args
[0] = XCAR (val
);
2291 ret
= Ffuncall (nargs
, args
);
2300 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2301 present value of that symbol.
2302 Call each element of FUNLIST,
2303 passing each of them the rest of ARGS.
2304 The caller (or its caller, etc) must gcpro all of ARGS,
2305 except that it isn't necessary to gcpro ARGS[0]. */
2308 run_hook_list_with_args (funlist
, nargs
, args
)
2309 Lisp_Object funlist
;
2315 Lisp_Object globals
;
2316 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2320 GCPRO3 (sym
, val
, globals
);
2322 for (val
= funlist
; CONSP (val
); val
= XCDR (val
))
2324 if (EQ (XCAR (val
), Qt
))
2326 /* t indicates this hook has a local binding;
2327 it means to run the global binding too. */
2329 for (globals
= Fdefault_value (sym
);
2331 globals
= XCDR (globals
))
2333 args
[0] = XCAR (globals
);
2334 /* In a global value, t should not occur. If it does, we
2335 must ignore it to avoid an endless loop. */
2336 if (!EQ (args
[0], Qt
))
2337 Ffuncall (nargs
, args
);
2342 args
[0] = XCAR (val
);
2343 Ffuncall (nargs
, args
);
2350 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2353 run_hook_with_args_2 (hook
, arg1
, arg2
)
2354 Lisp_Object hook
, arg1
, arg2
;
2356 Lisp_Object temp
[3];
2361 Frun_hook_with_args (3, temp
);
2364 /* Apply fn to arg */
2367 Lisp_Object fn
, arg
;
2369 struct gcpro gcpro1
;
2373 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2377 Lisp_Object args
[2];
2381 RETURN_UNGCPRO (Fapply (2, args
));
2383 #else /* not NO_ARG_ARRAY */
2384 RETURN_UNGCPRO (Fapply (2, &fn
));
2385 #endif /* not NO_ARG_ARRAY */
2388 /* Call function fn on no arguments */
2393 struct gcpro gcpro1
;
2396 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2399 /* Call function fn with 1 argument arg1 */
2403 Lisp_Object fn
, arg1
;
2405 struct gcpro gcpro1
;
2407 Lisp_Object args
[2];
2413 RETURN_UNGCPRO (Ffuncall (2, args
));
2414 #else /* not NO_ARG_ARRAY */
2417 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2418 #endif /* not NO_ARG_ARRAY */
2421 /* Call function fn with 2 arguments arg1, arg2 */
2424 call2 (fn
, arg1
, arg2
)
2425 Lisp_Object fn
, arg1
, arg2
;
2427 struct gcpro gcpro1
;
2429 Lisp_Object args
[3];
2435 RETURN_UNGCPRO (Ffuncall (3, args
));
2436 #else /* not NO_ARG_ARRAY */
2439 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2440 #endif /* not NO_ARG_ARRAY */
2443 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2446 call3 (fn
, arg1
, arg2
, arg3
)
2447 Lisp_Object fn
, arg1
, arg2
, arg3
;
2449 struct gcpro gcpro1
;
2451 Lisp_Object args
[4];
2458 RETURN_UNGCPRO (Ffuncall (4, args
));
2459 #else /* not NO_ARG_ARRAY */
2462 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2463 #endif /* not NO_ARG_ARRAY */
2466 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2469 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2470 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2472 struct gcpro gcpro1
;
2474 Lisp_Object args
[5];
2482 RETURN_UNGCPRO (Ffuncall (5, args
));
2483 #else /* not NO_ARG_ARRAY */
2486 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2487 #endif /* not NO_ARG_ARRAY */
2490 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2493 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2494 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2496 struct gcpro gcpro1
;
2498 Lisp_Object args
[6];
2507 RETURN_UNGCPRO (Ffuncall (6, args
));
2508 #else /* not NO_ARG_ARRAY */
2511 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2512 #endif /* not NO_ARG_ARRAY */
2515 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2518 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2519 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2521 struct gcpro gcpro1
;
2523 Lisp_Object args
[7];
2533 RETURN_UNGCPRO (Ffuncall (7, args
));
2534 #else /* not NO_ARG_ARRAY */
2537 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2538 #endif /* not NO_ARG_ARRAY */
2541 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2542 "Call first argument as a function, passing remaining arguments to it.\n\
2543 Return the value that function returns.\n\
2544 Thus, (funcall 'cons 'x 'y) returns (x . y).")
2551 int numargs
= nargs
- 1;
2552 Lisp_Object lisp_numargs
;
2554 struct backtrace backtrace
;
2555 register Lisp_Object
*internal_args
;
2559 if (consing_since_gc
> gc_cons_threshold
)
2560 Fgarbage_collect ();
2562 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2564 if (max_lisp_eval_depth
< 100)
2565 max_lisp_eval_depth
= 100;
2566 if (lisp_eval_depth
> max_lisp_eval_depth
)
2567 error ("Lisp nesting exceeds max-lisp-eval-depth");
2570 backtrace
.next
= backtrace_list
;
2571 backtrace_list
= &backtrace
;
2572 backtrace
.function
= &args
[0];
2573 backtrace
.args
= &args
[1];
2574 backtrace
.nargs
= nargs
- 1;
2575 backtrace
.evalargs
= 0;
2576 backtrace
.debug_on_exit
= 0;
2578 if (debug_on_next_call
)
2579 do_debug_on_call (Qlambda
);
2585 fun
= Findirect_function (fun
);
2589 if (numargs
< XSUBR (fun
)->min_args
2590 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2592 XSETFASTINT (lisp_numargs
, numargs
);
2593 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (lisp_numargs
, Qnil
)));
2596 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2597 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2599 if (XSUBR (fun
)->max_args
== MANY
)
2601 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
2605 if (XSUBR (fun
)->max_args
> numargs
)
2607 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2608 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
2609 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2610 internal_args
[i
] = Qnil
;
2613 internal_args
= args
+ 1;
2614 switch (XSUBR (fun
)->max_args
)
2617 val
= (*XSUBR (fun
)->function
) ();
2620 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
2623 val
= (*XSUBR (fun
)->function
) (internal_args
[0],
2627 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2631 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2636 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2637 internal_args
[2], internal_args
[3],
2641 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2642 internal_args
[2], internal_args
[3],
2643 internal_args
[4], internal_args
[5]);
2646 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2647 internal_args
[2], internal_args
[3],
2648 internal_args
[4], internal_args
[5],
2653 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2654 internal_args
[2], internal_args
[3],
2655 internal_args
[4], internal_args
[5],
2656 internal_args
[6], internal_args
[7]);
2661 /* If a subr takes more than 8 arguments without using MANY
2662 or UNEVALLED, we need to extend this function to support it.
2663 Until this is done, there is no way to call the function. */
2667 if (COMPILEDP (fun
))
2668 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2672 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2673 funcar
= Fcar (fun
);
2674 if (!SYMBOLP (funcar
))
2675 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2676 if (EQ (funcar
, Qlambda
))
2677 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2678 else if (EQ (funcar
, Qmocklisp
))
2679 val
= ml_apply (fun
, Flist (numargs
, args
+ 1));
2680 else if (EQ (funcar
, Qautoload
))
2682 do_autoload (fun
, args
[0]);
2686 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2690 if (backtrace
.debug_on_exit
)
2691 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2692 backtrace_list
= backtrace
.next
;
2697 apply_lambda (fun
, args
, eval_flag
)
2698 Lisp_Object fun
, args
;
2701 Lisp_Object args_left
;
2702 Lisp_Object numargs
;
2703 register Lisp_Object
*arg_vector
;
2704 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2706 register Lisp_Object tem
;
2708 numargs
= Flength (args
);
2709 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2712 GCPRO3 (*arg_vector
, args_left
, fun
);
2715 for (i
= 0; i
< XINT (numargs
);)
2717 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2718 if (eval_flag
) tem
= Feval (tem
);
2719 arg_vector
[i
++] = tem
;
2727 backtrace_list
->args
= arg_vector
;
2728 backtrace_list
->nargs
= i
;
2730 backtrace_list
->evalargs
= 0;
2731 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
2733 /* Do the debug-on-exit now, while arg_vector still exists. */
2734 if (backtrace_list
->debug_on_exit
)
2735 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
2736 /* Don't do it again when we return to eval. */
2737 backtrace_list
->debug_on_exit
= 0;
2741 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2742 and return the result of evaluation.
2743 FUN must be either a lambda-expression or a compiled-code object. */
2746 funcall_lambda (fun
, nargs
, arg_vector
)
2749 register Lisp_Object
*arg_vector
;
2751 Lisp_Object val
, syms_left
, next
;
2752 int count
= specpdl_ptr
- specpdl
;
2753 int i
, optional
, rest
;
2755 if (NILP (Vmocklisp_arguments
))
2756 specbind (Qmocklisp_arguments
, Qt
); /* t means NOT mocklisp! */
2760 syms_left
= XCDR (fun
);
2761 if (CONSP (syms_left
))
2762 syms_left
= XCAR (syms_left
);
2764 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2766 else if (COMPILEDP (fun
))
2767 syms_left
= XVECTOR (fun
)->contents
[COMPILED_ARGLIST
];
2771 i
= optional
= rest
= 0;
2772 for (; CONSP (syms_left
); syms_left
= XCDR (syms_left
))
2776 next
= XCAR (syms_left
);
2777 while (!SYMBOLP (next
))
2778 next
= Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2780 if (EQ (next
, Qand_rest
))
2782 else if (EQ (next
, Qand_optional
))
2786 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
2790 specbind (next
, arg_vector
[i
++]);
2792 return Fsignal (Qwrong_number_of_arguments
,
2793 Fcons (fun
, Fcons (make_number (nargs
), Qnil
)));
2795 specbind (next
, Qnil
);
2798 if (!NILP (syms_left
))
2799 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2801 return Fsignal (Qwrong_number_of_arguments
,
2802 Fcons (fun
, Fcons (make_number (nargs
), Qnil
)));
2805 val
= Fprogn (XCDR (XCDR (fun
)));
2808 /* If we have not actually read the bytecode string
2809 and constants vector yet, fetch them from the file. */
2810 if (CONSP (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
]))
2811 Ffetch_bytecode (fun
);
2812 val
= Fbyte_code (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
],
2813 XVECTOR (fun
)->contents
[COMPILED_CONSTANTS
],
2814 XVECTOR (fun
)->contents
[COMPILED_STACK_DEPTH
]);
2817 return unbind_to (count
, val
);
2820 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
2822 "If byte-compiled OBJECT is lazy-loaded, fetch it now.")
2828 if (COMPILEDP (object
)
2829 && CONSP (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]))
2831 tem
= read_doc_string (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]);
2833 error ("invalid byte code");
2834 XVECTOR (object
)->contents
[COMPILED_BYTECODE
] = XCAR (tem
);
2835 XVECTOR (object
)->contents
[COMPILED_CONSTANTS
] = XCDR (tem
);
2843 register int count
= specpdl_ptr
- specpdl
;
2844 if (specpdl_size
>= max_specpdl_size
)
2846 if (max_specpdl_size
< 400)
2847 max_specpdl_size
= 400;
2848 if (specpdl_size
>= max_specpdl_size
)
2850 if (!NILP (Vdebug_on_error
))
2851 /* Leave room for some specpdl in the debugger. */
2852 max_specpdl_size
= specpdl_size
+ 100;
2854 Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil
));
2858 if (specpdl_size
> max_specpdl_size
)
2859 specpdl_size
= max_specpdl_size
;
2860 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
2861 specpdl_ptr
= specpdl
+ count
;
2865 specbind (symbol
, value
)
2866 Lisp_Object symbol
, value
;
2870 CHECK_SYMBOL (symbol
, 0);
2871 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2874 /* The most common case is that a non-constant symbol with a trivial
2875 value. Make that as fast as we can. */
2876 if (!MISCP (XSYMBOL (symbol
)->value
)
2877 && !EQ (symbol
, Qnil
)
2879 && !(XSYMBOL (symbol
)->name
->data
[0] == ':'
2880 && EQ (XSYMBOL (symbol
)->obarray
, initial_obarray
)
2881 && !EQ (value
, symbol
)))
2883 specpdl_ptr
->symbol
= symbol
;
2884 specpdl_ptr
->old_value
= XSYMBOL (symbol
)->value
;
2885 specpdl_ptr
->func
= NULL
;
2887 XSYMBOL (symbol
)->value
= value
;
2891 ovalue
= find_symbol_value (symbol
);
2892 specpdl_ptr
->func
= 0;
2893 specpdl_ptr
->old_value
= ovalue
;
2895 if (BUFFER_LOCAL_VALUEP (XSYMBOL (symbol
)->value
)
2896 || SOME_BUFFER_LOCAL_VALUEP (XSYMBOL (symbol
)->value
)
2897 || BUFFER_OBJFWDP (XSYMBOL (symbol
)->value
))
2899 Lisp_Object current_buffer
, binding_buffer
;
2900 /* For a local variable, record both the symbol and which
2901 buffer's value we are saving. */
2902 current_buffer
= Fcurrent_buffer ();
2903 binding_buffer
= current_buffer
;
2904 /* If the variable is not local in this buffer,
2905 we are saving the global value, so restore that. */
2906 if (NILP (Flocal_variable_p (symbol
, binding_buffer
)))
2907 binding_buffer
= Qnil
;
2909 = Fcons (symbol
, Fcons (binding_buffer
, current_buffer
));
2912 specpdl_ptr
->symbol
= symbol
;
2915 if (BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
))
2916 store_symval_forwarding (symbol
, ovalue
, value
);
2918 set_internal (symbol
, value
, 0, 1);
2923 record_unwind_protect (function
, arg
)
2924 Lisp_Object (*function
) P_ ((Lisp_Object
));
2927 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2929 specpdl_ptr
->func
= function
;
2930 specpdl_ptr
->symbol
= Qnil
;
2931 specpdl_ptr
->old_value
= arg
;
2936 unbind_to (count
, value
)
2940 int quitf
= !NILP (Vquit_flag
);
2941 struct gcpro gcpro1
;
2946 while (specpdl_ptr
!= specpdl
+ count
)
2950 if (specpdl_ptr
->func
!= 0)
2951 (*specpdl_ptr
->func
) (specpdl_ptr
->old_value
);
2952 /* Note that a "binding" of nil is really an unwind protect,
2953 so in that case the "old value" is a list of forms to evaluate. */
2954 else if (NILP (specpdl_ptr
->symbol
))
2955 Fprogn (specpdl_ptr
->old_value
);
2956 /* If the symbol is a list, it is really
2957 (SYMBOL BINDING_BUFFER . CURRENT_BUFFER)
2958 and it indicates we bound a variable that has
2959 buffer-local bindings. */
2960 else if (CONSP (specpdl_ptr
->symbol
))
2962 Lisp_Object symbol
, buffer
;
2964 symbol
= XCAR (specpdl_ptr
->symbol
);
2965 buffer
= XCAR (XCDR (specpdl_ptr
->symbol
));
2967 /* Handle restoring a default value. */
2969 Fset_default (symbol
, specpdl_ptr
->old_value
);
2970 /* Handle restoring a value saved from a live buffer. */
2972 set_internal (symbol
, specpdl_ptr
->old_value
, XBUFFER (buffer
), 1);
2976 /* If variable has a trivial value (no forwarding), we can
2977 just set it. No need to check for constant symbols here,
2978 since that was already done by specbind. */
2979 if (!MISCP (XSYMBOL (specpdl_ptr
->symbol
)->value
))
2980 XSYMBOL (specpdl_ptr
->symbol
)->value
= specpdl_ptr
->old_value
;
2982 set_internal (specpdl_ptr
->symbol
, specpdl_ptr
->old_value
, 0, 1);
2986 if (NILP (Vquit_flag
) && quitf
)
2995 /* Get the value of symbol's global binding, even if that binding
2996 is not now dynamically visible. */
2999 top_level_value (symbol
)
3002 register struct specbinding
*ptr
= specpdl
;
3004 CHECK_SYMBOL (symbol
, 0);
3005 for (; ptr
!= specpdl_ptr
; ptr
++)
3007 if (EQ (ptr
->symbol
, symbol
))
3008 return ptr
->old_value
;
3010 return Fsymbol_value (symbol
);
3014 top_level_set (symbol
, newval
)
3015 Lisp_Object symbol
, newval
;
3017 register struct specbinding
*ptr
= specpdl
;
3019 CHECK_SYMBOL (symbol
, 0);
3020 for (; ptr
!= specpdl_ptr
; ptr
++)
3022 if (EQ (ptr
->symbol
, symbol
))
3024 ptr
->old_value
= newval
;
3028 return Fset (symbol
, newval
);
3033 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
3034 "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\
3035 The debugger is entered when that frame exits, if the flag is non-nil.")
3037 Lisp_Object level
, flag
;
3039 register struct backtrace
*backlist
= backtrace_list
;
3042 CHECK_NUMBER (level
, 0);
3044 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
3046 backlist
= backlist
->next
;
3050 backlist
->debug_on_exit
= !NILP (flag
);
3055 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
3056 "Print a trace of Lisp function calls currently active.\n\
3057 Output stream used is value of `standard-output'.")
3060 register struct backtrace
*backlist
= backtrace_list
;
3064 extern Lisp_Object Vprint_level
;
3065 struct gcpro gcpro1
;
3067 XSETFASTINT (Vprint_level
, 3);
3074 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
3075 if (backlist
->nargs
== UNEVALLED
)
3077 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
3078 write_string ("\n", -1);
3082 tem
= *backlist
->function
;
3083 Fprin1 (tem
, Qnil
); /* This can QUIT */
3084 write_string ("(", -1);
3085 if (backlist
->nargs
== MANY
)
3087 for (tail
= *backlist
->args
, i
= 0;
3089 tail
= Fcdr (tail
), i
++)
3091 if (i
) write_string (" ", -1);
3092 Fprin1 (Fcar (tail
), Qnil
);
3097 for (i
= 0; i
< backlist
->nargs
; i
++)
3099 if (i
) write_string (" ", -1);
3100 Fprin1 (backlist
->args
[i
], Qnil
);
3103 write_string (")\n", -1);
3105 backlist
= backlist
->next
;
3108 Vprint_level
= Qnil
;
3113 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, "",
3114 "Return the function and arguments NFRAMES up from current execution point.\n\
3115 If that frame has not evaluated the arguments yet (or is a special form),\n\
3116 the value is (nil FUNCTION ARG-FORMS...).\n\
3117 If that frame has evaluated its arguments and called its function already,\n\
3118 the value is (t FUNCTION ARG-VALUES...).\n\
3119 A &rest arg is represented as the tail of the list ARG-VALUES.\n\
3120 FUNCTION is whatever was supplied as car of evaluated list,\n\
3121 or a lambda expression for macro calls.\n\
3122 If NFRAMES is more than the number of frames, the value is nil.")
3124 Lisp_Object nframes
;
3126 register struct backtrace
*backlist
= backtrace_list
;
3130 CHECK_NATNUM (nframes
, 0);
3132 /* Find the frame requested. */
3133 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
3134 backlist
= backlist
->next
;
3138 if (backlist
->nargs
== UNEVALLED
)
3139 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
3142 if (backlist
->nargs
== MANY
)
3143 tem
= *backlist
->args
;
3145 tem
= Flist (backlist
->nargs
, backlist
->args
);
3147 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
3155 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
3156 "*Limit on number of Lisp variable bindings & unwind-protects.\n\
3157 If Lisp code tries to make more than this many at once,\n\
3158 an error is signaled.");
3160 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
3161 "*Limit on depth in `eval', `apply' and `funcall' before error.\n\
3162 This limit is to catch infinite recursions for you before they cause\n\
3163 actual stack overflow in C, which would be fatal for Emacs.\n\
3164 You can safely make it considerably larger than its default value,\n\
3165 if that proves inconveniently small.");
3167 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
3168 "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
3169 Typing C-g sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
3172 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
3173 "Non-nil inhibits C-g quitting from happening immediately.\n\
3174 Note that `quit-flag' will still be set by typing C-g,\n\
3175 so a quit will be signaled as soon as `inhibit-quit' is nil.\n\
3176 To prevent this happening, set `quit-flag' to nil\n\
3177 before making `inhibit-quit' nil.");
3178 Vinhibit_quit
= Qnil
;
3180 Qinhibit_quit
= intern ("inhibit-quit");
3181 staticpro (&Qinhibit_quit
);
3183 Qautoload
= intern ("autoload");
3184 staticpro (&Qautoload
);
3186 Qdebug_on_error
= intern ("debug-on-error");
3187 staticpro (&Qdebug_on_error
);
3189 Qmacro
= intern ("macro");
3190 staticpro (&Qmacro
);
3192 /* Note that the process handling also uses Qexit, but we don't want
3193 to staticpro it twice, so we just do it here. */
3194 Qexit
= intern ("exit");
3197 Qinteractive
= intern ("interactive");
3198 staticpro (&Qinteractive
);
3200 Qcommandp
= intern ("commandp");
3201 staticpro (&Qcommandp
);
3203 Qdefun
= intern ("defun");
3204 staticpro (&Qdefun
);
3206 Qand_rest
= intern ("&rest");
3207 staticpro (&Qand_rest
);
3209 Qand_optional
= intern ("&optional");
3210 staticpro (&Qand_optional
);
3212 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
3213 "*Non-nil means automatically display a backtrace buffer\n\
3214 after any error that is handled by the editor command loop.\n\
3215 If the value is a list, an error only means to display a backtrace\n\
3216 if one of its condition symbols appears in the list.");
3217 Vstack_trace_on_error
= Qnil
;
3219 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
3220 "*Non-nil means enter debugger if an error is signaled.\n\
3221 Does not apply to errors handled by `condition-case'.\n\
3222 If the value is a list, an error only means to enter the debugger\n\
3223 if one of its condition symbols appears in the list.\n\
3224 See also variable `debug-on-quit'.");
3225 Vdebug_on_error
= Qnil
;
3227 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
3228 "*List of errors for which the debugger should not be called.\n\
3229 Each element may be a condition-name or a regexp that matches error messages.\n\
3230 If any element applies to a given error, that error skips the debugger\n\
3231 and just returns to top level.\n\
3232 This overrides the variable `debug-on-error'.\n\
3233 It does not apply to errors handled by `condition-case'.");
3234 Vdebug_ignored_errors
= Qnil
;
3236 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
3237 "*Non-nil means enter debugger if quit is signaled (C-g, for example).\n\
3238 Does not apply if quit is handled by a `condition-case'.");
3241 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
3242 "Non-nil means enter debugger before next `eval', `apply' or `funcall'.");
3244 DEFVAR_BOOL ("debugger-may-continue", &debugger_may_continue
,
3245 "Non-nil means debugger may continue execution.\n\
3246 This is nil when the debugger is called under circumstances where it\n\
3247 might not be safe to continue.");
3248 debugger_may_continue
= 1;
3250 DEFVAR_LISP ("debugger", &Vdebugger
,
3251 "Function to call to invoke debugger.\n\
3252 If due to frame exit, args are `exit' and the value being returned;\n\
3253 this function's value will be returned instead of that.\n\
3254 If due to error, args are `error' and a list of the args to `signal'.\n\
3255 If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
3256 If due to `eval' entry, one arg, t.");
3259 DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function
,
3260 "If non-nil, this is a function for `signal' to call.\n\
3261 It receives the same arguments that `signal' was given.\n\
3262 The Edebug package uses this to regain control.");
3263 Vsignal_hook_function
= Qnil
;
3265 Qmocklisp_arguments
= intern ("mocklisp-arguments");
3266 staticpro (&Qmocklisp_arguments
);
3267 DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments
,
3268 "While in a mocklisp function, the list of its unevaluated args.");
3269 Vmocklisp_arguments
= Qt
;
3271 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal
,
3272 "*Non-nil means call the debugger regardless of condition handlers.\n\
3273 Note that `debug-on-error', `debug-on-quit' and friends\n\
3274 still determine whether to handle the particular condition.");
3275 Vdebug_on_signal
= Qnil
;
3277 Vrun_hooks
= intern ("run-hooks");
3278 staticpro (&Vrun_hooks
);
3280 staticpro (&Vautoload_queue
);
3281 Vautoload_queue
= Qnil
;
3282 staticpro (&Vsignaling_function
);
3283 Vsignaling_function
= Qnil
;
3294 defsubr (&Sfunction
);
3296 defsubr (&Sdefmacro
);
3298 defsubr (&Sdefconst
);
3299 defsubr (&Suser_variable_p
);
3303 defsubr (&Smacroexpand
);
3306 defsubr (&Sunwind_protect
);
3307 defsubr (&Scondition_case
);
3309 defsubr (&Sinteractive_p
);
3310 defsubr (&Scommandp
);
3311 defsubr (&Sautoload
);
3314 defsubr (&Sfuncall
);
3315 defsubr (&Srun_hooks
);
3316 defsubr (&Srun_hook_with_args
);
3317 defsubr (&Srun_hook_with_args_until_success
);
3318 defsubr (&Srun_hook_with_args_until_failure
);
3319 defsubr (&Sfetch_bytecode
);
3320 defsubr (&Sbacktrace_debug
);
3321 defsubr (&Sbacktrace
);
3322 defsubr (&Sbacktrace_frame
);