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. */
24 #include "blockinput.h"
35 /* This definition is duplicated in alloc.c and keyboard.c */
36 /* Putting it in lisp.h makes cc bomb out! */
40 struct backtrace
*next
;
41 Lisp_Object
*function
;
42 Lisp_Object
*args
; /* Points to vector of args. */
43 int nargs
; /* Length of vector.
44 If nargs is UNEVALLED, args points to slot holding
45 list of unevalled args */
47 /* Nonzero means call value of debugger when done with this operation. */
51 struct backtrace
*backtrace_list
;
53 /* This structure helps implement the `catch' and `throw' control
54 structure. A struct catchtag contains all the information needed
55 to restore the state of the interpreter after a non-local jump.
57 Handlers for error conditions (represented by `struct handler'
58 structures) just point to a catch tag to do the cleanup required
61 catchtag structures are chained together in the C calling stack;
62 the `next' member points to the next outer catchtag.
64 A call like (throw TAG VAL) searches for a catchtag whose `tag'
65 member is TAG, and then unbinds to it. The `val' member is used to
66 hold VAL while the stack is unwound; `val' is returned as the value
69 All the other members are concerned with restoring the interpreter
75 struct catchtag
*next
;
78 struct backtrace
*backlist
;
79 struct handler
*handlerlist
;
82 int poll_suppress_count
;
85 struct catchtag
*catchlist
;
87 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
88 Lisp_Object Qinhibit_quit
, Vinhibit_quit
, Vquit_flag
;
89 Lisp_Object Qmocklisp_arguments
, Vmocklisp_arguments
, Qmocklisp
;
90 Lisp_Object Qand_rest
, Qand_optional
;
91 Lisp_Object Qdebug_on_error
;
93 /* This holds either the symbol `run-hooks' or nil.
94 It is nil at an early stage of startup, and when Emacs
96 Lisp_Object Vrun_hooks
;
98 /* Non-nil means record all fset's and provide's, to be undone
99 if the file being autoloaded is not fully loaded.
100 They are recorded by being consed onto the front of Vautoload_queue:
101 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */
103 Lisp_Object Vautoload_queue
;
105 /* Current number of specbindings allocated in specpdl. */
108 /* Pointer to beginning of specpdl. */
109 struct specbinding
*specpdl
;
111 /* Pointer to first unused element in specpdl. */
112 struct specbinding
*specpdl_ptr
;
114 /* Maximum size allowed for specpdl allocation */
115 int max_specpdl_size
;
117 /* Depth in Lisp evaluations and function calls. */
120 /* Maximum allowed depth in Lisp evaluations and function calls. */
121 int max_lisp_eval_depth
;
123 /* Nonzero means enter debugger before next function call */
124 int debug_on_next_call
;
126 /* List of conditions (non-nil atom means all) which cause a backtrace
127 if an error is handled by the command loop's error handler. */
128 Lisp_Object Vstack_trace_on_error
;
130 /* List of conditions (non-nil atom means all) which enter the debugger
131 if an error is handled by the command loop's error handler. */
132 Lisp_Object Vdebug_on_error
;
134 /* List of conditions and regexps specifying error messages which
135 do not enter the debugger even if Vdebug_on_errors says they should. */
136 Lisp_Object Vdebug_ignored_errors
;
138 /* Non-nil means call the debugger even if the error will be handled. */
139 Lisp_Object Vdebug_on_signal
;
141 /* Hook for edebug to use. */
142 Lisp_Object Vsignal_hook_function
;
144 /* Nonzero means enter debugger if a quit signal
145 is handled by the command loop's error handler. */
148 /* The value of num_nonmacro_input_events as of the last time we
149 started to enter the debugger. If we decide to enter the debugger
150 again when this is still equal to num_nonmacro_input_events, then we
151 know that the debugger itself has an error, and we should just
152 signal the error instead of entering an infinite loop of debugger
154 int when_entered_debugger
;
156 Lisp_Object Vdebugger
;
158 void specbind (), record_unwind_protect ();
160 Lisp_Object
run_hook_with_args ();
162 Lisp_Object
funcall_lambda ();
163 extern Lisp_Object
ml_apply (); /* Apply a mocklisp function to unevaluated argument list */
168 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
169 specpdl_ptr
= specpdl
;
170 max_specpdl_size
= 600;
171 max_lisp_eval_depth
= 300;
178 specpdl_ptr
= specpdl
;
183 debug_on_next_call
= 0;
185 /* This is less than the initial value of num_nonmacro_input_events. */
186 when_entered_debugger
= -1;
193 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
194 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
195 if (specpdl_size
+ 40 > max_specpdl_size
)
196 max_specpdl_size
= specpdl_size
+ 40;
197 debug_on_next_call
= 0;
198 when_entered_debugger
= num_nonmacro_input_events
;
199 return apply1 (Vdebugger
, arg
);
202 do_debug_on_call (code
)
205 debug_on_next_call
= 0;
206 backtrace_list
->debug_on_exit
= 1;
207 call_debugger (Fcons (code
, Qnil
));
210 /* NOTE!!! Every function that can call EVAL must protect its args
211 and temporaries from garbage collection while it needs them.
212 The definition of `For' shows what you have to do. */
214 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
215 "Eval args until one of them yields non-nil, then return that value.\n\
216 The remaining args are not evalled at all.\n\
217 If all args return nil, return nil.")
221 register Lisp_Object val
;
222 Lisp_Object args_left
;
233 val
= Feval (Fcar (args_left
));
236 args_left
= Fcdr (args_left
);
238 while (!NILP(args_left
));
244 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
245 "Eval args until one of them yields nil, then return nil.\n\
246 The remaining args are not evalled at all.\n\
247 If no arg yields nil, return the last arg's value.")
251 register Lisp_Object val
;
252 Lisp_Object args_left
;
263 val
= Feval (Fcar (args_left
));
266 args_left
= Fcdr (args_left
);
268 while (!NILP(args_left
));
274 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
275 "(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...\n\
276 Returns the value of THEN or the value of the last of the ELSE's.\n\
277 THEN must be one expression, but ELSE... can be zero or more expressions.\n\
278 If COND yields nil, and there are no ELSE's, the value is nil.")
282 register Lisp_Object cond
;
286 cond
= Feval (Fcar (args
));
290 return Feval (Fcar (Fcdr (args
)));
291 return Fprogn (Fcdr (Fcdr (args
)));
294 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
295 "(cond CLAUSES...): try each clause until one succeeds.\n\
296 Each clause looks like (CONDITION BODY...). CONDITION is evaluated\n\
297 and, if the value is non-nil, this clause succeeds:\n\
298 then the expressions in BODY are evaluated and the last one's\n\
299 value is the value of the cond-form.\n\
300 If no clause succeeds, cond returns nil.\n\
301 If a clause has one element, as in (CONDITION),\n\
302 CONDITION's value if non-nil is returned from the cond-form.")
306 register Lisp_Object clause
, val
;
313 clause
= Fcar (args
);
314 val
= Feval (Fcar (clause
));
317 if (!EQ (XCONS (clause
)->cdr
, Qnil
))
318 val
= Fprogn (XCONS (clause
)->cdr
);
321 args
= XCONS (args
)->cdr
;
328 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
329 "(progn BODY...): eval BODY forms sequentially and return value of last one.")
333 register Lisp_Object val
, tem
;
334 Lisp_Object args_left
;
337 /* In Mocklisp code, symbols at the front of the progn arglist
338 are to be bound to zero. */
339 if (!EQ (Vmocklisp_arguments
, Qt
))
341 val
= make_number (0);
342 while (!NILP (args
) && (tem
= Fcar (args
), SYMBOLP (tem
)))
345 specbind (tem
, val
), args
= Fcdr (args
);
357 val
= Feval (Fcar (args_left
));
358 args_left
= Fcdr (args_left
);
360 while (!NILP(args_left
));
366 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
367 "(prog1 FIRST BODY...): eval FIRST and BODY sequentially; value from FIRST.\n\
368 The value of FIRST is saved during the evaluation of the remaining args,\n\
369 whose values are discarded.")
374 register Lisp_Object args_left
;
375 struct gcpro gcpro1
, gcpro2
;
376 register int argnum
= 0;
388 val
= Feval (Fcar (args_left
));
390 Feval (Fcar (args_left
));
391 args_left
= Fcdr (args_left
);
393 while (!NILP(args_left
));
399 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
400 "(prog2 X Y BODY...): eval X, Y and BODY sequentially; value from Y.\n\
401 The value of Y is saved during the evaluation of the remaining args,\n\
402 whose values are discarded.")
407 register Lisp_Object args_left
;
408 struct gcpro gcpro1
, gcpro2
;
409 register int argnum
= -1;
423 val
= Feval (Fcar (args_left
));
425 Feval (Fcar (args_left
));
426 args_left
= Fcdr (args_left
);
428 while (!NILP (args_left
));
434 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
435 "(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.\n\
436 The symbols SYM are variables; they are literal (not evaluated).\n\
437 The values VAL are expressions; they are evaluated.\n\
438 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.\n\
439 The second VAL is not computed until after the first SYM is set, and so on;\n\
440 each VAL can use the new value of variables set earlier in the `setq'.\n\
441 The return value of the `setq' form is the value of the last VAL.")
445 register Lisp_Object args_left
;
446 register Lisp_Object val
, sym
;
457 val
= Feval (Fcar (Fcdr (args_left
)));
458 sym
= Fcar (args_left
);
460 args_left
= Fcdr (Fcdr (args_left
));
462 while (!NILP(args_left
));
468 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
469 "Return the argument, without evaluating it. `(quote x)' yields `x'.")
476 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
477 "Like `quote', but preferred for objects which are functions.\n\
478 In byte compilation, `function' causes its argument to be compiled.\n\
479 `quote' cannot do that.")
486 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
487 "Return t if function in which this appears was called interactively.\n\
488 This means that the function was called with call-interactively (which\n\
489 includes being called as the binding of a key)\n\
490 and input is currently coming from the keyboard (not in keyboard macro).")
493 register struct backtrace
*btp
;
494 register Lisp_Object fun
;
499 btp
= backtrace_list
;
501 /* If this isn't a byte-compiled function, there may be a frame at
502 the top for Finteractive_p itself. If so, skip it. */
503 fun
= Findirect_function (*btp
->function
);
504 if (SUBRP (fun
) && XSUBR (fun
) == &Sinteractive_p
)
507 /* If we're running an Emacs 18-style byte-compiled function, there
508 may be a frame for Fbytecode. Now, given the strictest
509 definition, this function isn't really being called
510 interactively, but because that's the way Emacs 18 always builds
511 byte-compiled functions, we'll accept it for now. */
512 if (EQ (*btp
->function
, Qbytecode
))
515 /* If this isn't a byte-compiled function, then we may now be
516 looking at several frames for special forms. Skip past them. */
518 btp
->nargs
== UNEVALLED
)
521 /* btp now points at the frame of the innermost function that isn't
522 a special form, ignoring frames for Finteractive_p and/or
523 Fbytecode at the top. If this frame is for a built-in function
524 (such as load or eval-region) return nil. */
525 fun
= Findirect_function (*btp
->function
);
528 /* btp points to the frame of a Lisp function that called interactive-p.
529 Return t if that function was called interactively. */
530 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
535 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
536 "(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.\n\
537 The definition is (lambda ARGLIST [DOCSTRING] BODY...).\n\
538 See also the function `interactive'.")
542 register Lisp_Object fn_name
;
543 register Lisp_Object defn
;
545 fn_name
= Fcar (args
);
546 defn
= Fcons (Qlambda
, Fcdr (args
));
547 if (!NILP (Vpurify_flag
))
548 defn
= Fpurecopy (defn
);
549 Ffset (fn_name
, defn
);
550 LOADHIST_ATTACH (fn_name
);
554 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
555 "(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.\n\
556 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).\n\
557 When the macro is called, as in (NAME ARGS...),\n\
558 the function (lambda ARGLIST BODY...) is applied to\n\
559 the list ARGS... as it appears in the expression,\n\
560 and the result should be a form to be evaluated instead of the original.")
564 register Lisp_Object fn_name
;
565 register Lisp_Object defn
;
567 fn_name
= Fcar (args
);
568 defn
= Fcons (Qmacro
, Fcons (Qlambda
, Fcdr (args
)));
569 if (!NILP (Vpurify_flag
))
570 defn
= Fpurecopy (defn
);
571 Ffset (fn_name
, defn
);
572 LOADHIST_ATTACH (fn_name
);
576 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
577 "(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.\n\
578 You are not required to define a variable in order to use it,\n\
579 but the definition can supply documentation and an initial value\n\
580 in a way that tags can recognize.\n\n\
581 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.\n\
582 If SYMBOL is buffer-local, its default value is what is set;\n\
583 buffer-local values are not affected.\n\
584 INITVALUE and DOCSTRING are optional.\n\
585 If DOCSTRING starts with *, this variable is identified as a user option.\n\
586 This means that M-x set-variable and M-x edit-options recognize it.\n\
587 If INITVALUE is missing, SYMBOL's value is not set.")
591 register Lisp_Object sym
, tem
, tail
;
595 if (!NILP (Fcdr (Fcdr (tail
))))
596 error ("too many arguments");
600 tem
= Fdefault_boundp (sym
);
602 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
604 tail
= Fcdr (Fcdr (args
));
605 if (!NILP (Fcar (tail
)))
608 if (!NILP (Vpurify_flag
))
609 tem
= Fpurecopy (tem
);
610 Fput (sym
, Qvariable_documentation
, tem
);
612 LOADHIST_ATTACH (sym
);
616 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
617 "(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant variable.\n\
618 The intent is that programs do not change this value, but users may.\n\
619 Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\
620 If SYMBOL is buffer-local, its default value is what is set;\n\
621 buffer-local values are not affected.\n\
622 DOCSTRING is optional.\n\
623 If DOCSTRING starts with *, this variable is identified as a user option.\n\
624 This means that M-x set-variable and M-x edit-options recognize it.\n\n\
625 Note: do not use `defconst' for user options in libraries that are not\n\
626 normally loaded, since it is useful for users to be able to specify\n\
627 their own values for such variables before loading the library.\n\
628 Since `defconst' unconditionally assigns the variable,\n\
629 it would override the user's choice.")
633 register Lisp_Object sym
, tem
;
636 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
637 error ("too many arguments");
639 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
640 tem
= Fcar (Fcdr (Fcdr (args
)));
643 if (!NILP (Vpurify_flag
))
644 tem
= Fpurecopy (tem
);
645 Fput (sym
, Qvariable_documentation
, tem
);
647 LOADHIST_ATTACH (sym
);
651 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
652 "Returns t if VARIABLE is intended to be set and modified by users.\n\
653 \(The alternative is a variable used internally in a Lisp program.)\n\
654 Determined by whether the first character of the documentation\n\
655 for the variable is `*'.")
657 Lisp_Object variable
;
659 Lisp_Object documentation
;
661 if (!SYMBOLP (variable
))
664 documentation
= Fget (variable
, Qvariable_documentation
);
665 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
667 if (STRINGP (documentation
)
668 && ((unsigned char) XSTRING (documentation
)->data
[0] == '*'))
670 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
671 if (CONSP (documentation
)
672 && STRINGP (XCONS (documentation
)->car
)
673 && INTEGERP (XCONS (documentation
)->cdr
)
674 && XINT (XCONS (documentation
)->cdr
) < 0)
679 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
680 "(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
681 The value of the last form in BODY is returned.\n\
682 Each element of VARLIST is a symbol (which is bound to nil)\n\
683 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
684 Each VALUEFORM can refer to the symbols already bound by this VARLIST.")
688 Lisp_Object varlist
, val
, elt
;
689 int count
= specpdl_ptr
- specpdl
;
690 struct gcpro gcpro1
, gcpro2
, gcpro3
;
692 GCPRO3 (args
, elt
, varlist
);
694 varlist
= Fcar (args
);
695 while (!NILP (varlist
))
698 elt
= Fcar (varlist
);
700 specbind (elt
, Qnil
);
701 else if (! NILP (Fcdr (Fcdr (elt
))))
703 Fcons (build_string ("`let' bindings can have only one value-form"),
707 val
= Feval (Fcar (Fcdr (elt
)));
708 specbind (Fcar (elt
), val
);
710 varlist
= Fcdr (varlist
);
713 val
= Fprogn (Fcdr (args
));
714 return unbind_to (count
, val
);
717 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
718 "(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
719 The value of the last form in BODY is returned.\n\
720 Each element of VARLIST is a symbol (which is bound to nil)\n\
721 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
722 All the VALUEFORMs are evalled before any symbols are bound.")
726 Lisp_Object
*temps
, tem
;
727 register Lisp_Object elt
, varlist
;
728 int count
= specpdl_ptr
- specpdl
;
730 struct gcpro gcpro1
, gcpro2
;
732 varlist
= Fcar (args
);
734 /* Make space to hold the values to give the bound variables */
735 elt
= Flength (varlist
);
736 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
738 /* Compute the values and store them in `temps' */
740 GCPRO2 (args
, *temps
);
743 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
746 elt
= Fcar (varlist
);
748 temps
[argnum
++] = Qnil
;
749 else if (! NILP (Fcdr (Fcdr (elt
))))
751 Fcons (build_string ("`let' bindings can have only one value-form"),
754 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
755 gcpro2
.nvars
= argnum
;
759 varlist
= Fcar (args
);
760 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
762 elt
= Fcar (varlist
);
763 tem
= temps
[argnum
++];
767 specbind (Fcar (elt
), tem
);
770 elt
= Fprogn (Fcdr (args
));
771 return unbind_to (count
, elt
);
774 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
775 "(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.\n\
776 The order of execution is thus TEST, BODY, TEST, BODY and so on\n\
777 until TEST returns nil.")
781 Lisp_Object test
, body
, tem
;
782 struct gcpro gcpro1
, gcpro2
;
788 while (tem
= Feval (test
),
789 (!EQ (Vmocklisp_arguments
, Qt
) ? XINT (tem
) : !NILP (tem
)))
799 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
800 "Return result of expanding macros at top level of FORM.\n\
801 If FORM is not a macro call, it is returned unchanged.\n\
802 Otherwise, the macro is expanded and the expansion is considered\n\
803 in place of FORM. When a non-macro-call results, it is returned.\n\n\
804 The second optional arg ENVIRONMENT species an environment of macro\n\
805 definitions to shadow the loaded ones for use in file byte-compilation.")
808 Lisp_Object environment
;
810 /* With cleanups from Hallvard Furuseth. */
811 register Lisp_Object expander
, sym
, def
, tem
;
815 /* Come back here each time we expand a macro call,
816 in case it expands into another macro call. */
819 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
820 def
= sym
= XCONS (form
)->car
;
822 /* Trace symbols aliases to other symbols
823 until we get a symbol that is not an alias. */
824 while (SYMBOLP (def
))
828 tem
= Fassq (sym
, environment
);
831 def
= XSYMBOL (sym
)->function
;
832 if (!EQ (def
, Qunbound
))
837 /* Right now TEM is the result from SYM in ENVIRONMENT,
838 and if TEM is nil then DEF is SYM's function definition. */
841 /* SYM is not mentioned in ENVIRONMENT.
842 Look at its function definition. */
843 if (EQ (def
, Qunbound
) || !CONSP (def
))
844 /* Not defined or definition not suitable */
846 if (EQ (XCONS (def
)->car
, Qautoload
))
848 /* Autoloading function: will it be a macro when loaded? */
849 tem
= Fnth (make_number (4), def
);
850 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
851 /* Yes, load it and try again. */
855 do_autoload (def
, sym
);
862 else if (!EQ (XCONS (def
)->car
, Qmacro
))
864 else expander
= XCONS (def
)->cdr
;
868 expander
= XCONS (tem
)->cdr
;
872 form
= apply1 (expander
, XCONS (form
)->cdr
);
877 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
878 "(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.\n\
879 TAG is evalled to get the tag to use. Then the BODY is executed.\n\
880 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.\n\
881 If no throw happens, `catch' returns the value of the last BODY form.\n\
882 If a throw happens, it specifies the value to return from `catch'.")
886 register Lisp_Object tag
;
890 tag
= Feval (Fcar (args
));
892 return internal_catch (tag
, Fprogn
, Fcdr (args
));
895 /* Set up a catch, then call C function FUNC on argument ARG.
896 FUNC should return a Lisp_Object.
897 This is how catches are done from within C code. */
900 internal_catch (tag
, func
, arg
)
902 Lisp_Object (*func
) ();
905 /* This structure is made part of the chain `catchlist'. */
908 /* Fill in the components of c, and put it on the list. */
912 c
.backlist
= backtrace_list
;
913 c
.handlerlist
= handlerlist
;
914 c
.lisp_eval_depth
= lisp_eval_depth
;
915 c
.pdlcount
= specpdl_ptr
- specpdl
;
916 c
.poll_suppress_count
= poll_suppress_count
;
921 if (! _setjmp (c
.jmp
))
922 c
.val
= (*func
) (arg
);
924 /* Throw works by a longjmp that comes right here. */
929 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
930 jump to that CATCH, returning VALUE as the value of that catch.
932 This is the guts Fthrow and Fsignal; they differ only in the way
933 they choose the catch tag to throw to. A catch tag for a
934 condition-case form has a TAG of Qnil.
936 Before each catch is discarded, unbind all special bindings and
937 execute all unwind-protect clauses made above that catch. Unwind
938 the handler stack as we go, so that the proper handlers are in
939 effect for each unwind-protect clause we run. At the end, restore
940 some static info saved in CATCH, and longjmp to the location
943 This is used for correct unwinding in Fthrow and Fsignal. */
946 unwind_to_catch (catch, value
)
947 struct catchtag
*catch;
950 register int last_time
;
952 /* Save the value in the tag. */
955 /* Restore the polling-suppression count. */
956 set_poll_suppress_count (catch->poll_suppress_count
);
960 last_time
= catchlist
== catch;
962 /* Unwind the specpdl stack, and then restore the proper set of
964 unbind_to (catchlist
->pdlcount
, Qnil
);
965 handlerlist
= catchlist
->handlerlist
;
966 catchlist
= catchlist
->next
;
970 gcprolist
= catch->gcpro
;
971 backtrace_list
= catch->backlist
;
972 lisp_eval_depth
= catch->lisp_eval_depth
;
974 _longjmp (catch->jmp
, 1);
977 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
978 "(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.\n\
979 Both TAG and VALUE are evalled.")
981 register Lisp_Object tag
, value
;
983 register struct catchtag
*c
;
988 for (c
= catchlist
; c
; c
= c
->next
)
990 if (EQ (c
->tag
, tag
))
991 unwind_to_catch (c
, value
);
993 tag
= Fsignal (Qno_catch
, Fcons (tag
, Fcons (value
, Qnil
)));
998 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
999 "Do BODYFORM, protecting with UNWINDFORMS.\n\
1000 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).\n\
1001 If BODYFORM completes normally, its value is returned\n\
1002 after executing the UNWINDFORMS.\n\
1003 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.")
1008 int count
= specpdl_ptr
- specpdl
;
1010 record_unwind_protect (0, Fcdr (args
));
1011 val
= Feval (Fcar (args
));
1012 return unbind_to (count
, val
);
1015 /* Chain of condition handlers currently in effect.
1016 The elements of this chain are contained in the stack frames
1017 of Fcondition_case and internal_condition_case.
1018 When an error is signaled (by calling Fsignal, below),
1019 this chain is searched for an element that applies. */
1021 struct handler
*handlerlist
;
1023 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1024 "Regain control when an error is signaled.\n\
1025 Usage looks like (condition-case VAR BODYFORM HANDLERS...).\n\
1026 executes BODYFORM and returns its value if no error happens.\n\
1027 Each element of HANDLERS looks like (CONDITION-NAME BODY...)\n\
1028 where the BODY is made of Lisp expressions.\n\n\
1029 A handler is applicable to an error\n\
1030 if CONDITION-NAME is one of the error's condition names.\n\
1031 If an error happens, the first applicable handler is run.\n\
1033 The car of a handler may be a list of condition names\n\
1034 instead of a single condition name.\n\
1036 When a handler handles an error,\n\
1037 control returns to the condition-case and the handler BODY... is executed\n\
1038 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\
1039 VAR may be nil; then you do not get access to the signal information.\n\
1041 The value of the last BODY form is returned from the condition-case.\n\
1042 See also the function `signal' for more info.")
1049 register Lisp_Object var
, bodyform
, handlers
;
1052 bodyform
= Fcar (Fcdr (args
));
1053 handlers
= Fcdr (Fcdr (args
));
1054 CHECK_SYMBOL (var
, 0);
1056 for (val
= handlers
; ! NILP (val
); val
= Fcdr (val
))
1062 && (SYMBOLP (XCONS (tem
)->car
)
1063 || CONSP (XCONS (tem
)->car
)))))
1064 error ("Invalid condition handler", tem
);
1069 c
.backlist
= backtrace_list
;
1070 c
.handlerlist
= handlerlist
;
1071 c
.lisp_eval_depth
= lisp_eval_depth
;
1072 c
.pdlcount
= specpdl_ptr
- specpdl
;
1073 c
.poll_suppress_count
= poll_suppress_count
;
1074 c
.gcpro
= gcprolist
;
1075 if (_setjmp (c
.jmp
))
1078 specbind (h
.var
, c
.val
);
1079 val
= Fprogn (Fcdr (h
.chosen_clause
));
1081 /* Note that this just undoes the binding of h.var; whoever
1082 longjumped to us unwound the stack to c.pdlcount before
1084 unbind_to (c
.pdlcount
, Qnil
);
1091 h
.handler
= handlers
;
1092 h
.next
= handlerlist
;
1096 val
= Feval (bodyform
);
1098 handlerlist
= h
.next
;
1102 /* Call the function BFUN with no arguments, catching errors within it
1103 according to HANDLERS. If there is an error, call HFUN with
1104 one argument which is the data that describes the error:
1107 HANDLERS can be a list of conditions to catch.
1108 If HANDLERS is Qt, catch all errors.
1109 If HANDLERS is Qerror, catch all errors
1110 but allow the debugger to run if that is enabled. */
1113 internal_condition_case (bfun
, handlers
, hfun
)
1114 Lisp_Object (*bfun
) ();
1115 Lisp_Object handlers
;
1116 Lisp_Object (*hfun
) ();
1122 /* Since Fsignal resets this to 0, it had better be 0 now
1123 or else we have a potential bug. */
1124 if (interrupt_input_blocked
!= 0)
1129 c
.backlist
= backtrace_list
;
1130 c
.handlerlist
= handlerlist
;
1131 c
.lisp_eval_depth
= lisp_eval_depth
;
1132 c
.pdlcount
= specpdl_ptr
- specpdl
;
1133 c
.poll_suppress_count
= poll_suppress_count
;
1134 c
.gcpro
= gcprolist
;
1135 if (_setjmp (c
.jmp
))
1137 return (*hfun
) (c
.val
);
1141 h
.handler
= handlers
;
1143 h
.next
= handlerlist
;
1149 handlerlist
= h
.next
;
1153 /* Like internal_condition_case but call HFUN with ARG as its argument. */
1156 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1157 Lisp_Object (*bfun
) ();
1159 Lisp_Object handlers
;
1160 Lisp_Object (*hfun
) ();
1168 c
.backlist
= backtrace_list
;
1169 c
.handlerlist
= handlerlist
;
1170 c
.lisp_eval_depth
= lisp_eval_depth
;
1171 c
.pdlcount
= specpdl_ptr
- specpdl
;
1172 c
.poll_suppress_count
= poll_suppress_count
;
1173 c
.gcpro
= gcprolist
;
1174 if (_setjmp (c
.jmp
))
1176 return (*hfun
) (c
.val
);
1180 h
.handler
= handlers
;
1182 h
.next
= handlerlist
;
1186 val
= (*bfun
) (arg
);
1188 handlerlist
= h
.next
;
1192 static Lisp_Object
find_handler_clause ();
1194 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1195 "Signal an error. Args are ERROR-SYMBOL and associated DATA.\n\
1196 This function does not return.\n\n\
1197 An error symbol is a symbol with an `error-conditions' property\n\
1198 that is a list of condition names.\n\
1199 A handler for any of those names will get to handle this signal.\n\
1200 The symbol `error' should normally be one of them.\n\
1202 DATA should be a list. Its elements are printed as part of the error message.\n\
1203 If the signal is handled, DATA is made available to the handler.\n\
1204 See also the function `condition-case'.")
1205 (error_symbol
, data
)
1206 Lisp_Object error_symbol
, data
;
1208 register struct handler
*allhandlers
= handlerlist
;
1209 Lisp_Object conditions
;
1210 extern int gc_in_progress
;
1211 extern int waiting_for_input
;
1212 Lisp_Object debugger_value
;
1214 Lisp_Object real_error_symbol
;
1215 Lisp_Object combined_data
;
1217 quit_error_check ();
1219 if (gc_in_progress
|| waiting_for_input
)
1222 #ifdef HAVE_WINDOW_SYSTEM
1223 TOTALLY_UNBLOCK_INPUT
;
1226 if (NILP (error_symbol
))
1227 real_error_symbol
= Fcar (data
);
1229 real_error_symbol
= error_symbol
;
1231 /* This hook is used by edebug. */
1232 if (! NILP (Vsignal_hook_function
))
1233 call2 (Vsignal_hook_function
, error_symbol
, data
);
1235 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1237 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1239 register Lisp_Object clause
;
1240 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1241 error_symbol
, data
, &debugger_value
);
1243 #if 0 /* Most callers are not prepared to handle gc if this returns.
1244 So, since this feature is not very useful, take it out. */
1245 /* If have called debugger and user wants to continue,
1247 if (EQ (clause
, Qlambda
))
1248 return debugger_value
;
1250 if (EQ (clause
, Qlambda
))
1252 /* We can't return values to code which signaled an error, but we
1253 can continue code which has signaled a quit. */
1254 if (EQ (real_error_symbol
, Qquit
))
1257 error ("Cannot return from the debugger in an error");
1263 Lisp_Object unwind_data
;
1264 struct handler
*h
= handlerlist
;
1266 handlerlist
= allhandlers
;
1268 if (NILP (error_symbol
))
1271 unwind_data
= Fcons (error_symbol
, data
);
1272 h
->chosen_clause
= clause
;
1273 unwind_to_catch (h
->tag
, unwind_data
);
1277 handlerlist
= allhandlers
;
1278 /* If no handler is present now, try to run the debugger,
1279 and if that fails, throw to top level. */
1280 find_handler_clause (Qerror
, conditions
, error_symbol
, data
, &debugger_value
);
1282 Fthrow (Qtop_level
, Qt
);
1284 if (! NILP (error_symbol
))
1285 data
= Fcons (error_symbol
, data
);
1287 string
= Ferror_message_string (data
);
1288 fatal (XSTRING (string
)->data
, 0, 0);
1291 /* Return nonzero iff LIST is a non-nil atom or
1292 a list containing one of CONDITIONS. */
1295 wants_debugger (list
, conditions
)
1296 Lisp_Object list
, conditions
;
1303 while (CONSP (conditions
))
1305 Lisp_Object
this, tail
;
1306 this = XCONS (conditions
)->car
;
1307 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1308 if (EQ (XCONS (tail
)->car
, this))
1310 conditions
= XCONS (conditions
)->cdr
;
1315 /* Return 1 if an error with condition-symbols CONDITIONS,
1316 and described by SIGNAL-DATA, should skip the debugger
1317 according to debugger-ignore-errors. */
1320 skip_debugger (conditions
, data
)
1321 Lisp_Object conditions
, data
;
1324 int first_string
= 1;
1325 Lisp_Object error_message
;
1327 for (tail
= Vdebug_ignored_errors
; CONSP (tail
);
1328 tail
= XCONS (tail
)->cdr
)
1330 if (STRINGP (XCONS (tail
)->car
))
1334 error_message
= Ferror_message_string (data
);
1337 if (fast_string_match (XCONS (tail
)->car
, error_message
) >= 0)
1342 Lisp_Object contail
;
1344 for (contail
= conditions
; CONSP (contail
);
1345 contail
= XCONS (contail
)->cdr
)
1346 if (EQ (XCONS (tail
)->car
, XCONS (contail
)->car
))
1354 /* Value of Qlambda means we have called debugger and user has continued.
1355 There are two ways to pass SIG and DATA:
1356 - SIG is the error symbol, and DATA is the rest of the data.
1357 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1359 Store value returned from debugger into *DEBUGGER_VALUE_PTR. */
1362 find_handler_clause (handlers
, conditions
, sig
, data
, debugger_value_ptr
)
1363 Lisp_Object handlers
, conditions
, sig
, data
;
1364 Lisp_Object
*debugger_value_ptr
;
1366 register Lisp_Object h
;
1367 register Lisp_Object tem
;
1369 if (EQ (handlers
, Qt
)) /* t is used by handlers for all conditions, set up by C code. */
1371 /* error is used similarly, but means print an error message
1372 and run the debugger if that is enabled. */
1373 if (EQ (handlers
, Qerror
)
1374 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1375 there is a handler. */
1377 int count
= specpdl_ptr
- specpdl
;
1378 int debugger_called
= 0;
1379 Lisp_Object sig_symbol
, combined_data
;
1383 combined_data
= data
;
1384 sig_symbol
= Fcar (data
);
1388 combined_data
= Fcons (sig
, data
);
1392 if (wants_debugger (Vstack_trace_on_error
, conditions
))
1393 internal_with_output_to_temp_buffer ("*Backtrace*", Fbacktrace
, Qnil
);
1394 if ((EQ (sig_symbol
, Qquit
)
1396 : wants_debugger (Vdebug_on_error
, conditions
))
1397 && ! skip_debugger (conditions
, combined_data
)
1398 && when_entered_debugger
< num_nonmacro_input_events
)
1400 specbind (Qdebug_on_error
, Qnil
);
1402 = call_debugger (Fcons (Qerror
,
1403 Fcons (combined_data
, Qnil
)));
1404 debugger_called
= 1;
1406 /* If there is no handler, return saying whether we ran the debugger. */
1407 if (EQ (handlers
, Qerror
))
1409 if (debugger_called
)
1410 return unbind_to (count
, Qlambda
);
1414 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1416 Lisp_Object handler
, condit
;
1419 if (!CONSP (handler
))
1421 condit
= Fcar (handler
);
1422 /* Handle a single condition name in handler HANDLER. */
1423 if (SYMBOLP (condit
))
1425 tem
= Fmemq (Fcar (handler
), conditions
);
1429 /* Handle a list of condition names in handler HANDLER. */
1430 else if (CONSP (condit
))
1432 while (CONSP (condit
))
1434 tem
= Fmemq (Fcar (condit
), conditions
);
1437 condit
= XCONS (condit
)->cdr
;
1444 /* dump an error message; called like printf */
1448 error (m
, a1
, a2
, a3
)
1468 int used
= doprnt (buf
, size
, m
, m
+ mlen
, 3, args
);
1473 buffer
= (char *) xrealloc (buffer
, size
);
1476 buffer
= (char *) xmalloc (size
);
1481 string
= build_string (buf
);
1485 Fsignal (Qerror
, Fcons (string
, Qnil
));
1488 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 1, 0,
1489 "T if FUNCTION makes provisions for interactive calling.\n\
1490 This means it contains a description for how to read arguments to give it.\n\
1491 The value is nil for an invalid function or a symbol with no function\n\
1494 Interactively callable functions include strings and vectors (treated\n\
1495 as keyboard macros), lambda-expressions that contain a top-level call\n\
1496 to `interactive', autoload definitions made by `autoload' with non-nil\n\
1497 fourth argument, and some of the built-in functions of Lisp.\n\
1499 Also, a symbol satisfies `commandp' if its function definition does so.")
1501 Lisp_Object function
;
1503 register Lisp_Object fun
;
1504 register Lisp_Object funcar
;
1505 register Lisp_Object tem
;
1510 fun
= indirect_function (fun
);
1511 if (EQ (fun
, Qunbound
))
1514 /* Emacs primitives are interactive if their DEFUN specifies an
1515 interactive spec. */
1518 if (XSUBR (fun
)->prompt
)
1524 /* Bytecode objects are interactive if they are long enough to
1525 have an element whose index is COMPILED_INTERACTIVE, which is
1526 where the interactive spec is stored. */
1527 else if (COMPILEDP (fun
))
1528 return ((XVECTOR (fun
)->size
& PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
1531 /* Strings and vectors are keyboard macros. */
1532 if (STRINGP (fun
) || VECTORP (fun
))
1535 /* Lists may represent commands. */
1538 funcar
= Fcar (fun
);
1539 if (!SYMBOLP (funcar
))
1540 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1541 if (EQ (funcar
, Qlambda
))
1542 return Fassq (Qinteractive
, Fcdr (Fcdr (fun
)));
1543 if (EQ (funcar
, Qmocklisp
))
1544 return Qt
; /* All mocklisp functions can be called interactively */
1545 if (EQ (funcar
, Qautoload
))
1546 return Fcar (Fcdr (Fcdr (Fcdr (fun
))));
1552 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1553 "Define FUNCTION to autoload from FILE.\n\
1554 FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\
1555 Third arg DOCSTRING is documentation for the function.\n\
1556 Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\
1557 Fifth arg TYPE indicates the type of the object:\n\
1558 nil or omitted says FUNCTION is a function,\n\
1559 `keymap' says FUNCTION is really a keymap, and\n\
1560 `macro' or t says FUNCTION is really a macro.\n\
1561 Third through fifth args give info about the real definition.\n\
1562 They default to nil.\n\
1563 If FUNCTION is already defined other than as an autoload,\n\
1564 this does nothing and returns nil.")
1565 (function
, file
, docstring
, interactive
, type
)
1566 Lisp_Object function
, file
, docstring
, interactive
, type
;
1569 Lisp_Object args
[4];
1572 CHECK_SYMBOL (function
, 0);
1573 CHECK_STRING (file
, 1);
1575 /* If function is defined and not as an autoload, don't override */
1576 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
1577 && !(CONSP (XSYMBOL (function
)->function
)
1578 && EQ (XCONS (XSYMBOL (function
)->function
)->car
, Qautoload
)))
1583 args
[1] = docstring
;
1584 args
[2] = interactive
;
1587 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
1588 #else /* NO_ARG_ARRAY */
1589 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
1590 #endif /* not NO_ARG_ARRAY */
1594 un_autoload (oldqueue
)
1595 Lisp_Object oldqueue
;
1597 register Lisp_Object queue
, first
, second
;
1599 /* Queue to unwind is current value of Vautoload_queue.
1600 oldqueue is the shadowed value to leave in Vautoload_queue. */
1601 queue
= Vautoload_queue
;
1602 Vautoload_queue
= oldqueue
;
1603 while (CONSP (queue
))
1605 first
= Fcar (queue
);
1606 second
= Fcdr (first
);
1607 first
= Fcar (first
);
1608 if (EQ (second
, Qnil
))
1611 Ffset (first
, second
);
1612 queue
= Fcdr (queue
);
1617 /* Load an autoloaded function.
1618 FUNNAME is the symbol which is the function's name.
1619 FUNDEF is the autoload definition (a list). */
1621 do_autoload (fundef
, funname
)
1622 Lisp_Object fundef
, funname
;
1624 int count
= specpdl_ptr
- specpdl
;
1625 Lisp_Object fun
, val
, queue
, first
, second
;
1626 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1629 CHECK_SYMBOL (funname
, 0);
1630 GCPRO3 (fun
, funname
, fundef
);
1632 /* Value saved here is to be restored into Vautoload_queue */
1633 record_unwind_protect (un_autoload
, Vautoload_queue
);
1634 Vautoload_queue
= Qt
;
1635 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
, Qt
);
1637 /* Save the old autoloads, in case we ever do an unload. */
1638 queue
= Vautoload_queue
;
1639 while (CONSP (queue
))
1641 first
= Fcar (queue
);
1642 second
= Fcdr (first
);
1643 first
= Fcar (first
);
1645 /* Note: This test is subtle. The cdr of an autoload-queue entry
1646 may be an atom if the autoload entry was generated by a defalias
1649 Fput (first
, Qautoload
, (Fcdr (second
)));
1651 queue
= Fcdr (queue
);
1654 /* Once loading finishes, don't undo it. */
1655 Vautoload_queue
= Qt
;
1656 unbind_to (count
, Qnil
);
1658 fun
= Findirect_function (fun
);
1660 if (!NILP (Fequal (fun
, fundef
)))
1661 error ("Autoloading failed to define function %s",
1662 XSYMBOL (funname
)->name
->data
);
1666 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
1667 "Evaluate FORM and return its value.")
1671 Lisp_Object fun
, val
, original_fun
, original_args
;
1673 struct backtrace backtrace
;
1674 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1678 if (EQ (Vmocklisp_arguments
, Qt
))
1679 return Fsymbol_value (form
);
1680 val
= Fsymbol_value (form
);
1682 XSETFASTINT (val
, 0);
1683 else if (EQ (val
, Qt
))
1684 XSETFASTINT (val
, 1);
1691 if (consing_since_gc
> gc_cons_threshold
)
1694 Fgarbage_collect ();
1698 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1700 if (max_lisp_eval_depth
< 100)
1701 max_lisp_eval_depth
= 100;
1702 if (lisp_eval_depth
> max_lisp_eval_depth
)
1703 error ("Lisp nesting exceeds max-lisp-eval-depth");
1706 original_fun
= Fcar (form
);
1707 original_args
= Fcdr (form
);
1709 backtrace
.next
= backtrace_list
;
1710 backtrace_list
= &backtrace
;
1711 backtrace
.function
= &original_fun
; /* This also protects them from gc */
1712 backtrace
.args
= &original_args
;
1713 backtrace
.nargs
= UNEVALLED
;
1714 backtrace
.evalargs
= 1;
1715 backtrace
.debug_on_exit
= 0;
1717 if (debug_on_next_call
)
1718 do_debug_on_call (Qt
);
1720 /* At this point, only original_fun and original_args
1721 have values that will be used below */
1723 fun
= Findirect_function (original_fun
);
1727 Lisp_Object numargs
;
1728 Lisp_Object argvals
[7];
1729 Lisp_Object args_left
;
1730 register int i
, maxargs
;
1732 args_left
= original_args
;
1733 numargs
= Flength (args_left
);
1735 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
1736 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
1737 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1739 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1741 backtrace
.evalargs
= 0;
1742 val
= (*XSUBR (fun
)->function
) (args_left
);
1746 if (XSUBR (fun
)->max_args
== MANY
)
1748 /* Pass a vector of evaluated arguments */
1750 register int argnum
= 0;
1752 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1754 GCPRO3 (args_left
, fun
, fun
);
1758 while (!NILP (args_left
))
1760 vals
[argnum
++] = Feval (Fcar (args_left
));
1761 args_left
= Fcdr (args_left
);
1762 gcpro3
.nvars
= argnum
;
1765 backtrace
.args
= vals
;
1766 backtrace
.nargs
= XINT (numargs
);
1768 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
1773 GCPRO3 (args_left
, fun
, fun
);
1774 gcpro3
.var
= argvals
;
1777 maxargs
= XSUBR (fun
)->max_args
;
1778 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
1780 argvals
[i
] = Feval (Fcar (args_left
));
1786 backtrace
.args
= argvals
;
1787 backtrace
.nargs
= XINT (numargs
);
1792 val
= (*XSUBR (fun
)->function
) ();
1795 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
1798 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
1801 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1805 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1806 argvals
[2], argvals
[3]);
1809 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1810 argvals
[3], argvals
[4]);
1813 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1814 argvals
[3], argvals
[4], argvals
[5]);
1817 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1818 argvals
[3], argvals
[4], argvals
[5],
1823 /* Someone has created a subr that takes more arguments than
1824 is supported by this code. We need to either rewrite the
1825 subr to use a different argument protocol, or add more
1826 cases to this switch. */
1830 if (COMPILEDP (fun
))
1831 val
= apply_lambda (fun
, original_args
, 1);
1835 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1836 funcar
= Fcar (fun
);
1837 if (!SYMBOLP (funcar
))
1838 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1839 if (EQ (funcar
, Qautoload
))
1841 do_autoload (fun
, original_fun
);
1844 if (EQ (funcar
, Qmacro
))
1845 val
= Feval (apply1 (Fcdr (fun
), original_args
));
1846 else if (EQ (funcar
, Qlambda
))
1847 val
= apply_lambda (fun
, original_args
, 1);
1848 else if (EQ (funcar
, Qmocklisp
))
1849 val
= ml_apply (fun
, original_args
);
1851 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1854 if (!EQ (Vmocklisp_arguments
, Qt
))
1857 XSETFASTINT (val
, 0);
1858 else if (EQ (val
, Qt
))
1859 XSETFASTINT (val
, 1);
1862 if (backtrace
.debug_on_exit
)
1863 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
1864 backtrace_list
= backtrace
.next
;
1868 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
1869 "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
1870 Then return the value FUNCTION returns.\n\
1871 Thus, (apply '+ 1 2 '(3 4)) returns 10.")
1876 register int i
, numargs
;
1877 register Lisp_Object spread_arg
;
1878 register Lisp_Object
*funcall_args
;
1880 struct gcpro gcpro1
;
1884 spread_arg
= args
[nargs
- 1];
1885 CHECK_LIST (spread_arg
, nargs
);
1887 numargs
= XINT (Flength (spread_arg
));
1890 return Ffuncall (nargs
- 1, args
);
1891 else if (numargs
== 1)
1893 args
[nargs
- 1] = XCONS (spread_arg
)->car
;
1894 return Ffuncall (nargs
, args
);
1897 numargs
+= nargs
- 2;
1899 fun
= indirect_function (fun
);
1900 if (EQ (fun
, Qunbound
))
1902 /* Let funcall get the error */
1909 if (numargs
< XSUBR (fun
)->min_args
1910 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
1911 goto funcall
; /* Let funcall get the error */
1912 else if (XSUBR (fun
)->max_args
> numargs
)
1914 /* Avoid making funcall cons up a yet another new vector of arguments
1915 by explicitly supplying nil's for optional values */
1916 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
1917 * sizeof (Lisp_Object
));
1918 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
1919 funcall_args
[++i
] = Qnil
;
1920 GCPRO1 (*funcall_args
);
1921 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
1925 /* We add 1 to numargs because funcall_args includes the
1926 function itself as well as its arguments. */
1929 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
1930 * sizeof (Lisp_Object
));
1931 GCPRO1 (*funcall_args
);
1932 gcpro1
.nvars
= 1 + numargs
;
1935 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
1936 /* Spread the last arg we got. Its first element goes in
1937 the slot that it used to occupy, hence this value of I. */
1939 while (!NILP (spread_arg
))
1941 funcall_args
[i
++] = XCONS (spread_arg
)->car
;
1942 spread_arg
= XCONS (spread_arg
)->cdr
;
1945 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
1948 /* Run hook variables in various ways. */
1950 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
1952 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 1, MANY
, 0,
1953 "Run each hook in HOOKS. Major mode functions use this.\n\
1954 Each argument should be a symbol, a hook variable.\n\
1955 These symbols are processed in the order specified.\n\
1956 If a hook symbol has a non-nil value, that value may be a function\n\
1957 or a list of functions to be called to run the hook.\n\
1958 If the value is a function, it is called with no arguments.\n\
1959 If it is a list, the elements are called, in order, with no arguments.\n\
1961 To make a hook variable buffer-local, use `make-local-hook',\n\
1962 not `make-local-variable'.")
1967 Lisp_Object hook
[1];
1970 for (i
= 0; i
< nargs
; i
++)
1973 run_hook_with_args (1, hook
, to_completion
);
1979 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
1980 Srun_hook_with_args
, 1, MANY
, 0,
1981 "Run HOOK with the specified arguments ARGS.\n\
1982 HOOK should be a symbol, a hook variable. If HOOK has a non-nil\n\
1983 value, that value may be a function or a list of functions to be\n\
1984 called to run the hook. If the value is a function, it is called with\n\
1985 the given arguments and its return value is returned. If it is a list\n\
1986 of functions, those functions are called, in order,\n\
1987 with the given arguments ARGS.\n\
1988 It is best not to depend on the value return by `run-hook-with-args',\n\
1989 as that may change.\n\
1991 To make a hook variable buffer-local, use `make-local-hook',\n\
1992 not `make-local-variable'.")
1997 return run_hook_with_args (nargs
, args
, to_completion
);
2000 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2001 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2002 "Run HOOK with the specified arguments ARGS.\n\
2003 HOOK should be a symbol, a hook variable. Its value should\n\
2004 be a list of functions. We call those functions, one by one,\n\
2005 passing arguments ARGS to each of them, until one of them\n\
2006 returns a non-nil value. Then we return that value.\n\
2007 If all the functions return nil, we return nil.\n\
2009 To make a hook variable buffer-local, use `make-local-hook',\n\
2010 not `make-local-variable'.")
2015 return run_hook_with_args (nargs
, args
, until_success
);
2018 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2019 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2020 "Run HOOK with the specified arguments ARGS.\n\
2021 HOOK should be a symbol, a hook variable. Its value should\n\
2022 be a list of functions. We call those functions, one by one,\n\
2023 passing arguments ARGS to each of them, until one of them\n\
2024 returns nil. Then we return nil.\n\
2025 If all the functions return non-nil, we return non-nil.\n\
2027 To make a hook variable buffer-local, use `make-local-hook',\n\
2028 not `make-local-variable'.")
2033 return run_hook_with_args (nargs
, args
, until_failure
);
2036 /* ARGS[0] should be a hook symbol.
2037 Call each of the functions in the hook value, passing each of them
2038 as arguments all the rest of ARGS (all NARGS - 1 elements).
2039 COND specifies a condition to test after each call
2040 to decide whether to stop.
2041 The caller (or its caller, etc) must gcpro all of ARGS,
2042 except that it isn't necessary to gcpro ARGS[0]. */
2045 run_hook_with_args (nargs
, args
, cond
)
2048 enum run_hooks_condition cond
;
2050 Lisp_Object sym
, val
, ret
;
2051 struct gcpro gcpro1
, gcpro2
;
2053 /* If we are dying or still initializing,
2054 don't do anything--it would probably crash if we tried. */
2055 if (NILP (Vrun_hooks
))
2059 val
= find_symbol_value (sym
);
2060 ret
= (cond
== until_failure
? Qt
: Qnil
);
2062 if (EQ (val
, Qunbound
) || NILP (val
))
2064 else if (!CONSP (val
) || EQ (XCONS (val
)->car
, Qlambda
))
2067 return Ffuncall (nargs
, args
);
2074 CONSP (val
) && ((cond
== to_completion
)
2075 || (cond
== until_success
? NILP (ret
)
2077 val
= XCONS (val
)->cdr
)
2079 if (EQ (XCONS (val
)->car
, Qt
))
2081 /* t indicates this hook has a local binding;
2082 it means to run the global binding too. */
2083 Lisp_Object globals
;
2085 for (globals
= Fdefault_value (sym
);
2086 CONSP (globals
) && ((cond
== to_completion
)
2087 || (cond
== until_success
? NILP (ret
)
2089 globals
= XCONS (globals
)->cdr
)
2091 args
[0] = XCONS (globals
)->car
;
2092 /* In a global value, t should not occur. If it does, we
2093 must ignore it to avoid an endless loop. */
2094 if (!EQ (args
[0], Qt
))
2095 ret
= Ffuncall (nargs
, args
);
2100 args
[0] = XCONS (val
)->car
;
2101 ret
= Ffuncall (nargs
, args
);
2110 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2111 present value of that symbol.
2112 Call each element of FUNLIST,
2113 passing each of them the rest of ARGS.
2114 The caller (or its caller, etc) must gcpro all of ARGS,
2115 except that it isn't necessary to gcpro ARGS[0]. */
2118 run_hook_list_with_args (funlist
, nargs
, args
)
2119 Lisp_Object funlist
;
2125 struct gcpro gcpro1
, gcpro2
;
2130 for (val
= funlist
; CONSP (val
); val
= XCONS (val
)->cdr
)
2132 if (EQ (XCONS (val
)->car
, Qt
))
2134 /* t indicates this hook has a local binding;
2135 it means to run the global binding too. */
2136 Lisp_Object globals
;
2138 for (globals
= Fdefault_value (sym
);
2140 globals
= XCONS (globals
)->cdr
)
2142 args
[0] = XCONS (globals
)->car
;
2143 /* In a global value, t should not occur. If it does, we
2144 must ignore it to avoid an endless loop. */
2145 if (!EQ (args
[0], Qt
))
2146 Ffuncall (nargs
, args
);
2151 args
[0] = XCONS (val
)->car
;
2152 Ffuncall (nargs
, args
);
2159 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2162 run_hook_with_args_2 (hook
, arg1
, arg2
)
2163 Lisp_Object hook
, arg1
, arg2
;
2165 Lisp_Object temp
[3];
2170 Frun_hook_with_args (3, temp
);
2173 /* Apply fn to arg */
2176 Lisp_Object fn
, arg
;
2178 struct gcpro gcpro1
;
2182 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2186 Lisp_Object args
[2];
2190 RETURN_UNGCPRO (Fapply (2, args
));
2192 #else /* not NO_ARG_ARRAY */
2193 RETURN_UNGCPRO (Fapply (2, &fn
));
2194 #endif /* not NO_ARG_ARRAY */
2197 /* Call function fn on no arguments */
2202 struct gcpro gcpro1
;
2205 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2208 /* Call function fn with 1 argument arg1 */
2212 Lisp_Object fn
, arg1
;
2214 struct gcpro gcpro1
;
2216 Lisp_Object args
[2];
2222 RETURN_UNGCPRO (Ffuncall (2, args
));
2223 #else /* not NO_ARG_ARRAY */
2226 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2227 #endif /* not NO_ARG_ARRAY */
2230 /* Call function fn with 2 arguments arg1, arg2 */
2233 call2 (fn
, arg1
, arg2
)
2234 Lisp_Object fn
, arg1
, arg2
;
2236 struct gcpro gcpro1
;
2238 Lisp_Object args
[3];
2244 RETURN_UNGCPRO (Ffuncall (3, args
));
2245 #else /* not NO_ARG_ARRAY */
2248 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2249 #endif /* not NO_ARG_ARRAY */
2252 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2255 call3 (fn
, arg1
, arg2
, arg3
)
2256 Lisp_Object fn
, arg1
, arg2
, arg3
;
2258 struct gcpro gcpro1
;
2260 Lisp_Object args
[4];
2267 RETURN_UNGCPRO (Ffuncall (4, args
));
2268 #else /* not NO_ARG_ARRAY */
2271 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2272 #endif /* not NO_ARG_ARRAY */
2275 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2278 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2279 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2281 struct gcpro gcpro1
;
2283 Lisp_Object args
[5];
2291 RETURN_UNGCPRO (Ffuncall (5, args
));
2292 #else /* not NO_ARG_ARRAY */
2295 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2296 #endif /* not NO_ARG_ARRAY */
2299 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2302 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2303 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2305 struct gcpro gcpro1
;
2307 Lisp_Object args
[6];
2316 RETURN_UNGCPRO (Ffuncall (6, args
));
2317 #else /* not NO_ARG_ARRAY */
2320 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2321 #endif /* not NO_ARG_ARRAY */
2324 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2327 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2328 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2330 struct gcpro gcpro1
;
2332 Lisp_Object args
[7];
2342 RETURN_UNGCPRO (Ffuncall (7, args
));
2343 #else /* not NO_ARG_ARRAY */
2346 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2347 #endif /* not NO_ARG_ARRAY */
2350 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2351 "Call first argument as a function, passing remaining arguments to it.\n\
2352 Return the value that function returns.\n\
2353 Thus, (funcall 'cons 'x 'y) returns (x . y).")
2360 int numargs
= nargs
- 1;
2361 Lisp_Object lisp_numargs
;
2363 struct backtrace backtrace
;
2364 register Lisp_Object
*internal_args
;
2368 if (consing_since_gc
> gc_cons_threshold
)
2369 Fgarbage_collect ();
2371 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2373 if (max_lisp_eval_depth
< 100)
2374 max_lisp_eval_depth
= 100;
2375 if (lisp_eval_depth
> max_lisp_eval_depth
)
2376 error ("Lisp nesting exceeds max-lisp-eval-depth");
2379 backtrace
.next
= backtrace_list
;
2380 backtrace_list
= &backtrace
;
2381 backtrace
.function
= &args
[0];
2382 backtrace
.args
= &args
[1];
2383 backtrace
.nargs
= nargs
- 1;
2384 backtrace
.evalargs
= 0;
2385 backtrace
.debug_on_exit
= 0;
2387 if (debug_on_next_call
)
2388 do_debug_on_call (Qlambda
);
2394 fun
= Findirect_function (fun
);
2398 if (numargs
< XSUBR (fun
)->min_args
2399 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2401 XSETFASTINT (lisp_numargs
, numargs
);
2402 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (lisp_numargs
, Qnil
)));
2405 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2406 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2408 if (XSUBR (fun
)->max_args
== MANY
)
2410 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
2414 if (XSUBR (fun
)->max_args
> numargs
)
2416 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2417 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
2418 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2419 internal_args
[i
] = Qnil
;
2422 internal_args
= args
+ 1;
2423 switch (XSUBR (fun
)->max_args
)
2426 val
= (*XSUBR (fun
)->function
) ();
2429 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
2432 val
= (*XSUBR (fun
)->function
) (internal_args
[0],
2436 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2440 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2445 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2446 internal_args
[2], internal_args
[3],
2450 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2451 internal_args
[2], internal_args
[3],
2452 internal_args
[4], internal_args
[5]);
2455 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2456 internal_args
[2], internal_args
[3],
2457 internal_args
[4], internal_args
[5],
2463 /* If a subr takes more than 6 arguments without using MANY
2464 or UNEVALLED, we need to extend this function to support it.
2465 Until this is done, there is no way to call the function. */
2469 if (COMPILEDP (fun
))
2470 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2474 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2475 funcar
= Fcar (fun
);
2476 if (!SYMBOLP (funcar
))
2477 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2478 if (EQ (funcar
, Qlambda
))
2479 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2480 else if (EQ (funcar
, Qmocklisp
))
2481 val
= ml_apply (fun
, Flist (numargs
, args
+ 1));
2482 else if (EQ (funcar
, Qautoload
))
2484 do_autoload (fun
, args
[0]);
2488 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2492 if (backtrace
.debug_on_exit
)
2493 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2494 backtrace_list
= backtrace
.next
;
2499 apply_lambda (fun
, args
, eval_flag
)
2500 Lisp_Object fun
, args
;
2503 Lisp_Object args_left
;
2504 Lisp_Object numargs
;
2505 register Lisp_Object
*arg_vector
;
2506 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2508 register Lisp_Object tem
;
2510 numargs
= Flength (args
);
2511 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2514 GCPRO3 (*arg_vector
, args_left
, fun
);
2517 for (i
= 0; i
< XINT (numargs
);)
2519 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2520 if (eval_flag
) tem
= Feval (tem
);
2521 arg_vector
[i
++] = tem
;
2529 backtrace_list
->args
= arg_vector
;
2530 backtrace_list
->nargs
= i
;
2532 backtrace_list
->evalargs
= 0;
2533 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
2535 /* Do the debug-on-exit now, while arg_vector still exists. */
2536 if (backtrace_list
->debug_on_exit
)
2537 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
2538 /* Don't do it again when we return to eval. */
2539 backtrace_list
->debug_on_exit
= 0;
2543 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2544 and return the result of evaluation.
2545 FUN must be either a lambda-expression or a compiled-code object. */
2548 funcall_lambda (fun
, nargs
, arg_vector
)
2551 register Lisp_Object
*arg_vector
;
2553 Lisp_Object val
, tem
;
2554 register Lisp_Object syms_left
;
2555 Lisp_Object numargs
;
2556 register Lisp_Object next
;
2557 int count
= specpdl_ptr
- specpdl
;
2559 int optional
= 0, rest
= 0;
2561 specbind (Qmocklisp_arguments
, Qt
); /* t means NOT mocklisp! */
2563 XSETFASTINT (numargs
, nargs
);
2566 syms_left
= Fcar (Fcdr (fun
));
2567 else if (COMPILEDP (fun
))
2568 syms_left
= XVECTOR (fun
)->contents
[COMPILED_ARGLIST
];
2572 for (; !NILP (syms_left
); syms_left
= Fcdr (syms_left
))
2575 next
= Fcar (syms_left
);
2576 while (!SYMBOLP (next
))
2577 next
= Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2578 if (EQ (next
, Qand_rest
))
2580 else if (EQ (next
, Qand_optional
))
2584 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
2589 tem
= arg_vector
[i
++];
2590 specbind (next
, tem
);
2593 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2595 specbind (next
, Qnil
);
2599 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2602 val
= Fprogn (Fcdr (Fcdr (fun
)));
2605 /* If we have not actually read the bytecode string
2606 and constants vector yet, fetch them from the file. */
2607 if (CONSP (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
]))
2608 Ffetch_bytecode (fun
);
2609 val
= Fbyte_code (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
],
2610 XVECTOR (fun
)->contents
[COMPILED_CONSTANTS
],
2611 XVECTOR (fun
)->contents
[COMPILED_STACK_DEPTH
]);
2613 return unbind_to (count
, val
);
2616 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
2618 "If byte-compiled OBJECT is lazy-loaded, fetch it now.")
2624 if (COMPILEDP (object
)
2625 && CONSP (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]))
2627 tem
= read_doc_string (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]);
2629 error ("invalid byte code");
2630 XVECTOR (object
)->contents
[COMPILED_BYTECODE
] = XCONS (tem
)->car
;
2631 XVECTOR (object
)->contents
[COMPILED_CONSTANTS
] = XCONS (tem
)->cdr
;
2639 register int count
= specpdl_ptr
- specpdl
;
2640 if (specpdl_size
>= max_specpdl_size
)
2642 if (max_specpdl_size
< 400)
2643 max_specpdl_size
= 400;
2644 if (specpdl_size
>= max_specpdl_size
)
2646 if (!NILP (Vdebug_on_error
))
2647 /* Leave room for some specpdl in the debugger. */
2648 max_specpdl_size
= specpdl_size
+ 100;
2650 Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil
));
2654 if (specpdl_size
> max_specpdl_size
)
2655 specpdl_size
= max_specpdl_size
;
2656 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
2657 specpdl_ptr
= specpdl
+ count
;
2661 specbind (symbol
, value
)
2662 Lisp_Object symbol
, value
;
2666 CHECK_SYMBOL (symbol
, 0);
2668 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2670 specpdl_ptr
->symbol
= symbol
;
2671 specpdl_ptr
->func
= 0;
2672 specpdl_ptr
->old_value
= ovalue
= find_symbol_value (symbol
);
2674 if (BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
))
2675 store_symval_forwarding (symbol
, ovalue
, value
);
2677 set_internal (symbol
, value
, 1);
2681 record_unwind_protect (function
, arg
)
2682 Lisp_Object (*function
)();
2685 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2687 specpdl_ptr
->func
= function
;
2688 specpdl_ptr
->symbol
= Qnil
;
2689 specpdl_ptr
->old_value
= arg
;
2694 unbind_to (count
, value
)
2698 int quitf
= !NILP (Vquit_flag
);
2699 struct gcpro gcpro1
;
2705 while (specpdl_ptr
!= specpdl
+ count
)
2708 if (specpdl_ptr
->func
!= 0)
2709 (*specpdl_ptr
->func
) (specpdl_ptr
->old_value
);
2710 /* Note that a "binding" of nil is really an unwind protect,
2711 so in that case the "old value" is a list of forms to evaluate. */
2712 else if (NILP (specpdl_ptr
->symbol
))
2713 Fprogn (specpdl_ptr
->old_value
);
2715 set_internal (specpdl_ptr
->symbol
, specpdl_ptr
->old_value
, 1);
2717 if (NILP (Vquit_flag
) && quitf
) Vquit_flag
= Qt
;
2726 /* Get the value of symbol's global binding, even if that binding
2727 is not now dynamically visible. */
2730 top_level_value (symbol
)
2733 register struct specbinding
*ptr
= specpdl
;
2735 CHECK_SYMBOL (symbol
, 0);
2736 for (; ptr
!= specpdl_ptr
; ptr
++)
2738 if (EQ (ptr
->symbol
, symbol
))
2739 return ptr
->old_value
;
2741 return Fsymbol_value (symbol
);
2745 top_level_set (symbol
, newval
)
2746 Lisp_Object symbol
, newval
;
2748 register struct specbinding
*ptr
= specpdl
;
2750 CHECK_SYMBOL (symbol
, 0);
2751 for (; ptr
!= specpdl_ptr
; ptr
++)
2753 if (EQ (ptr
->symbol
, symbol
))
2755 ptr
->old_value
= newval
;
2759 return Fset (symbol
, newval
);
2764 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
2765 "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\
2766 The debugger is entered when that frame exits, if the flag is non-nil.")
2768 Lisp_Object level
, flag
;
2770 register struct backtrace
*backlist
= backtrace_list
;
2773 CHECK_NUMBER (level
, 0);
2775 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
2777 backlist
= backlist
->next
;
2781 backlist
->debug_on_exit
= !NILP (flag
);
2786 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
2787 "Print a trace of Lisp function calls currently active.\n\
2788 Output stream used is value of `standard-output'.")
2791 register struct backtrace
*backlist
= backtrace_list
;
2795 extern Lisp_Object Vprint_level
;
2796 struct gcpro gcpro1
;
2798 XSETFASTINT (Vprint_level
, 3);
2805 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
2806 if (backlist
->nargs
== UNEVALLED
)
2808 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
2809 write_string ("\n", -1);
2813 tem
= *backlist
->function
;
2814 Fprin1 (tem
, Qnil
); /* This can QUIT */
2815 write_string ("(", -1);
2816 if (backlist
->nargs
== MANY
)
2818 for (tail
= *backlist
->args
, i
= 0;
2820 tail
= Fcdr (tail
), i
++)
2822 if (i
) write_string (" ", -1);
2823 Fprin1 (Fcar (tail
), Qnil
);
2828 for (i
= 0; i
< backlist
->nargs
; i
++)
2830 if (i
) write_string (" ", -1);
2831 Fprin1 (backlist
->args
[i
], Qnil
);
2834 write_string (")\n", -1);
2836 backlist
= backlist
->next
;
2839 Vprint_level
= Qnil
;
2844 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, "",
2845 "Return the function and arguments NFRAMES up from current execution point.\n\
2846 If that frame has not evaluated the arguments yet (or is a special form),\n\
2847 the value is (nil FUNCTION ARG-FORMS...).\n\
2848 If that frame has evaluated its arguments and called its function already,\n\
2849 the value is (t FUNCTION ARG-VALUES...).\n\
2850 A &rest arg is represented as the tail of the list ARG-VALUES.\n\
2851 FUNCTION is whatever was supplied as car of evaluated list,\n\
2852 or a lambda expression for macro calls.\n\
2853 If NFRAMES is more than the number of frames, the value is nil.")
2855 Lisp_Object nframes
;
2857 register struct backtrace
*backlist
= backtrace_list
;
2861 CHECK_NATNUM (nframes
, 0);
2863 /* Find the frame requested. */
2864 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
2865 backlist
= backlist
->next
;
2869 if (backlist
->nargs
== UNEVALLED
)
2870 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
2873 if (backlist
->nargs
== MANY
)
2874 tem
= *backlist
->args
;
2876 tem
= Flist (backlist
->nargs
, backlist
->args
);
2878 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
2884 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
2885 "*Limit on number of Lisp variable bindings & unwind-protects.\n\
2886 If Lisp code tries to make more than this many at once,\n\
2887 an error is signaled.");
2889 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
2890 "*Limit on depth in `eval', `apply' and `funcall' before error.\n\
2891 This limit is to catch infinite recursions for you before they cause\n\
2892 actual stack overflow in C, which would be fatal for Emacs.\n\
2893 You can safely make it considerably larger than its default value,\n\
2894 if that proves inconveniently small.");
2896 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
2897 "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
2898 Typing C-g sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
2901 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
2902 "Non-nil inhibits C-g quitting from happening immediately.\n\
2903 Note that `quit-flag' will still be set by typing C-g,\n\
2904 so a quit will be signaled as soon as `inhibit-quit' is nil.\n\
2905 To prevent this happening, set `quit-flag' to nil\n\
2906 before making `inhibit-quit' nil.");
2907 Vinhibit_quit
= Qnil
;
2909 Qinhibit_quit
= intern ("inhibit-quit");
2910 staticpro (&Qinhibit_quit
);
2912 Qautoload
= intern ("autoload");
2913 staticpro (&Qautoload
);
2915 Qdebug_on_error
= intern ("debug-on-error");
2916 staticpro (&Qdebug_on_error
);
2918 Qmacro
= intern ("macro");
2919 staticpro (&Qmacro
);
2921 /* Note that the process handling also uses Qexit, but we don't want
2922 to staticpro it twice, so we just do it here. */
2923 Qexit
= intern ("exit");
2926 Qinteractive
= intern ("interactive");
2927 staticpro (&Qinteractive
);
2929 Qcommandp
= intern ("commandp");
2930 staticpro (&Qcommandp
);
2932 Qdefun
= intern ("defun");
2933 staticpro (&Qdefun
);
2935 Qand_rest
= intern ("&rest");
2936 staticpro (&Qand_rest
);
2938 Qand_optional
= intern ("&optional");
2939 staticpro (&Qand_optional
);
2941 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
2942 "*Non-nil means automatically display a backtrace buffer\n\
2943 after any error that is handled by the editor command loop.\n\
2944 If the value is a list, an error only means to display a backtrace\n\
2945 if one of its condition symbols appears in the list.");
2946 Vstack_trace_on_error
= Qnil
;
2948 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
2949 "*Non-nil means enter debugger if an error is signaled.\n\
2950 Does not apply to errors handled by `condition-case'.\n\
2951 If the value is a list, an error only means to enter the debugger\n\
2952 if one of its condition symbols appears in the list.\n\
2953 See also variable `debug-on-quit'.");
2954 Vdebug_on_error
= Qnil
;
2956 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
2957 "*List of errors for which the debugger should not be called.\n\
2958 Each element may be a condition-name or a regexp that matches error messages.\n\
2959 If any element applies to a given error, that error skips the debugger\n\
2960 and just returns to top level.\n\
2961 This overrides the variable `debug-on-error'.\n\
2962 It does not apply to errors handled by `condition-case'.");
2963 Vdebug_ignored_errors
= Qnil
;
2965 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
2966 "*Non-nil means enter debugger if quit is signaled (C-g, for example).\n\
2967 Does not apply if quit is handled by a `condition-case'.");
2970 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
2971 "Non-nil means enter debugger before next `eval', `apply' or `funcall'.");
2973 DEFVAR_LISP ("debugger", &Vdebugger
,
2974 "Function to call to invoke debugger.\n\
2975 If due to frame exit, args are `exit' and the value being returned;\n\
2976 this function's value will be returned instead of that.\n\
2977 If due to error, args are `error' and a list of the args to `signal'.\n\
2978 If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
2979 If due to `eval' entry, one arg, t.");
2982 DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function
,
2983 "If non-nil, this is a function for `signal' to call.\n\
2984 It receives the same arguments that `signal' was given.\n\
2985 The Edebug package uses this to regain control.");
2986 Vsignal_hook_function
= Qnil
;
2988 Qmocklisp_arguments
= intern ("mocklisp-arguments");
2989 staticpro (&Qmocklisp_arguments
);
2990 DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments
,
2991 "While in a mocklisp function, the list of its unevaluated args.");
2992 Vmocklisp_arguments
= Qt
;
2994 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal
,
2995 "*Non-nil means call the debugger regardless of condition handlers.\n\
2996 Note that `debug-on-error', `debug-on-quit' and friends\n\
2997 still determine whether to handle the particular condition.");
2998 Vdebug_on_signal
= Qnil
;
3000 Vrun_hooks
= intern ("run-hooks");
3001 staticpro (&Vrun_hooks
);
3003 staticpro (&Vautoload_queue
);
3004 Vautoload_queue
= Qnil
;
3015 defsubr (&Sfunction
);
3017 defsubr (&Sdefmacro
);
3019 defsubr (&Sdefconst
);
3020 defsubr (&Suser_variable_p
);
3024 defsubr (&Smacroexpand
);
3027 defsubr (&Sunwind_protect
);
3028 defsubr (&Scondition_case
);
3030 defsubr (&Sinteractive_p
);
3031 defsubr (&Scommandp
);
3032 defsubr (&Sautoload
);
3035 defsubr (&Sfuncall
);
3036 defsubr (&Srun_hooks
);
3037 defsubr (&Srun_hook_with_args
);
3038 defsubr (&Srun_hook_with_args_until_success
);
3039 defsubr (&Srun_hook_with_args_until_failure
);
3040 defsubr (&Sfetch_bytecode
);
3041 defsubr (&Sbacktrace_debug
);
3042 defsubr (&Sbacktrace
);
3043 defsubr (&Sbacktrace_frame
);