1 /* Evaluator for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
29 #include "blockinput.h"
40 /* This definition is duplicated in alloc.c and keyboard.c */
41 /* Putting it in lisp.h makes cc bomb out! */
45 struct backtrace
*next
;
46 Lisp_Object
*function
;
47 Lisp_Object
*args
; /* Points to vector of args. */
48 int nargs
; /* Length of vector.
49 If nargs is UNEVALLED, args points to slot holding
50 list of unevalled args */
52 /* Nonzero means call value of debugger when done with this operation. */
56 struct backtrace
*backtrace_list
;
58 /* This structure helps implement the `catch' and `throw' control
59 structure. A struct catchtag contains all the information needed
60 to restore the state of the interpreter after a non-local jump.
62 Handlers for error conditions (represented by `struct handler'
63 structures) just point to a catch tag to do the cleanup required
66 catchtag structures are chained together in the C calling stack;
67 the `next' member points to the next outer catchtag.
69 A call like (throw TAG VAL) searches for a catchtag whose `tag'
70 member is TAG, and then unbinds to it. The `val' member is used to
71 hold VAL while the stack is unwound; `val' is returned as the value
74 All the other members are concerned with restoring the interpreter
80 struct catchtag
*next
;
83 struct backtrace
*backlist
;
84 struct handler
*handlerlist
;
87 int poll_suppress_count
;
90 struct catchtag
*catchlist
;
92 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
93 Lisp_Object Qinhibit_quit
, Vinhibit_quit
, Vquit_flag
;
94 Lisp_Object Qmocklisp_arguments
, Vmocklisp_arguments
, Qmocklisp
;
95 Lisp_Object Qand_rest
, Qand_optional
;
96 Lisp_Object Qdebug_on_error
;
98 /* This holds either the symbol `run-hooks' or nil.
99 It is nil at an early stage of startup, and when Emacs
101 Lisp_Object Vrun_hooks
;
103 /* Non-nil means record all fset's and provide's, to be undone
104 if the file being autoloaded is not fully loaded.
105 They are recorded by being consed onto the front of Vautoload_queue:
106 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */
108 Lisp_Object Vautoload_queue
;
110 /* Current number of specbindings allocated in specpdl. */
113 /* Pointer to beginning of specpdl. */
114 struct specbinding
*specpdl
;
116 /* Pointer to first unused element in specpdl. */
117 struct specbinding
*specpdl_ptr
;
119 /* Maximum size allowed for specpdl allocation */
120 int max_specpdl_size
;
122 /* Depth in Lisp evaluations and function calls. */
125 /* Maximum allowed depth in Lisp evaluations and function calls. */
126 int max_lisp_eval_depth
;
128 /* Nonzero means enter debugger before next function call */
129 int debug_on_next_call
;
131 /* List of conditions (non-nil atom means all) which cause a backtrace
132 if an error is handled by the command loop's error handler. */
133 Lisp_Object Vstack_trace_on_error
;
135 /* List of conditions (non-nil atom means all) which enter the debugger
136 if an error is handled by the command loop's error handler. */
137 Lisp_Object Vdebug_on_error
;
139 /* List of conditions and regexps specifying error messages which
140 do not enter the debugger even if Vdebug_on_errors says they should. */
141 Lisp_Object Vdebug_ignored_errors
;
143 /* Non-nil means call the debugger even if the error will be handled. */
144 Lisp_Object Vdebug_on_signal
;
146 /* Hook for edebug to use. */
147 Lisp_Object Vsignal_hook_function
;
149 /* Nonzero means enter debugger if a quit signal
150 is handled by the command loop's error handler. */
153 /* The value of num_nonmacro_input_events as of the last time we
154 started to enter the debugger. If we decide to enter the debugger
155 again when this is still equal to num_nonmacro_input_events, then we
156 know that the debugger itself has an error, and we should just
157 signal the error instead of entering an infinite loop of debugger
159 int when_entered_debugger
;
161 Lisp_Object Vdebugger
;
163 void specbind (), record_unwind_protect ();
165 Lisp_Object
run_hook_with_args ();
167 Lisp_Object
funcall_lambda ();
168 extern Lisp_Object
ml_apply (); /* Apply a mocklisp function to unevaluated argument list */
174 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
175 specpdl_ptr
= specpdl
;
176 max_specpdl_size
= 600;
177 max_lisp_eval_depth
= 300;
185 specpdl_ptr
= specpdl
;
190 debug_on_next_call
= 0;
192 /* This is less than the initial value of num_nonmacro_input_events. */
193 when_entered_debugger
= -1;
200 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
201 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
202 if (specpdl_size
+ 40 > max_specpdl_size
)
203 max_specpdl_size
= specpdl_size
+ 40;
204 debug_on_next_call
= 0;
205 when_entered_debugger
= num_nonmacro_input_events
;
206 return apply1 (Vdebugger
, arg
);
210 do_debug_on_call (code
)
213 debug_on_next_call
= 0;
214 backtrace_list
->debug_on_exit
= 1;
215 call_debugger (Fcons (code
, Qnil
));
218 /* NOTE!!! Every function that can call EVAL must protect its args
219 and temporaries from garbage collection while it needs them.
220 The definition of `For' shows what you have to do. */
222 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
223 "Eval args until one of them yields non-nil, then return that value.\n\
224 The remaining args are not evalled at all.\n\
225 If all args return nil, return nil.")
229 register Lisp_Object val
;
230 Lisp_Object args_left
;
241 val
= Feval (Fcar (args_left
));
244 args_left
= Fcdr (args_left
);
246 while (!NILP(args_left
));
252 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
253 "Eval args until one of them yields nil, then return nil.\n\
254 The remaining args are not evalled at all.\n\
255 If no arg yields nil, return the last arg's value.")
259 register Lisp_Object val
;
260 Lisp_Object args_left
;
271 val
= Feval (Fcar (args_left
));
274 args_left
= Fcdr (args_left
);
276 while (!NILP(args_left
));
282 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
283 "(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...\n\
284 Returns the value of THEN or the value of the last of the ELSE's.\n\
285 THEN must be one expression, but ELSE... can be zero or more expressions.\n\
286 If COND yields nil, and there are no ELSE's, the value is nil.")
290 register Lisp_Object cond
;
294 cond
= Feval (Fcar (args
));
298 return Feval (Fcar (Fcdr (args
)));
299 return Fprogn (Fcdr (Fcdr (args
)));
302 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
303 "(cond CLAUSES...): try each clause until one succeeds.\n\
304 Each clause looks like (CONDITION BODY...). CONDITION is evaluated\n\
305 and, if the value is non-nil, this clause succeeds:\n\
306 then the expressions in BODY are evaluated and the last one's\n\
307 value is the value of the cond-form.\n\
308 If no clause succeeds, cond returns nil.\n\
309 If a clause has one element, as in (CONDITION),\n\
310 CONDITION's value if non-nil is returned from the cond-form.")
314 register Lisp_Object clause
, val
;
321 clause
= Fcar (args
);
322 val
= Feval (Fcar (clause
));
325 if (!EQ (XCONS (clause
)->cdr
, Qnil
))
326 val
= Fprogn (XCONS (clause
)->cdr
);
329 args
= XCONS (args
)->cdr
;
336 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
337 "(progn BODY...): eval BODY forms sequentially and return value of last one.")
341 register Lisp_Object val
, tem
;
342 Lisp_Object args_left
;
345 /* In Mocklisp code, symbols at the front of the progn arglist
346 are to be bound to zero. */
347 if (!EQ (Vmocklisp_arguments
, Qt
))
349 val
= make_number (0);
350 while (!NILP (args
) && (tem
= Fcar (args
), SYMBOLP (tem
)))
353 specbind (tem
, val
), args
= Fcdr (args
);
365 val
= Feval (Fcar (args_left
));
366 args_left
= Fcdr (args_left
);
368 while (!NILP(args_left
));
374 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
375 "(prog1 FIRST BODY...): eval FIRST and BODY sequentially; value from FIRST.\n\
376 The value of FIRST is saved during the evaluation of the remaining args,\n\
377 whose values are discarded.")
382 register Lisp_Object args_left
;
383 struct gcpro gcpro1
, gcpro2
;
384 register int argnum
= 0;
396 val
= Feval (Fcar (args_left
));
398 Feval (Fcar (args_left
));
399 args_left
= Fcdr (args_left
);
401 while (!NILP(args_left
));
407 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
408 "(prog2 X Y BODY...): eval X, Y and BODY sequentially; value from Y.\n\
409 The value of Y is saved during the evaluation of the remaining args,\n\
410 whose values are discarded.")
415 register Lisp_Object args_left
;
416 struct gcpro gcpro1
, gcpro2
;
417 register int argnum
= -1;
431 val
= Feval (Fcar (args_left
));
433 Feval (Fcar (args_left
));
434 args_left
= Fcdr (args_left
);
436 while (!NILP (args_left
));
442 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
443 "(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.\n\
444 The symbols SYM are variables; they are literal (not evaluated).\n\
445 The values VAL are expressions; they are evaluated.\n\
446 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.\n\
447 The second VAL is not computed until after the first SYM is set, and so on;\n\
448 each VAL can use the new value of variables set earlier in the `setq'.\n\
449 The return value of the `setq' form is the value of the last VAL.")
453 register Lisp_Object args_left
;
454 register Lisp_Object val
, sym
;
465 val
= Feval (Fcar (Fcdr (args_left
)));
466 sym
= Fcar (args_left
);
468 args_left
= Fcdr (Fcdr (args_left
));
470 while (!NILP(args_left
));
476 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
477 "Return the argument, without evaluating it. `(quote x)' yields `x'.")
484 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
485 "Like `quote', but preferred for objects which are functions.\n\
486 In byte compilation, `function' causes its argument to be compiled.\n\
487 `quote' cannot do that.")
494 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
495 "Return t if function in which this appears was called interactively.\n\
496 This means that the function was called with call-interactively (which\n\
497 includes being called as the binding of a key)\n\
498 and input is currently coming from the keyboard (not in keyboard macro).")
501 register struct backtrace
*btp
;
502 register Lisp_Object fun
;
507 btp
= backtrace_list
;
509 /* If this isn't a byte-compiled function, there may be a frame at
510 the top for Finteractive_p itself. If so, skip it. */
511 fun
= Findirect_function (*btp
->function
);
512 if (SUBRP (fun
) && XSUBR (fun
) == &Sinteractive_p
)
515 /* If we're running an Emacs 18-style byte-compiled function, there
516 may be a frame for Fbytecode. Now, given the strictest
517 definition, this function isn't really being called
518 interactively, but because that's the way Emacs 18 always builds
519 byte-compiled functions, we'll accept it for now. */
520 if (EQ (*btp
->function
, Qbytecode
))
523 /* If this isn't a byte-compiled function, then we may now be
524 looking at several frames for special forms. Skip past them. */
526 btp
->nargs
== UNEVALLED
)
529 /* btp now points at the frame of the innermost function that isn't
530 a special form, ignoring frames for Finteractive_p and/or
531 Fbytecode at the top. If this frame is for a built-in function
532 (such as load or eval-region) return nil. */
533 fun
= Findirect_function (*btp
->function
);
536 /* btp points to the frame of a Lisp function that called interactive-p.
537 Return t if that function was called interactively. */
538 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
543 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
544 "(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.\n\
545 The definition is (lambda ARGLIST [DOCSTRING] BODY...).\n\
546 See also the function `interactive'.")
550 register Lisp_Object fn_name
;
551 register Lisp_Object defn
;
553 fn_name
= Fcar (args
);
554 defn
= Fcons (Qlambda
, Fcdr (args
));
555 if (!NILP (Vpurify_flag
))
556 defn
= Fpurecopy (defn
);
557 Ffset (fn_name
, defn
);
558 LOADHIST_ATTACH (fn_name
);
562 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
563 "(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.\n\
564 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).\n\
565 When the macro is called, as in (NAME ARGS...),\n\
566 the function (lambda ARGLIST BODY...) is applied to\n\
567 the list ARGS... as it appears in the expression,\n\
568 and the result should be a form to be evaluated instead of the original.")
572 register Lisp_Object fn_name
;
573 register Lisp_Object defn
;
575 fn_name
= Fcar (args
);
576 defn
= Fcons (Qmacro
, Fcons (Qlambda
, Fcdr (args
)));
577 if (!NILP (Vpurify_flag
))
578 defn
= Fpurecopy (defn
);
579 Ffset (fn_name
, defn
);
580 LOADHIST_ATTACH (fn_name
);
584 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
585 "(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.\n\
586 You are not required to define a variable in order to use it,\n\
587 but the definition can supply documentation and an initial value\n\
588 in a way that tags can recognize.\n\n\
589 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.\n\
590 If SYMBOL is buffer-local, its default value is what is set;\n\
591 buffer-local values are not affected.\n\
592 INITVALUE and DOCSTRING are optional.\n\
593 If DOCSTRING starts with *, this variable is identified as a user option.\n\
594 This means that M-x set-variable and M-x edit-options recognize it.\n\
595 If INITVALUE is missing, SYMBOL's value is not set.")
599 register Lisp_Object sym
, tem
, tail
;
603 if (!NILP (Fcdr (Fcdr (tail
))))
604 error ("too many arguments");
608 tem
= Fdefault_boundp (sym
);
610 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
612 tail
= Fcdr (Fcdr (args
));
613 if (!NILP (Fcar (tail
)))
616 if (!NILP (Vpurify_flag
))
617 tem
= Fpurecopy (tem
);
618 Fput (sym
, Qvariable_documentation
, tem
);
620 LOADHIST_ATTACH (sym
);
624 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
625 "(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant variable.\n\
626 The intent is that neither programs nor users should ever change this value.\n\
627 Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\
628 If SYMBOL is buffer-local, its default value is what is set;\n\
629 buffer-local values are not affected.\n\
630 DOCSTRING is optional.")
634 register Lisp_Object sym
, tem
;
637 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
638 error ("too many arguments");
640 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
641 tem
= Fcar (Fcdr (Fcdr (args
)));
644 if (!NILP (Vpurify_flag
))
645 tem
= Fpurecopy (tem
);
646 Fput (sym
, Qvariable_documentation
, tem
);
648 LOADHIST_ATTACH (sym
);
652 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
653 "Returns t if VARIABLE is intended to be set and modified by users.\n\
654 \(The alternative is a variable used internally in a Lisp program.)\n\
655 Determined by whether the first character of the documentation\n\
656 for the variable is `*'.")
658 Lisp_Object variable
;
660 Lisp_Object documentation
;
662 if (!SYMBOLP (variable
))
665 documentation
= Fget (variable
, Qvariable_documentation
);
666 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
668 if (STRINGP (documentation
)
669 && ((unsigned char) XSTRING (documentation
)->data
[0] == '*'))
671 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
672 if (CONSP (documentation
)
673 && STRINGP (XCONS (documentation
)->car
)
674 && INTEGERP (XCONS (documentation
)->cdr
)
675 && XINT (XCONS (documentation
)->cdr
) < 0)
680 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
681 "(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
682 The value of the last form in BODY is returned.\n\
683 Each element of VARLIST is a symbol (which is bound to nil)\n\
684 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
685 Each VALUEFORM can refer to the symbols already bound by this VARLIST.")
689 Lisp_Object varlist
, val
, elt
;
690 int count
= specpdl_ptr
- specpdl
;
691 struct gcpro gcpro1
, gcpro2
, gcpro3
;
693 GCPRO3 (args
, elt
, varlist
);
695 varlist
= Fcar (args
);
696 while (!NILP (varlist
))
699 elt
= Fcar (varlist
);
701 specbind (elt
, Qnil
);
702 else if (! NILP (Fcdr (Fcdr (elt
))))
704 Fcons (build_string ("`let' bindings can have only one value-form"),
708 val
= Feval (Fcar (Fcdr (elt
)));
709 specbind (Fcar (elt
), val
);
711 varlist
= Fcdr (varlist
);
714 val
= Fprogn (Fcdr (args
));
715 return unbind_to (count
, val
);
718 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
719 "(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
720 The value of the last form in BODY is returned.\n\
721 Each element of VARLIST is a symbol (which is bound to nil)\n\
722 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
723 All the VALUEFORMs are evalled before any symbols are bound.")
727 Lisp_Object
*temps
, tem
;
728 register Lisp_Object elt
, varlist
;
729 int count
= specpdl_ptr
- specpdl
;
731 struct gcpro gcpro1
, gcpro2
;
733 varlist
= Fcar (args
);
735 /* Make space to hold the values to give the bound variables */
736 elt
= Flength (varlist
);
737 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
739 /* Compute the values and store them in `temps' */
741 GCPRO2 (args
, *temps
);
744 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
747 elt
= Fcar (varlist
);
749 temps
[argnum
++] = Qnil
;
750 else if (! NILP (Fcdr (Fcdr (elt
))))
752 Fcons (build_string ("`let' bindings can have only one value-form"),
755 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
756 gcpro2
.nvars
= argnum
;
760 varlist
= Fcar (args
);
761 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
763 elt
= Fcar (varlist
);
764 tem
= temps
[argnum
++];
768 specbind (Fcar (elt
), tem
);
771 elt
= Fprogn (Fcdr (args
));
772 return unbind_to (count
, elt
);
775 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
776 "(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.\n\
777 The order of execution is thus TEST, BODY, TEST, BODY and so on\n\
778 until TEST returns nil.")
782 Lisp_Object test
, body
, tem
;
783 struct gcpro gcpro1
, gcpro2
;
789 while (tem
= Feval (test
),
790 (!EQ (Vmocklisp_arguments
, Qt
) ? XINT (tem
) : !NILP (tem
)))
800 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
801 "Return result of expanding macros at top level of FORM.\n\
802 If FORM is not a macro call, it is returned unchanged.\n\
803 Otherwise, the macro is expanded and the expansion is considered\n\
804 in place of FORM. When a non-macro-call results, it is returned.\n\n\
805 The second optional arg ENVIRONMENT species an environment of macro\n\
806 definitions to shadow the loaded ones for use in file byte-compilation.")
809 Lisp_Object environment
;
811 /* With cleanups from Hallvard Furuseth. */
812 register Lisp_Object expander
, sym
, def
, tem
;
816 /* Come back here each time we expand a macro call,
817 in case it expands into another macro call. */
820 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
821 def
= sym
= XCONS (form
)->car
;
823 /* Trace symbols aliases to other symbols
824 until we get a symbol that is not an alias. */
825 while (SYMBOLP (def
))
829 tem
= Fassq (sym
, environment
);
832 def
= XSYMBOL (sym
)->function
;
833 if (!EQ (def
, Qunbound
))
838 /* Right now TEM is the result from SYM in ENVIRONMENT,
839 and if TEM is nil then DEF is SYM's function definition. */
842 /* SYM is not mentioned in ENVIRONMENT.
843 Look at its function definition. */
844 if (EQ (def
, Qunbound
) || !CONSP (def
))
845 /* Not defined or definition not suitable */
847 if (EQ (XCONS (def
)->car
, Qautoload
))
849 /* Autoloading function: will it be a macro when loaded? */
850 tem
= Fnth (make_number (4), def
);
851 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
852 /* Yes, load it and try again. */
856 do_autoload (def
, sym
);
863 else if (!EQ (XCONS (def
)->car
, Qmacro
))
865 else expander
= XCONS (def
)->cdr
;
869 expander
= XCONS (tem
)->cdr
;
873 form
= apply1 (expander
, XCONS (form
)->cdr
);
878 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
879 "(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.\n\
880 TAG is evalled to get the tag to use; it must not be nil.\n\
882 Then the BODY is executed.\n\
883 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.\n\
884 If no throw happens, `catch' returns the value of the last BODY form.\n\
885 If a throw happens, it specifies the value to return from `catch'.")
889 register Lisp_Object tag
;
893 tag
= Feval (Fcar (args
));
895 return internal_catch (tag
, Fprogn
, Fcdr (args
));
898 /* Set up a catch, then call C function FUNC on argument ARG.
899 FUNC should return a Lisp_Object.
900 This is how catches are done from within C code. */
903 internal_catch (tag
, func
, arg
)
905 Lisp_Object (*func
) ();
908 /* This structure is made part of the chain `catchlist'. */
911 /* Fill in the components of c, and put it on the list. */
915 c
.backlist
= backtrace_list
;
916 c
.handlerlist
= handlerlist
;
917 c
.lisp_eval_depth
= lisp_eval_depth
;
918 c
.pdlcount
= specpdl_ptr
- specpdl
;
919 c
.poll_suppress_count
= poll_suppress_count
;
924 if (! _setjmp (c
.jmp
))
925 c
.val
= (*func
) (arg
);
927 /* Throw works by a longjmp that comes right here. */
932 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
933 jump to that CATCH, returning VALUE as the value of that catch.
935 This is the guts Fthrow and Fsignal; they differ only in the way
936 they choose the catch tag to throw to. A catch tag for a
937 condition-case form has a TAG of Qnil.
939 Before each catch is discarded, unbind all special bindings and
940 execute all unwind-protect clauses made above that catch. Unwind
941 the handler stack as we go, so that the proper handlers are in
942 effect for each unwind-protect clause we run. At the end, restore
943 some static info saved in CATCH, and longjmp to the location
946 This is used for correct unwinding in Fthrow and Fsignal. */
949 unwind_to_catch (catch, value
)
950 struct catchtag
*catch;
953 register int last_time
;
955 /* Save the value in the tag. */
958 /* Restore the polling-suppression count. */
959 set_poll_suppress_count (catch->poll_suppress_count
);
963 last_time
= catchlist
== catch;
965 /* Unwind the specpdl stack, and then restore the proper set of
967 unbind_to (catchlist
->pdlcount
, Qnil
);
968 handlerlist
= catchlist
->handlerlist
;
969 catchlist
= catchlist
->next
;
973 gcprolist
= catch->gcpro
;
974 backtrace_list
= catch->backlist
;
975 lisp_eval_depth
= catch->lisp_eval_depth
;
977 _longjmp (catch->jmp
, 1);
980 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
981 "(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.\n\
982 Both TAG and VALUE are evalled.")
984 register Lisp_Object tag
, value
;
986 register struct catchtag
*c
;
991 for (c
= catchlist
; c
; c
= c
->next
)
993 if (EQ (c
->tag
, tag
))
994 unwind_to_catch (c
, value
);
996 tag
= Fsignal (Qno_catch
, Fcons (tag
, Fcons (value
, Qnil
)));
1001 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1002 "Do BODYFORM, protecting with UNWINDFORMS.\n\
1003 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).\n\
1004 If BODYFORM completes normally, its value is returned\n\
1005 after executing the UNWINDFORMS.\n\
1006 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.")
1011 int count
= specpdl_ptr
- specpdl
;
1013 record_unwind_protect (0, Fcdr (args
));
1014 val
= Feval (Fcar (args
));
1015 return unbind_to (count
, val
);
1018 /* Chain of condition handlers currently in effect.
1019 The elements of this chain are contained in the stack frames
1020 of Fcondition_case and internal_condition_case.
1021 When an error is signaled (by calling Fsignal, below),
1022 this chain is searched for an element that applies. */
1024 struct handler
*handlerlist
;
1026 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1027 "Regain control when an error is signaled.\n\
1028 Usage looks like (condition-case VAR BODYFORM HANDLERS...).\n\
1029 executes BODYFORM and returns its value if no error happens.\n\
1030 Each element of HANDLERS looks like (CONDITION-NAME BODY...)\n\
1031 where the BODY is made of Lisp expressions.\n\n\
1032 A handler is applicable to an error\n\
1033 if CONDITION-NAME is one of the error's condition names.\n\
1034 If an error happens, the first applicable handler is run.\n\
1036 The car of a handler may be a list of condition names\n\
1037 instead of a single condition name.\n\
1039 When a handler handles an error,\n\
1040 control returns to the condition-case and the handler BODY... is executed\n\
1041 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\
1042 VAR may be nil; then you do not get access to the signal information.\n\
1044 The value of the last BODY form is returned from the condition-case.\n\
1045 See also the function `signal' for more info.")
1052 register Lisp_Object var
, bodyform
, handlers
;
1055 bodyform
= Fcar (Fcdr (args
));
1056 handlers
= Fcdr (Fcdr (args
));
1057 CHECK_SYMBOL (var
, 0);
1059 for (val
= handlers
; ! NILP (val
); val
= Fcdr (val
))
1065 && (SYMBOLP (XCONS (tem
)->car
)
1066 || CONSP (XCONS (tem
)->car
)))))
1067 error ("Invalid condition handler", tem
);
1072 c
.backlist
= backtrace_list
;
1073 c
.handlerlist
= handlerlist
;
1074 c
.lisp_eval_depth
= lisp_eval_depth
;
1075 c
.pdlcount
= specpdl_ptr
- specpdl
;
1076 c
.poll_suppress_count
= poll_suppress_count
;
1077 c
.gcpro
= gcprolist
;
1078 if (_setjmp (c
.jmp
))
1081 specbind (h
.var
, c
.val
);
1082 val
= Fprogn (Fcdr (h
.chosen_clause
));
1084 /* Note that this just undoes the binding of h.var; whoever
1085 longjumped to us unwound the stack to c.pdlcount before
1087 unbind_to (c
.pdlcount
, Qnil
);
1094 h
.handler
= handlers
;
1095 h
.next
= handlerlist
;
1099 val
= Feval (bodyform
);
1101 handlerlist
= h
.next
;
1105 /* Call the function BFUN with no arguments, catching errors within it
1106 according to HANDLERS. If there is an error, call HFUN with
1107 one argument which is the data that describes the error:
1110 HANDLERS can be a list of conditions to catch.
1111 If HANDLERS is Qt, catch all errors.
1112 If HANDLERS is Qerror, catch all errors
1113 but allow the debugger to run if that is enabled. */
1116 internal_condition_case (bfun
, handlers
, hfun
)
1117 Lisp_Object (*bfun
) ();
1118 Lisp_Object handlers
;
1119 Lisp_Object (*hfun
) ();
1125 /* Since Fsignal resets this to 0, it had better be 0 now
1126 or else we have a potential bug. */
1127 if (interrupt_input_blocked
!= 0)
1132 c
.backlist
= backtrace_list
;
1133 c
.handlerlist
= handlerlist
;
1134 c
.lisp_eval_depth
= lisp_eval_depth
;
1135 c
.pdlcount
= specpdl_ptr
- specpdl
;
1136 c
.poll_suppress_count
= poll_suppress_count
;
1137 c
.gcpro
= gcprolist
;
1138 if (_setjmp (c
.jmp
))
1140 return (*hfun
) (c
.val
);
1144 h
.handler
= handlers
;
1146 h
.next
= handlerlist
;
1152 handlerlist
= h
.next
;
1156 /* Like internal_condition_case but call HFUN with ARG as its argument. */
1159 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1160 Lisp_Object (*bfun
) ();
1162 Lisp_Object handlers
;
1163 Lisp_Object (*hfun
) ();
1171 c
.backlist
= backtrace_list
;
1172 c
.handlerlist
= handlerlist
;
1173 c
.lisp_eval_depth
= lisp_eval_depth
;
1174 c
.pdlcount
= specpdl_ptr
- specpdl
;
1175 c
.poll_suppress_count
= poll_suppress_count
;
1176 c
.gcpro
= gcprolist
;
1177 if (_setjmp (c
.jmp
))
1179 return (*hfun
) (c
.val
);
1183 h
.handler
= handlers
;
1185 h
.next
= handlerlist
;
1189 val
= (*bfun
) (arg
);
1191 handlerlist
= h
.next
;
1195 static Lisp_Object
find_handler_clause ();
1197 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1198 "Signal an error. Args are ERROR-SYMBOL and associated DATA.\n\
1199 This function does not return.\n\n\
1200 An error symbol is a symbol with an `error-conditions' property\n\
1201 that is a list of condition names.\n\
1202 A handler for any of those names will get to handle this signal.\n\
1203 The symbol `error' should normally be one of them.\n\
1205 DATA should be a list. Its elements are printed as part of the error message.\n\
1206 If the signal is handled, DATA is made available to the handler.\n\
1207 See also the function `condition-case'.")
1208 (error_symbol
, data
)
1209 Lisp_Object error_symbol
, data
;
1211 /* When memory is full, ERROR-SYMBOL is nil,
1212 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA). */
1213 register struct handler
*allhandlers
= handlerlist
;
1214 Lisp_Object conditions
;
1215 extern int gc_in_progress
;
1216 extern int waiting_for_input
;
1217 Lisp_Object debugger_value
;
1219 Lisp_Object real_error_symbol
;
1220 Lisp_Object combined_data
;
1221 extern int display_busy_cursor_p
;
1224 if (gc_in_progress
|| waiting_for_input
)
1227 TOTALLY_UNBLOCK_INPUT
;
1229 if (NILP (error_symbol
))
1230 real_error_symbol
= Fcar (data
);
1232 real_error_symbol
= error_symbol
;
1234 #ifdef HAVE_X_WINDOWS
1235 if (display_busy_cursor_p
)
1236 Fx_hide_busy_cursor (Qt
);
1239 /* This hook is used by edebug. */
1240 if (! NILP (Vsignal_hook_function
))
1241 call2 (Vsignal_hook_function
, error_symbol
, data
);
1243 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1245 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1247 register Lisp_Object clause
;
1248 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1249 error_symbol
, data
, &debugger_value
);
1251 #if 0 /* Most callers are not prepared to handle gc if this returns.
1252 So, since this feature is not very useful, take it out. */
1253 /* If have called debugger and user wants to continue,
1255 if (EQ (clause
, Qlambda
))
1256 return debugger_value
;
1258 if (EQ (clause
, Qlambda
))
1260 /* We can't return values to code which signaled an error, but we
1261 can continue code which has signaled a quit. */
1262 if (EQ (real_error_symbol
, Qquit
))
1265 error ("Cannot return from the debugger in an error");
1271 Lisp_Object unwind_data
;
1272 struct handler
*h
= handlerlist
;
1274 handlerlist
= allhandlers
;
1276 if (NILP (error_symbol
))
1279 unwind_data
= Fcons (error_symbol
, data
);
1280 h
->chosen_clause
= clause
;
1281 unwind_to_catch (h
->tag
, unwind_data
);
1285 handlerlist
= allhandlers
;
1286 /* If no handler is present now, try to run the debugger,
1287 and if that fails, throw to top level. */
1288 find_handler_clause (Qerror
, conditions
, error_symbol
, data
, &debugger_value
);
1290 Fthrow (Qtop_level
, Qt
);
1292 if (! NILP (error_symbol
))
1293 data
= Fcons (error_symbol
, data
);
1295 string
= Ferror_message_string (data
);
1296 fatal ("%s", XSTRING (string
)->data
, 0);
1299 /* Return nonzero iff LIST is a non-nil atom or
1300 a list containing one of CONDITIONS. */
1303 wants_debugger (list
, conditions
)
1304 Lisp_Object list
, conditions
;
1311 while (CONSP (conditions
))
1313 Lisp_Object
this, tail
;
1314 this = XCONS (conditions
)->car
;
1315 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1316 if (EQ (XCONS (tail
)->car
, this))
1318 conditions
= XCONS (conditions
)->cdr
;
1323 /* Return 1 if an error with condition-symbols CONDITIONS,
1324 and described by SIGNAL-DATA, should skip the debugger
1325 according to debugger-ignore-errors. */
1328 skip_debugger (conditions
, data
)
1329 Lisp_Object conditions
, data
;
1332 int first_string
= 1;
1333 Lisp_Object error_message
;
1335 for (tail
= Vdebug_ignored_errors
; CONSP (tail
);
1336 tail
= XCONS (tail
)->cdr
)
1338 if (STRINGP (XCONS (tail
)->car
))
1342 error_message
= Ferror_message_string (data
);
1345 if (fast_string_match (XCONS (tail
)->car
, error_message
) >= 0)
1350 Lisp_Object contail
;
1352 for (contail
= conditions
; CONSP (contail
);
1353 contail
= XCONS (contail
)->cdr
)
1354 if (EQ (XCONS (tail
)->car
, XCONS (contail
)->car
))
1362 /* Value of Qlambda means we have called debugger and user has continued.
1363 There are two ways to pass SIG and DATA:
1364 = SIG is the error symbol, and DATA is the rest of the data.
1365 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1366 This is for memory-full errors only.
1368 Store value returned from debugger into *DEBUGGER_VALUE_PTR. */
1371 find_handler_clause (handlers
, conditions
, sig
, data
, debugger_value_ptr
)
1372 Lisp_Object handlers
, conditions
, sig
, data
;
1373 Lisp_Object
*debugger_value_ptr
;
1375 register Lisp_Object h
;
1376 register Lisp_Object tem
;
1378 if (EQ (handlers
, Qt
)) /* t is used by handlers for all conditions, set up by C code. */
1380 /* error is used similarly, but means print an error message
1381 and run the debugger if that is enabled. */
1382 if (EQ (handlers
, Qerror
)
1383 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1384 there is a handler. */
1386 int count
= specpdl_ptr
- specpdl
;
1387 int debugger_called
= 0;
1388 Lisp_Object sig_symbol
, combined_data
;
1389 /* This is set to 1 if we are handling a memory-full error,
1390 because these must not run the debugger.
1391 (There is no room in memory to do that!) */
1392 int no_debugger
= 0;
1396 combined_data
= data
;
1397 sig_symbol
= Fcar (data
);
1402 combined_data
= Fcons (sig
, data
);
1406 if (wants_debugger (Vstack_trace_on_error
, conditions
))
1409 internal_with_output_to_temp_buffer ("*Backtrace*",
1410 (Lisp_Object (*) (Lisp_Object
)) Fbacktrace
,
1413 internal_with_output_to_temp_buffer ("*Backtrace*",
1418 && (EQ (sig_symbol
, Qquit
)
1420 : wants_debugger (Vdebug_on_error
, conditions
))
1421 && ! skip_debugger (conditions
, combined_data
)
1422 && when_entered_debugger
< num_nonmacro_input_events
)
1424 specbind (Qdebug_on_error
, Qnil
);
1426 = call_debugger (Fcons (Qerror
,
1427 Fcons (combined_data
, Qnil
)));
1428 debugger_called
= 1;
1430 /* If there is no handler, return saying whether we ran the debugger. */
1431 if (EQ (handlers
, Qerror
))
1433 if (debugger_called
)
1434 return unbind_to (count
, Qlambda
);
1438 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1440 Lisp_Object handler
, condit
;
1443 if (!CONSP (handler
))
1445 condit
= Fcar (handler
);
1446 /* Handle a single condition name in handler HANDLER. */
1447 if (SYMBOLP (condit
))
1449 tem
= Fmemq (Fcar (handler
), conditions
);
1453 /* Handle a list of condition names in handler HANDLER. */
1454 else if (CONSP (condit
))
1456 while (CONSP (condit
))
1458 tem
= Fmemq (Fcar (condit
), conditions
);
1461 condit
= XCONS (condit
)->cdr
;
1468 /* dump an error message; called like printf */
1472 error (m
, a1
, a2
, a3
)
1492 int used
= doprnt (buffer
, size
, m
, m
+ mlen
, 3, args
);
1497 buffer
= (char *) xrealloc (buffer
, size
);
1500 buffer
= (char *) xmalloc (size
);
1505 string
= build_string (buffer
);
1509 Fsignal (Qerror
, Fcons (string
, Qnil
));
1512 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 1, 0,
1513 "T if FUNCTION makes provisions for interactive calling.\n\
1514 This means it contains a description for how to read arguments to give it.\n\
1515 The value is nil for an invalid function or a symbol with no function\n\
1518 Interactively callable functions include strings and vectors (treated\n\
1519 as keyboard macros), lambda-expressions that contain a top-level call\n\
1520 to `interactive', autoload definitions made by `autoload' with non-nil\n\
1521 fourth argument, and some of the built-in functions of Lisp.\n\
1523 Also, a symbol satisfies `commandp' if its function definition does so.")
1525 Lisp_Object function
;
1527 register Lisp_Object fun
;
1528 register Lisp_Object funcar
;
1529 register Lisp_Object tem
;
1534 fun
= indirect_function (fun
);
1535 if (EQ (fun
, Qunbound
))
1538 /* Emacs primitives are interactive if their DEFUN specifies an
1539 interactive spec. */
1542 if (XSUBR (fun
)->prompt
)
1548 /* Bytecode objects are interactive if they are long enough to
1549 have an element whose index is COMPILED_INTERACTIVE, which is
1550 where the interactive spec is stored. */
1551 else if (COMPILEDP (fun
))
1552 return ((XVECTOR (fun
)->size
& PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
1555 /* Strings and vectors are keyboard macros. */
1556 if (STRINGP (fun
) || VECTORP (fun
))
1559 /* Lists may represent commands. */
1562 funcar
= Fcar (fun
);
1563 if (!SYMBOLP (funcar
))
1564 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1565 if (EQ (funcar
, Qlambda
))
1566 return Fassq (Qinteractive
, Fcdr (Fcdr (fun
)));
1567 if (EQ (funcar
, Qmocklisp
))
1568 return Qt
; /* All mocklisp functions can be called interactively */
1569 if (EQ (funcar
, Qautoload
))
1570 return Fcar (Fcdr (Fcdr (Fcdr (fun
))));
1576 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1577 "Define FUNCTION to autoload from FILE.\n\
1578 FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\
1579 Third arg DOCSTRING is documentation for the function.\n\
1580 Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\
1581 Fifth arg TYPE indicates the type of the object:\n\
1582 nil or omitted says FUNCTION is a function,\n\
1583 `keymap' says FUNCTION is really a keymap, and\n\
1584 `macro' or t says FUNCTION is really a macro.\n\
1585 Third through fifth args give info about the real definition.\n\
1586 They default to nil.\n\
1587 If FUNCTION is already defined other than as an autoload,\n\
1588 this does nothing and returns nil.")
1589 (function
, file
, docstring
, interactive
, type
)
1590 Lisp_Object function
, file
, docstring
, interactive
, type
;
1593 Lisp_Object args
[4];
1596 CHECK_SYMBOL (function
, 0);
1597 CHECK_STRING (file
, 1);
1599 /* If function is defined and not as an autoload, don't override */
1600 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
1601 && !(CONSP (XSYMBOL (function
)->function
)
1602 && EQ (XCONS (XSYMBOL (function
)->function
)->car
, Qautoload
)))
1607 args
[1] = docstring
;
1608 args
[2] = interactive
;
1611 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
1612 #else /* NO_ARG_ARRAY */
1613 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
1614 #endif /* not NO_ARG_ARRAY */
1618 un_autoload (oldqueue
)
1619 Lisp_Object oldqueue
;
1621 register Lisp_Object queue
, first
, second
;
1623 /* Queue to unwind is current value of Vautoload_queue.
1624 oldqueue is the shadowed value to leave in Vautoload_queue. */
1625 queue
= Vautoload_queue
;
1626 Vautoload_queue
= oldqueue
;
1627 while (CONSP (queue
))
1629 first
= Fcar (queue
);
1630 second
= Fcdr (first
);
1631 first
= Fcar (first
);
1632 if (EQ (second
, Qnil
))
1635 Ffset (first
, second
);
1636 queue
= Fcdr (queue
);
1641 /* Load an autoloaded function.
1642 FUNNAME is the symbol which is the function's name.
1643 FUNDEF is the autoload definition (a list). */
1646 do_autoload (fundef
, funname
)
1647 Lisp_Object fundef
, funname
;
1649 int count
= specpdl_ptr
- specpdl
;
1650 Lisp_Object fun
, val
, queue
, first
, second
;
1651 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1654 CHECK_SYMBOL (funname
, 0);
1655 GCPRO3 (fun
, funname
, fundef
);
1657 /* Preserve the match data. */
1658 record_unwind_protect (Fset_match_data
, Fmatch_data (Qnil
, Qnil
));
1660 /* Value saved here is to be restored into Vautoload_queue. */
1661 record_unwind_protect (un_autoload
, Vautoload_queue
);
1662 Vautoload_queue
= Qt
;
1663 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
, Qt
);
1665 /* Save the old autoloads, in case we ever do an unload. */
1666 queue
= Vautoload_queue
;
1667 while (CONSP (queue
))
1669 first
= Fcar (queue
);
1670 second
= Fcdr (first
);
1671 first
= Fcar (first
);
1673 /* Note: This test is subtle. The cdr of an autoload-queue entry
1674 may be an atom if the autoload entry was generated by a defalias
1677 Fput (first
, Qautoload
, (Fcdr (second
)));
1679 queue
= Fcdr (queue
);
1682 /* Once loading finishes, don't undo it. */
1683 Vautoload_queue
= Qt
;
1684 unbind_to (count
, Qnil
);
1686 fun
= Findirect_function (fun
);
1688 if (!NILP (Fequal (fun
, fundef
)))
1689 error ("Autoloading failed to define function %s",
1690 XSYMBOL (funname
)->name
->data
);
1694 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
1695 "Evaluate FORM and return its value.")
1699 Lisp_Object fun
, val
, original_fun
, original_args
;
1701 struct backtrace backtrace
;
1702 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1704 /* Since Fsignal resets this to 0, it had better be 0 now
1705 or else we have a potential bug. */
1706 if (interrupt_input_blocked
!= 0)
1711 if (EQ (Vmocklisp_arguments
, Qt
))
1712 return Fsymbol_value (form
);
1713 val
= Fsymbol_value (form
);
1715 XSETFASTINT (val
, 0);
1716 else if (EQ (val
, Qt
))
1717 XSETFASTINT (val
, 1);
1724 if (consing_since_gc
> gc_cons_threshold
)
1727 Fgarbage_collect ();
1731 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1733 if (max_lisp_eval_depth
< 100)
1734 max_lisp_eval_depth
= 100;
1735 if (lisp_eval_depth
> max_lisp_eval_depth
)
1736 error ("Lisp nesting exceeds max-lisp-eval-depth");
1739 original_fun
= Fcar (form
);
1740 original_args
= Fcdr (form
);
1742 backtrace
.next
= backtrace_list
;
1743 backtrace_list
= &backtrace
;
1744 backtrace
.function
= &original_fun
; /* This also protects them from gc */
1745 backtrace
.args
= &original_args
;
1746 backtrace
.nargs
= UNEVALLED
;
1747 backtrace
.evalargs
= 1;
1748 backtrace
.debug_on_exit
= 0;
1750 if (debug_on_next_call
)
1751 do_debug_on_call (Qt
);
1753 /* At this point, only original_fun and original_args
1754 have values that will be used below */
1756 fun
= Findirect_function (original_fun
);
1760 Lisp_Object numargs
;
1761 Lisp_Object argvals
[8];
1762 Lisp_Object args_left
;
1763 register int i
, maxargs
;
1765 args_left
= original_args
;
1766 numargs
= Flength (args_left
);
1768 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
1769 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
1770 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1772 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1774 backtrace
.evalargs
= 0;
1775 val
= (*XSUBR (fun
)->function
) (args_left
);
1779 if (XSUBR (fun
)->max_args
== MANY
)
1781 /* Pass a vector of evaluated arguments */
1783 register int argnum
= 0;
1785 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1787 GCPRO3 (args_left
, fun
, fun
);
1791 while (!NILP (args_left
))
1793 vals
[argnum
++] = Feval (Fcar (args_left
));
1794 args_left
= Fcdr (args_left
);
1795 gcpro3
.nvars
= argnum
;
1798 backtrace
.args
= vals
;
1799 backtrace
.nargs
= XINT (numargs
);
1801 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
1806 GCPRO3 (args_left
, fun
, fun
);
1807 gcpro3
.var
= argvals
;
1810 maxargs
= XSUBR (fun
)->max_args
;
1811 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
1813 argvals
[i
] = Feval (Fcar (args_left
));
1819 backtrace
.args
= argvals
;
1820 backtrace
.nargs
= XINT (numargs
);
1825 val
= (*XSUBR (fun
)->function
) ();
1828 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
1831 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
1834 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1838 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1839 argvals
[2], argvals
[3]);
1842 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1843 argvals
[3], argvals
[4]);
1846 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1847 argvals
[3], argvals
[4], argvals
[5]);
1850 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1851 argvals
[3], argvals
[4], argvals
[5],
1856 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1857 argvals
[3], argvals
[4], argvals
[5],
1858 argvals
[6], argvals
[7]);
1862 /* Someone has created a subr that takes more arguments than
1863 is supported by this code. We need to either rewrite the
1864 subr to use a different argument protocol, or add more
1865 cases to this switch. */
1869 if (COMPILEDP (fun
))
1870 val
= apply_lambda (fun
, original_args
, 1);
1874 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1875 funcar
= Fcar (fun
);
1876 if (!SYMBOLP (funcar
))
1877 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1878 if (EQ (funcar
, Qautoload
))
1880 do_autoload (fun
, original_fun
);
1883 if (EQ (funcar
, Qmacro
))
1884 val
= Feval (apply1 (Fcdr (fun
), original_args
));
1885 else if (EQ (funcar
, Qlambda
))
1886 val
= apply_lambda (fun
, original_args
, 1);
1887 else if (EQ (funcar
, Qmocklisp
))
1888 val
= ml_apply (fun
, original_args
);
1890 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1893 if (!EQ (Vmocklisp_arguments
, Qt
))
1896 XSETFASTINT (val
, 0);
1897 else if (EQ (val
, Qt
))
1898 XSETFASTINT (val
, 1);
1901 if (backtrace
.debug_on_exit
)
1902 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
1903 backtrace_list
= backtrace
.next
;
1907 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
1908 "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
1909 Then return the value FUNCTION returns.\n\
1910 Thus, (apply '+ 1 2 '(3 4)) returns 10.")
1915 register int i
, numargs
;
1916 register Lisp_Object spread_arg
;
1917 register Lisp_Object
*funcall_args
;
1919 struct gcpro gcpro1
;
1923 spread_arg
= args
[nargs
- 1];
1924 CHECK_LIST (spread_arg
, nargs
);
1926 numargs
= XINT (Flength (spread_arg
));
1929 return Ffuncall (nargs
- 1, args
);
1930 else if (numargs
== 1)
1932 args
[nargs
- 1] = XCONS (spread_arg
)->car
;
1933 return Ffuncall (nargs
, args
);
1936 numargs
+= nargs
- 2;
1938 fun
= indirect_function (fun
);
1939 if (EQ (fun
, Qunbound
))
1941 /* Let funcall get the error */
1948 if (numargs
< XSUBR (fun
)->min_args
1949 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
1950 goto funcall
; /* Let funcall get the error */
1951 else if (XSUBR (fun
)->max_args
> numargs
)
1953 /* Avoid making funcall cons up a yet another new vector of arguments
1954 by explicitly supplying nil's for optional values */
1955 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
1956 * sizeof (Lisp_Object
));
1957 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
1958 funcall_args
[++i
] = Qnil
;
1959 GCPRO1 (*funcall_args
);
1960 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
1964 /* We add 1 to numargs because funcall_args includes the
1965 function itself as well as its arguments. */
1968 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
1969 * sizeof (Lisp_Object
));
1970 GCPRO1 (*funcall_args
);
1971 gcpro1
.nvars
= 1 + numargs
;
1974 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
1975 /* Spread the last arg we got. Its first element goes in
1976 the slot that it used to occupy, hence this value of I. */
1978 while (!NILP (spread_arg
))
1980 funcall_args
[i
++] = XCONS (spread_arg
)->car
;
1981 spread_arg
= XCONS (spread_arg
)->cdr
;
1984 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
1987 /* Run hook variables in various ways. */
1989 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
1991 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 1, MANY
, 0,
1992 "Run each hook in HOOKS. Major mode functions use this.\n\
1993 Each argument should be a symbol, a hook variable.\n\
1994 These symbols are processed in the order specified.\n\
1995 If a hook symbol has a non-nil value, that value may be a function\n\
1996 or a list of functions to be called to run the hook.\n\
1997 If the value is a function, it is called with no arguments.\n\
1998 If it is a list, the elements are called, in order, with no arguments.\n\
2000 To make a hook variable buffer-local, use `make-local-hook',\n\
2001 not `make-local-variable'.")
2006 Lisp_Object hook
[1];
2009 for (i
= 0; i
< nargs
; i
++)
2012 run_hook_with_args (1, hook
, to_completion
);
2018 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2019 Srun_hook_with_args
, 1, MANY
, 0,
2020 "Run HOOK with the specified arguments ARGS.\n\
2021 HOOK should be a symbol, a hook variable. If HOOK has a non-nil\n\
2022 value, that value may be a function or a list of functions to be\n\
2023 called to run the hook. If the value is a function, it is called with\n\
2024 the given arguments and its return value is returned. If it is a list\n\
2025 of functions, those functions are called, in order,\n\
2026 with the given arguments ARGS.\n\
2027 It is best not to depend on the value return by `run-hook-with-args',\n\
2028 as that may change.\n\
2030 To make a hook variable buffer-local, use `make-local-hook',\n\
2031 not `make-local-variable'.")
2036 return run_hook_with_args (nargs
, args
, to_completion
);
2039 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2040 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2041 "Run HOOK with the specified arguments ARGS.\n\
2042 HOOK should be a symbol, a hook variable. Its value should\n\
2043 be a list of functions. We call those functions, one by one,\n\
2044 passing arguments ARGS to each of them, until one of them\n\
2045 returns a non-nil value. Then we return that value.\n\
2046 If all the functions return nil, we return nil.\n\
2048 To make a hook variable buffer-local, use `make-local-hook',\n\
2049 not `make-local-variable'.")
2054 return run_hook_with_args (nargs
, args
, until_success
);
2057 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2058 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2059 "Run HOOK with the specified arguments ARGS.\n\
2060 HOOK should be a symbol, a hook variable. Its value should\n\
2061 be a list of functions. We call those functions, one by one,\n\
2062 passing arguments ARGS to each of them, until one of them\n\
2063 returns nil. Then we return nil.\n\
2064 If all the functions return non-nil, we return non-nil.\n\
2066 To make a hook variable buffer-local, use `make-local-hook',\n\
2067 not `make-local-variable'.")
2072 return run_hook_with_args (nargs
, args
, until_failure
);
2075 /* ARGS[0] should be a hook symbol.
2076 Call each of the functions in the hook value, passing each of them
2077 as arguments all the rest of ARGS (all NARGS - 1 elements).
2078 COND specifies a condition to test after each call
2079 to decide whether to stop.
2080 The caller (or its caller, etc) must gcpro all of ARGS,
2081 except that it isn't necessary to gcpro ARGS[0]. */
2084 run_hook_with_args (nargs
, args
, cond
)
2087 enum run_hooks_condition cond
;
2089 Lisp_Object sym
, val
, ret
;
2090 Lisp_Object globals
;
2091 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2093 /* If we are dying or still initializing,
2094 don't do anything--it would probably crash if we tried. */
2095 if (NILP (Vrun_hooks
))
2099 val
= find_symbol_value (sym
);
2100 ret
= (cond
== until_failure
? Qt
: Qnil
);
2102 if (EQ (val
, Qunbound
) || NILP (val
))
2104 else if (!CONSP (val
) || EQ (XCONS (val
)->car
, Qlambda
))
2107 return Ffuncall (nargs
, args
);
2112 GCPRO3 (sym
, val
, globals
);
2115 CONSP (val
) && ((cond
== to_completion
)
2116 || (cond
== until_success
? NILP (ret
)
2118 val
= XCONS (val
)->cdr
)
2120 if (EQ (XCONS (val
)->car
, Qt
))
2122 /* t indicates this hook has a local binding;
2123 it means to run the global binding too. */
2125 for (globals
= Fdefault_value (sym
);
2126 CONSP (globals
) && ((cond
== to_completion
)
2127 || (cond
== until_success
? NILP (ret
)
2129 globals
= XCONS (globals
)->cdr
)
2131 args
[0] = XCONS (globals
)->car
;
2132 /* In a global value, t should not occur. If it does, we
2133 must ignore it to avoid an endless loop. */
2134 if (!EQ (args
[0], Qt
))
2135 ret
= Ffuncall (nargs
, args
);
2140 args
[0] = XCONS (val
)->car
;
2141 ret
= Ffuncall (nargs
, args
);
2150 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2151 present value of that symbol.
2152 Call each element of FUNLIST,
2153 passing each of them the rest of ARGS.
2154 The caller (or its caller, etc) must gcpro all of ARGS,
2155 except that it isn't necessary to gcpro ARGS[0]. */
2158 run_hook_list_with_args (funlist
, nargs
, args
)
2159 Lisp_Object funlist
;
2165 Lisp_Object globals
;
2166 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2170 GCPRO3 (sym
, val
, globals
);
2172 for (val
= funlist
; CONSP (val
); val
= XCONS (val
)->cdr
)
2174 if (EQ (XCONS (val
)->car
, Qt
))
2176 /* t indicates this hook has a local binding;
2177 it means to run the global binding too. */
2179 for (globals
= Fdefault_value (sym
);
2181 globals
= XCONS (globals
)->cdr
)
2183 args
[0] = XCONS (globals
)->car
;
2184 /* In a global value, t should not occur. If it does, we
2185 must ignore it to avoid an endless loop. */
2186 if (!EQ (args
[0], Qt
))
2187 Ffuncall (nargs
, args
);
2192 args
[0] = XCONS (val
)->car
;
2193 Ffuncall (nargs
, args
);
2200 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2203 run_hook_with_args_2 (hook
, arg1
, arg2
)
2204 Lisp_Object hook
, arg1
, arg2
;
2206 Lisp_Object temp
[3];
2211 Frun_hook_with_args (3, temp
);
2214 /* Apply fn to arg */
2217 Lisp_Object fn
, arg
;
2219 struct gcpro gcpro1
;
2223 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2227 Lisp_Object args
[2];
2231 RETURN_UNGCPRO (Fapply (2, args
));
2233 #else /* not NO_ARG_ARRAY */
2234 RETURN_UNGCPRO (Fapply (2, &fn
));
2235 #endif /* not NO_ARG_ARRAY */
2238 /* Call function fn on no arguments */
2243 struct gcpro gcpro1
;
2246 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2249 /* Call function fn with 1 argument arg1 */
2253 Lisp_Object fn
, arg1
;
2255 struct gcpro gcpro1
;
2257 Lisp_Object args
[2];
2263 RETURN_UNGCPRO (Ffuncall (2, args
));
2264 #else /* not NO_ARG_ARRAY */
2267 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2268 #endif /* not NO_ARG_ARRAY */
2271 /* Call function fn with 2 arguments arg1, arg2 */
2274 call2 (fn
, arg1
, arg2
)
2275 Lisp_Object fn
, arg1
, arg2
;
2277 struct gcpro gcpro1
;
2279 Lisp_Object args
[3];
2285 RETURN_UNGCPRO (Ffuncall (3, args
));
2286 #else /* not NO_ARG_ARRAY */
2289 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2290 #endif /* not NO_ARG_ARRAY */
2293 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2296 call3 (fn
, arg1
, arg2
, arg3
)
2297 Lisp_Object fn
, arg1
, arg2
, arg3
;
2299 struct gcpro gcpro1
;
2301 Lisp_Object args
[4];
2308 RETURN_UNGCPRO (Ffuncall (4, args
));
2309 #else /* not NO_ARG_ARRAY */
2312 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2313 #endif /* not NO_ARG_ARRAY */
2316 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2319 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2320 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2322 struct gcpro gcpro1
;
2324 Lisp_Object args
[5];
2332 RETURN_UNGCPRO (Ffuncall (5, args
));
2333 #else /* not NO_ARG_ARRAY */
2336 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2337 #endif /* not NO_ARG_ARRAY */
2340 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2343 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2344 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2346 struct gcpro gcpro1
;
2348 Lisp_Object args
[6];
2357 RETURN_UNGCPRO (Ffuncall (6, args
));
2358 #else /* not NO_ARG_ARRAY */
2361 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2362 #endif /* not NO_ARG_ARRAY */
2365 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2368 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2369 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2371 struct gcpro gcpro1
;
2373 Lisp_Object args
[7];
2383 RETURN_UNGCPRO (Ffuncall (7, args
));
2384 #else /* not NO_ARG_ARRAY */
2387 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2388 #endif /* not NO_ARG_ARRAY */
2391 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2392 "Call first argument as a function, passing remaining arguments to it.\n\
2393 Return the value that function returns.\n\
2394 Thus, (funcall 'cons 'x 'y) returns (x . y).")
2401 int numargs
= nargs
- 1;
2402 Lisp_Object lisp_numargs
;
2404 struct backtrace backtrace
;
2405 register Lisp_Object
*internal_args
;
2409 if (consing_since_gc
> gc_cons_threshold
)
2410 Fgarbage_collect ();
2412 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2414 if (max_lisp_eval_depth
< 100)
2415 max_lisp_eval_depth
= 100;
2416 if (lisp_eval_depth
> max_lisp_eval_depth
)
2417 error ("Lisp nesting exceeds max-lisp-eval-depth");
2420 backtrace
.next
= backtrace_list
;
2421 backtrace_list
= &backtrace
;
2422 backtrace
.function
= &args
[0];
2423 backtrace
.args
= &args
[1];
2424 backtrace
.nargs
= nargs
- 1;
2425 backtrace
.evalargs
= 0;
2426 backtrace
.debug_on_exit
= 0;
2428 if (debug_on_next_call
)
2429 do_debug_on_call (Qlambda
);
2435 fun
= Findirect_function (fun
);
2439 if (numargs
< XSUBR (fun
)->min_args
2440 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2442 XSETFASTINT (lisp_numargs
, numargs
);
2443 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (lisp_numargs
, Qnil
)));
2446 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2447 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2449 if (XSUBR (fun
)->max_args
== MANY
)
2451 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
2455 if (XSUBR (fun
)->max_args
> numargs
)
2457 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2458 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
2459 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2460 internal_args
[i
] = Qnil
;
2463 internal_args
= args
+ 1;
2464 switch (XSUBR (fun
)->max_args
)
2467 val
= (*XSUBR (fun
)->function
) ();
2470 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
2473 val
= (*XSUBR (fun
)->function
) (internal_args
[0],
2477 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2481 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2486 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2487 internal_args
[2], internal_args
[3],
2491 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2492 internal_args
[2], internal_args
[3],
2493 internal_args
[4], internal_args
[5]);
2496 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2497 internal_args
[2], internal_args
[3],
2498 internal_args
[4], internal_args
[5],
2503 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2504 internal_args
[2], internal_args
[3],
2505 internal_args
[4], internal_args
[5],
2506 internal_args
[6], internal_args
[7]);
2511 /* If a subr takes more than 8 arguments without using MANY
2512 or UNEVALLED, we need to extend this function to support it.
2513 Until this is done, there is no way to call the function. */
2517 if (COMPILEDP (fun
))
2518 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2522 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2523 funcar
= Fcar (fun
);
2524 if (!SYMBOLP (funcar
))
2525 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2526 if (EQ (funcar
, Qlambda
))
2527 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2528 else if (EQ (funcar
, Qmocklisp
))
2529 val
= ml_apply (fun
, Flist (numargs
, args
+ 1));
2530 else if (EQ (funcar
, Qautoload
))
2532 do_autoload (fun
, args
[0]);
2536 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2540 if (backtrace
.debug_on_exit
)
2541 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2542 backtrace_list
= backtrace
.next
;
2547 apply_lambda (fun
, args
, eval_flag
)
2548 Lisp_Object fun
, args
;
2551 Lisp_Object args_left
;
2552 Lisp_Object numargs
;
2553 register Lisp_Object
*arg_vector
;
2554 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2556 register Lisp_Object tem
;
2558 numargs
= Flength (args
);
2559 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2562 GCPRO3 (*arg_vector
, args_left
, fun
);
2565 for (i
= 0; i
< XINT (numargs
);)
2567 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2568 if (eval_flag
) tem
= Feval (tem
);
2569 arg_vector
[i
++] = tem
;
2577 backtrace_list
->args
= arg_vector
;
2578 backtrace_list
->nargs
= i
;
2580 backtrace_list
->evalargs
= 0;
2581 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
2583 /* Do the debug-on-exit now, while arg_vector still exists. */
2584 if (backtrace_list
->debug_on_exit
)
2585 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
2586 /* Don't do it again when we return to eval. */
2587 backtrace_list
->debug_on_exit
= 0;
2591 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2592 and return the result of evaluation.
2593 FUN must be either a lambda-expression or a compiled-code object. */
2596 funcall_lambda (fun
, nargs
, arg_vector
)
2599 register Lisp_Object
*arg_vector
;
2601 Lisp_Object val
, tem
;
2602 register Lisp_Object syms_left
;
2603 Lisp_Object numargs
;
2604 register Lisp_Object next
;
2605 int count
= specpdl_ptr
- specpdl
;
2607 int optional
= 0, rest
= 0;
2609 specbind (Qmocklisp_arguments
, Qt
); /* t means NOT mocklisp! */
2611 XSETFASTINT (numargs
, nargs
);
2614 syms_left
= Fcar (Fcdr (fun
));
2615 else if (COMPILEDP (fun
))
2616 syms_left
= XVECTOR (fun
)->contents
[COMPILED_ARGLIST
];
2620 for (; !NILP (syms_left
); syms_left
= Fcdr (syms_left
))
2623 next
= Fcar (syms_left
);
2624 while (!SYMBOLP (next
))
2625 next
= Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2626 if (EQ (next
, Qand_rest
))
2628 else if (EQ (next
, Qand_optional
))
2632 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
2637 tem
= arg_vector
[i
++];
2638 specbind (next
, tem
);
2641 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2643 specbind (next
, Qnil
);
2647 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2650 val
= Fprogn (Fcdr (Fcdr (fun
)));
2653 /* If we have not actually read the bytecode string
2654 and constants vector yet, fetch them from the file. */
2655 if (CONSP (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
]))
2656 Ffetch_bytecode (fun
);
2657 val
= Fbyte_code (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
],
2658 XVECTOR (fun
)->contents
[COMPILED_CONSTANTS
],
2659 XVECTOR (fun
)->contents
[COMPILED_STACK_DEPTH
]);
2661 return unbind_to (count
, val
);
2664 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
2666 "If byte-compiled OBJECT is lazy-loaded, fetch it now.")
2672 if (COMPILEDP (object
)
2673 && CONSP (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]))
2675 tem
= read_doc_string (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]);
2677 error ("invalid byte code");
2678 XVECTOR (object
)->contents
[COMPILED_BYTECODE
] = XCONS (tem
)->car
;
2679 XVECTOR (object
)->contents
[COMPILED_CONSTANTS
] = XCONS (tem
)->cdr
;
2687 register int count
= specpdl_ptr
- specpdl
;
2688 if (specpdl_size
>= max_specpdl_size
)
2690 if (max_specpdl_size
< 400)
2691 max_specpdl_size
= 400;
2692 if (specpdl_size
>= max_specpdl_size
)
2694 if (!NILP (Vdebug_on_error
))
2695 /* Leave room for some specpdl in the debugger. */
2696 max_specpdl_size
= specpdl_size
+ 100;
2698 Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil
));
2702 if (specpdl_size
> max_specpdl_size
)
2703 specpdl_size
= max_specpdl_size
;
2704 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
2705 specpdl_ptr
= specpdl
+ count
;
2709 specbind (symbol
, value
)
2710 Lisp_Object symbol
, value
;
2714 CHECK_SYMBOL (symbol
, 0);
2716 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2718 specpdl_ptr
->symbol
= symbol
;
2719 specpdl_ptr
->func
= 0;
2720 specpdl_ptr
->old_value
= ovalue
= find_symbol_value (symbol
);
2722 if (BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
))
2723 store_symval_forwarding (symbol
, ovalue
, value
);
2725 set_internal (symbol
, value
, 1);
2729 record_unwind_protect (function
, arg
)
2730 Lisp_Object (*function
) P_ ((Lisp_Object
));
2733 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2735 specpdl_ptr
->func
= function
;
2736 specpdl_ptr
->symbol
= Qnil
;
2737 specpdl_ptr
->old_value
= arg
;
2742 unbind_to (count
, value
)
2746 int quitf
= !NILP (Vquit_flag
);
2747 struct gcpro gcpro1
;
2753 while (specpdl_ptr
!= specpdl
+ count
)
2756 if (specpdl_ptr
->func
!= 0)
2757 (*specpdl_ptr
->func
) (specpdl_ptr
->old_value
);
2758 /* Note that a "binding" of nil is really an unwind protect,
2759 so in that case the "old value" is a list of forms to evaluate. */
2760 else if (NILP (specpdl_ptr
->symbol
))
2761 Fprogn (specpdl_ptr
->old_value
);
2763 set_internal (specpdl_ptr
->symbol
, specpdl_ptr
->old_value
, 1);
2765 if (NILP (Vquit_flag
) && quitf
) Vquit_flag
= Qt
;
2774 /* Get the value of symbol's global binding, even if that binding
2775 is not now dynamically visible. */
2778 top_level_value (symbol
)
2781 register struct specbinding
*ptr
= specpdl
;
2783 CHECK_SYMBOL (symbol
, 0);
2784 for (; ptr
!= specpdl_ptr
; ptr
++)
2786 if (EQ (ptr
->symbol
, symbol
))
2787 return ptr
->old_value
;
2789 return Fsymbol_value (symbol
);
2793 top_level_set (symbol
, newval
)
2794 Lisp_Object symbol
, newval
;
2796 register struct specbinding
*ptr
= specpdl
;
2798 CHECK_SYMBOL (symbol
, 0);
2799 for (; ptr
!= specpdl_ptr
; ptr
++)
2801 if (EQ (ptr
->symbol
, symbol
))
2803 ptr
->old_value
= newval
;
2807 return Fset (symbol
, newval
);
2812 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
2813 "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\
2814 The debugger is entered when that frame exits, if the flag is non-nil.")
2816 Lisp_Object level
, flag
;
2818 register struct backtrace
*backlist
= backtrace_list
;
2821 CHECK_NUMBER (level
, 0);
2823 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
2825 backlist
= backlist
->next
;
2829 backlist
->debug_on_exit
= !NILP (flag
);
2834 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
2835 "Print a trace of Lisp function calls currently active.\n\
2836 Output stream used is value of `standard-output'.")
2839 register struct backtrace
*backlist
= backtrace_list
;
2843 extern Lisp_Object Vprint_level
;
2844 struct gcpro gcpro1
;
2846 XSETFASTINT (Vprint_level
, 3);
2853 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
2854 if (backlist
->nargs
== UNEVALLED
)
2856 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
2857 write_string ("\n", -1);
2861 tem
= *backlist
->function
;
2862 Fprin1 (tem
, Qnil
); /* This can QUIT */
2863 write_string ("(", -1);
2864 if (backlist
->nargs
== MANY
)
2866 for (tail
= *backlist
->args
, i
= 0;
2868 tail
= Fcdr (tail
), i
++)
2870 if (i
) write_string (" ", -1);
2871 Fprin1 (Fcar (tail
), Qnil
);
2876 for (i
= 0; i
< backlist
->nargs
; i
++)
2878 if (i
) write_string (" ", -1);
2879 Fprin1 (backlist
->args
[i
], Qnil
);
2882 write_string (")\n", -1);
2884 backlist
= backlist
->next
;
2887 Vprint_level
= Qnil
;
2892 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, "",
2893 "Return the function and arguments NFRAMES up from current execution point.\n\
2894 If that frame has not evaluated the arguments yet (or is a special form),\n\
2895 the value is (nil FUNCTION ARG-FORMS...).\n\
2896 If that frame has evaluated its arguments and called its function already,\n\
2897 the value is (t FUNCTION ARG-VALUES...).\n\
2898 A &rest arg is represented as the tail of the list ARG-VALUES.\n\
2899 FUNCTION is whatever was supplied as car of evaluated list,\n\
2900 or a lambda expression for macro calls.\n\
2901 If NFRAMES is more than the number of frames, the value is nil.")
2903 Lisp_Object nframes
;
2905 register struct backtrace
*backlist
= backtrace_list
;
2909 CHECK_NATNUM (nframes
, 0);
2911 /* Find the frame requested. */
2912 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
2913 backlist
= backlist
->next
;
2917 if (backlist
->nargs
== UNEVALLED
)
2918 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
2921 if (backlist
->nargs
== MANY
)
2922 tem
= *backlist
->args
;
2924 tem
= Flist (backlist
->nargs
, backlist
->args
);
2926 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
2933 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
2934 "*Limit on number of Lisp variable bindings & unwind-protects.\n\
2935 If Lisp code tries to make more than this many at once,\n\
2936 an error is signaled.");
2938 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
2939 "*Limit on depth in `eval', `apply' and `funcall' before error.\n\
2940 This limit is to catch infinite recursions for you before they cause\n\
2941 actual stack overflow in C, which would be fatal for Emacs.\n\
2942 You can safely make it considerably larger than its default value,\n\
2943 if that proves inconveniently small.");
2945 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
2946 "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
2947 Typing C-g sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
2950 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
2951 "Non-nil inhibits C-g quitting from happening immediately.\n\
2952 Note that `quit-flag' will still be set by typing C-g,\n\
2953 so a quit will be signaled as soon as `inhibit-quit' is nil.\n\
2954 To prevent this happening, set `quit-flag' to nil\n\
2955 before making `inhibit-quit' nil.");
2956 Vinhibit_quit
= Qnil
;
2958 Qinhibit_quit
= intern ("inhibit-quit");
2959 staticpro (&Qinhibit_quit
);
2961 Qautoload
= intern ("autoload");
2962 staticpro (&Qautoload
);
2964 Qdebug_on_error
= intern ("debug-on-error");
2965 staticpro (&Qdebug_on_error
);
2967 Qmacro
= intern ("macro");
2968 staticpro (&Qmacro
);
2970 /* Note that the process handling also uses Qexit, but we don't want
2971 to staticpro it twice, so we just do it here. */
2972 Qexit
= intern ("exit");
2975 Qinteractive
= intern ("interactive");
2976 staticpro (&Qinteractive
);
2978 Qcommandp
= intern ("commandp");
2979 staticpro (&Qcommandp
);
2981 Qdefun
= intern ("defun");
2982 staticpro (&Qdefun
);
2984 Qand_rest
= intern ("&rest");
2985 staticpro (&Qand_rest
);
2987 Qand_optional
= intern ("&optional");
2988 staticpro (&Qand_optional
);
2990 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
2991 "*Non-nil means automatically display a backtrace buffer\n\
2992 after any error that is handled by the editor command loop.\n\
2993 If the value is a list, an error only means to display a backtrace\n\
2994 if one of its condition symbols appears in the list.");
2995 Vstack_trace_on_error
= Qnil
;
2997 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
2998 "*Non-nil means enter debugger if an error is signaled.\n\
2999 Does not apply to errors handled by `condition-case'.\n\
3000 If the value is a list, an error only means to enter the debugger\n\
3001 if one of its condition symbols appears in the list.\n\
3002 See also variable `debug-on-quit'.");
3003 Vdebug_on_error
= Qnil
;
3005 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
3006 "*List of errors for which the debugger should not be called.\n\
3007 Each element may be a condition-name or a regexp that matches error messages.\n\
3008 If any element applies to a given error, that error skips the debugger\n\
3009 and just returns to top level.\n\
3010 This overrides the variable `debug-on-error'.\n\
3011 It does not apply to errors handled by `condition-case'.");
3012 Vdebug_ignored_errors
= Qnil
;
3014 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
3015 "*Non-nil means enter debugger if quit is signaled (C-g, for example).\n\
3016 Does not apply if quit is handled by a `condition-case'.");
3019 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
3020 "Non-nil means enter debugger before next `eval', `apply' or `funcall'.");
3022 DEFVAR_LISP ("debugger", &Vdebugger
,
3023 "Function to call to invoke debugger.\n\
3024 If due to frame exit, args are `exit' and the value being returned;\n\
3025 this function's value will be returned instead of that.\n\
3026 If due to error, args are `error' and a list of the args to `signal'.\n\
3027 If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
3028 If due to `eval' entry, one arg, t.");
3031 DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function
,
3032 "If non-nil, this is a function for `signal' to call.\n\
3033 It receives the same arguments that `signal' was given.\n\
3034 The Edebug package uses this to regain control.");
3035 Vsignal_hook_function
= Qnil
;
3037 Qmocklisp_arguments
= intern ("mocklisp-arguments");
3038 staticpro (&Qmocklisp_arguments
);
3039 DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments
,
3040 "While in a mocklisp function, the list of its unevaluated args.");
3041 Vmocklisp_arguments
= Qt
;
3043 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal
,
3044 "*Non-nil means call the debugger regardless of condition handlers.\n\
3045 Note that `debug-on-error', `debug-on-quit' and friends\n\
3046 still determine whether to handle the particular condition.");
3047 Vdebug_on_signal
= Qnil
;
3049 Vrun_hooks
= intern ("run-hooks");
3050 staticpro (&Vrun_hooks
);
3052 staticpro (&Vautoload_queue
);
3053 Vautoload_queue
= Qnil
;
3064 defsubr (&Sfunction
);
3066 defsubr (&Sdefmacro
);
3068 defsubr (&Sdefconst
);
3069 defsubr (&Suser_variable_p
);
3073 defsubr (&Smacroexpand
);
3076 defsubr (&Sunwind_protect
);
3077 defsubr (&Scondition_case
);
3079 defsubr (&Sinteractive_p
);
3080 defsubr (&Scommandp
);
3081 defsubr (&Sautoload
);
3084 defsubr (&Sfuncall
);
3085 defsubr (&Srun_hooks
);
3086 defsubr (&Srun_hook_with_args
);
3087 defsubr (&Srun_hook_with_args_until_success
);
3088 defsubr (&Srun_hook_with_args_until_failure
);
3089 defsubr (&Sfetch_bytecode
);
3090 defsubr (&Sbacktrace_debug
);
3091 defsubr (&Sbacktrace
);
3092 defsubr (&Sbacktrace_frame
);