1 /* Evaluator for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
29 #include "blockinput.h"
40 /* This definition is duplicated in alloc.c and keyboard.c */
41 /* Putting it in lisp.h makes cc bomb out! */
45 struct backtrace
*next
;
46 Lisp_Object
*function
;
47 Lisp_Object
*args
; /* Points to vector of args. */
48 int nargs
; /* Length of vector.
49 If nargs is UNEVALLED, args points to slot holding
50 list of unevalled args */
52 /* Nonzero means call value of debugger when done with this operation. */
56 struct backtrace
*backtrace_list
;
58 /* This structure helps implement the `catch' and `throw' control
59 structure. A struct catchtag contains all the information needed
60 to restore the state of the interpreter after a non-local jump.
62 Handlers for error conditions (represented by `struct handler'
63 structures) just point to a catch tag to do the cleanup required
66 catchtag structures are chained together in the C calling stack;
67 the `next' member points to the next outer catchtag.
69 A call like (throw TAG VAL) searches for a catchtag whose `tag'
70 member is TAG, and then unbinds to it. The `val' member is used to
71 hold VAL while the stack is unwound; `val' is returned as the value
74 All the other members are concerned with restoring the interpreter
80 struct catchtag
*next
;
83 struct backtrace
*backlist
;
84 struct handler
*handlerlist
;
87 int poll_suppress_count
;
90 struct catchtag
*catchlist
;
92 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
93 Lisp_Object Qinhibit_quit
, Vinhibit_quit
, Vquit_flag
;
94 Lisp_Object Qmocklisp_arguments
, Vmocklisp_arguments
, Qmocklisp
;
95 Lisp_Object Qand_rest
, Qand_optional
;
96 Lisp_Object Qdebug_on_error
;
98 /* This holds either the symbol `run-hooks' or nil.
99 It is nil at an early stage of startup, and when Emacs
101 Lisp_Object Vrun_hooks
;
103 /* Non-nil means record all fset's and provide's, to be undone
104 if the file being autoloaded is not fully loaded.
105 They are recorded by being consed onto the front of Vautoload_queue:
106 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */
108 Lisp_Object Vautoload_queue
;
110 /* Current number of specbindings allocated in specpdl. */
113 /* Pointer to beginning of specpdl. */
114 struct specbinding
*specpdl
;
116 /* Pointer to first unused element in specpdl. */
117 struct specbinding
*specpdl_ptr
;
119 /* Maximum size allowed for specpdl allocation */
120 int max_specpdl_size
;
122 /* Depth in Lisp evaluations and function calls. */
125 /* Maximum allowed depth in Lisp evaluations and function calls. */
126 int max_lisp_eval_depth
;
128 /* Nonzero means enter debugger before next function call */
129 int debug_on_next_call
;
131 /* List of conditions (non-nil atom means all) which cause a backtrace
132 if an error is handled by the command loop's error handler. */
133 Lisp_Object Vstack_trace_on_error
;
135 /* List of conditions (non-nil atom means all) which enter the debugger
136 if an error is handled by the command loop's error handler. */
137 Lisp_Object Vdebug_on_error
;
139 /* List of conditions and regexps specifying error messages which
140 do not enter the debugger even if Vdebug_on_errors says they should. */
141 Lisp_Object Vdebug_ignored_errors
;
143 /* Non-nil means call the debugger even if the error will be handled. */
144 Lisp_Object Vdebug_on_signal
;
146 /* Hook for edebug to use. */
147 Lisp_Object Vsignal_hook_function
;
149 /* Nonzero means enter debugger if a quit signal
150 is handled by the command loop's error handler. */
153 /* The value of num_nonmacro_input_events as of the last time we
154 started to enter the debugger. If we decide to enter the debugger
155 again when this is still equal to num_nonmacro_input_events, then we
156 know that the debugger itself has an error, and we should just
157 signal the error instead of entering an infinite loop of debugger
159 int when_entered_debugger
;
161 Lisp_Object Vdebugger
;
163 void specbind (), record_unwind_protect ();
165 Lisp_Object
run_hook_with_args ();
167 Lisp_Object
funcall_lambda ();
168 extern Lisp_Object
ml_apply (); /* Apply a mocklisp function to unevaluated argument list */
174 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
175 specpdl_ptr
= specpdl
;
176 max_specpdl_size
= 600;
177 max_lisp_eval_depth
= 300;
185 specpdl_ptr
= specpdl
;
190 debug_on_next_call
= 0;
192 /* This is less than the initial value of num_nonmacro_input_events. */
193 when_entered_debugger
= -1;
200 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
201 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
202 if (specpdl_size
+ 40 > max_specpdl_size
)
203 max_specpdl_size
= specpdl_size
+ 40;
204 debug_on_next_call
= 0;
205 when_entered_debugger
= num_nonmacro_input_events
;
206 return apply1 (Vdebugger
, arg
);
210 do_debug_on_call (code
)
213 debug_on_next_call
= 0;
214 backtrace_list
->debug_on_exit
= 1;
215 call_debugger (Fcons (code
, Qnil
));
218 /* NOTE!!! Every function that can call EVAL must protect its args
219 and temporaries from garbage collection while it needs them.
220 The definition of `For' shows what you have to do. */
222 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
223 "Eval args until one of them yields non-nil, then return that value.\n\
224 The remaining args are not evalled at all.\n\
225 If all args return nil, return nil.")
229 register Lisp_Object val
;
230 Lisp_Object args_left
;
241 val
= Feval (Fcar (args_left
));
244 args_left
= Fcdr (args_left
);
246 while (!NILP(args_left
));
252 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
253 "Eval args until one of them yields nil, then return nil.\n\
254 The remaining args are not evalled at all.\n\
255 If no arg yields nil, return the last arg's value.")
259 register Lisp_Object val
;
260 Lisp_Object args_left
;
271 val
= Feval (Fcar (args_left
));
274 args_left
= Fcdr (args_left
);
276 while (!NILP(args_left
));
282 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
283 "(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...\n\
284 Returns the value of THEN or the value of the last of the ELSE's.\n\
285 THEN must be one expression, but ELSE... can be zero or more expressions.\n\
286 If COND yields nil, and there are no ELSE's, the value is nil.")
290 register Lisp_Object cond
;
294 cond
= Feval (Fcar (args
));
298 return Feval (Fcar (Fcdr (args
)));
299 return Fprogn (Fcdr (Fcdr (args
)));
302 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
303 "(cond CLAUSES...): try each clause until one succeeds.\n\
304 Each clause looks like (CONDITION BODY...). CONDITION is evaluated\n\
305 and, if the value is non-nil, this clause succeeds:\n\
306 then the expressions in BODY are evaluated and the last one's\n\
307 value is the value of the cond-form.\n\
308 If no clause succeeds, cond returns nil.\n\
309 If a clause has one element, as in (CONDITION),\n\
310 CONDITION's value if non-nil is returned from the cond-form.")
314 register Lisp_Object clause
, val
;
321 clause
= Fcar (args
);
322 val
= Feval (Fcar (clause
));
325 if (!EQ (XCONS (clause
)->cdr
, Qnil
))
326 val
= Fprogn (XCONS (clause
)->cdr
);
329 args
= XCONS (args
)->cdr
;
336 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
337 "(progn BODY...): eval BODY forms sequentially and return value of last one.")
341 register Lisp_Object val
, tem
;
342 Lisp_Object args_left
;
345 /* In Mocklisp code, symbols at the front of the progn arglist
346 are to be bound to zero. */
347 if (!EQ (Vmocklisp_arguments
, Qt
))
349 val
= make_number (0);
350 while (!NILP (args
) && (tem
= Fcar (args
), SYMBOLP (tem
)))
353 specbind (tem
, val
), args
= Fcdr (args
);
365 val
= Feval (Fcar (args_left
));
366 args_left
= Fcdr (args_left
);
368 while (!NILP(args_left
));
374 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
375 "(prog1 FIRST BODY...): eval FIRST and BODY sequentially; value from FIRST.\n\
376 The value of FIRST is saved during the evaluation of the remaining args,\n\
377 whose values are discarded.")
382 register Lisp_Object args_left
;
383 struct gcpro gcpro1
, gcpro2
;
384 register int argnum
= 0;
396 val
= Feval (Fcar (args_left
));
398 Feval (Fcar (args_left
));
399 args_left
= Fcdr (args_left
);
401 while (!NILP(args_left
));
407 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
408 "(prog2 X Y BODY...): eval X, Y and BODY sequentially; value from Y.\n\
409 The value of Y is saved during the evaluation of the remaining args,\n\
410 whose values are discarded.")
415 register Lisp_Object args_left
;
416 struct gcpro gcpro1
, gcpro2
;
417 register int argnum
= -1;
431 val
= Feval (Fcar (args_left
));
433 Feval (Fcar (args_left
));
434 args_left
= Fcdr (args_left
);
436 while (!NILP (args_left
));
442 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
443 "(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.\n\
444 The symbols SYM are variables; they are literal (not evaluated).\n\
445 The values VAL are expressions; they are evaluated.\n\
446 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.\n\
447 The second VAL is not computed until after the first SYM is set, and so on;\n\
448 each VAL can use the new value of variables set earlier in the `setq'.\n\
449 The return value of the `setq' form is the value of the last VAL.")
453 register Lisp_Object args_left
;
454 register Lisp_Object val
, sym
;
465 val
= Feval (Fcar (Fcdr (args_left
)));
466 sym
= Fcar (args_left
);
468 args_left
= Fcdr (Fcdr (args_left
));
470 while (!NILP(args_left
));
476 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
477 "Return the argument, without evaluating it. `(quote x)' yields `x'.")
484 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
485 "Like `quote', but preferred for objects which are functions.\n\
486 In byte compilation, `function' causes its argument to be compiled.\n\
487 `quote' cannot do that.")
494 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
495 "Return t if function in which this appears was called interactively.\n\
496 This means that the function was called with call-interactively (which\n\
497 includes being called as the binding of a key)\n\
498 and input is currently coming from the keyboard (not in keyboard macro).")
501 register struct backtrace
*btp
;
502 register Lisp_Object fun
;
507 btp
= backtrace_list
;
509 /* If this isn't a byte-compiled function, there may be a frame at
510 the top for Finteractive_p itself. If so, skip it. */
511 fun
= Findirect_function (*btp
->function
);
512 if (SUBRP (fun
) && XSUBR (fun
) == &Sinteractive_p
)
515 /* If we're running an Emacs 18-style byte-compiled function, there
516 may be a frame for Fbytecode. Now, given the strictest
517 definition, this function isn't really being called
518 interactively, but because that's the way Emacs 18 always builds
519 byte-compiled functions, we'll accept it for now. */
520 if (EQ (*btp
->function
, Qbytecode
))
523 /* If this isn't a byte-compiled function, then we may now be
524 looking at several frames for special forms. Skip past them. */
526 btp
->nargs
== UNEVALLED
)
529 /* btp now points at the frame of the innermost function that isn't
530 a special form, ignoring frames for Finteractive_p and/or
531 Fbytecode at the top. If this frame is for a built-in function
532 (such as load or eval-region) return nil. */
533 fun
= Findirect_function (*btp
->function
);
536 /* btp points to the frame of a Lisp function that called interactive-p.
537 Return t if that function was called interactively. */
538 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
543 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
544 "(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.\n\
545 The definition is (lambda ARGLIST [DOCSTRING] BODY...).\n\
546 See also the function `interactive'.")
550 register Lisp_Object fn_name
;
551 register Lisp_Object defn
;
553 fn_name
= Fcar (args
);
554 defn
= Fcons (Qlambda
, Fcdr (args
));
555 if (!NILP (Vpurify_flag
))
556 defn
= Fpurecopy (defn
);
557 Ffset (fn_name
, defn
);
558 LOADHIST_ATTACH (fn_name
);
562 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
563 "(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.\n\
564 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).\n\
565 When the macro is called, as in (NAME ARGS...),\n\
566 the function (lambda ARGLIST BODY...) is applied to\n\
567 the list ARGS... as it appears in the expression,\n\
568 and the result should be a form to be evaluated instead of the original.")
572 register Lisp_Object fn_name
;
573 register Lisp_Object defn
;
575 fn_name
= Fcar (args
);
576 defn
= Fcons (Qmacro
, Fcons (Qlambda
, Fcdr (args
)));
577 if (!NILP (Vpurify_flag
))
578 defn
= Fpurecopy (defn
);
579 Ffset (fn_name
, defn
);
580 LOADHIST_ATTACH (fn_name
);
584 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
585 "(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.\n\
586 You are not required to define a variable in order to use it,\n\
587 but the definition can supply documentation and an initial value\n\
588 in a way that tags can recognize.\n\n\
589 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.\n\
590 If SYMBOL is buffer-local, its default value is what is set;\n\
591 buffer-local values are not affected.\n\
592 INITVALUE and DOCSTRING are optional.\n\
593 If DOCSTRING starts with *, this variable is identified as a user option.\n\
594 This means that M-x set-variable and M-x edit-options recognize it.\n\
595 If INITVALUE is missing, SYMBOL's value is not set.")
599 register Lisp_Object sym
, tem
, tail
;
603 if (!NILP (Fcdr (Fcdr (tail
))))
604 error ("too many arguments");
608 tem
= Fdefault_boundp (sym
);
610 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
612 tail
= Fcdr (Fcdr (args
));
613 if (!NILP (Fcar (tail
)))
616 if (!NILP (Vpurify_flag
))
617 tem
= Fpurecopy (tem
);
618 Fput (sym
, Qvariable_documentation
, tem
);
620 LOADHIST_ATTACH (sym
);
624 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
625 "(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant variable.\n\
626 The intent is that programs do not change this value, but users may.\n\
627 Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\
628 If SYMBOL is buffer-local, its default value is what is set;\n\
629 buffer-local values are not affected.\n\
630 DOCSTRING is optional.\n\
631 If DOCSTRING starts with *, this variable is identified as a user option.\n\
632 This means that M-x set-variable and M-x edit-options recognize it.\n\n\
633 Note: do not use `defconst' for user options in libraries that are not\n\
634 normally loaded, since it is useful for users to be able to specify\n\
635 their own values for such variables before loading the library.\n\
636 Since `defconst' unconditionally assigns the variable,\n\
637 it would override the user's choice.")
641 register Lisp_Object sym
, tem
;
644 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
645 error ("too many arguments");
647 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
648 tem
= Fcar (Fcdr (Fcdr (args
)));
651 if (!NILP (Vpurify_flag
))
652 tem
= Fpurecopy (tem
);
653 Fput (sym
, Qvariable_documentation
, tem
);
655 LOADHIST_ATTACH (sym
);
659 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
660 "Returns t if VARIABLE is intended to be set and modified by users.\n\
661 \(The alternative is a variable used internally in a Lisp program.)\n\
662 Determined by whether the first character of the documentation\n\
663 for the variable is `*'.")
665 Lisp_Object variable
;
667 Lisp_Object documentation
;
669 if (!SYMBOLP (variable
))
672 documentation
= Fget (variable
, Qvariable_documentation
);
673 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
675 if (STRINGP (documentation
)
676 && ((unsigned char) XSTRING (documentation
)->data
[0] == '*'))
678 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
679 if (CONSP (documentation
)
680 && STRINGP (XCONS (documentation
)->car
)
681 && INTEGERP (XCONS (documentation
)->cdr
)
682 && XINT (XCONS (documentation
)->cdr
) < 0)
687 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
688 "(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
689 The value of the last form in BODY is returned.\n\
690 Each element of VARLIST is a symbol (which is bound to nil)\n\
691 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
692 Each VALUEFORM can refer to the symbols already bound by this VARLIST.")
696 Lisp_Object varlist
, val
, elt
;
697 int count
= specpdl_ptr
- specpdl
;
698 struct gcpro gcpro1
, gcpro2
, gcpro3
;
700 GCPRO3 (args
, elt
, varlist
);
702 varlist
= Fcar (args
);
703 while (!NILP (varlist
))
706 elt
= Fcar (varlist
);
708 specbind (elt
, Qnil
);
709 else if (! NILP (Fcdr (Fcdr (elt
))))
711 Fcons (build_string ("`let' bindings can have only one value-form"),
715 val
= Feval (Fcar (Fcdr (elt
)));
716 specbind (Fcar (elt
), val
);
718 varlist
= Fcdr (varlist
);
721 val
= Fprogn (Fcdr (args
));
722 return unbind_to (count
, val
);
725 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
726 "(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
727 The value of the last form in BODY is returned.\n\
728 Each element of VARLIST is a symbol (which is bound to nil)\n\
729 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
730 All the VALUEFORMs are evalled before any symbols are bound.")
734 Lisp_Object
*temps
, tem
;
735 register Lisp_Object elt
, varlist
;
736 int count
= specpdl_ptr
- specpdl
;
738 struct gcpro gcpro1
, gcpro2
;
740 varlist
= Fcar (args
);
742 /* Make space to hold the values to give the bound variables */
743 elt
= Flength (varlist
);
744 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
746 /* Compute the values and store them in `temps' */
748 GCPRO2 (args
, *temps
);
751 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
754 elt
= Fcar (varlist
);
756 temps
[argnum
++] = Qnil
;
757 else if (! NILP (Fcdr (Fcdr (elt
))))
759 Fcons (build_string ("`let' bindings can have only one value-form"),
762 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
763 gcpro2
.nvars
= argnum
;
767 varlist
= Fcar (args
);
768 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
770 elt
= Fcar (varlist
);
771 tem
= temps
[argnum
++];
775 specbind (Fcar (elt
), tem
);
778 elt
= Fprogn (Fcdr (args
));
779 return unbind_to (count
, elt
);
782 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
783 "(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.\n\
784 The order of execution is thus TEST, BODY, TEST, BODY and so on\n\
785 until TEST returns nil.")
789 Lisp_Object test
, body
, tem
;
790 struct gcpro gcpro1
, gcpro2
;
796 while (tem
= Feval (test
),
797 (!EQ (Vmocklisp_arguments
, Qt
) ? XINT (tem
) : !NILP (tem
)))
807 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
808 "Return result of expanding macros at top level of FORM.\n\
809 If FORM is not a macro call, it is returned unchanged.\n\
810 Otherwise, the macro is expanded and the expansion is considered\n\
811 in place of FORM. When a non-macro-call results, it is returned.\n\n\
812 The second optional arg ENVIRONMENT species an environment of macro\n\
813 definitions to shadow the loaded ones for use in file byte-compilation.")
816 Lisp_Object environment
;
818 /* With cleanups from Hallvard Furuseth. */
819 register Lisp_Object expander
, sym
, def
, tem
;
823 /* Come back here each time we expand a macro call,
824 in case it expands into another macro call. */
827 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
828 def
= sym
= XCONS (form
)->car
;
830 /* Trace symbols aliases to other symbols
831 until we get a symbol that is not an alias. */
832 while (SYMBOLP (def
))
836 tem
= Fassq (sym
, environment
);
839 def
= XSYMBOL (sym
)->function
;
840 if (!EQ (def
, Qunbound
))
845 /* Right now TEM is the result from SYM in ENVIRONMENT,
846 and if TEM is nil then DEF is SYM's function definition. */
849 /* SYM is not mentioned in ENVIRONMENT.
850 Look at its function definition. */
851 if (EQ (def
, Qunbound
) || !CONSP (def
))
852 /* Not defined or definition not suitable */
854 if (EQ (XCONS (def
)->car
, Qautoload
))
856 /* Autoloading function: will it be a macro when loaded? */
857 tem
= Fnth (make_number (4), def
);
858 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
859 /* Yes, load it and try again. */
863 do_autoload (def
, sym
);
870 else if (!EQ (XCONS (def
)->car
, Qmacro
))
872 else expander
= XCONS (def
)->cdr
;
876 expander
= XCONS (tem
)->cdr
;
880 form
= apply1 (expander
, XCONS (form
)->cdr
);
885 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
886 "(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.\n\
887 TAG is evalled to get the tag to use; it must not be nil.\n\
889 Then the BODY is executed.\n\
890 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.\n\
891 If no throw happens, `catch' returns the value of the last BODY form.\n\
892 If a throw happens, it specifies the value to return from `catch'.")
896 register Lisp_Object tag
;
900 tag
= Feval (Fcar (args
));
902 return internal_catch (tag
, Fprogn
, Fcdr (args
));
905 /* Set up a catch, then call C function FUNC on argument ARG.
906 FUNC should return a Lisp_Object.
907 This is how catches are done from within C code. */
910 internal_catch (tag
, func
, arg
)
912 Lisp_Object (*func
) ();
915 /* This structure is made part of the chain `catchlist'. */
918 /* Fill in the components of c, and put it on the list. */
922 c
.backlist
= backtrace_list
;
923 c
.handlerlist
= handlerlist
;
924 c
.lisp_eval_depth
= lisp_eval_depth
;
925 c
.pdlcount
= specpdl_ptr
- specpdl
;
926 c
.poll_suppress_count
= poll_suppress_count
;
931 if (! _setjmp (c
.jmp
))
932 c
.val
= (*func
) (arg
);
934 /* Throw works by a longjmp that comes right here. */
939 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
940 jump to that CATCH, returning VALUE as the value of that catch.
942 This is the guts Fthrow and Fsignal; they differ only in the way
943 they choose the catch tag to throw to. A catch tag for a
944 condition-case form has a TAG of Qnil.
946 Before each catch is discarded, unbind all special bindings and
947 execute all unwind-protect clauses made above that catch. Unwind
948 the handler stack as we go, so that the proper handlers are in
949 effect for each unwind-protect clause we run. At the end, restore
950 some static info saved in CATCH, and longjmp to the location
953 This is used for correct unwinding in Fthrow and Fsignal. */
956 unwind_to_catch (catch, value
)
957 struct catchtag
*catch;
960 register int last_time
;
962 /* Save the value in the tag. */
965 /* Restore the polling-suppression count. */
966 set_poll_suppress_count (catch->poll_suppress_count
);
970 last_time
= catchlist
== catch;
972 /* Unwind the specpdl stack, and then restore the proper set of
974 unbind_to (catchlist
->pdlcount
, Qnil
);
975 handlerlist
= catchlist
->handlerlist
;
976 catchlist
= catchlist
->next
;
980 gcprolist
= catch->gcpro
;
981 backtrace_list
= catch->backlist
;
982 lisp_eval_depth
= catch->lisp_eval_depth
;
984 _longjmp (catch->jmp
, 1);
987 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
988 "(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.\n\
989 Both TAG and VALUE are evalled.")
991 register Lisp_Object tag
, value
;
993 register struct catchtag
*c
;
998 for (c
= catchlist
; c
; c
= c
->next
)
1000 if (EQ (c
->tag
, tag
))
1001 unwind_to_catch (c
, value
);
1003 tag
= Fsignal (Qno_catch
, Fcons (tag
, Fcons (value
, Qnil
)));
1008 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1009 "Do BODYFORM, protecting with UNWINDFORMS.\n\
1010 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).\n\
1011 If BODYFORM completes normally, its value is returned\n\
1012 after executing the UNWINDFORMS.\n\
1013 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.")
1018 int count
= specpdl_ptr
- specpdl
;
1020 record_unwind_protect (0, Fcdr (args
));
1021 val
= Feval (Fcar (args
));
1022 return unbind_to (count
, val
);
1025 /* Chain of condition handlers currently in effect.
1026 The elements of this chain are contained in the stack frames
1027 of Fcondition_case and internal_condition_case.
1028 When an error is signaled (by calling Fsignal, below),
1029 this chain is searched for an element that applies. */
1031 struct handler
*handlerlist
;
1033 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1034 "Regain control when an error is signaled.\n\
1035 Usage looks like (condition-case VAR BODYFORM HANDLERS...).\n\
1036 executes BODYFORM and returns its value if no error happens.\n\
1037 Each element of HANDLERS looks like (CONDITION-NAME BODY...)\n\
1038 where the BODY is made of Lisp expressions.\n\n\
1039 A handler is applicable to an error\n\
1040 if CONDITION-NAME is one of the error's condition names.\n\
1041 If an error happens, the first applicable handler is run.\n\
1043 The car of a handler may be a list of condition names\n\
1044 instead of a single condition name.\n\
1046 When a handler handles an error,\n\
1047 control returns to the condition-case and the handler BODY... is executed\n\
1048 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\
1049 VAR may be nil; then you do not get access to the signal information.\n\
1051 The value of the last BODY form is returned from the condition-case.\n\
1052 See also the function `signal' for more info.")
1059 register Lisp_Object var
, bodyform
, handlers
;
1062 bodyform
= Fcar (Fcdr (args
));
1063 handlers
= Fcdr (Fcdr (args
));
1064 CHECK_SYMBOL (var
, 0);
1066 for (val
= handlers
; ! NILP (val
); val
= Fcdr (val
))
1072 && (SYMBOLP (XCONS (tem
)->car
)
1073 || CONSP (XCONS (tem
)->car
)))))
1074 error ("Invalid condition handler", tem
);
1079 c
.backlist
= backtrace_list
;
1080 c
.handlerlist
= handlerlist
;
1081 c
.lisp_eval_depth
= lisp_eval_depth
;
1082 c
.pdlcount
= specpdl_ptr
- specpdl
;
1083 c
.poll_suppress_count
= poll_suppress_count
;
1084 c
.gcpro
= gcprolist
;
1085 if (_setjmp (c
.jmp
))
1088 specbind (h
.var
, c
.val
);
1089 val
= Fprogn (Fcdr (h
.chosen_clause
));
1091 /* Note that this just undoes the binding of h.var; whoever
1092 longjumped to us unwound the stack to c.pdlcount before
1094 unbind_to (c
.pdlcount
, Qnil
);
1101 h
.handler
= handlers
;
1102 h
.next
= handlerlist
;
1106 val
= Feval (bodyform
);
1108 handlerlist
= h
.next
;
1112 /* Call the function BFUN with no arguments, catching errors within it
1113 according to HANDLERS. If there is an error, call HFUN with
1114 one argument which is the data that describes the error:
1117 HANDLERS can be a list of conditions to catch.
1118 If HANDLERS is Qt, catch all errors.
1119 If HANDLERS is Qerror, catch all errors
1120 but allow the debugger to run if that is enabled. */
1123 internal_condition_case (bfun
, handlers
, hfun
)
1124 Lisp_Object (*bfun
) ();
1125 Lisp_Object handlers
;
1126 Lisp_Object (*hfun
) ();
1132 /* Since Fsignal resets this to 0, it had better be 0 now
1133 or else we have a potential bug. */
1134 if (interrupt_input_blocked
!= 0)
1139 c
.backlist
= backtrace_list
;
1140 c
.handlerlist
= handlerlist
;
1141 c
.lisp_eval_depth
= lisp_eval_depth
;
1142 c
.pdlcount
= specpdl_ptr
- specpdl
;
1143 c
.poll_suppress_count
= poll_suppress_count
;
1144 c
.gcpro
= gcprolist
;
1145 if (_setjmp (c
.jmp
))
1147 return (*hfun
) (c
.val
);
1151 h
.handler
= handlers
;
1153 h
.next
= handlerlist
;
1159 handlerlist
= h
.next
;
1163 /* Like internal_condition_case but call HFUN with ARG as its argument. */
1166 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1167 Lisp_Object (*bfun
) ();
1169 Lisp_Object handlers
;
1170 Lisp_Object (*hfun
) ();
1178 c
.backlist
= backtrace_list
;
1179 c
.handlerlist
= handlerlist
;
1180 c
.lisp_eval_depth
= lisp_eval_depth
;
1181 c
.pdlcount
= specpdl_ptr
- specpdl
;
1182 c
.poll_suppress_count
= poll_suppress_count
;
1183 c
.gcpro
= gcprolist
;
1184 if (_setjmp (c
.jmp
))
1186 return (*hfun
) (c
.val
);
1190 h
.handler
= handlers
;
1192 h
.next
= handlerlist
;
1196 val
= (*bfun
) (arg
);
1198 handlerlist
= h
.next
;
1202 static Lisp_Object
find_handler_clause ();
1204 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1205 "Signal an error. Args are ERROR-SYMBOL and associated DATA.\n\
1206 This function does not return.\n\n\
1207 An error symbol is a symbol with an `error-conditions' property\n\
1208 that is a list of condition names.\n\
1209 A handler for any of those names will get to handle this signal.\n\
1210 The symbol `error' should normally be one of them.\n\
1212 DATA should be a list. Its elements are printed as part of the error message.\n\
1213 If the signal is handled, DATA is made available to the handler.\n\
1214 See also the function `condition-case'.")
1215 (error_symbol
, data
)
1216 Lisp_Object error_symbol
, data
;
1218 register struct handler
*allhandlers
= handlerlist
;
1219 Lisp_Object conditions
;
1220 extern int gc_in_progress
;
1221 extern int waiting_for_input
;
1222 Lisp_Object debugger_value
;
1224 Lisp_Object real_error_symbol
;
1225 Lisp_Object combined_data
;
1227 quit_error_check ();
1229 if (gc_in_progress
|| waiting_for_input
)
1232 TOTALLY_UNBLOCK_INPUT
;
1234 if (NILP (error_symbol
))
1235 real_error_symbol
= Fcar (data
);
1237 real_error_symbol
= error_symbol
;
1239 /* This hook is used by edebug. */
1240 if (! NILP (Vsignal_hook_function
))
1241 call2 (Vsignal_hook_function
, error_symbol
, data
);
1243 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1245 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1247 register Lisp_Object clause
;
1248 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1249 error_symbol
, data
, &debugger_value
);
1251 #if 0 /* Most callers are not prepared to handle gc if this returns.
1252 So, since this feature is not very useful, take it out. */
1253 /* If have called debugger and user wants to continue,
1255 if (EQ (clause
, Qlambda
))
1256 return debugger_value
;
1258 if (EQ (clause
, Qlambda
))
1260 /* We can't return values to code which signaled an error, but we
1261 can continue code which has signaled a quit. */
1262 if (EQ (real_error_symbol
, Qquit
))
1265 error ("Cannot return from the debugger in an error");
1271 Lisp_Object unwind_data
;
1272 struct handler
*h
= handlerlist
;
1274 handlerlist
= allhandlers
;
1276 if (NILP (error_symbol
))
1279 unwind_data
= Fcons (error_symbol
, data
);
1280 h
->chosen_clause
= clause
;
1281 unwind_to_catch (h
->tag
, unwind_data
);
1285 handlerlist
= allhandlers
;
1286 /* If no handler is present now, try to run the debugger,
1287 and if that fails, throw to top level. */
1288 find_handler_clause (Qerror
, conditions
, error_symbol
, data
, &debugger_value
);
1290 Fthrow (Qtop_level
, Qt
);
1292 if (! NILP (error_symbol
))
1293 data
= Fcons (error_symbol
, data
);
1295 string
= Ferror_message_string (data
);
1296 fatal (XSTRING (string
)->data
, 0, 0);
1299 /* Return nonzero iff LIST is a non-nil atom or
1300 a list containing one of CONDITIONS. */
1303 wants_debugger (list
, conditions
)
1304 Lisp_Object list
, conditions
;
1311 while (CONSP (conditions
))
1313 Lisp_Object
this, tail
;
1314 this = XCONS (conditions
)->car
;
1315 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1316 if (EQ (XCONS (tail
)->car
, this))
1318 conditions
= XCONS (conditions
)->cdr
;
1323 /* Return 1 if an error with condition-symbols CONDITIONS,
1324 and described by SIGNAL-DATA, should skip the debugger
1325 according to debugger-ignore-errors. */
1328 skip_debugger (conditions
, data
)
1329 Lisp_Object conditions
, data
;
1332 int first_string
= 1;
1333 Lisp_Object error_message
;
1335 for (tail
= Vdebug_ignored_errors
; CONSP (tail
);
1336 tail
= XCONS (tail
)->cdr
)
1338 if (STRINGP (XCONS (tail
)->car
))
1342 error_message
= Ferror_message_string (data
);
1345 if (fast_string_match (XCONS (tail
)->car
, error_message
) >= 0)
1350 Lisp_Object contail
;
1352 for (contail
= conditions
; CONSP (contail
);
1353 contail
= XCONS (contail
)->cdr
)
1354 if (EQ (XCONS (tail
)->car
, XCONS (contail
)->car
))
1362 /* Value of Qlambda means we have called debugger and user has continued.
1363 There are two ways to pass SIG and DATA:
1364 - SIG is the error symbol, and DATA is the rest of the data.
1365 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1367 Store value returned from debugger into *DEBUGGER_VALUE_PTR. */
1370 find_handler_clause (handlers
, conditions
, sig
, data
, debugger_value_ptr
)
1371 Lisp_Object handlers
, conditions
, sig
, data
;
1372 Lisp_Object
*debugger_value_ptr
;
1374 register Lisp_Object h
;
1375 register Lisp_Object tem
;
1377 if (EQ (handlers
, Qt
)) /* t is used by handlers for all conditions, set up by C code. */
1379 /* error is used similarly, but means print an error message
1380 and run the debugger if that is enabled. */
1381 if (EQ (handlers
, Qerror
)
1382 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1383 there is a handler. */
1385 int count
= specpdl_ptr
- specpdl
;
1386 int debugger_called
= 0;
1387 Lisp_Object sig_symbol
, combined_data
;
1391 combined_data
= data
;
1392 sig_symbol
= Fcar (data
);
1396 combined_data
= Fcons (sig
, data
);
1400 if (wants_debugger (Vstack_trace_on_error
, conditions
))
1403 internal_with_output_to_temp_buffer ("*Backtrace*",
1404 (Lisp_Object (*) (Lisp_Object
)) Fbacktrace
,
1407 internal_with_output_to_temp_buffer ("*Backtrace*",
1411 if ((EQ (sig_symbol
, Qquit
)
1413 : wants_debugger (Vdebug_on_error
, conditions
))
1414 && ! skip_debugger (conditions
, combined_data
)
1415 && when_entered_debugger
< num_nonmacro_input_events
)
1417 specbind (Qdebug_on_error
, Qnil
);
1419 = call_debugger (Fcons (Qerror
,
1420 Fcons (combined_data
, Qnil
)));
1421 debugger_called
= 1;
1423 /* If there is no handler, return saying whether we ran the debugger. */
1424 if (EQ (handlers
, Qerror
))
1426 if (debugger_called
)
1427 return unbind_to (count
, Qlambda
);
1431 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1433 Lisp_Object handler
, condit
;
1436 if (!CONSP (handler
))
1438 condit
= Fcar (handler
);
1439 /* Handle a single condition name in handler HANDLER. */
1440 if (SYMBOLP (condit
))
1442 tem
= Fmemq (Fcar (handler
), conditions
);
1446 /* Handle a list of condition names in handler HANDLER. */
1447 else if (CONSP (condit
))
1449 while (CONSP (condit
))
1451 tem
= Fmemq (Fcar (condit
), conditions
);
1454 condit
= XCONS (condit
)->cdr
;
1461 /* dump an error message; called like printf */
1465 error (m
, a1
, a2
, a3
)
1485 int used
= doprnt (buf
, size
, m
, m
+ mlen
, 3, args
);
1490 buffer
= (char *) xrealloc (buffer
, size
);
1493 buffer
= (char *) xmalloc (size
);
1498 string
= build_string (buf
);
1502 Fsignal (Qerror
, Fcons (string
, Qnil
));
1505 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 1, 0,
1506 "T if FUNCTION makes provisions for interactive calling.\n\
1507 This means it contains a description for how to read arguments to give it.\n\
1508 The value is nil for an invalid function or a symbol with no function\n\
1511 Interactively callable functions include strings and vectors (treated\n\
1512 as keyboard macros), lambda-expressions that contain a top-level call\n\
1513 to `interactive', autoload definitions made by `autoload' with non-nil\n\
1514 fourth argument, and some of the built-in functions of Lisp.\n\
1516 Also, a symbol satisfies `commandp' if its function definition does so.")
1518 Lisp_Object function
;
1520 register Lisp_Object fun
;
1521 register Lisp_Object funcar
;
1522 register Lisp_Object tem
;
1527 fun
= indirect_function (fun
);
1528 if (EQ (fun
, Qunbound
))
1531 /* Emacs primitives are interactive if their DEFUN specifies an
1532 interactive spec. */
1535 if (XSUBR (fun
)->prompt
)
1541 /* Bytecode objects are interactive if they are long enough to
1542 have an element whose index is COMPILED_INTERACTIVE, which is
1543 where the interactive spec is stored. */
1544 else if (COMPILEDP (fun
))
1545 return ((XVECTOR (fun
)->size
& PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
1548 /* Strings and vectors are keyboard macros. */
1549 if (STRINGP (fun
) || VECTORP (fun
))
1552 /* Lists may represent commands. */
1555 funcar
= Fcar (fun
);
1556 if (!SYMBOLP (funcar
))
1557 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1558 if (EQ (funcar
, Qlambda
))
1559 return Fassq (Qinteractive
, Fcdr (Fcdr (fun
)));
1560 if (EQ (funcar
, Qmocklisp
))
1561 return Qt
; /* All mocklisp functions can be called interactively */
1562 if (EQ (funcar
, Qautoload
))
1563 return Fcar (Fcdr (Fcdr (Fcdr (fun
))));
1569 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1570 "Define FUNCTION to autoload from FILE.\n\
1571 FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\
1572 Third arg DOCSTRING is documentation for the function.\n\
1573 Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\
1574 Fifth arg TYPE indicates the type of the object:\n\
1575 nil or omitted says FUNCTION is a function,\n\
1576 `keymap' says FUNCTION is really a keymap, and\n\
1577 `macro' or t says FUNCTION is really a macro.\n\
1578 Third through fifth args give info about the real definition.\n\
1579 They default to nil.\n\
1580 If FUNCTION is already defined other than as an autoload,\n\
1581 this does nothing and returns nil.")
1582 (function
, file
, docstring
, interactive
, type
)
1583 Lisp_Object function
, file
, docstring
, interactive
, type
;
1586 Lisp_Object args
[4];
1589 CHECK_SYMBOL (function
, 0);
1590 CHECK_STRING (file
, 1);
1592 /* If function is defined and not as an autoload, don't override */
1593 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
1594 && !(CONSP (XSYMBOL (function
)->function
)
1595 && EQ (XCONS (XSYMBOL (function
)->function
)->car
, Qautoload
)))
1600 args
[1] = docstring
;
1601 args
[2] = interactive
;
1604 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
1605 #else /* NO_ARG_ARRAY */
1606 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
1607 #endif /* not NO_ARG_ARRAY */
1611 un_autoload (oldqueue
)
1612 Lisp_Object oldqueue
;
1614 register Lisp_Object queue
, first
, second
;
1616 /* Queue to unwind is current value of Vautoload_queue.
1617 oldqueue is the shadowed value to leave in Vautoload_queue. */
1618 queue
= Vautoload_queue
;
1619 Vautoload_queue
= oldqueue
;
1620 while (CONSP (queue
))
1622 first
= Fcar (queue
);
1623 second
= Fcdr (first
);
1624 first
= Fcar (first
);
1625 if (EQ (second
, Qnil
))
1628 Ffset (first
, second
);
1629 queue
= Fcdr (queue
);
1634 /* Load an autoloaded function.
1635 FUNNAME is the symbol which is the function's name.
1636 FUNDEF is the autoload definition (a list). */
1639 do_autoload (fundef
, funname
)
1640 Lisp_Object fundef
, funname
;
1642 int count
= specpdl_ptr
- specpdl
;
1643 Lisp_Object fun
, val
, queue
, first
, second
;
1644 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1647 CHECK_SYMBOL (funname
, 0);
1648 GCPRO3 (fun
, funname
, fundef
);
1650 /* Value saved here is to be restored into Vautoload_queue */
1651 record_unwind_protect (un_autoload
, Vautoload_queue
);
1652 Vautoload_queue
= Qt
;
1653 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
, Qt
);
1655 /* Save the old autoloads, in case we ever do an unload. */
1656 queue
= Vautoload_queue
;
1657 while (CONSP (queue
))
1659 first
= Fcar (queue
);
1660 second
= Fcdr (first
);
1661 first
= Fcar (first
);
1663 /* Note: This test is subtle. The cdr of an autoload-queue entry
1664 may be an atom if the autoload entry was generated by a defalias
1667 Fput (first
, Qautoload
, (Fcdr (second
)));
1669 queue
= Fcdr (queue
);
1672 /* Once loading finishes, don't undo it. */
1673 Vautoload_queue
= Qt
;
1674 unbind_to (count
, Qnil
);
1676 fun
= Findirect_function (fun
);
1678 if (!NILP (Fequal (fun
, fundef
)))
1679 error ("Autoloading failed to define function %s",
1680 XSYMBOL (funname
)->name
->data
);
1684 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
1685 "Evaluate FORM and return its value.")
1689 Lisp_Object fun
, val
, original_fun
, original_args
;
1691 struct backtrace backtrace
;
1692 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1696 if (EQ (Vmocklisp_arguments
, Qt
))
1697 return Fsymbol_value (form
);
1698 val
= Fsymbol_value (form
);
1700 XSETFASTINT (val
, 0);
1701 else if (EQ (val
, Qt
))
1702 XSETFASTINT (val
, 1);
1709 if (consing_since_gc
> gc_cons_threshold
)
1712 Fgarbage_collect ();
1716 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1718 if (max_lisp_eval_depth
< 100)
1719 max_lisp_eval_depth
= 100;
1720 if (lisp_eval_depth
> max_lisp_eval_depth
)
1721 error ("Lisp nesting exceeds max-lisp-eval-depth");
1724 original_fun
= Fcar (form
);
1725 original_args
= Fcdr (form
);
1727 backtrace
.next
= backtrace_list
;
1728 backtrace_list
= &backtrace
;
1729 backtrace
.function
= &original_fun
; /* This also protects them from gc */
1730 backtrace
.args
= &original_args
;
1731 backtrace
.nargs
= UNEVALLED
;
1732 backtrace
.evalargs
= 1;
1733 backtrace
.debug_on_exit
= 0;
1735 if (debug_on_next_call
)
1736 do_debug_on_call (Qt
);
1738 /* At this point, only original_fun and original_args
1739 have values that will be used below */
1741 fun
= Findirect_function (original_fun
);
1745 Lisp_Object numargs
;
1746 Lisp_Object argvals
[8];
1747 Lisp_Object args_left
;
1748 register int i
, maxargs
;
1750 args_left
= original_args
;
1751 numargs
= Flength (args_left
);
1753 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
1754 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
1755 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1757 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1759 backtrace
.evalargs
= 0;
1760 val
= (*XSUBR (fun
)->function
) (args_left
);
1764 if (XSUBR (fun
)->max_args
== MANY
)
1766 /* Pass a vector of evaluated arguments */
1768 register int argnum
= 0;
1770 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1772 GCPRO3 (args_left
, fun
, fun
);
1776 while (!NILP (args_left
))
1778 vals
[argnum
++] = Feval (Fcar (args_left
));
1779 args_left
= Fcdr (args_left
);
1780 gcpro3
.nvars
= argnum
;
1783 backtrace
.args
= vals
;
1784 backtrace
.nargs
= XINT (numargs
);
1786 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
1791 GCPRO3 (args_left
, fun
, fun
);
1792 gcpro3
.var
= argvals
;
1795 maxargs
= XSUBR (fun
)->max_args
;
1796 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
1798 argvals
[i
] = Feval (Fcar (args_left
));
1804 backtrace
.args
= argvals
;
1805 backtrace
.nargs
= XINT (numargs
);
1810 val
= (*XSUBR (fun
)->function
) ();
1813 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
1816 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
1819 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1823 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1824 argvals
[2], argvals
[3]);
1827 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1828 argvals
[3], argvals
[4]);
1831 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1832 argvals
[3], argvals
[4], argvals
[5]);
1835 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1836 argvals
[3], argvals
[4], argvals
[5],
1841 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1842 argvals
[3], argvals
[4], argvals
[5],
1843 argvals
[6], argvals
[7]);
1847 /* Someone has created a subr that takes more arguments than
1848 is supported by this code. We need to either rewrite the
1849 subr to use a different argument protocol, or add more
1850 cases to this switch. */
1854 if (COMPILEDP (fun
))
1855 val
= apply_lambda (fun
, original_args
, 1);
1859 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1860 funcar
= Fcar (fun
);
1861 if (!SYMBOLP (funcar
))
1862 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1863 if (EQ (funcar
, Qautoload
))
1865 do_autoload (fun
, original_fun
);
1868 if (EQ (funcar
, Qmacro
))
1869 val
= Feval (apply1 (Fcdr (fun
), original_args
));
1870 else if (EQ (funcar
, Qlambda
))
1871 val
= apply_lambda (fun
, original_args
, 1);
1872 else if (EQ (funcar
, Qmocklisp
))
1873 val
= ml_apply (fun
, original_args
);
1875 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1878 if (!EQ (Vmocklisp_arguments
, Qt
))
1881 XSETFASTINT (val
, 0);
1882 else if (EQ (val
, Qt
))
1883 XSETFASTINT (val
, 1);
1886 if (backtrace
.debug_on_exit
)
1887 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
1888 backtrace_list
= backtrace
.next
;
1892 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
1893 "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
1894 Then return the value FUNCTION returns.\n\
1895 Thus, (apply '+ 1 2 '(3 4)) returns 10.")
1900 register int i
, numargs
;
1901 register Lisp_Object spread_arg
;
1902 register Lisp_Object
*funcall_args
;
1904 struct gcpro gcpro1
;
1908 spread_arg
= args
[nargs
- 1];
1909 CHECK_LIST (spread_arg
, nargs
);
1911 numargs
= XINT (Flength (spread_arg
));
1914 return Ffuncall (nargs
- 1, args
);
1915 else if (numargs
== 1)
1917 args
[nargs
- 1] = XCONS (spread_arg
)->car
;
1918 return Ffuncall (nargs
, args
);
1921 numargs
+= nargs
- 2;
1923 fun
= indirect_function (fun
);
1924 if (EQ (fun
, Qunbound
))
1926 /* Let funcall get the error */
1933 if (numargs
< XSUBR (fun
)->min_args
1934 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
1935 goto funcall
; /* Let funcall get the error */
1936 else if (XSUBR (fun
)->max_args
> numargs
)
1938 /* Avoid making funcall cons up a yet another new vector of arguments
1939 by explicitly supplying nil's for optional values */
1940 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
1941 * sizeof (Lisp_Object
));
1942 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
1943 funcall_args
[++i
] = Qnil
;
1944 GCPRO1 (*funcall_args
);
1945 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
1949 /* We add 1 to numargs because funcall_args includes the
1950 function itself as well as its arguments. */
1953 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
1954 * sizeof (Lisp_Object
));
1955 GCPRO1 (*funcall_args
);
1956 gcpro1
.nvars
= 1 + numargs
;
1959 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
1960 /* Spread the last arg we got. Its first element goes in
1961 the slot that it used to occupy, hence this value of I. */
1963 while (!NILP (spread_arg
))
1965 funcall_args
[i
++] = XCONS (spread_arg
)->car
;
1966 spread_arg
= XCONS (spread_arg
)->cdr
;
1969 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
1972 /* Run hook variables in various ways. */
1974 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
1976 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 1, MANY
, 0,
1977 "Run each hook in HOOKS. Major mode functions use this.\n\
1978 Each argument should be a symbol, a hook variable.\n\
1979 These symbols are processed in the order specified.\n\
1980 If a hook symbol has a non-nil value, that value may be a function\n\
1981 or a list of functions to be called to run the hook.\n\
1982 If the value is a function, it is called with no arguments.\n\
1983 If it is a list, the elements are called, in order, with no arguments.\n\
1985 To make a hook variable buffer-local, use `make-local-hook',\n\
1986 not `make-local-variable'.")
1991 Lisp_Object hook
[1];
1994 for (i
= 0; i
< nargs
; i
++)
1997 run_hook_with_args (1, hook
, to_completion
);
2003 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2004 Srun_hook_with_args
, 1, MANY
, 0,
2005 "Run HOOK with the specified arguments ARGS.\n\
2006 HOOK should be a symbol, a hook variable. If HOOK has a non-nil\n\
2007 value, that value may be a function or a list of functions to be\n\
2008 called to run the hook. If the value is a function, it is called with\n\
2009 the given arguments and its return value is returned. If it is a list\n\
2010 of functions, those functions are called, in order,\n\
2011 with the given arguments ARGS.\n\
2012 It is best not to depend on the value return by `run-hook-with-args',\n\
2013 as that may change.\n\
2015 To make a hook variable buffer-local, use `make-local-hook',\n\
2016 not `make-local-variable'.")
2021 return run_hook_with_args (nargs
, args
, to_completion
);
2024 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2025 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2026 "Run HOOK with the specified arguments ARGS.\n\
2027 HOOK should be a symbol, a hook variable. Its value should\n\
2028 be a list of functions. We call those functions, one by one,\n\
2029 passing arguments ARGS to each of them, until one of them\n\
2030 returns a non-nil value. Then we return that value.\n\
2031 If all the functions return nil, we return nil.\n\
2033 To make a hook variable buffer-local, use `make-local-hook',\n\
2034 not `make-local-variable'.")
2039 return run_hook_with_args (nargs
, args
, until_success
);
2042 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2043 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2044 "Run HOOK with the specified arguments ARGS.\n\
2045 HOOK should be a symbol, a hook variable. Its value should\n\
2046 be a list of functions. We call those functions, one by one,\n\
2047 passing arguments ARGS to each of them, until one of them\n\
2048 returns nil. Then we return nil.\n\
2049 If all the functions return non-nil, we return non-nil.\n\
2051 To make a hook variable buffer-local, use `make-local-hook',\n\
2052 not `make-local-variable'.")
2057 return run_hook_with_args (nargs
, args
, until_failure
);
2060 /* ARGS[0] should be a hook symbol.
2061 Call each of the functions in the hook value, passing each of them
2062 as arguments all the rest of ARGS (all NARGS - 1 elements).
2063 COND specifies a condition to test after each call
2064 to decide whether to stop.
2065 The caller (or its caller, etc) must gcpro all of ARGS,
2066 except that it isn't necessary to gcpro ARGS[0]. */
2069 run_hook_with_args (nargs
, args
, cond
)
2072 enum run_hooks_condition cond
;
2074 Lisp_Object sym
, val
, ret
;
2075 struct gcpro gcpro1
, gcpro2
;
2077 /* If we are dying or still initializing,
2078 don't do anything--it would probably crash if we tried. */
2079 if (NILP (Vrun_hooks
))
2083 val
= find_symbol_value (sym
);
2084 ret
= (cond
== until_failure
? Qt
: Qnil
);
2086 if (EQ (val
, Qunbound
) || NILP (val
))
2088 else if (!CONSP (val
) || EQ (XCONS (val
)->car
, Qlambda
))
2091 return Ffuncall (nargs
, args
);
2098 CONSP (val
) && ((cond
== to_completion
)
2099 || (cond
== until_success
? NILP (ret
)
2101 val
= XCONS (val
)->cdr
)
2103 if (EQ (XCONS (val
)->car
, Qt
))
2105 /* t indicates this hook has a local binding;
2106 it means to run the global binding too. */
2107 Lisp_Object globals
;
2109 for (globals
= Fdefault_value (sym
);
2110 CONSP (globals
) && ((cond
== to_completion
)
2111 || (cond
== until_success
? NILP (ret
)
2113 globals
= XCONS (globals
)->cdr
)
2115 args
[0] = XCONS (globals
)->car
;
2116 /* In a global value, t should not occur. If it does, we
2117 must ignore it to avoid an endless loop. */
2118 if (!EQ (args
[0], Qt
))
2119 ret
= Ffuncall (nargs
, args
);
2124 args
[0] = XCONS (val
)->car
;
2125 ret
= Ffuncall (nargs
, args
);
2134 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2135 present value of that symbol.
2136 Call each element of FUNLIST,
2137 passing each of them the rest of ARGS.
2138 The caller (or its caller, etc) must gcpro all of ARGS,
2139 except that it isn't necessary to gcpro ARGS[0]. */
2142 run_hook_list_with_args (funlist
, nargs
, args
)
2143 Lisp_Object funlist
;
2149 struct gcpro gcpro1
, gcpro2
;
2154 for (val
= funlist
; CONSP (val
); val
= XCONS (val
)->cdr
)
2156 if (EQ (XCONS (val
)->car
, Qt
))
2158 /* t indicates this hook has a local binding;
2159 it means to run the global binding too. */
2160 Lisp_Object globals
;
2162 for (globals
= Fdefault_value (sym
);
2164 globals
= XCONS (globals
)->cdr
)
2166 args
[0] = XCONS (globals
)->car
;
2167 /* In a global value, t should not occur. If it does, we
2168 must ignore it to avoid an endless loop. */
2169 if (!EQ (args
[0], Qt
))
2170 Ffuncall (nargs
, args
);
2175 args
[0] = XCONS (val
)->car
;
2176 Ffuncall (nargs
, args
);
2183 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2186 run_hook_with_args_2 (hook
, arg1
, arg2
)
2187 Lisp_Object hook
, arg1
, arg2
;
2189 Lisp_Object temp
[3];
2194 Frun_hook_with_args (3, temp
);
2197 /* Apply fn to arg */
2200 Lisp_Object fn
, arg
;
2202 struct gcpro gcpro1
;
2206 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2210 Lisp_Object args
[2];
2214 RETURN_UNGCPRO (Fapply (2, args
));
2216 #else /* not NO_ARG_ARRAY */
2217 RETURN_UNGCPRO (Fapply (2, &fn
));
2218 #endif /* not NO_ARG_ARRAY */
2221 /* Call function fn on no arguments */
2226 struct gcpro gcpro1
;
2229 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2232 /* Call function fn with 1 argument arg1 */
2236 Lisp_Object fn
, arg1
;
2238 struct gcpro gcpro1
;
2240 Lisp_Object args
[2];
2246 RETURN_UNGCPRO (Ffuncall (2, args
));
2247 #else /* not NO_ARG_ARRAY */
2250 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2251 #endif /* not NO_ARG_ARRAY */
2254 /* Call function fn with 2 arguments arg1, arg2 */
2257 call2 (fn
, arg1
, arg2
)
2258 Lisp_Object fn
, arg1
, arg2
;
2260 struct gcpro gcpro1
;
2262 Lisp_Object args
[3];
2268 RETURN_UNGCPRO (Ffuncall (3, args
));
2269 #else /* not NO_ARG_ARRAY */
2272 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2273 #endif /* not NO_ARG_ARRAY */
2276 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2279 call3 (fn
, arg1
, arg2
, arg3
)
2280 Lisp_Object fn
, arg1
, arg2
, arg3
;
2282 struct gcpro gcpro1
;
2284 Lisp_Object args
[4];
2291 RETURN_UNGCPRO (Ffuncall (4, args
));
2292 #else /* not NO_ARG_ARRAY */
2295 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2296 #endif /* not NO_ARG_ARRAY */
2299 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2302 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2303 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2305 struct gcpro gcpro1
;
2307 Lisp_Object args
[5];
2315 RETURN_UNGCPRO (Ffuncall (5, args
));
2316 #else /* not NO_ARG_ARRAY */
2319 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2320 #endif /* not NO_ARG_ARRAY */
2323 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2326 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2327 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2329 struct gcpro gcpro1
;
2331 Lisp_Object args
[6];
2340 RETURN_UNGCPRO (Ffuncall (6, args
));
2341 #else /* not NO_ARG_ARRAY */
2344 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2345 #endif /* not NO_ARG_ARRAY */
2348 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2351 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2352 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2354 struct gcpro gcpro1
;
2356 Lisp_Object args
[7];
2366 RETURN_UNGCPRO (Ffuncall (7, args
));
2367 #else /* not NO_ARG_ARRAY */
2370 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2371 #endif /* not NO_ARG_ARRAY */
2374 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2375 "Call first argument as a function, passing remaining arguments to it.\n\
2376 Return the value that function returns.\n\
2377 Thus, (funcall 'cons 'x 'y) returns (x . y).")
2384 int numargs
= nargs
- 1;
2385 Lisp_Object lisp_numargs
;
2387 struct backtrace backtrace
;
2388 register Lisp_Object
*internal_args
;
2392 if (consing_since_gc
> gc_cons_threshold
)
2393 Fgarbage_collect ();
2395 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2397 if (max_lisp_eval_depth
< 100)
2398 max_lisp_eval_depth
= 100;
2399 if (lisp_eval_depth
> max_lisp_eval_depth
)
2400 error ("Lisp nesting exceeds max-lisp-eval-depth");
2403 backtrace
.next
= backtrace_list
;
2404 backtrace_list
= &backtrace
;
2405 backtrace
.function
= &args
[0];
2406 backtrace
.args
= &args
[1];
2407 backtrace
.nargs
= nargs
- 1;
2408 backtrace
.evalargs
= 0;
2409 backtrace
.debug_on_exit
= 0;
2411 if (debug_on_next_call
)
2412 do_debug_on_call (Qlambda
);
2418 fun
= Findirect_function (fun
);
2422 if (numargs
< XSUBR (fun
)->min_args
2423 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2425 XSETFASTINT (lisp_numargs
, numargs
);
2426 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (lisp_numargs
, Qnil
)));
2429 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2430 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2432 if (XSUBR (fun
)->max_args
== MANY
)
2434 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
2438 if (XSUBR (fun
)->max_args
> numargs
)
2440 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2441 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
2442 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2443 internal_args
[i
] = Qnil
;
2446 internal_args
= args
+ 1;
2447 switch (XSUBR (fun
)->max_args
)
2450 val
= (*XSUBR (fun
)->function
) ();
2453 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
2456 val
= (*XSUBR (fun
)->function
) (internal_args
[0],
2460 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2464 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2469 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2470 internal_args
[2], internal_args
[3],
2474 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2475 internal_args
[2], internal_args
[3],
2476 internal_args
[4], internal_args
[5]);
2479 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2480 internal_args
[2], internal_args
[3],
2481 internal_args
[4], internal_args
[5],
2486 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2487 internal_args
[2], internal_args
[3],
2488 internal_args
[4], internal_args
[5],
2489 internal_args
[6], internal_args
[7]);
2494 /* If a subr takes more than 8 arguments without using MANY
2495 or UNEVALLED, we need to extend this function to support it.
2496 Until this is done, there is no way to call the function. */
2500 if (COMPILEDP (fun
))
2501 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2505 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2506 funcar
= Fcar (fun
);
2507 if (!SYMBOLP (funcar
))
2508 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2509 if (EQ (funcar
, Qlambda
))
2510 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2511 else if (EQ (funcar
, Qmocklisp
))
2512 val
= ml_apply (fun
, Flist (numargs
, args
+ 1));
2513 else if (EQ (funcar
, Qautoload
))
2515 do_autoload (fun
, args
[0]);
2519 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2523 if (backtrace
.debug_on_exit
)
2524 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2525 backtrace_list
= backtrace
.next
;
2530 apply_lambda (fun
, args
, eval_flag
)
2531 Lisp_Object fun
, args
;
2534 Lisp_Object args_left
;
2535 Lisp_Object numargs
;
2536 register Lisp_Object
*arg_vector
;
2537 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2539 register Lisp_Object tem
;
2541 numargs
= Flength (args
);
2542 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2545 GCPRO3 (*arg_vector
, args_left
, fun
);
2548 for (i
= 0; i
< XINT (numargs
);)
2550 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2551 if (eval_flag
) tem
= Feval (tem
);
2552 arg_vector
[i
++] = tem
;
2560 backtrace_list
->args
= arg_vector
;
2561 backtrace_list
->nargs
= i
;
2563 backtrace_list
->evalargs
= 0;
2564 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
2566 /* Do the debug-on-exit now, while arg_vector still exists. */
2567 if (backtrace_list
->debug_on_exit
)
2568 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
2569 /* Don't do it again when we return to eval. */
2570 backtrace_list
->debug_on_exit
= 0;
2574 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2575 and return the result of evaluation.
2576 FUN must be either a lambda-expression or a compiled-code object. */
2579 funcall_lambda (fun
, nargs
, arg_vector
)
2582 register Lisp_Object
*arg_vector
;
2584 Lisp_Object val
, tem
;
2585 register Lisp_Object syms_left
;
2586 Lisp_Object numargs
;
2587 register Lisp_Object next
;
2588 int count
= specpdl_ptr
- specpdl
;
2590 int optional
= 0, rest
= 0;
2592 specbind (Qmocklisp_arguments
, Qt
); /* t means NOT mocklisp! */
2594 XSETFASTINT (numargs
, nargs
);
2597 syms_left
= Fcar (Fcdr (fun
));
2598 else if (COMPILEDP (fun
))
2599 syms_left
= XVECTOR (fun
)->contents
[COMPILED_ARGLIST
];
2603 for (; !NILP (syms_left
); syms_left
= Fcdr (syms_left
))
2606 next
= Fcar (syms_left
);
2607 while (!SYMBOLP (next
))
2608 next
= Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2609 if (EQ (next
, Qand_rest
))
2611 else if (EQ (next
, Qand_optional
))
2615 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
2620 tem
= arg_vector
[i
++];
2621 specbind (next
, tem
);
2624 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2626 specbind (next
, Qnil
);
2630 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2633 val
= Fprogn (Fcdr (Fcdr (fun
)));
2636 /* If we have not actually read the bytecode string
2637 and constants vector yet, fetch them from the file. */
2638 if (CONSP (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
]))
2639 Ffetch_bytecode (fun
);
2640 val
= Fbyte_code (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
],
2641 XVECTOR (fun
)->contents
[COMPILED_CONSTANTS
],
2642 XVECTOR (fun
)->contents
[COMPILED_STACK_DEPTH
]);
2644 return unbind_to (count
, val
);
2647 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
2649 "If byte-compiled OBJECT is lazy-loaded, fetch it now.")
2655 if (COMPILEDP (object
)
2656 && CONSP (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]))
2658 tem
= read_doc_string (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]);
2660 error ("invalid byte code");
2661 XVECTOR (object
)->contents
[COMPILED_BYTECODE
] = XCONS (tem
)->car
;
2662 XVECTOR (object
)->contents
[COMPILED_CONSTANTS
] = XCONS (tem
)->cdr
;
2670 register int count
= specpdl_ptr
- specpdl
;
2671 if (specpdl_size
>= max_specpdl_size
)
2673 if (max_specpdl_size
< 400)
2674 max_specpdl_size
= 400;
2675 if (specpdl_size
>= max_specpdl_size
)
2677 if (!NILP (Vdebug_on_error
))
2678 /* Leave room for some specpdl in the debugger. */
2679 max_specpdl_size
= specpdl_size
+ 100;
2681 Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil
));
2685 if (specpdl_size
> max_specpdl_size
)
2686 specpdl_size
= max_specpdl_size
;
2687 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
2688 specpdl_ptr
= specpdl
+ count
;
2692 specbind (symbol
, value
)
2693 Lisp_Object symbol
, value
;
2697 CHECK_SYMBOL (symbol
, 0);
2699 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2701 specpdl_ptr
->symbol
= symbol
;
2702 specpdl_ptr
->func
= 0;
2703 specpdl_ptr
->old_value
= ovalue
= find_symbol_value (symbol
);
2705 if (BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
))
2706 store_symval_forwarding (symbol
, ovalue
, value
);
2708 set_internal (symbol
, value
, 1);
2712 record_unwind_protect (function
, arg
)
2713 Lisp_Object (*function
) P_ ((Lisp_Object
));
2716 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2718 specpdl_ptr
->func
= function
;
2719 specpdl_ptr
->symbol
= Qnil
;
2720 specpdl_ptr
->old_value
= arg
;
2725 unbind_to (count
, value
)
2729 int quitf
= !NILP (Vquit_flag
);
2730 struct gcpro gcpro1
;
2736 while (specpdl_ptr
!= specpdl
+ count
)
2739 if (specpdl_ptr
->func
!= 0)
2740 (*specpdl_ptr
->func
) (specpdl_ptr
->old_value
);
2741 /* Note that a "binding" of nil is really an unwind protect,
2742 so in that case the "old value" is a list of forms to evaluate. */
2743 else if (NILP (specpdl_ptr
->symbol
))
2744 Fprogn (specpdl_ptr
->old_value
);
2746 set_internal (specpdl_ptr
->symbol
, specpdl_ptr
->old_value
, 1);
2748 if (NILP (Vquit_flag
) && quitf
) Vquit_flag
= Qt
;
2757 /* Get the value of symbol's global binding, even if that binding
2758 is not now dynamically visible. */
2761 top_level_value (symbol
)
2764 register struct specbinding
*ptr
= specpdl
;
2766 CHECK_SYMBOL (symbol
, 0);
2767 for (; ptr
!= specpdl_ptr
; ptr
++)
2769 if (EQ (ptr
->symbol
, symbol
))
2770 return ptr
->old_value
;
2772 return Fsymbol_value (symbol
);
2776 top_level_set (symbol
, newval
)
2777 Lisp_Object symbol
, newval
;
2779 register struct specbinding
*ptr
= specpdl
;
2781 CHECK_SYMBOL (symbol
, 0);
2782 for (; ptr
!= specpdl_ptr
; ptr
++)
2784 if (EQ (ptr
->symbol
, symbol
))
2786 ptr
->old_value
= newval
;
2790 return Fset (symbol
, newval
);
2795 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
2796 "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\
2797 The debugger is entered when that frame exits, if the flag is non-nil.")
2799 Lisp_Object level
, flag
;
2801 register struct backtrace
*backlist
= backtrace_list
;
2804 CHECK_NUMBER (level
, 0);
2806 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
2808 backlist
= backlist
->next
;
2812 backlist
->debug_on_exit
= !NILP (flag
);
2817 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
2818 "Print a trace of Lisp function calls currently active.\n\
2819 Output stream used is value of `standard-output'.")
2822 register struct backtrace
*backlist
= backtrace_list
;
2826 extern Lisp_Object Vprint_level
;
2827 struct gcpro gcpro1
;
2829 XSETFASTINT (Vprint_level
, 3);
2836 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
2837 if (backlist
->nargs
== UNEVALLED
)
2839 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
2840 write_string ("\n", -1);
2844 tem
= *backlist
->function
;
2845 Fprin1 (tem
, Qnil
); /* This can QUIT */
2846 write_string ("(", -1);
2847 if (backlist
->nargs
== MANY
)
2849 for (tail
= *backlist
->args
, i
= 0;
2851 tail
= Fcdr (tail
), i
++)
2853 if (i
) write_string (" ", -1);
2854 Fprin1 (Fcar (tail
), Qnil
);
2859 for (i
= 0; i
< backlist
->nargs
; i
++)
2861 if (i
) write_string (" ", -1);
2862 Fprin1 (backlist
->args
[i
], Qnil
);
2865 write_string (")\n", -1);
2867 backlist
= backlist
->next
;
2870 Vprint_level
= Qnil
;
2875 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, "",
2876 "Return the function and arguments NFRAMES up from current execution point.\n\
2877 If that frame has not evaluated the arguments yet (or is a special form),\n\
2878 the value is (nil FUNCTION ARG-FORMS...).\n\
2879 If that frame has evaluated its arguments and called its function already,\n\
2880 the value is (t FUNCTION ARG-VALUES...).\n\
2881 A &rest arg is represented as the tail of the list ARG-VALUES.\n\
2882 FUNCTION is whatever was supplied as car of evaluated list,\n\
2883 or a lambda expression for macro calls.\n\
2884 If NFRAMES is more than the number of frames, the value is nil.")
2886 Lisp_Object nframes
;
2888 register struct backtrace
*backlist
= backtrace_list
;
2892 CHECK_NATNUM (nframes
, 0);
2894 /* Find the frame requested. */
2895 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
2896 backlist
= backlist
->next
;
2900 if (backlist
->nargs
== UNEVALLED
)
2901 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
2904 if (backlist
->nargs
== MANY
)
2905 tem
= *backlist
->args
;
2907 tem
= Flist (backlist
->nargs
, backlist
->args
);
2909 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
2916 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
2917 "*Limit on number of Lisp variable bindings & unwind-protects.\n\
2918 If Lisp code tries to make more than this many at once,\n\
2919 an error is signaled.");
2921 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
2922 "*Limit on depth in `eval', `apply' and `funcall' before error.\n\
2923 This limit is to catch infinite recursions for you before they cause\n\
2924 actual stack overflow in C, which would be fatal for Emacs.\n\
2925 You can safely make it considerably larger than its default value,\n\
2926 if that proves inconveniently small.");
2928 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
2929 "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
2930 Typing C-g sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
2933 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
2934 "Non-nil inhibits C-g quitting from happening immediately.\n\
2935 Note that `quit-flag' will still be set by typing C-g,\n\
2936 so a quit will be signaled as soon as `inhibit-quit' is nil.\n\
2937 To prevent this happening, set `quit-flag' to nil\n\
2938 before making `inhibit-quit' nil.");
2939 Vinhibit_quit
= Qnil
;
2941 Qinhibit_quit
= intern ("inhibit-quit");
2942 staticpro (&Qinhibit_quit
);
2944 Qautoload
= intern ("autoload");
2945 staticpro (&Qautoload
);
2947 Qdebug_on_error
= intern ("debug-on-error");
2948 staticpro (&Qdebug_on_error
);
2950 Qmacro
= intern ("macro");
2951 staticpro (&Qmacro
);
2953 /* Note that the process handling also uses Qexit, but we don't want
2954 to staticpro it twice, so we just do it here. */
2955 Qexit
= intern ("exit");
2958 Qinteractive
= intern ("interactive");
2959 staticpro (&Qinteractive
);
2961 Qcommandp
= intern ("commandp");
2962 staticpro (&Qcommandp
);
2964 Qdefun
= intern ("defun");
2965 staticpro (&Qdefun
);
2967 Qand_rest
= intern ("&rest");
2968 staticpro (&Qand_rest
);
2970 Qand_optional
= intern ("&optional");
2971 staticpro (&Qand_optional
);
2973 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
2974 "*Non-nil means automatically display a backtrace buffer\n\
2975 after any error that is handled by the editor command loop.\n\
2976 If the value is a list, an error only means to display a backtrace\n\
2977 if one of its condition symbols appears in the list.");
2978 Vstack_trace_on_error
= Qnil
;
2980 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
2981 "*Non-nil means enter debugger if an error is signaled.\n\
2982 Does not apply to errors handled by `condition-case'.\n\
2983 If the value is a list, an error only means to enter the debugger\n\
2984 if one of its condition symbols appears in the list.\n\
2985 See also variable `debug-on-quit'.");
2986 Vdebug_on_error
= Qnil
;
2988 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
2989 "*List of errors for which the debugger should not be called.\n\
2990 Each element may be a condition-name or a regexp that matches error messages.\n\
2991 If any element applies to a given error, that error skips the debugger\n\
2992 and just returns to top level.\n\
2993 This overrides the variable `debug-on-error'.\n\
2994 It does not apply to errors handled by `condition-case'.");
2995 Vdebug_ignored_errors
= Qnil
;
2997 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
2998 "*Non-nil means enter debugger if quit is signaled (C-g, for example).\n\
2999 Does not apply if quit is handled by a `condition-case'.");
3002 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
3003 "Non-nil means enter debugger before next `eval', `apply' or `funcall'.");
3005 DEFVAR_LISP ("debugger", &Vdebugger
,
3006 "Function to call to invoke debugger.\n\
3007 If due to frame exit, args are `exit' and the value being returned;\n\
3008 this function's value will be returned instead of that.\n\
3009 If due to error, args are `error' and a list of the args to `signal'.\n\
3010 If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
3011 If due to `eval' entry, one arg, t.");
3014 DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function
,
3015 "If non-nil, this is a function for `signal' to call.\n\
3016 It receives the same arguments that `signal' was given.\n\
3017 The Edebug package uses this to regain control.");
3018 Vsignal_hook_function
= Qnil
;
3020 Qmocklisp_arguments
= intern ("mocklisp-arguments");
3021 staticpro (&Qmocklisp_arguments
);
3022 DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments
,
3023 "While in a mocklisp function, the list of its unevaluated args.");
3024 Vmocklisp_arguments
= Qt
;
3026 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal
,
3027 "*Non-nil means call the debugger regardless of condition handlers.\n\
3028 Note that `debug-on-error', `debug-on-quit' and friends\n\
3029 still determine whether to handle the particular condition.");
3030 Vdebug_on_signal
= Qnil
;
3032 Vrun_hooks
= intern ("run-hooks");
3033 staticpro (&Vrun_hooks
);
3035 staticpro (&Vautoload_queue
);
3036 Vautoload_queue
= Qnil
;
3047 defsubr (&Sfunction
);
3049 defsubr (&Sdefmacro
);
3051 defsubr (&Sdefconst
);
3052 defsubr (&Suser_variable_p
);
3056 defsubr (&Smacroexpand
);
3059 defsubr (&Sunwind_protect
);
3060 defsubr (&Scondition_case
);
3062 defsubr (&Sinteractive_p
);
3063 defsubr (&Scommandp
);
3064 defsubr (&Sautoload
);
3067 defsubr (&Sfuncall
);
3068 defsubr (&Srun_hooks
);
3069 defsubr (&Srun_hook_with_args
);
3070 defsubr (&Srun_hook_with_args_until_success
);
3071 defsubr (&Srun_hook_with_args_until_failure
);
3072 defsubr (&Sfetch_bytecode
);
3073 defsubr (&Sbacktrace_debug
);
3074 defsubr (&Sbacktrace
);
3075 defsubr (&Sbacktrace_frame
);