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). */
1622 do_autoload (fundef
, funname
)
1623 Lisp_Object fundef
, funname
;
1625 int count
= specpdl_ptr
- specpdl
;
1626 Lisp_Object fun
, val
, queue
, first
, second
;
1627 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1630 CHECK_SYMBOL (funname
, 0);
1631 GCPRO3 (fun
, funname
, fundef
);
1633 /* Value saved here is to be restored into Vautoload_queue */
1634 record_unwind_protect (un_autoload
, Vautoload_queue
);
1635 Vautoload_queue
= Qt
;
1636 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
, Qt
);
1638 /* Save the old autoloads, in case we ever do an unload. */
1639 queue
= Vautoload_queue
;
1640 while (CONSP (queue
))
1642 first
= Fcar (queue
);
1643 second
= Fcdr (first
);
1644 first
= Fcar (first
);
1646 /* Note: This test is subtle. The cdr of an autoload-queue entry
1647 may be an atom if the autoload entry was generated by a defalias
1650 Fput (first
, Qautoload
, (Fcdr (second
)));
1652 queue
= Fcdr (queue
);
1655 /* Once loading finishes, don't undo it. */
1656 Vautoload_queue
= Qt
;
1657 unbind_to (count
, Qnil
);
1659 fun
= Findirect_function (fun
);
1661 if (!NILP (Fequal (fun
, fundef
)))
1662 error ("Autoloading failed to define function %s",
1663 XSYMBOL (funname
)->name
->data
);
1667 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
1668 "Evaluate FORM and return its value.")
1672 Lisp_Object fun
, val
, original_fun
, original_args
;
1674 struct backtrace backtrace
;
1675 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1679 if (EQ (Vmocklisp_arguments
, Qt
))
1680 return Fsymbol_value (form
);
1681 val
= Fsymbol_value (form
);
1683 XSETFASTINT (val
, 0);
1684 else if (EQ (val
, Qt
))
1685 XSETFASTINT (val
, 1);
1692 if (consing_since_gc
> gc_cons_threshold
)
1695 Fgarbage_collect ();
1699 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1701 if (max_lisp_eval_depth
< 100)
1702 max_lisp_eval_depth
= 100;
1703 if (lisp_eval_depth
> max_lisp_eval_depth
)
1704 error ("Lisp nesting exceeds max-lisp-eval-depth");
1707 original_fun
= Fcar (form
);
1708 original_args
= Fcdr (form
);
1710 backtrace
.next
= backtrace_list
;
1711 backtrace_list
= &backtrace
;
1712 backtrace
.function
= &original_fun
; /* This also protects them from gc */
1713 backtrace
.args
= &original_args
;
1714 backtrace
.nargs
= UNEVALLED
;
1715 backtrace
.evalargs
= 1;
1716 backtrace
.debug_on_exit
= 0;
1718 if (debug_on_next_call
)
1719 do_debug_on_call (Qt
);
1721 /* At this point, only original_fun and original_args
1722 have values that will be used below */
1724 fun
= Findirect_function (original_fun
);
1728 Lisp_Object numargs
;
1729 Lisp_Object argvals
[8];
1730 Lisp_Object args_left
;
1731 register int i
, maxargs
;
1733 args_left
= original_args
;
1734 numargs
= Flength (args_left
);
1736 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
1737 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
1738 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1740 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1742 backtrace
.evalargs
= 0;
1743 val
= (*XSUBR (fun
)->function
) (args_left
);
1747 if (XSUBR (fun
)->max_args
== MANY
)
1749 /* Pass a vector of evaluated arguments */
1751 register int argnum
= 0;
1753 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1755 GCPRO3 (args_left
, fun
, fun
);
1759 while (!NILP (args_left
))
1761 vals
[argnum
++] = Feval (Fcar (args_left
));
1762 args_left
= Fcdr (args_left
);
1763 gcpro3
.nvars
= argnum
;
1766 backtrace
.args
= vals
;
1767 backtrace
.nargs
= XINT (numargs
);
1769 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
1774 GCPRO3 (args_left
, fun
, fun
);
1775 gcpro3
.var
= argvals
;
1778 maxargs
= XSUBR (fun
)->max_args
;
1779 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
1781 argvals
[i
] = Feval (Fcar (args_left
));
1787 backtrace
.args
= argvals
;
1788 backtrace
.nargs
= XINT (numargs
);
1793 val
= (*XSUBR (fun
)->function
) ();
1796 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
1799 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
1802 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1806 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1807 argvals
[2], argvals
[3]);
1810 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1811 argvals
[3], argvals
[4]);
1814 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1815 argvals
[3], argvals
[4], argvals
[5]);
1818 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1819 argvals
[3], argvals
[4], argvals
[5],
1824 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1825 argvals
[3], argvals
[4], argvals
[5],
1826 argvals
[6], argvals
[7]);
1830 /* Someone has created a subr that takes more arguments than
1831 is supported by this code. We need to either rewrite the
1832 subr to use a different argument protocol, or add more
1833 cases to this switch. */
1837 if (COMPILEDP (fun
))
1838 val
= apply_lambda (fun
, original_args
, 1);
1842 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1843 funcar
= Fcar (fun
);
1844 if (!SYMBOLP (funcar
))
1845 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1846 if (EQ (funcar
, Qautoload
))
1848 do_autoload (fun
, original_fun
);
1851 if (EQ (funcar
, Qmacro
))
1852 val
= Feval (apply1 (Fcdr (fun
), original_args
));
1853 else if (EQ (funcar
, Qlambda
))
1854 val
= apply_lambda (fun
, original_args
, 1);
1855 else if (EQ (funcar
, Qmocklisp
))
1856 val
= ml_apply (fun
, original_args
);
1858 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1861 if (!EQ (Vmocklisp_arguments
, Qt
))
1864 XSETFASTINT (val
, 0);
1865 else if (EQ (val
, Qt
))
1866 XSETFASTINT (val
, 1);
1869 if (backtrace
.debug_on_exit
)
1870 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
1871 backtrace_list
= backtrace
.next
;
1875 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
1876 "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
1877 Then return the value FUNCTION returns.\n\
1878 Thus, (apply '+ 1 2 '(3 4)) returns 10.")
1883 register int i
, numargs
;
1884 register Lisp_Object spread_arg
;
1885 register Lisp_Object
*funcall_args
;
1887 struct gcpro gcpro1
;
1891 spread_arg
= args
[nargs
- 1];
1892 CHECK_LIST (spread_arg
, nargs
);
1894 numargs
= XINT (Flength (spread_arg
));
1897 return Ffuncall (nargs
- 1, args
);
1898 else if (numargs
== 1)
1900 args
[nargs
- 1] = XCONS (spread_arg
)->car
;
1901 return Ffuncall (nargs
, args
);
1904 numargs
+= nargs
- 2;
1906 fun
= indirect_function (fun
);
1907 if (EQ (fun
, Qunbound
))
1909 /* Let funcall get the error */
1916 if (numargs
< XSUBR (fun
)->min_args
1917 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
1918 goto funcall
; /* Let funcall get the error */
1919 else if (XSUBR (fun
)->max_args
> numargs
)
1921 /* Avoid making funcall cons up a yet another new vector of arguments
1922 by explicitly supplying nil's for optional values */
1923 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
1924 * sizeof (Lisp_Object
));
1925 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
1926 funcall_args
[++i
] = Qnil
;
1927 GCPRO1 (*funcall_args
);
1928 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
1932 /* We add 1 to numargs because funcall_args includes the
1933 function itself as well as its arguments. */
1936 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
1937 * sizeof (Lisp_Object
));
1938 GCPRO1 (*funcall_args
);
1939 gcpro1
.nvars
= 1 + numargs
;
1942 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
1943 /* Spread the last arg we got. Its first element goes in
1944 the slot that it used to occupy, hence this value of I. */
1946 while (!NILP (spread_arg
))
1948 funcall_args
[i
++] = XCONS (spread_arg
)->car
;
1949 spread_arg
= XCONS (spread_arg
)->cdr
;
1952 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
1955 /* Run hook variables in various ways. */
1957 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
1959 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 1, MANY
, 0,
1960 "Run each hook in HOOKS. Major mode functions use this.\n\
1961 Each argument should be a symbol, a hook variable.\n\
1962 These symbols are processed in the order specified.\n\
1963 If a hook symbol has a non-nil value, that value may be a function\n\
1964 or a list of functions to be called to run the hook.\n\
1965 If the value is a function, it is called with no arguments.\n\
1966 If it is a list, the elements are called, in order, with no arguments.\n\
1968 To make a hook variable buffer-local, use `make-local-hook',\n\
1969 not `make-local-variable'.")
1974 Lisp_Object hook
[1];
1977 for (i
= 0; i
< nargs
; i
++)
1980 run_hook_with_args (1, hook
, to_completion
);
1986 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
1987 Srun_hook_with_args
, 1, MANY
, 0,
1988 "Run HOOK with the specified arguments ARGS.\n\
1989 HOOK should be a symbol, a hook variable. If HOOK has a non-nil\n\
1990 value, that value may be a function or a list of functions to be\n\
1991 called to run the hook. If the value is a function, it is called with\n\
1992 the given arguments and its return value is returned. If it is a list\n\
1993 of functions, those functions are called, in order,\n\
1994 with the given arguments ARGS.\n\
1995 It is best not to depend on the value return by `run-hook-with-args',\n\
1996 as that may change.\n\
1998 To make a hook variable buffer-local, use `make-local-hook',\n\
1999 not `make-local-variable'.")
2004 return run_hook_with_args (nargs
, args
, to_completion
);
2007 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2008 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2009 "Run HOOK with the specified arguments ARGS.\n\
2010 HOOK should be a symbol, a hook variable. Its value should\n\
2011 be a list of functions. We call those functions, one by one,\n\
2012 passing arguments ARGS to each of them, until one of them\n\
2013 returns a non-nil value. Then we return that value.\n\
2014 If all the functions return nil, we return nil.\n\
2016 To make a hook variable buffer-local, use `make-local-hook',\n\
2017 not `make-local-variable'.")
2022 return run_hook_with_args (nargs
, args
, until_success
);
2025 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2026 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2027 "Run HOOK with the specified arguments ARGS.\n\
2028 HOOK should be a symbol, a hook variable. Its value should\n\
2029 be a list of functions. We call those functions, one by one,\n\
2030 passing arguments ARGS to each of them, until one of them\n\
2031 returns nil. Then we return nil.\n\
2032 If all the functions return non-nil, we return non-nil.\n\
2034 To make a hook variable buffer-local, use `make-local-hook',\n\
2035 not `make-local-variable'.")
2040 return run_hook_with_args (nargs
, args
, until_failure
);
2043 /* ARGS[0] should be a hook symbol.
2044 Call each of the functions in the hook value, passing each of them
2045 as arguments all the rest of ARGS (all NARGS - 1 elements).
2046 COND specifies a condition to test after each call
2047 to decide whether to stop.
2048 The caller (or its caller, etc) must gcpro all of ARGS,
2049 except that it isn't necessary to gcpro ARGS[0]. */
2052 run_hook_with_args (nargs
, args
, cond
)
2055 enum run_hooks_condition cond
;
2057 Lisp_Object sym
, val
, ret
;
2058 struct gcpro gcpro1
, gcpro2
;
2060 /* If we are dying or still initializing,
2061 don't do anything--it would probably crash if we tried. */
2062 if (NILP (Vrun_hooks
))
2066 val
= find_symbol_value (sym
);
2067 ret
= (cond
== until_failure
? Qt
: Qnil
);
2069 if (EQ (val
, Qunbound
) || NILP (val
))
2071 else if (!CONSP (val
) || EQ (XCONS (val
)->car
, Qlambda
))
2074 return Ffuncall (nargs
, args
);
2081 CONSP (val
) && ((cond
== to_completion
)
2082 || (cond
== until_success
? NILP (ret
)
2084 val
= XCONS (val
)->cdr
)
2086 if (EQ (XCONS (val
)->car
, Qt
))
2088 /* t indicates this hook has a local binding;
2089 it means to run the global binding too. */
2090 Lisp_Object globals
;
2092 for (globals
= Fdefault_value (sym
);
2093 CONSP (globals
) && ((cond
== to_completion
)
2094 || (cond
== until_success
? NILP (ret
)
2096 globals
= XCONS (globals
)->cdr
)
2098 args
[0] = XCONS (globals
)->car
;
2099 /* In a global value, t should not occur. If it does, we
2100 must ignore it to avoid an endless loop. */
2101 if (!EQ (args
[0], Qt
))
2102 ret
= Ffuncall (nargs
, args
);
2107 args
[0] = XCONS (val
)->car
;
2108 ret
= Ffuncall (nargs
, args
);
2117 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2118 present value of that symbol.
2119 Call each element of FUNLIST,
2120 passing each of them the rest of ARGS.
2121 The caller (or its caller, etc) must gcpro all of ARGS,
2122 except that it isn't necessary to gcpro ARGS[0]. */
2125 run_hook_list_with_args (funlist
, nargs
, args
)
2126 Lisp_Object funlist
;
2132 struct gcpro gcpro1
, gcpro2
;
2137 for (val
= funlist
; CONSP (val
); val
= XCONS (val
)->cdr
)
2139 if (EQ (XCONS (val
)->car
, Qt
))
2141 /* t indicates this hook has a local binding;
2142 it means to run the global binding too. */
2143 Lisp_Object globals
;
2145 for (globals
= Fdefault_value (sym
);
2147 globals
= XCONS (globals
)->cdr
)
2149 args
[0] = XCONS (globals
)->car
;
2150 /* In a global value, t should not occur. If it does, we
2151 must ignore it to avoid an endless loop. */
2152 if (!EQ (args
[0], Qt
))
2153 Ffuncall (nargs
, args
);
2158 args
[0] = XCONS (val
)->car
;
2159 Ffuncall (nargs
, args
);
2166 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2169 run_hook_with_args_2 (hook
, arg1
, arg2
)
2170 Lisp_Object hook
, arg1
, arg2
;
2172 Lisp_Object temp
[3];
2177 Frun_hook_with_args (3, temp
);
2180 /* Apply fn to arg */
2183 Lisp_Object fn
, arg
;
2185 struct gcpro gcpro1
;
2189 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2193 Lisp_Object args
[2];
2197 RETURN_UNGCPRO (Fapply (2, args
));
2199 #else /* not NO_ARG_ARRAY */
2200 RETURN_UNGCPRO (Fapply (2, &fn
));
2201 #endif /* not NO_ARG_ARRAY */
2204 /* Call function fn on no arguments */
2209 struct gcpro gcpro1
;
2212 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2215 /* Call function fn with 1 argument arg1 */
2219 Lisp_Object fn
, arg1
;
2221 struct gcpro gcpro1
;
2223 Lisp_Object args
[2];
2229 RETURN_UNGCPRO (Ffuncall (2, args
));
2230 #else /* not NO_ARG_ARRAY */
2233 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2234 #endif /* not NO_ARG_ARRAY */
2237 /* Call function fn with 2 arguments arg1, arg2 */
2240 call2 (fn
, arg1
, arg2
)
2241 Lisp_Object fn
, arg1
, arg2
;
2243 struct gcpro gcpro1
;
2245 Lisp_Object args
[3];
2251 RETURN_UNGCPRO (Ffuncall (3, args
));
2252 #else /* not NO_ARG_ARRAY */
2255 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2256 #endif /* not NO_ARG_ARRAY */
2259 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2262 call3 (fn
, arg1
, arg2
, arg3
)
2263 Lisp_Object fn
, arg1
, arg2
, arg3
;
2265 struct gcpro gcpro1
;
2267 Lisp_Object args
[4];
2274 RETURN_UNGCPRO (Ffuncall (4, args
));
2275 #else /* not NO_ARG_ARRAY */
2278 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2279 #endif /* not NO_ARG_ARRAY */
2282 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2285 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2286 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2288 struct gcpro gcpro1
;
2290 Lisp_Object args
[5];
2298 RETURN_UNGCPRO (Ffuncall (5, args
));
2299 #else /* not NO_ARG_ARRAY */
2302 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2303 #endif /* not NO_ARG_ARRAY */
2306 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2309 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2310 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2312 struct gcpro gcpro1
;
2314 Lisp_Object args
[6];
2323 RETURN_UNGCPRO (Ffuncall (6, args
));
2324 #else /* not NO_ARG_ARRAY */
2327 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2328 #endif /* not NO_ARG_ARRAY */
2331 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2334 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2335 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2337 struct gcpro gcpro1
;
2339 Lisp_Object args
[7];
2349 RETURN_UNGCPRO (Ffuncall (7, args
));
2350 #else /* not NO_ARG_ARRAY */
2353 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2354 #endif /* not NO_ARG_ARRAY */
2357 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2358 "Call first argument as a function, passing remaining arguments to it.\n\
2359 Return the value that function returns.\n\
2360 Thus, (funcall 'cons 'x 'y) returns (x . y).")
2367 int numargs
= nargs
- 1;
2368 Lisp_Object lisp_numargs
;
2370 struct backtrace backtrace
;
2371 register Lisp_Object
*internal_args
;
2375 if (consing_since_gc
> gc_cons_threshold
)
2376 Fgarbage_collect ();
2378 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2380 if (max_lisp_eval_depth
< 100)
2381 max_lisp_eval_depth
= 100;
2382 if (lisp_eval_depth
> max_lisp_eval_depth
)
2383 error ("Lisp nesting exceeds max-lisp-eval-depth");
2386 backtrace
.next
= backtrace_list
;
2387 backtrace_list
= &backtrace
;
2388 backtrace
.function
= &args
[0];
2389 backtrace
.args
= &args
[1];
2390 backtrace
.nargs
= nargs
- 1;
2391 backtrace
.evalargs
= 0;
2392 backtrace
.debug_on_exit
= 0;
2394 if (debug_on_next_call
)
2395 do_debug_on_call (Qlambda
);
2401 fun
= Findirect_function (fun
);
2405 if (numargs
< XSUBR (fun
)->min_args
2406 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2408 XSETFASTINT (lisp_numargs
, numargs
);
2409 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (lisp_numargs
, Qnil
)));
2412 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2413 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2415 if (XSUBR (fun
)->max_args
== MANY
)
2417 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
2421 if (XSUBR (fun
)->max_args
> numargs
)
2423 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2424 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
2425 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2426 internal_args
[i
] = Qnil
;
2429 internal_args
= args
+ 1;
2430 switch (XSUBR (fun
)->max_args
)
2433 val
= (*XSUBR (fun
)->function
) ();
2436 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
2439 val
= (*XSUBR (fun
)->function
) (internal_args
[0],
2443 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2447 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2452 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2453 internal_args
[2], internal_args
[3],
2457 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2458 internal_args
[2], internal_args
[3],
2459 internal_args
[4], internal_args
[5]);
2462 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2463 internal_args
[2], internal_args
[3],
2464 internal_args
[4], internal_args
[5],
2469 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2470 internal_args
[2], internal_args
[3],
2471 internal_args
[4], internal_args
[5],
2472 internal_args
[6], internal_args
[7]);
2477 /* If a subr takes more than 8 arguments without using MANY
2478 or UNEVALLED, we need to extend this function to support it.
2479 Until this is done, there is no way to call the function. */
2483 if (COMPILEDP (fun
))
2484 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2488 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2489 funcar
= Fcar (fun
);
2490 if (!SYMBOLP (funcar
))
2491 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2492 if (EQ (funcar
, Qlambda
))
2493 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2494 else if (EQ (funcar
, Qmocklisp
))
2495 val
= ml_apply (fun
, Flist (numargs
, args
+ 1));
2496 else if (EQ (funcar
, Qautoload
))
2498 do_autoload (fun
, args
[0]);
2502 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2506 if (backtrace
.debug_on_exit
)
2507 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2508 backtrace_list
= backtrace
.next
;
2513 apply_lambda (fun
, args
, eval_flag
)
2514 Lisp_Object fun
, args
;
2517 Lisp_Object args_left
;
2518 Lisp_Object numargs
;
2519 register Lisp_Object
*arg_vector
;
2520 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2522 register Lisp_Object tem
;
2524 numargs
= Flength (args
);
2525 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2528 GCPRO3 (*arg_vector
, args_left
, fun
);
2531 for (i
= 0; i
< XINT (numargs
);)
2533 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2534 if (eval_flag
) tem
= Feval (tem
);
2535 arg_vector
[i
++] = tem
;
2543 backtrace_list
->args
= arg_vector
;
2544 backtrace_list
->nargs
= i
;
2546 backtrace_list
->evalargs
= 0;
2547 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
2549 /* Do the debug-on-exit now, while arg_vector still exists. */
2550 if (backtrace_list
->debug_on_exit
)
2551 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
2552 /* Don't do it again when we return to eval. */
2553 backtrace_list
->debug_on_exit
= 0;
2557 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2558 and return the result of evaluation.
2559 FUN must be either a lambda-expression or a compiled-code object. */
2562 funcall_lambda (fun
, nargs
, arg_vector
)
2565 register Lisp_Object
*arg_vector
;
2567 Lisp_Object val
, tem
;
2568 register Lisp_Object syms_left
;
2569 Lisp_Object numargs
;
2570 register Lisp_Object next
;
2571 int count
= specpdl_ptr
- specpdl
;
2573 int optional
= 0, rest
= 0;
2575 specbind (Qmocklisp_arguments
, Qt
); /* t means NOT mocklisp! */
2577 XSETFASTINT (numargs
, nargs
);
2580 syms_left
= Fcar (Fcdr (fun
));
2581 else if (COMPILEDP (fun
))
2582 syms_left
= XVECTOR (fun
)->contents
[COMPILED_ARGLIST
];
2586 for (; !NILP (syms_left
); syms_left
= Fcdr (syms_left
))
2589 next
= Fcar (syms_left
);
2590 while (!SYMBOLP (next
))
2591 next
= Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2592 if (EQ (next
, Qand_rest
))
2594 else if (EQ (next
, Qand_optional
))
2598 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
2603 tem
= arg_vector
[i
++];
2604 specbind (next
, tem
);
2607 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2609 specbind (next
, Qnil
);
2613 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2616 val
= Fprogn (Fcdr (Fcdr (fun
)));
2619 /* If we have not actually read the bytecode string
2620 and constants vector yet, fetch them from the file. */
2621 if (CONSP (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
]))
2622 Ffetch_bytecode (fun
);
2623 val
= Fbyte_code (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
],
2624 XVECTOR (fun
)->contents
[COMPILED_CONSTANTS
],
2625 XVECTOR (fun
)->contents
[COMPILED_STACK_DEPTH
]);
2627 return unbind_to (count
, val
);
2630 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
2632 "If byte-compiled OBJECT is lazy-loaded, fetch it now.")
2638 if (COMPILEDP (object
)
2639 && CONSP (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]))
2641 tem
= read_doc_string (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]);
2643 error ("invalid byte code");
2644 XVECTOR (object
)->contents
[COMPILED_BYTECODE
] = XCONS (tem
)->car
;
2645 XVECTOR (object
)->contents
[COMPILED_CONSTANTS
] = XCONS (tem
)->cdr
;
2653 register int count
= specpdl_ptr
- specpdl
;
2654 if (specpdl_size
>= max_specpdl_size
)
2656 if (max_specpdl_size
< 400)
2657 max_specpdl_size
= 400;
2658 if (specpdl_size
>= max_specpdl_size
)
2660 if (!NILP (Vdebug_on_error
))
2661 /* Leave room for some specpdl in the debugger. */
2662 max_specpdl_size
= specpdl_size
+ 100;
2664 Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil
));
2668 if (specpdl_size
> max_specpdl_size
)
2669 specpdl_size
= max_specpdl_size
;
2670 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
2671 specpdl_ptr
= specpdl
+ count
;
2675 specbind (symbol
, value
)
2676 Lisp_Object symbol
, value
;
2680 CHECK_SYMBOL (symbol
, 0);
2682 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2684 specpdl_ptr
->symbol
= symbol
;
2685 specpdl_ptr
->func
= 0;
2686 specpdl_ptr
->old_value
= ovalue
= find_symbol_value (symbol
);
2688 if (BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
))
2689 store_symval_forwarding (symbol
, ovalue
, value
);
2691 set_internal (symbol
, value
, 1);
2695 record_unwind_protect (function
, arg
)
2696 Lisp_Object (*function
) P_ ((Lisp_Object
));
2699 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2701 specpdl_ptr
->func
= function
;
2702 specpdl_ptr
->symbol
= Qnil
;
2703 specpdl_ptr
->old_value
= arg
;
2708 unbind_to (count
, value
)
2712 int quitf
= !NILP (Vquit_flag
);
2713 struct gcpro gcpro1
;
2719 while (specpdl_ptr
!= specpdl
+ count
)
2722 if (specpdl_ptr
->func
!= 0)
2723 (*specpdl_ptr
->func
) (specpdl_ptr
->old_value
);
2724 /* Note that a "binding" of nil is really an unwind protect,
2725 so in that case the "old value" is a list of forms to evaluate. */
2726 else if (NILP (specpdl_ptr
->symbol
))
2727 Fprogn (specpdl_ptr
->old_value
);
2729 set_internal (specpdl_ptr
->symbol
, specpdl_ptr
->old_value
, 1);
2731 if (NILP (Vquit_flag
) && quitf
) Vquit_flag
= Qt
;
2740 /* Get the value of symbol's global binding, even if that binding
2741 is not now dynamically visible. */
2744 top_level_value (symbol
)
2747 register struct specbinding
*ptr
= specpdl
;
2749 CHECK_SYMBOL (symbol
, 0);
2750 for (; ptr
!= specpdl_ptr
; ptr
++)
2752 if (EQ (ptr
->symbol
, symbol
))
2753 return ptr
->old_value
;
2755 return Fsymbol_value (symbol
);
2759 top_level_set (symbol
, newval
)
2760 Lisp_Object symbol
, newval
;
2762 register struct specbinding
*ptr
= specpdl
;
2764 CHECK_SYMBOL (symbol
, 0);
2765 for (; ptr
!= specpdl_ptr
; ptr
++)
2767 if (EQ (ptr
->symbol
, symbol
))
2769 ptr
->old_value
= newval
;
2773 return Fset (symbol
, newval
);
2778 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
2779 "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\
2780 The debugger is entered when that frame exits, if the flag is non-nil.")
2782 Lisp_Object level
, flag
;
2784 register struct backtrace
*backlist
= backtrace_list
;
2787 CHECK_NUMBER (level
, 0);
2789 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
2791 backlist
= backlist
->next
;
2795 backlist
->debug_on_exit
= !NILP (flag
);
2800 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
2801 "Print a trace of Lisp function calls currently active.\n\
2802 Output stream used is value of `standard-output'.")
2805 register struct backtrace
*backlist
= backtrace_list
;
2809 extern Lisp_Object Vprint_level
;
2810 struct gcpro gcpro1
;
2812 XSETFASTINT (Vprint_level
, 3);
2819 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
2820 if (backlist
->nargs
== UNEVALLED
)
2822 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
2823 write_string ("\n", -1);
2827 tem
= *backlist
->function
;
2828 Fprin1 (tem
, Qnil
); /* This can QUIT */
2829 write_string ("(", -1);
2830 if (backlist
->nargs
== MANY
)
2832 for (tail
= *backlist
->args
, i
= 0;
2834 tail
= Fcdr (tail
), i
++)
2836 if (i
) write_string (" ", -1);
2837 Fprin1 (Fcar (tail
), Qnil
);
2842 for (i
= 0; i
< backlist
->nargs
; i
++)
2844 if (i
) write_string (" ", -1);
2845 Fprin1 (backlist
->args
[i
], Qnil
);
2848 write_string (")\n", -1);
2850 backlist
= backlist
->next
;
2853 Vprint_level
= Qnil
;
2858 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, "",
2859 "Return the function and arguments NFRAMES up from current execution point.\n\
2860 If that frame has not evaluated the arguments yet (or is a special form),\n\
2861 the value is (nil FUNCTION ARG-FORMS...).\n\
2862 If that frame has evaluated its arguments and called its function already,\n\
2863 the value is (t FUNCTION ARG-VALUES...).\n\
2864 A &rest arg is represented as the tail of the list ARG-VALUES.\n\
2865 FUNCTION is whatever was supplied as car of evaluated list,\n\
2866 or a lambda expression for macro calls.\n\
2867 If NFRAMES is more than the number of frames, the value is nil.")
2869 Lisp_Object nframes
;
2871 register struct backtrace
*backlist
= backtrace_list
;
2875 CHECK_NATNUM (nframes
, 0);
2877 /* Find the frame requested. */
2878 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
2879 backlist
= backlist
->next
;
2883 if (backlist
->nargs
== UNEVALLED
)
2884 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
2887 if (backlist
->nargs
== MANY
)
2888 tem
= *backlist
->args
;
2890 tem
= Flist (backlist
->nargs
, backlist
->args
);
2892 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
2898 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
2899 "*Limit on number of Lisp variable bindings & unwind-protects.\n\
2900 If Lisp code tries to make more than this many at once,\n\
2901 an error is signaled.");
2903 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
2904 "*Limit on depth in `eval', `apply' and `funcall' before error.\n\
2905 This limit is to catch infinite recursions for you before they cause\n\
2906 actual stack overflow in C, which would be fatal for Emacs.\n\
2907 You can safely make it considerably larger than its default value,\n\
2908 if that proves inconveniently small.");
2910 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
2911 "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
2912 Typing C-g sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
2915 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
2916 "Non-nil inhibits C-g quitting from happening immediately.\n\
2917 Note that `quit-flag' will still be set by typing C-g,\n\
2918 so a quit will be signaled as soon as `inhibit-quit' is nil.\n\
2919 To prevent this happening, set `quit-flag' to nil\n\
2920 before making `inhibit-quit' nil.");
2921 Vinhibit_quit
= Qnil
;
2923 Qinhibit_quit
= intern ("inhibit-quit");
2924 staticpro (&Qinhibit_quit
);
2926 Qautoload
= intern ("autoload");
2927 staticpro (&Qautoload
);
2929 Qdebug_on_error
= intern ("debug-on-error");
2930 staticpro (&Qdebug_on_error
);
2932 Qmacro
= intern ("macro");
2933 staticpro (&Qmacro
);
2935 /* Note that the process handling also uses Qexit, but we don't want
2936 to staticpro it twice, so we just do it here. */
2937 Qexit
= intern ("exit");
2940 Qinteractive
= intern ("interactive");
2941 staticpro (&Qinteractive
);
2943 Qcommandp
= intern ("commandp");
2944 staticpro (&Qcommandp
);
2946 Qdefun
= intern ("defun");
2947 staticpro (&Qdefun
);
2949 Qand_rest
= intern ("&rest");
2950 staticpro (&Qand_rest
);
2952 Qand_optional
= intern ("&optional");
2953 staticpro (&Qand_optional
);
2955 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
2956 "*Non-nil means automatically display a backtrace buffer\n\
2957 after any error that is handled by the editor command loop.\n\
2958 If the value is a list, an error only means to display a backtrace\n\
2959 if one of its condition symbols appears in the list.");
2960 Vstack_trace_on_error
= Qnil
;
2962 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
2963 "*Non-nil means enter debugger if an error is signaled.\n\
2964 Does not apply to errors handled by `condition-case'.\n\
2965 If the value is a list, an error only means to enter the debugger\n\
2966 if one of its condition symbols appears in the list.\n\
2967 See also variable `debug-on-quit'.");
2968 Vdebug_on_error
= Qnil
;
2970 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
2971 "*List of errors for which the debugger should not be called.\n\
2972 Each element may be a condition-name or a regexp that matches error messages.\n\
2973 If any element applies to a given error, that error skips the debugger\n\
2974 and just returns to top level.\n\
2975 This overrides the variable `debug-on-error'.\n\
2976 It does not apply to errors handled by `condition-case'.");
2977 Vdebug_ignored_errors
= Qnil
;
2979 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
2980 "*Non-nil means enter debugger if quit is signaled (C-g, for example).\n\
2981 Does not apply if quit is handled by a `condition-case'.");
2984 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
2985 "Non-nil means enter debugger before next `eval', `apply' or `funcall'.");
2987 DEFVAR_LISP ("debugger", &Vdebugger
,
2988 "Function to call to invoke debugger.\n\
2989 If due to frame exit, args are `exit' and the value being returned;\n\
2990 this function's value will be returned instead of that.\n\
2991 If due to error, args are `error' and a list of the args to `signal'.\n\
2992 If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
2993 If due to `eval' entry, one arg, t.");
2996 DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function
,
2997 "If non-nil, this is a function for `signal' to call.\n\
2998 It receives the same arguments that `signal' was given.\n\
2999 The Edebug package uses this to regain control.");
3000 Vsignal_hook_function
= Qnil
;
3002 Qmocklisp_arguments
= intern ("mocklisp-arguments");
3003 staticpro (&Qmocklisp_arguments
);
3004 DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments
,
3005 "While in a mocklisp function, the list of its unevaluated args.");
3006 Vmocklisp_arguments
= Qt
;
3008 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal
,
3009 "*Non-nil means call the debugger regardless of condition handlers.\n\
3010 Note that `debug-on-error', `debug-on-quit' and friends\n\
3011 still determine whether to handle the particular condition.");
3012 Vdebug_on_signal
= Qnil
;
3014 Vrun_hooks
= intern ("run-hooks");
3015 staticpro (&Vrun_hooks
);
3017 staticpro (&Vautoload_queue
);
3018 Vautoload_queue
= Qnil
;
3029 defsubr (&Sfunction
);
3031 defsubr (&Sdefmacro
);
3033 defsubr (&Sdefconst
);
3034 defsubr (&Suser_variable_p
);
3038 defsubr (&Smacroexpand
);
3041 defsubr (&Sunwind_protect
);
3042 defsubr (&Scondition_case
);
3044 defsubr (&Sinteractive_p
);
3045 defsubr (&Scommandp
);
3046 defsubr (&Sautoload
);
3049 defsubr (&Sfuncall
);
3050 defsubr (&Srun_hooks
);
3051 defsubr (&Srun_hook_with_args
);
3052 defsubr (&Srun_hook_with_args_until_success
);
3053 defsubr (&Srun_hook_with_args_until_failure
);
3054 defsubr (&Sfetch_bytecode
);
3055 defsubr (&Sbacktrace_debug
);
3056 defsubr (&Sbacktrace
);
3057 defsubr (&Sbacktrace_frame
);