1 /* Evaluator for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 1999 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"
27 #include "dispextern.h"
30 /* This definition is duplicated in alloc.c and keyboard.c */
31 /* Putting it in lisp.h makes cc bomb out! */
35 struct backtrace
*next
;
36 Lisp_Object
*function
;
37 Lisp_Object
*args
; /* Points to vector of args. */
38 int nargs
; /* Length of vector.
39 If nargs is UNEVALLED, args points to slot holding
40 list of unevalled args */
42 /* Nonzero means call value of debugger when done with this operation. */
46 struct backtrace
*backtrace_list
;
48 /* This structure helps implement the `catch' and `throw' control
49 structure. A struct catchtag contains all the information needed
50 to restore the state of the interpreter after a non-local jump.
52 Handlers for error conditions (represented by `struct handler'
53 structures) just point to a catch tag to do the cleanup required
56 catchtag structures are chained together in the C calling stack;
57 the `next' member points to the next outer catchtag.
59 A call like (throw TAG VAL) searches for a catchtag whose `tag'
60 member is TAG, and then unbinds to it. The `val' member is used to
61 hold VAL while the stack is unwound; `val' is returned as the value
64 All the other members are concerned with restoring the interpreter
70 struct catchtag
*next
;
73 struct backtrace
*backlist
;
74 struct handler
*handlerlist
;
77 int poll_suppress_count
;
78 struct byte_stack
*byte_stack
;
81 struct catchtag
*catchlist
;
84 /* Count levels of GCPRO to detect failure to UNGCPRO. */
88 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
89 Lisp_Object Qinhibit_quit
, Vinhibit_quit
, Vquit_flag
;
90 Lisp_Object Qmocklisp_arguments
, Vmocklisp_arguments
, Qmocklisp
;
91 Lisp_Object Qand_rest
, Qand_optional
;
92 Lisp_Object Qdebug_on_error
;
94 /* This holds either the symbol `run-hooks' or nil.
95 It is nil at an early stage of startup, and when Emacs
97 Lisp_Object Vrun_hooks
;
99 /* Non-nil means record all fset's and provide's, to be undone
100 if the file being autoloaded is not fully loaded.
101 They are recorded by being consed onto the front of Vautoload_queue:
102 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */
104 Lisp_Object Vautoload_queue
;
106 /* Current number of specbindings allocated in specpdl. */
109 /* Pointer to beginning of specpdl. */
110 struct specbinding
*specpdl
;
112 /* Pointer to first unused element in specpdl. */
113 struct specbinding
*specpdl_ptr
;
115 /* Maximum size allowed for specpdl allocation */
116 int max_specpdl_size
;
118 /* Depth in Lisp evaluations and function calls. */
121 /* Maximum allowed depth in Lisp evaluations and function calls. */
122 int max_lisp_eval_depth
;
124 /* Nonzero means enter debugger before next function call */
125 int debug_on_next_call
;
127 /* Non-zero means debuffer may continue. This is zero when the
128 debugger is called during redisplay, where it might not be safe to
129 continue the interrupted redisplay. */
131 int debugger_may_continue
;
133 /* List of conditions (non-nil atom means all) which cause a backtrace
134 if an error is handled by the command loop's error handler. */
135 Lisp_Object Vstack_trace_on_error
;
137 /* List of conditions (non-nil atom means all) which enter the debugger
138 if an error is handled by the command loop's error handler. */
139 Lisp_Object Vdebug_on_error
;
141 /* List of conditions and regexps specifying error messages which
142 do not enter the debugger even if Vdebug_on_errors says they should. */
143 Lisp_Object Vdebug_ignored_errors
;
145 /* Non-nil means call the debugger even if the error will be handled. */
146 Lisp_Object Vdebug_on_signal
;
148 /* Hook for edebug to use. */
149 Lisp_Object Vsignal_hook_function
;
151 /* Nonzero means enter debugger if a quit signal
152 is handled by the command loop's error handler. */
155 /* The value of num_nonmacro_input_events as of the last time we
156 started to enter the debugger. If we decide to enter the debugger
157 again when this is still equal to num_nonmacro_input_events, then we
158 know that the debugger itself has an error, and we should just
159 signal the error instead of entering an infinite loop of debugger
161 int when_entered_debugger
;
163 Lisp_Object Vdebugger
;
165 void specbind (), record_unwind_protect ();
167 Lisp_Object
run_hook_with_args ();
169 Lisp_Object
funcall_lambda ();
170 extern Lisp_Object
ml_apply (); /* Apply a mocklisp function to unevaluated argument list */
176 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
177 specpdl_ptr
= specpdl
;
178 max_specpdl_size
= 600;
179 max_lisp_eval_depth
= 300;
187 specpdl_ptr
= specpdl
;
192 debug_on_next_call
= 0;
197 /* This is less than the initial value of num_nonmacro_input_events. */
198 when_entered_debugger
= -1;
205 int debug_while_redisplaying
;
206 int count
= specpdl_ptr
- specpdl
;
209 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
210 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
212 if (specpdl_size
+ 40 > max_specpdl_size
)
213 max_specpdl_size
= specpdl_size
+ 40;
215 debug_on_next_call
= 0;
216 when_entered_debugger
= num_nonmacro_input_events
;
218 /* Resetting redisplaying_p to 0 makes sure that debug output is
219 displayed if the debugger is invoked during redisplay. */
220 debug_while_redisplaying
= redisplaying_p
;
222 specbind (intern ("debugger-may-continue"),
223 debug_while_redisplaying
? Qnil
: Qt
);
225 val
= apply1 (Vdebugger
, arg
);
227 /* Interrupting redisplay and resuming it later is not safe under
228 all circumstances. So, when the debugger returns, abort the
229 interupted redisplay by going back to the top-level. */
230 if (debug_while_redisplaying
)
233 return unbind_to (count
, val
);
237 do_debug_on_call (code
)
240 debug_on_next_call
= 0;
241 backtrace_list
->debug_on_exit
= 1;
242 call_debugger (Fcons (code
, Qnil
));
245 /* NOTE!!! Every function that can call EVAL must protect its args
246 and temporaries from garbage collection while it needs them.
247 The definition of `For' shows what you have to do. */
249 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
250 "Eval args until one of them yields non-nil, then return that value.\n\
251 The remaining args are not evalled at all.\n\
252 If all args return nil, return nil.")
256 register Lisp_Object val
;
257 Lisp_Object args_left
;
268 val
= Feval (Fcar (args_left
));
271 args_left
= Fcdr (args_left
);
273 while (!NILP(args_left
));
279 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
280 "Eval args until one of them yields nil, then return nil.\n\
281 The remaining args are not evalled at all.\n\
282 If no arg yields nil, return the last arg's value.")
286 register Lisp_Object val
;
287 Lisp_Object args_left
;
298 val
= Feval (Fcar (args_left
));
301 args_left
= Fcdr (args_left
);
303 while (!NILP(args_left
));
309 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
310 "(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...\n\
311 Returns the value of THEN or the value of the last of the ELSE's.\n\
312 THEN must be one expression, but ELSE... can be zero or more expressions.\n\
313 If COND yields nil, and there are no ELSE's, the value is nil.")
317 register Lisp_Object cond
;
321 cond
= Feval (Fcar (args
));
325 return Feval (Fcar (Fcdr (args
)));
326 return Fprogn (Fcdr (Fcdr (args
)));
329 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
330 "(cond CLAUSES...): try each clause until one succeeds.\n\
331 Each clause looks like (CONDITION BODY...). CONDITION is evaluated\n\
332 and, if the value is non-nil, this clause succeeds:\n\
333 then the expressions in BODY are evaluated and the last one's\n\
334 value is the value of the cond-form.\n\
335 If no clause succeeds, cond returns nil.\n\
336 If a clause has one element, as in (CONDITION),\n\
337 CONDITION's value if non-nil is returned from the cond-form.")
341 register Lisp_Object clause
, val
;
348 clause
= Fcar (args
);
349 val
= Feval (Fcar (clause
));
352 if (!EQ (XCDR (clause
), Qnil
))
353 val
= Fprogn (XCDR (clause
));
363 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
364 "(progn BODY...): eval BODY forms sequentially and return value of last one.")
368 register Lisp_Object val
, tem
;
369 Lisp_Object args_left
;
372 /* In Mocklisp code, symbols at the front of the progn arglist
373 are to be bound to zero. */
374 if (!EQ (Vmocklisp_arguments
, Qt
))
376 val
= make_number (0);
377 while (!NILP (args
) && (tem
= Fcar (args
), SYMBOLP (tem
)))
380 specbind (tem
, val
), args
= Fcdr (args
);
392 val
= Feval (Fcar (args_left
));
393 args_left
= Fcdr (args_left
);
395 while (!NILP(args_left
));
401 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
402 "(prog1 FIRST BODY...): eval FIRST and BODY sequentially; value from FIRST.\n\
403 The value of FIRST is saved during the evaluation of the remaining args,\n\
404 whose values are discarded.")
409 register Lisp_Object args_left
;
410 struct gcpro gcpro1
, gcpro2
;
411 register int argnum
= 0;
423 val
= Feval (Fcar (args_left
));
425 Feval (Fcar (args_left
));
426 args_left
= Fcdr (args_left
);
428 while (!NILP(args_left
));
434 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
435 "(prog2 X Y BODY...): eval X, Y and BODY sequentially; value from Y.\n\
436 The value of Y is saved during the evaluation of the remaining args,\n\
437 whose values are discarded.")
442 register Lisp_Object args_left
;
443 struct gcpro gcpro1
, gcpro2
;
444 register int argnum
= -1;
458 val
= Feval (Fcar (args_left
));
460 Feval (Fcar (args_left
));
461 args_left
= Fcdr (args_left
);
463 while (!NILP (args_left
));
469 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
470 "(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.\n\
471 The symbols SYM are variables; they are literal (not evaluated).\n\
472 The values VAL are expressions; they are evaluated.\n\
473 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.\n\
474 The second VAL is not computed until after the first SYM is set, and so on;\n\
475 each VAL can use the new value of variables set earlier in the `setq'.\n\
476 The return value of the `setq' form is the value of the last VAL.")
480 register Lisp_Object args_left
;
481 register Lisp_Object val
, sym
;
492 val
= Feval (Fcar (Fcdr (args_left
)));
493 sym
= Fcar (args_left
);
495 args_left
= Fcdr (Fcdr (args_left
));
497 while (!NILP(args_left
));
503 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
504 "Return the argument, without evaluating it. `(quote x)' yields `x'.")
511 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
512 "Like `quote', but preferred for objects which are functions.\n\
513 In byte compilation, `function' causes its argument to be compiled.\n\
514 `quote' cannot do that.")
521 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
522 "Return t if function in which this appears was called interactively.\n\
523 This means that the function was called with call-interactively (which\n\
524 includes being called as the binding of a key)\n\
525 and input is currently coming from the keyboard (not in keyboard macro).")
528 register struct backtrace
*btp
;
529 register Lisp_Object fun
;
534 btp
= backtrace_list
;
536 /* If this isn't a byte-compiled function, there may be a frame at
537 the top for Finteractive_p itself. If so, skip it. */
538 fun
= Findirect_function (*btp
->function
);
539 if (SUBRP (fun
) && XSUBR (fun
) == &Sinteractive_p
)
542 /* If we're running an Emacs 18-style byte-compiled function, there
543 may be a frame for Fbytecode. Now, given the strictest
544 definition, this function isn't really being called
545 interactively, but because that's the way Emacs 18 always builds
546 byte-compiled functions, we'll accept it for now. */
547 if (EQ (*btp
->function
, Qbytecode
))
550 /* If this isn't a byte-compiled function, then we may now be
551 looking at several frames for special forms. Skip past them. */
553 btp
->nargs
== UNEVALLED
)
556 /* btp now points at the frame of the innermost function that isn't
557 a special form, ignoring frames for Finteractive_p and/or
558 Fbytecode at the top. If this frame is for a built-in function
559 (such as load or eval-region) return nil. */
560 fun
= Findirect_function (*btp
->function
);
563 /* btp points to the frame of a Lisp function that called interactive-p.
564 Return t if that function was called interactively. */
565 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
570 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
571 "(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.\n\
572 The definition is (lambda ARGLIST [DOCSTRING] BODY...).\n\
573 See also the function `interactive'.")
577 register Lisp_Object fn_name
;
578 register Lisp_Object defn
;
580 fn_name
= Fcar (args
);
581 defn
= Fcons (Qlambda
, Fcdr (args
));
582 if (!NILP (Vpurify_flag
))
583 defn
= Fpurecopy (defn
);
584 Ffset (fn_name
, defn
);
585 LOADHIST_ATTACH (fn_name
);
589 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
590 "(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.\n\
591 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).\n\
592 When the macro is called, as in (NAME ARGS...),\n\
593 the function (lambda ARGLIST BODY...) is applied to\n\
594 the list ARGS... as it appears in the expression,\n\
595 and the result should be a form to be evaluated instead of the original.")
599 register Lisp_Object fn_name
;
600 register Lisp_Object defn
;
602 fn_name
= Fcar (args
);
603 defn
= Fcons (Qmacro
, Fcons (Qlambda
, Fcdr (args
)));
604 if (!NILP (Vpurify_flag
))
605 defn
= Fpurecopy (defn
);
606 Ffset (fn_name
, defn
);
607 LOADHIST_ATTACH (fn_name
);
611 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
612 "(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.\n\
613 You are not required to define a variable in order to use it,\n\
614 but the definition can supply documentation and an initial value\n\
615 in a way that tags can recognize.\n\n\
616 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.\n\
617 If SYMBOL is buffer-local, its default value is what is set;\n\
618 buffer-local values are not affected.\n\
619 INITVALUE and DOCSTRING are optional.\n\
620 If DOCSTRING starts with *, this variable is identified as a user option.\n\
621 This means that M-x set-variable and M-x edit-options recognize it.\n\
622 If INITVALUE is missing, SYMBOL's value is not set.")
626 register Lisp_Object sym
, tem
, tail
;
630 if (!NILP (Fcdr (Fcdr (tail
))))
631 error ("too many arguments");
635 tem
= Fdefault_boundp (sym
);
637 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
639 tail
= Fcdr (Fcdr (args
));
640 if (!NILP (Fcar (tail
)))
643 if (!NILP (Vpurify_flag
))
644 tem
= Fpurecopy (tem
);
645 Fput (sym
, Qvariable_documentation
, tem
);
647 LOADHIST_ATTACH (sym
);
651 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
652 "(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant variable.\n\
653 The intent is that neither programs nor users should ever change this value.\n\
654 Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\
655 If SYMBOL is buffer-local, its default value is what is set;\n\
656 buffer-local values are not affected.\n\
657 DOCSTRING is optional.")
661 register Lisp_Object sym
, tem
;
664 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
665 error ("too many arguments");
667 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
668 tem
= Fcar (Fcdr (Fcdr (args
)));
671 if (!NILP (Vpurify_flag
))
672 tem
= Fpurecopy (tem
);
673 Fput (sym
, Qvariable_documentation
, tem
);
675 LOADHIST_ATTACH (sym
);
679 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
680 "Returns t if VARIABLE is intended to be set and modified by users.\n\
681 \(The alternative is a variable used internally in a Lisp program.)\n\
682 Determined by whether the first character of the documentation\n\
683 for the variable is `*'.")
685 Lisp_Object variable
;
687 Lisp_Object documentation
;
689 if (!SYMBOLP (variable
))
692 documentation
= Fget (variable
, Qvariable_documentation
);
693 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
695 if (STRINGP (documentation
)
696 && ((unsigned char) XSTRING (documentation
)->data
[0] == '*'))
698 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
699 if (CONSP (documentation
)
700 && STRINGP (XCAR (documentation
))
701 && INTEGERP (XCDR (documentation
))
702 && XINT (XCDR (documentation
)) < 0)
707 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
708 "(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
709 The value of the last form in BODY is returned.\n\
710 Each element of VARLIST is a symbol (which is bound to nil)\n\
711 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
712 Each VALUEFORM can refer to the symbols already bound by this VARLIST.")
716 Lisp_Object varlist
, val
, elt
;
717 int count
= specpdl_ptr
- specpdl
;
718 struct gcpro gcpro1
, gcpro2
, gcpro3
;
720 GCPRO3 (args
, elt
, varlist
);
722 varlist
= Fcar (args
);
723 while (!NILP (varlist
))
726 elt
= Fcar (varlist
);
728 specbind (elt
, Qnil
);
729 else if (! NILP (Fcdr (Fcdr (elt
))))
731 Fcons (build_string ("`let' bindings can have only one value-form"),
735 val
= Feval (Fcar (Fcdr (elt
)));
736 specbind (Fcar (elt
), val
);
738 varlist
= Fcdr (varlist
);
741 val
= Fprogn (Fcdr (args
));
742 return unbind_to (count
, val
);
745 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
746 "(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
747 The value of the last form in BODY is returned.\n\
748 Each element of VARLIST is a symbol (which is bound to nil)\n\
749 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
750 All the VALUEFORMs are evalled before any symbols are bound.")
754 Lisp_Object
*temps
, tem
;
755 register Lisp_Object elt
, varlist
;
756 int count
= specpdl_ptr
- specpdl
;
758 struct gcpro gcpro1
, gcpro2
;
760 varlist
= Fcar (args
);
762 /* Make space to hold the values to give the bound variables */
763 elt
= Flength (varlist
);
764 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
766 /* Compute the values and store them in `temps' */
768 GCPRO2 (args
, *temps
);
771 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
774 elt
= Fcar (varlist
);
776 temps
[argnum
++] = Qnil
;
777 else if (! NILP (Fcdr (Fcdr (elt
))))
779 Fcons (build_string ("`let' bindings can have only one value-form"),
782 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
783 gcpro2
.nvars
= argnum
;
787 varlist
= Fcar (args
);
788 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
790 elt
= Fcar (varlist
);
791 tem
= temps
[argnum
++];
795 specbind (Fcar (elt
), tem
);
798 elt
= Fprogn (Fcdr (args
));
799 return unbind_to (count
, elt
);
802 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
803 "(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.\n\
804 The order of execution is thus TEST, BODY, TEST, BODY and so on\n\
805 until TEST returns nil.")
809 Lisp_Object test
, body
, tem
;
810 struct gcpro gcpro1
, gcpro2
;
816 while (tem
= Feval (test
),
817 (!EQ (Vmocklisp_arguments
, Qt
) ? XINT (tem
) : !NILP (tem
)))
827 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
828 "Return result of expanding macros at top level of FORM.\n\
829 If FORM is not a macro call, it is returned unchanged.\n\
830 Otherwise, the macro is expanded and the expansion is considered\n\
831 in place of FORM. When a non-macro-call results, it is returned.\n\n\
832 The second optional arg ENVIRONMENT species an environment of macro\n\
833 definitions to shadow the loaded ones for use in file byte-compilation.")
836 Lisp_Object environment
;
838 /* With cleanups from Hallvard Furuseth. */
839 register Lisp_Object expander
, sym
, def
, tem
;
843 /* Come back here each time we expand a macro call,
844 in case it expands into another macro call. */
847 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
848 def
= sym
= XCAR (form
);
850 /* Trace symbols aliases to other symbols
851 until we get a symbol that is not an alias. */
852 while (SYMBOLP (def
))
856 tem
= Fassq (sym
, environment
);
859 def
= XSYMBOL (sym
)->function
;
860 if (!EQ (def
, Qunbound
))
865 /* Right now TEM is the result from SYM in ENVIRONMENT,
866 and if TEM is nil then DEF is SYM's function definition. */
869 /* SYM is not mentioned in ENVIRONMENT.
870 Look at its function definition. */
871 if (EQ (def
, Qunbound
) || !CONSP (def
))
872 /* Not defined or definition not suitable */
874 if (EQ (XCAR (def
), Qautoload
))
876 /* Autoloading function: will it be a macro when loaded? */
877 tem
= Fnth (make_number (4), def
);
878 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
879 /* Yes, load it and try again. */
883 do_autoload (def
, sym
);
890 else if (!EQ (XCAR (def
), Qmacro
))
892 else expander
= XCDR (def
);
896 expander
= XCDR (tem
);
900 form
= apply1 (expander
, XCDR (form
));
905 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
906 "(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.\n\
907 TAG is evalled to get the tag to use; it must not be nil.\n\
909 Then the BODY is executed.\n\
910 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.\n\
911 If no throw happens, `catch' returns the value of the last BODY form.\n\
912 If a throw happens, it specifies the value to return from `catch'.")
916 register Lisp_Object tag
;
920 tag
= Feval (Fcar (args
));
922 return internal_catch (tag
, Fprogn
, Fcdr (args
));
925 /* Set up a catch, then call C function FUNC on argument ARG.
926 FUNC should return a Lisp_Object.
927 This is how catches are done from within C code. */
930 internal_catch (tag
, func
, arg
)
932 Lisp_Object (*func
) ();
935 /* This structure is made part of the chain `catchlist'. */
938 /* Fill in the components of c, and put it on the list. */
942 c
.backlist
= backtrace_list
;
943 c
.handlerlist
= handlerlist
;
944 c
.lisp_eval_depth
= lisp_eval_depth
;
945 c
.pdlcount
= specpdl_ptr
- specpdl
;
946 c
.poll_suppress_count
= poll_suppress_count
;
948 c
.byte_stack
= byte_stack_list
;
952 if (! _setjmp (c
.jmp
))
953 c
.val
= (*func
) (arg
);
955 /* Throw works by a longjmp that comes right here. */
960 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
961 jump to that CATCH, returning VALUE as the value of that catch.
963 This is the guts Fthrow and Fsignal; they differ only in the way
964 they choose the catch tag to throw to. A catch tag for a
965 condition-case form has a TAG of Qnil.
967 Before each catch is discarded, unbind all special bindings and
968 execute all unwind-protect clauses made above that catch. Unwind
969 the handler stack as we go, so that the proper handlers are in
970 effect for each unwind-protect clause we run. At the end, restore
971 some static info saved in CATCH, and longjmp to the location
974 This is used for correct unwinding in Fthrow and Fsignal. */
977 unwind_to_catch (catch, value
)
978 struct catchtag
*catch;
981 register int last_time
;
983 /* Save the value in the tag. */
986 /* Restore the polling-suppression count. */
987 set_poll_suppress_count (catch->poll_suppress_count
);
991 last_time
= catchlist
== catch;
993 /* Unwind the specpdl stack, and then restore the proper set of
995 unbind_to (catchlist
->pdlcount
, Qnil
);
996 handlerlist
= catchlist
->handlerlist
;
997 catchlist
= catchlist
->next
;
1001 byte_stack_list
= catch->byte_stack
;
1002 gcprolist
= catch->gcpro
;
1005 gcpro_level
= gcprolist
->level
+ 1;
1009 backtrace_list
= catch->backlist
;
1010 lisp_eval_depth
= catch->lisp_eval_depth
;
1012 _longjmp (catch->jmp
, 1);
1015 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
1016 "(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.\n\
1017 Both TAG and VALUE are evalled.")
1019 register Lisp_Object tag
, value
;
1021 register struct catchtag
*c
;
1026 for (c
= catchlist
; c
; c
= c
->next
)
1028 if (EQ (c
->tag
, tag
))
1029 unwind_to_catch (c
, value
);
1031 tag
= Fsignal (Qno_catch
, Fcons (tag
, Fcons (value
, Qnil
)));
1036 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
1037 "Do BODYFORM, protecting with UNWINDFORMS.\n\
1038 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).\n\
1039 If BODYFORM completes normally, its value is returned\n\
1040 after executing the UNWINDFORMS.\n\
1041 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.")
1046 int count
= specpdl_ptr
- specpdl
;
1048 record_unwind_protect (0, Fcdr (args
));
1049 val
= Feval (Fcar (args
));
1050 return unbind_to (count
, val
);
1053 /* Chain of condition handlers currently in effect.
1054 The elements of this chain are contained in the stack frames
1055 of Fcondition_case and internal_condition_case.
1056 When an error is signaled (by calling Fsignal, below),
1057 this chain is searched for an element that applies. */
1059 struct handler
*handlerlist
;
1061 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1062 "Regain control when an error is signaled.\n\
1063 Usage looks like (condition-case VAR BODYFORM HANDLERS...).\n\
1064 executes BODYFORM and returns its value if no error happens.\n\
1065 Each element of HANDLERS looks like (CONDITION-NAME BODY...)\n\
1066 where the BODY is made of Lisp expressions.\n\n\
1067 A handler is applicable to an error\n\
1068 if CONDITION-NAME is one of the error's condition names.\n\
1069 If an error happens, the first applicable handler is run.\n\
1071 The car of a handler may be a list of condition names\n\
1072 instead of a single condition name.\n\
1074 When a handler handles an error,\n\
1075 control returns to the condition-case and the handler BODY... is executed\n\
1076 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\
1077 VAR may be nil; then you do not get access to the signal information.\n\
1079 The value of the last BODY form is returned from the condition-case.\n\
1080 See also the function `signal' for more info.")
1087 register Lisp_Object var
, bodyform
, handlers
;
1090 bodyform
= Fcar (Fcdr (args
));
1091 handlers
= Fcdr (Fcdr (args
));
1092 CHECK_SYMBOL (var
, 0);
1094 for (val
= handlers
; ! NILP (val
); val
= Fcdr (val
))
1100 && (SYMBOLP (XCAR (tem
))
1101 || CONSP (XCAR (tem
))))))
1102 error ("Invalid condition handler", tem
);
1107 c
.backlist
= backtrace_list
;
1108 c
.handlerlist
= handlerlist
;
1109 c
.lisp_eval_depth
= lisp_eval_depth
;
1110 c
.pdlcount
= specpdl_ptr
- specpdl
;
1111 c
.poll_suppress_count
= poll_suppress_count
;
1112 c
.gcpro
= gcprolist
;
1113 c
.byte_stack
= byte_stack_list
;
1114 if (_setjmp (c
.jmp
))
1117 specbind (h
.var
, c
.val
);
1118 val
= Fprogn (Fcdr (h
.chosen_clause
));
1120 /* Note that this just undoes the binding of h.var; whoever
1121 longjumped to us unwound the stack to c.pdlcount before
1123 unbind_to (c
.pdlcount
, Qnil
);
1130 h
.handler
= handlers
;
1131 h
.next
= handlerlist
;
1135 val
= Feval (bodyform
);
1137 handlerlist
= h
.next
;
1141 /* Call the function BFUN with no arguments, catching errors within it
1142 according to HANDLERS. If there is an error, call HFUN with
1143 one argument which is the data that describes the error:
1146 HANDLERS can be a list of conditions to catch.
1147 If HANDLERS is Qt, catch all errors.
1148 If HANDLERS is Qerror, catch all errors
1149 but allow the debugger to run if that is enabled. */
1152 internal_condition_case (bfun
, handlers
, hfun
)
1153 Lisp_Object (*bfun
) ();
1154 Lisp_Object handlers
;
1155 Lisp_Object (*hfun
) ();
1161 /* Since Fsignal resets this to 0, it had better be 0 now
1162 or else we have a potential bug. */
1163 if (interrupt_input_blocked
!= 0)
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 c
.byte_stack
= byte_stack_list
;
1175 if (_setjmp (c
.jmp
))
1177 return (*hfun
) (c
.val
);
1181 h
.handler
= handlers
;
1183 h
.next
= handlerlist
;
1189 handlerlist
= h
.next
;
1193 /* Like internal_condition_case but call HFUN with ARG as its argument. */
1196 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1197 Lisp_Object (*bfun
) ();
1199 Lisp_Object handlers
;
1200 Lisp_Object (*hfun
) ();
1208 c
.backlist
= backtrace_list
;
1209 c
.handlerlist
= handlerlist
;
1210 c
.lisp_eval_depth
= lisp_eval_depth
;
1211 c
.pdlcount
= specpdl_ptr
- specpdl
;
1212 c
.poll_suppress_count
= poll_suppress_count
;
1213 c
.gcpro
= gcprolist
;
1214 c
.byte_stack
= byte_stack_list
;
1215 if (_setjmp (c
.jmp
))
1217 return (*hfun
) (c
.val
);
1221 h
.handler
= handlers
;
1223 h
.next
= handlerlist
;
1227 val
= (*bfun
) (arg
);
1229 handlerlist
= h
.next
;
1233 static Lisp_Object
find_handler_clause ();
1235 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1236 "Signal an error. Args are ERROR-SYMBOL and associated DATA.\n\
1237 This function does not return.\n\n\
1238 An error symbol is a symbol with an `error-conditions' property\n\
1239 that is a list of condition names.\n\
1240 A handler for any of those names will get to handle this signal.\n\
1241 The symbol `error' should normally be one of them.\n\
1243 DATA should be a list. Its elements are printed as part of the error message.\n\
1244 If the signal is handled, DATA is made available to the handler.\n\
1245 See also the function `condition-case'.")
1246 (error_symbol
, data
)
1247 Lisp_Object error_symbol
, data
;
1249 /* When memory is full, ERROR-SYMBOL is nil,
1250 and DATA is (REAL-ERROR-SYMBOL . REAL-DATA). */
1251 register struct handler
*allhandlers
= handlerlist
;
1252 Lisp_Object conditions
;
1253 extern int gc_in_progress
;
1254 extern int waiting_for_input
;
1255 Lisp_Object debugger_value
;
1257 Lisp_Object real_error_symbol
;
1258 extern int display_busy_cursor_p
;
1261 if (gc_in_progress
|| waiting_for_input
)
1264 TOTALLY_UNBLOCK_INPUT
;
1266 if (NILP (error_symbol
))
1267 real_error_symbol
= Fcar (data
);
1269 real_error_symbol
= error_symbol
;
1271 #ifdef HAVE_X_WINDOWS
1272 if (display_busy_cursor_p
)
1273 Fx_hide_busy_cursor (Qt
);
1276 /* This hook is used by edebug. */
1277 if (! NILP (Vsignal_hook_function
))
1278 call2 (Vsignal_hook_function
, error_symbol
, data
);
1280 conditions
= Fget (real_error_symbol
, Qerror_conditions
);
1282 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1284 register Lisp_Object clause
;
1285 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1286 error_symbol
, data
, &debugger_value
);
1288 #if 0 /* Most callers are not prepared to handle gc if this returns.
1289 So, since this feature is not very useful, take it out. */
1290 /* If have called debugger and user wants to continue,
1292 if (EQ (clause
, Qlambda
))
1293 return debugger_value
;
1295 if (EQ (clause
, Qlambda
))
1297 /* We can't return values to code which signaled an error, but we
1298 can continue code which has signaled a quit. */
1299 if (EQ (real_error_symbol
, Qquit
))
1302 error ("Cannot return from the debugger in an error");
1308 Lisp_Object unwind_data
;
1309 struct handler
*h
= handlerlist
;
1311 handlerlist
= allhandlers
;
1313 if (NILP (error_symbol
))
1316 unwind_data
= Fcons (error_symbol
, data
);
1317 h
->chosen_clause
= clause
;
1318 unwind_to_catch (h
->tag
, unwind_data
);
1322 handlerlist
= allhandlers
;
1323 /* If no handler is present now, try to run the debugger,
1324 and if that fails, throw to top level. */
1325 find_handler_clause (Qerror
, conditions
, error_symbol
, data
, &debugger_value
);
1327 Fthrow (Qtop_level
, Qt
);
1329 if (! NILP (error_symbol
))
1330 data
= Fcons (error_symbol
, data
);
1332 string
= Ferror_message_string (data
);
1333 fatal ("%s", XSTRING (string
)->data
, 0);
1336 /* Return nonzero iff LIST is a non-nil atom or
1337 a list containing one of CONDITIONS. */
1340 wants_debugger (list
, conditions
)
1341 Lisp_Object list
, conditions
;
1348 while (CONSP (conditions
))
1350 Lisp_Object
this, tail
;
1351 this = XCAR (conditions
);
1352 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1353 if (EQ (XCAR (tail
), this))
1355 conditions
= XCDR (conditions
);
1360 /* Return 1 if an error with condition-symbols CONDITIONS,
1361 and described by SIGNAL-DATA, should skip the debugger
1362 according to debugger-ignore-errors. */
1365 skip_debugger (conditions
, data
)
1366 Lisp_Object conditions
, data
;
1369 int first_string
= 1;
1370 Lisp_Object error_message
;
1372 for (tail
= Vdebug_ignored_errors
; CONSP (tail
);
1375 if (STRINGP (XCAR (tail
)))
1379 error_message
= Ferror_message_string (data
);
1382 if (fast_string_match (XCAR (tail
), error_message
) >= 0)
1387 Lisp_Object contail
;
1389 for (contail
= conditions
; CONSP (contail
);
1390 contail
= XCDR (contail
))
1391 if (EQ (XCAR (tail
), XCAR (contail
)))
1399 /* Value of Qlambda means we have called debugger and user has continued.
1400 There are two ways to pass SIG and DATA:
1401 = SIG is the error symbol, and DATA is the rest of the data.
1402 = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1403 This is for memory-full errors only.
1405 Store value returned from debugger into *DEBUGGER_VALUE_PTR. */
1408 find_handler_clause (handlers
, conditions
, sig
, data
, debugger_value_ptr
)
1409 Lisp_Object handlers
, conditions
, sig
, data
;
1410 Lisp_Object
*debugger_value_ptr
;
1412 register Lisp_Object h
;
1413 register Lisp_Object tem
;
1415 if (EQ (handlers
, Qt
)) /* t is used by handlers for all conditions, set up by C code. */
1417 /* error is used similarly, but means print an error message
1418 and run the debugger if that is enabled. */
1419 if (EQ (handlers
, Qerror
)
1420 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1421 there is a handler. */
1423 int count
= specpdl_ptr
- specpdl
;
1424 int debugger_called
= 0;
1425 Lisp_Object sig_symbol
, combined_data
;
1426 /* This is set to 1 if we are handling a memory-full error,
1427 because these must not run the debugger.
1428 (There is no room in memory to do that!) */
1429 int no_debugger
= 0;
1433 combined_data
= data
;
1434 sig_symbol
= Fcar (data
);
1439 combined_data
= Fcons (sig
, data
);
1443 if (wants_debugger (Vstack_trace_on_error
, conditions
))
1446 internal_with_output_to_temp_buffer ("*Backtrace*",
1447 (Lisp_Object (*) (Lisp_Object
)) Fbacktrace
,
1450 internal_with_output_to_temp_buffer ("*Backtrace*",
1455 && (EQ (sig_symbol
, Qquit
)
1457 : wants_debugger (Vdebug_on_error
, conditions
))
1458 && ! skip_debugger (conditions
, combined_data
)
1459 && when_entered_debugger
< num_nonmacro_input_events
)
1461 specbind (Qdebug_on_error
, Qnil
);
1463 = call_debugger (Fcons (Qerror
,
1464 Fcons (combined_data
, Qnil
)));
1465 debugger_called
= 1;
1467 /* If there is no handler, return saying whether we ran the debugger. */
1468 if (EQ (handlers
, Qerror
))
1470 if (debugger_called
)
1471 return unbind_to (count
, Qlambda
);
1475 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1477 Lisp_Object handler
, condit
;
1480 if (!CONSP (handler
))
1482 condit
= Fcar (handler
);
1483 /* Handle a single condition name in handler HANDLER. */
1484 if (SYMBOLP (condit
))
1486 tem
= Fmemq (Fcar (handler
), conditions
);
1490 /* Handle a list of condition names in handler HANDLER. */
1491 else if (CONSP (condit
))
1493 while (CONSP (condit
))
1495 tem
= Fmemq (Fcar (condit
), conditions
);
1498 condit
= XCDR (condit
);
1505 /* dump an error message; called like printf */
1509 error (m
, a1
, a2
, a3
)
1529 int used
= doprnt (buffer
, size
, m
, m
+ mlen
, 3, args
);
1534 buffer
= (char *) xrealloc (buffer
, size
);
1537 buffer
= (char *) xmalloc (size
);
1542 string
= build_string (buffer
);
1546 Fsignal (Qerror
, Fcons (string
, Qnil
));
1549 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 1, 0,
1550 "T if FUNCTION makes provisions for interactive calling.\n\
1551 This means it contains a description for how to read arguments to give it.\n\
1552 The value is nil for an invalid function or a symbol with no function\n\
1555 Interactively callable functions include strings and vectors (treated\n\
1556 as keyboard macros), lambda-expressions that contain a top-level call\n\
1557 to `interactive', autoload definitions made by `autoload' with non-nil\n\
1558 fourth argument, and some of the built-in functions of Lisp.\n\
1560 Also, a symbol satisfies `commandp' if its function definition does so.")
1562 Lisp_Object function
;
1564 register Lisp_Object fun
;
1565 register Lisp_Object funcar
;
1569 fun
= indirect_function (fun
);
1570 if (EQ (fun
, Qunbound
))
1573 /* Emacs primitives are interactive if their DEFUN specifies an
1574 interactive spec. */
1577 if (XSUBR (fun
)->prompt
)
1583 /* Bytecode objects are interactive if they are long enough to
1584 have an element whose index is COMPILED_INTERACTIVE, which is
1585 where the interactive spec is stored. */
1586 else if (COMPILEDP (fun
))
1587 return ((XVECTOR (fun
)->size
& PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
1590 /* Strings and vectors are keyboard macros. */
1591 if (STRINGP (fun
) || VECTORP (fun
))
1594 /* Lists may represent commands. */
1597 funcar
= Fcar (fun
);
1598 if (!SYMBOLP (funcar
))
1599 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1600 if (EQ (funcar
, Qlambda
))
1601 return Fassq (Qinteractive
, Fcdr (Fcdr (fun
)));
1602 if (EQ (funcar
, Qmocklisp
))
1603 return Qt
; /* All mocklisp functions can be called interactively */
1604 if (EQ (funcar
, Qautoload
))
1605 return Fcar (Fcdr (Fcdr (Fcdr (fun
))));
1611 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1612 "Define FUNCTION to autoload from FILE.\n\
1613 FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\
1614 Third arg DOCSTRING is documentation for the function.\n\
1615 Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\
1616 Fifth arg TYPE indicates the type of the object:\n\
1617 nil or omitted says FUNCTION is a function,\n\
1618 `keymap' says FUNCTION is really a keymap, and\n\
1619 `macro' or t says FUNCTION is really a macro.\n\
1620 Third through fifth args give info about the real definition.\n\
1621 They default to nil.\n\
1622 If FUNCTION is already defined other than as an autoload,\n\
1623 this does nothing and returns nil.")
1624 (function
, file
, docstring
, interactive
, type
)
1625 Lisp_Object function
, file
, docstring
, interactive
, type
;
1628 Lisp_Object args
[4];
1631 CHECK_SYMBOL (function
, 0);
1632 CHECK_STRING (file
, 1);
1634 /* If function is defined and not as an autoload, don't override */
1635 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
1636 && !(CONSP (XSYMBOL (function
)->function
)
1637 && EQ (XCAR (XSYMBOL (function
)->function
), Qautoload
)))
1642 args
[1] = docstring
;
1643 args
[2] = interactive
;
1646 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
1647 #else /* NO_ARG_ARRAY */
1648 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
1649 #endif /* not NO_ARG_ARRAY */
1653 un_autoload (oldqueue
)
1654 Lisp_Object oldqueue
;
1656 register Lisp_Object queue
, first
, second
;
1658 /* Queue to unwind is current value of Vautoload_queue.
1659 oldqueue is the shadowed value to leave in Vautoload_queue. */
1660 queue
= Vautoload_queue
;
1661 Vautoload_queue
= oldqueue
;
1662 while (CONSP (queue
))
1664 first
= Fcar (queue
);
1665 second
= Fcdr (first
);
1666 first
= Fcar (first
);
1667 if (EQ (second
, Qnil
))
1670 Ffset (first
, second
);
1671 queue
= Fcdr (queue
);
1676 /* Load an autoloaded function.
1677 FUNNAME is the symbol which is the function's name.
1678 FUNDEF is the autoload definition (a list). */
1681 do_autoload (fundef
, funname
)
1682 Lisp_Object fundef
, funname
;
1684 int count
= specpdl_ptr
- specpdl
;
1685 Lisp_Object fun
, queue
, first
, second
;
1686 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1689 CHECK_SYMBOL (funname
, 0);
1690 GCPRO3 (fun
, funname
, fundef
);
1692 /* Preserve the match data. */
1693 record_unwind_protect (Fset_match_data
, Fmatch_data (Qnil
, Qnil
));
1695 /* Value saved here is to be restored into Vautoload_queue. */
1696 record_unwind_protect (un_autoload
, Vautoload_queue
);
1697 Vautoload_queue
= Qt
;
1698 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
, Qt
);
1700 /* Save the old autoloads, in case we ever do an unload. */
1701 queue
= Vautoload_queue
;
1702 while (CONSP (queue
))
1704 first
= Fcar (queue
);
1705 second
= Fcdr (first
);
1706 first
= Fcar (first
);
1708 /* Note: This test is subtle. The cdr of an autoload-queue entry
1709 may be an atom if the autoload entry was generated by a defalias
1712 Fput (first
, Qautoload
, (Fcdr (second
)));
1714 queue
= Fcdr (queue
);
1717 /* Once loading finishes, don't undo it. */
1718 Vautoload_queue
= Qt
;
1719 unbind_to (count
, Qnil
);
1721 fun
= Findirect_function (fun
);
1723 if (!NILP (Fequal (fun
, fundef
)))
1724 error ("Autoloading failed to define function %s",
1725 XSYMBOL (funname
)->name
->data
);
1729 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
1730 "Evaluate FORM and return its value.")
1734 Lisp_Object fun
, val
, original_fun
, original_args
;
1736 struct backtrace backtrace
;
1737 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1739 /* Since Fsignal resets this to 0, it had better be 0 now
1740 or else we have a potential bug. */
1741 if (interrupt_input_blocked
!= 0)
1746 if (EQ (Vmocklisp_arguments
, Qt
))
1747 return Fsymbol_value (form
);
1748 val
= Fsymbol_value (form
);
1750 XSETFASTINT (val
, 0);
1751 else if (EQ (val
, Qt
))
1752 XSETFASTINT (val
, 1);
1759 if (consing_since_gc
> gc_cons_threshold
)
1762 Fgarbage_collect ();
1766 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1768 if (max_lisp_eval_depth
< 100)
1769 max_lisp_eval_depth
= 100;
1770 if (lisp_eval_depth
> max_lisp_eval_depth
)
1771 error ("Lisp nesting exceeds max-lisp-eval-depth");
1774 original_fun
= Fcar (form
);
1775 original_args
= Fcdr (form
);
1777 backtrace
.next
= backtrace_list
;
1778 backtrace_list
= &backtrace
;
1779 backtrace
.function
= &original_fun
; /* This also protects them from gc */
1780 backtrace
.args
= &original_args
;
1781 backtrace
.nargs
= UNEVALLED
;
1782 backtrace
.evalargs
= 1;
1783 backtrace
.debug_on_exit
= 0;
1785 if (debug_on_next_call
)
1786 do_debug_on_call (Qt
);
1788 /* At this point, only original_fun and original_args
1789 have values that will be used below */
1791 fun
= Findirect_function (original_fun
);
1795 Lisp_Object numargs
;
1796 Lisp_Object argvals
[8];
1797 Lisp_Object args_left
;
1798 register int i
, maxargs
;
1800 args_left
= original_args
;
1801 numargs
= Flength (args_left
);
1803 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
1804 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
1805 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1807 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1809 backtrace
.evalargs
= 0;
1810 val
= (*XSUBR (fun
)->function
) (args_left
);
1814 if (XSUBR (fun
)->max_args
== MANY
)
1816 /* Pass a vector of evaluated arguments */
1818 register int argnum
= 0;
1820 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1822 GCPRO3 (args_left
, fun
, fun
);
1826 while (!NILP (args_left
))
1828 vals
[argnum
++] = Feval (Fcar (args_left
));
1829 args_left
= Fcdr (args_left
);
1830 gcpro3
.nvars
= argnum
;
1833 backtrace
.args
= vals
;
1834 backtrace
.nargs
= XINT (numargs
);
1836 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
1841 GCPRO3 (args_left
, fun
, fun
);
1842 gcpro3
.var
= argvals
;
1845 maxargs
= XSUBR (fun
)->max_args
;
1846 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
1848 argvals
[i
] = Feval (Fcar (args_left
));
1854 backtrace
.args
= argvals
;
1855 backtrace
.nargs
= XINT (numargs
);
1860 val
= (*XSUBR (fun
)->function
) ();
1863 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
1866 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
1869 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1873 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1874 argvals
[2], argvals
[3]);
1877 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1878 argvals
[3], argvals
[4]);
1881 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1882 argvals
[3], argvals
[4], argvals
[5]);
1885 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1886 argvals
[3], argvals
[4], argvals
[5],
1891 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1892 argvals
[3], argvals
[4], argvals
[5],
1893 argvals
[6], argvals
[7]);
1897 /* Someone has created a subr that takes more arguments than
1898 is supported by this code. We need to either rewrite the
1899 subr to use a different argument protocol, or add more
1900 cases to this switch. */
1904 if (COMPILEDP (fun
))
1905 val
= apply_lambda (fun
, original_args
, 1);
1909 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1910 funcar
= Fcar (fun
);
1911 if (!SYMBOLP (funcar
))
1912 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1913 if (EQ (funcar
, Qautoload
))
1915 do_autoload (fun
, original_fun
);
1918 if (EQ (funcar
, Qmacro
))
1919 val
= Feval (apply1 (Fcdr (fun
), original_args
));
1920 else if (EQ (funcar
, Qlambda
))
1921 val
= apply_lambda (fun
, original_args
, 1);
1922 else if (EQ (funcar
, Qmocklisp
))
1923 val
= ml_apply (fun
, original_args
);
1925 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1928 if (!EQ (Vmocklisp_arguments
, Qt
))
1931 XSETFASTINT (val
, 0);
1932 else if (EQ (val
, Qt
))
1933 XSETFASTINT (val
, 1);
1936 if (backtrace
.debug_on_exit
)
1937 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
1938 backtrace_list
= backtrace
.next
;
1942 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
1943 "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
1944 Then return the value FUNCTION returns.\n\
1945 Thus, (apply '+ 1 2 '(3 4)) returns 10.")
1950 register int i
, numargs
;
1951 register Lisp_Object spread_arg
;
1952 register Lisp_Object
*funcall_args
;
1954 struct gcpro gcpro1
;
1958 spread_arg
= args
[nargs
- 1];
1959 CHECK_LIST (spread_arg
, nargs
);
1961 numargs
= XINT (Flength (spread_arg
));
1964 return Ffuncall (nargs
- 1, args
);
1965 else if (numargs
== 1)
1967 args
[nargs
- 1] = XCAR (spread_arg
);
1968 return Ffuncall (nargs
, args
);
1971 numargs
+= nargs
- 2;
1973 fun
= indirect_function (fun
);
1974 if (EQ (fun
, Qunbound
))
1976 /* Let funcall get the error */
1983 if (numargs
< XSUBR (fun
)->min_args
1984 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
1985 goto funcall
; /* Let funcall get the error */
1986 else if (XSUBR (fun
)->max_args
> numargs
)
1988 /* Avoid making funcall cons up a yet another new vector of arguments
1989 by explicitly supplying nil's for optional values */
1990 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
1991 * sizeof (Lisp_Object
));
1992 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
1993 funcall_args
[++i
] = Qnil
;
1994 GCPRO1 (*funcall_args
);
1995 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
1999 /* We add 1 to numargs because funcall_args includes the
2000 function itself as well as its arguments. */
2003 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
2004 * sizeof (Lisp_Object
));
2005 GCPRO1 (*funcall_args
);
2006 gcpro1
.nvars
= 1 + numargs
;
2009 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
2010 /* Spread the last arg we got. Its first element goes in
2011 the slot that it used to occupy, hence this value of I. */
2013 while (!NILP (spread_arg
))
2015 funcall_args
[i
++] = XCAR (spread_arg
);
2016 spread_arg
= XCDR (spread_arg
);
2019 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
2022 /* Run hook variables in various ways. */
2024 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
2026 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 1, MANY
, 0,
2027 "Run each hook in HOOKS. Major mode functions use this.\n\
2028 Each argument should be a symbol, a hook variable.\n\
2029 These symbols are processed in the order specified.\n\
2030 If a hook symbol has a non-nil value, that value may be a function\n\
2031 or a list of functions to be called to run the hook.\n\
2032 If the value is a function, it is called with no arguments.\n\
2033 If it is a list, the elements are called, in order, with no arguments.\n\
2035 To make a hook variable buffer-local, use `make-local-hook',\n\
2036 not `make-local-variable'.")
2041 Lisp_Object hook
[1];
2044 for (i
= 0; i
< nargs
; i
++)
2047 run_hook_with_args (1, hook
, to_completion
);
2053 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
2054 Srun_hook_with_args
, 1, MANY
, 0,
2055 "Run HOOK with the specified arguments ARGS.\n\
2056 HOOK should be a symbol, a hook variable. If HOOK has a non-nil\n\
2057 value, that value may be a function or a list of functions to be\n\
2058 called to run the hook. If the value is a function, it is called with\n\
2059 the given arguments and its return value is returned. If it is a list\n\
2060 of functions, those functions are called, in order,\n\
2061 with the given arguments ARGS.\n\
2062 It is best not to depend on the value return by `run-hook-with-args',\n\
2063 as that may change.\n\
2065 To make a hook variable buffer-local, use `make-local-hook',\n\
2066 not `make-local-variable'.")
2071 return run_hook_with_args (nargs
, args
, to_completion
);
2074 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
2075 Srun_hook_with_args_until_success
, 1, MANY
, 0,
2076 "Run HOOK with the specified arguments ARGS.\n\
2077 HOOK should be a symbol, a hook variable. Its value should\n\
2078 be a list of functions. We call those functions, one by one,\n\
2079 passing arguments ARGS to each of them, until one of them\n\
2080 returns a non-nil value. Then we return that value.\n\
2081 If all the functions return nil, we return nil.\n\
2083 To make a hook variable buffer-local, use `make-local-hook',\n\
2084 not `make-local-variable'.")
2089 return run_hook_with_args (nargs
, args
, until_success
);
2092 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
2093 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
2094 "Run HOOK with the specified arguments ARGS.\n\
2095 HOOK should be a symbol, a hook variable. Its value should\n\
2096 be a list of functions. We call those functions, one by one,\n\
2097 passing arguments ARGS to each of them, until one of them\n\
2098 returns nil. Then we return nil.\n\
2099 If all the functions return non-nil, we return non-nil.\n\
2101 To make a hook variable buffer-local, use `make-local-hook',\n\
2102 not `make-local-variable'.")
2107 return run_hook_with_args (nargs
, args
, until_failure
);
2110 /* ARGS[0] should be a hook symbol.
2111 Call each of the functions in the hook value, passing each of them
2112 as arguments all the rest of ARGS (all NARGS - 1 elements).
2113 COND specifies a condition to test after each call
2114 to decide whether to stop.
2115 The caller (or its caller, etc) must gcpro all of ARGS,
2116 except that it isn't necessary to gcpro ARGS[0]. */
2119 run_hook_with_args (nargs
, args
, cond
)
2122 enum run_hooks_condition cond
;
2124 Lisp_Object sym
, val
, ret
;
2125 Lisp_Object globals
;
2126 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2128 /* If we are dying or still initializing,
2129 don't do anything--it would probably crash if we tried. */
2130 if (NILP (Vrun_hooks
))
2134 val
= find_symbol_value (sym
);
2135 ret
= (cond
== until_failure
? Qt
: Qnil
);
2137 if (EQ (val
, Qunbound
) || NILP (val
))
2139 else if (!CONSP (val
) || EQ (XCAR (val
), Qlambda
))
2142 return Ffuncall (nargs
, args
);
2147 GCPRO3 (sym
, val
, globals
);
2150 CONSP (val
) && ((cond
== to_completion
)
2151 || (cond
== until_success
? NILP (ret
)
2155 if (EQ (XCAR (val
), Qt
))
2157 /* t indicates this hook has a local binding;
2158 it means to run the global binding too. */
2160 for (globals
= Fdefault_value (sym
);
2161 CONSP (globals
) && ((cond
== to_completion
)
2162 || (cond
== until_success
? NILP (ret
)
2164 globals
= XCDR (globals
))
2166 args
[0] = XCAR (globals
);
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 ret
= Ffuncall (nargs
, args
);
2175 args
[0] = XCAR (val
);
2176 ret
= Ffuncall (nargs
, args
);
2185 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2186 present value of that symbol.
2187 Call each element of FUNLIST,
2188 passing each of them the rest of ARGS.
2189 The caller (or its caller, etc) must gcpro all of ARGS,
2190 except that it isn't necessary to gcpro ARGS[0]. */
2193 run_hook_list_with_args (funlist
, nargs
, args
)
2194 Lisp_Object funlist
;
2200 Lisp_Object globals
;
2201 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2205 GCPRO3 (sym
, val
, globals
);
2207 for (val
= funlist
; CONSP (val
); val
= XCDR (val
))
2209 if (EQ (XCAR (val
), Qt
))
2211 /* t indicates this hook has a local binding;
2212 it means to run the global binding too. */
2214 for (globals
= Fdefault_value (sym
);
2216 globals
= XCDR (globals
))
2218 args
[0] = XCAR (globals
);
2219 /* In a global value, t should not occur. If it does, we
2220 must ignore it to avoid an endless loop. */
2221 if (!EQ (args
[0], Qt
))
2222 Ffuncall (nargs
, args
);
2227 args
[0] = XCAR (val
);
2228 Ffuncall (nargs
, args
);
2235 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2238 run_hook_with_args_2 (hook
, arg1
, arg2
)
2239 Lisp_Object hook
, arg1
, arg2
;
2241 Lisp_Object temp
[3];
2246 Frun_hook_with_args (3, temp
);
2249 /* Apply fn to arg */
2252 Lisp_Object fn
, arg
;
2254 struct gcpro gcpro1
;
2258 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2262 Lisp_Object args
[2];
2266 RETURN_UNGCPRO (Fapply (2, args
));
2268 #else /* not NO_ARG_ARRAY */
2269 RETURN_UNGCPRO (Fapply (2, &fn
));
2270 #endif /* not NO_ARG_ARRAY */
2273 /* Call function fn on no arguments */
2278 struct gcpro gcpro1
;
2281 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2284 /* Call function fn with 1 argument arg1 */
2288 Lisp_Object fn
, arg1
;
2290 struct gcpro gcpro1
;
2292 Lisp_Object args
[2];
2298 RETURN_UNGCPRO (Ffuncall (2, args
));
2299 #else /* not NO_ARG_ARRAY */
2302 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2303 #endif /* not NO_ARG_ARRAY */
2306 /* Call function fn with 2 arguments arg1, arg2 */
2309 call2 (fn
, arg1
, arg2
)
2310 Lisp_Object fn
, arg1
, arg2
;
2312 struct gcpro gcpro1
;
2314 Lisp_Object args
[3];
2320 RETURN_UNGCPRO (Ffuncall (3, args
));
2321 #else /* not NO_ARG_ARRAY */
2324 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2325 #endif /* not NO_ARG_ARRAY */
2328 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2331 call3 (fn
, arg1
, arg2
, arg3
)
2332 Lisp_Object fn
, arg1
, arg2
, arg3
;
2334 struct gcpro gcpro1
;
2336 Lisp_Object args
[4];
2343 RETURN_UNGCPRO (Ffuncall (4, args
));
2344 #else /* not NO_ARG_ARRAY */
2347 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2348 #endif /* not NO_ARG_ARRAY */
2351 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2354 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2355 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2357 struct gcpro gcpro1
;
2359 Lisp_Object args
[5];
2367 RETURN_UNGCPRO (Ffuncall (5, args
));
2368 #else /* not NO_ARG_ARRAY */
2371 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2372 #endif /* not NO_ARG_ARRAY */
2375 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2378 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2379 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2381 struct gcpro gcpro1
;
2383 Lisp_Object args
[6];
2392 RETURN_UNGCPRO (Ffuncall (6, args
));
2393 #else /* not NO_ARG_ARRAY */
2396 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2397 #endif /* not NO_ARG_ARRAY */
2400 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2403 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2404 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2406 struct gcpro gcpro1
;
2408 Lisp_Object args
[7];
2418 RETURN_UNGCPRO (Ffuncall (7, args
));
2419 #else /* not NO_ARG_ARRAY */
2422 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2423 #endif /* not NO_ARG_ARRAY */
2426 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2427 "Call first argument as a function, passing remaining arguments to it.\n\
2428 Return the value that function returns.\n\
2429 Thus, (funcall 'cons 'x 'y) returns (x . y).")
2436 int numargs
= nargs
- 1;
2437 Lisp_Object lisp_numargs
;
2439 struct backtrace backtrace
;
2440 register Lisp_Object
*internal_args
;
2444 if (consing_since_gc
> gc_cons_threshold
)
2445 Fgarbage_collect ();
2447 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2449 if (max_lisp_eval_depth
< 100)
2450 max_lisp_eval_depth
= 100;
2451 if (lisp_eval_depth
> max_lisp_eval_depth
)
2452 error ("Lisp nesting exceeds max-lisp-eval-depth");
2455 backtrace
.next
= backtrace_list
;
2456 backtrace_list
= &backtrace
;
2457 backtrace
.function
= &args
[0];
2458 backtrace
.args
= &args
[1];
2459 backtrace
.nargs
= nargs
- 1;
2460 backtrace
.evalargs
= 0;
2461 backtrace
.debug_on_exit
= 0;
2463 if (debug_on_next_call
)
2464 do_debug_on_call (Qlambda
);
2470 fun
= Findirect_function (fun
);
2474 if (numargs
< XSUBR (fun
)->min_args
2475 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2477 XSETFASTINT (lisp_numargs
, numargs
);
2478 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (lisp_numargs
, Qnil
)));
2481 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2482 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2484 if (XSUBR (fun
)->max_args
== MANY
)
2486 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
2490 if (XSUBR (fun
)->max_args
> numargs
)
2492 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2493 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
2494 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2495 internal_args
[i
] = Qnil
;
2498 internal_args
= args
+ 1;
2499 switch (XSUBR (fun
)->max_args
)
2502 val
= (*XSUBR (fun
)->function
) ();
2505 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
2508 val
= (*XSUBR (fun
)->function
) (internal_args
[0],
2512 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2516 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2521 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2522 internal_args
[2], internal_args
[3],
2526 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2527 internal_args
[2], internal_args
[3],
2528 internal_args
[4], internal_args
[5]);
2531 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2532 internal_args
[2], internal_args
[3],
2533 internal_args
[4], internal_args
[5],
2538 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2539 internal_args
[2], internal_args
[3],
2540 internal_args
[4], internal_args
[5],
2541 internal_args
[6], internal_args
[7]);
2546 /* If a subr takes more than 8 arguments without using MANY
2547 or UNEVALLED, we need to extend this function to support it.
2548 Until this is done, there is no way to call the function. */
2552 if (COMPILEDP (fun
))
2553 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2557 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2558 funcar
= Fcar (fun
);
2559 if (!SYMBOLP (funcar
))
2560 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2561 if (EQ (funcar
, Qlambda
))
2562 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2563 else if (EQ (funcar
, Qmocklisp
))
2564 val
= ml_apply (fun
, Flist (numargs
, args
+ 1));
2565 else if (EQ (funcar
, Qautoload
))
2567 do_autoload (fun
, args
[0]);
2571 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2575 if (backtrace
.debug_on_exit
)
2576 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2577 backtrace_list
= backtrace
.next
;
2582 apply_lambda (fun
, args
, eval_flag
)
2583 Lisp_Object fun
, args
;
2586 Lisp_Object args_left
;
2587 Lisp_Object numargs
;
2588 register Lisp_Object
*arg_vector
;
2589 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2591 register Lisp_Object tem
;
2593 numargs
= Flength (args
);
2594 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2597 GCPRO3 (*arg_vector
, args_left
, fun
);
2600 for (i
= 0; i
< XINT (numargs
);)
2602 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2603 if (eval_flag
) tem
= Feval (tem
);
2604 arg_vector
[i
++] = tem
;
2612 backtrace_list
->args
= arg_vector
;
2613 backtrace_list
->nargs
= i
;
2615 backtrace_list
->evalargs
= 0;
2616 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
2618 /* Do the debug-on-exit now, while arg_vector still exists. */
2619 if (backtrace_list
->debug_on_exit
)
2620 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
2621 /* Don't do it again when we return to eval. */
2622 backtrace_list
->debug_on_exit
= 0;
2626 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2627 and return the result of evaluation.
2628 FUN must be either a lambda-expression or a compiled-code object. */
2631 funcall_lambda (fun
, nargs
, arg_vector
)
2634 register Lisp_Object
*arg_vector
;
2636 Lisp_Object val
, tem
;
2637 register Lisp_Object syms_left
;
2638 Lisp_Object numargs
;
2639 register Lisp_Object next
;
2640 int count
= specpdl_ptr
- specpdl
;
2642 int optional
= 0, rest
= 0;
2644 specbind (Qmocklisp_arguments
, Qt
); /* t means NOT mocklisp! */
2646 XSETFASTINT (numargs
, nargs
);
2649 syms_left
= Fcar (Fcdr (fun
));
2650 else if (COMPILEDP (fun
))
2651 syms_left
= XVECTOR (fun
)->contents
[COMPILED_ARGLIST
];
2655 for (; !NILP (syms_left
); syms_left
= Fcdr (syms_left
))
2658 next
= Fcar (syms_left
);
2659 while (!SYMBOLP (next
))
2660 next
= Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2661 if (EQ (next
, Qand_rest
))
2663 else if (EQ (next
, Qand_optional
))
2667 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
2672 tem
= arg_vector
[i
++];
2673 specbind (next
, tem
);
2676 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2678 specbind (next
, Qnil
);
2682 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2685 val
= Fprogn (Fcdr (Fcdr (fun
)));
2688 /* If we have not actually read the bytecode string
2689 and constants vector yet, fetch them from the file. */
2690 if (CONSP (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
]))
2691 Ffetch_bytecode (fun
);
2692 val
= Fbyte_code (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
],
2693 XVECTOR (fun
)->contents
[COMPILED_CONSTANTS
],
2694 XVECTOR (fun
)->contents
[COMPILED_STACK_DEPTH
]);
2696 return unbind_to (count
, val
);
2699 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
2701 "If byte-compiled OBJECT is lazy-loaded, fetch it now.")
2707 if (COMPILEDP (object
)
2708 && CONSP (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]))
2710 tem
= read_doc_string (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]);
2712 error ("invalid byte code");
2713 XVECTOR (object
)->contents
[COMPILED_BYTECODE
] = XCAR (tem
);
2714 XVECTOR (object
)->contents
[COMPILED_CONSTANTS
] = XCDR (tem
);
2722 register int count
= specpdl_ptr
- specpdl
;
2723 if (specpdl_size
>= max_specpdl_size
)
2725 if (max_specpdl_size
< 400)
2726 max_specpdl_size
= 400;
2727 if (specpdl_size
>= max_specpdl_size
)
2729 if (!NILP (Vdebug_on_error
))
2730 /* Leave room for some specpdl in the debugger. */
2731 max_specpdl_size
= specpdl_size
+ 100;
2733 Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil
));
2737 if (specpdl_size
> max_specpdl_size
)
2738 specpdl_size
= max_specpdl_size
;
2739 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
2740 specpdl_ptr
= specpdl
+ count
;
2744 specbind (symbol
, value
)
2745 Lisp_Object symbol
, value
;
2749 CHECK_SYMBOL (symbol
, 0);
2751 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2753 specpdl_ptr
->symbol
= symbol
;
2754 specpdl_ptr
->func
= 0;
2755 specpdl_ptr
->old_value
= ovalue
= find_symbol_value (symbol
);
2757 if (BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
))
2758 store_symval_forwarding (symbol
, ovalue
, value
);
2760 set_internal (symbol
, value
, 1);
2764 record_unwind_protect (function
, arg
)
2765 Lisp_Object (*function
) P_ ((Lisp_Object
));
2768 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2770 specpdl_ptr
->func
= function
;
2771 specpdl_ptr
->symbol
= Qnil
;
2772 specpdl_ptr
->old_value
= arg
;
2777 unbind_to (count
, value
)
2781 int quitf
= !NILP (Vquit_flag
);
2782 struct gcpro gcpro1
;
2788 while (specpdl_ptr
!= specpdl
+ count
)
2791 if (specpdl_ptr
->func
!= 0)
2792 (*specpdl_ptr
->func
) (specpdl_ptr
->old_value
);
2793 /* Note that a "binding" of nil is really an unwind protect,
2794 so in that case the "old value" is a list of forms to evaluate. */
2795 else if (NILP (specpdl_ptr
->symbol
))
2796 Fprogn (specpdl_ptr
->old_value
);
2798 set_internal (specpdl_ptr
->symbol
, specpdl_ptr
->old_value
, 1);
2800 if (NILP (Vquit_flag
) && quitf
) Vquit_flag
= Qt
;
2809 /* Get the value of symbol's global binding, even if that binding
2810 is not now dynamically visible. */
2813 top_level_value (symbol
)
2816 register struct specbinding
*ptr
= specpdl
;
2818 CHECK_SYMBOL (symbol
, 0);
2819 for (; ptr
!= specpdl_ptr
; ptr
++)
2821 if (EQ (ptr
->symbol
, symbol
))
2822 return ptr
->old_value
;
2824 return Fsymbol_value (symbol
);
2828 top_level_set (symbol
, newval
)
2829 Lisp_Object symbol
, newval
;
2831 register struct specbinding
*ptr
= specpdl
;
2833 CHECK_SYMBOL (symbol
, 0);
2834 for (; ptr
!= specpdl_ptr
; ptr
++)
2836 if (EQ (ptr
->symbol
, symbol
))
2838 ptr
->old_value
= newval
;
2842 return Fset (symbol
, newval
);
2847 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
2848 "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\
2849 The debugger is entered when that frame exits, if the flag is non-nil.")
2851 Lisp_Object level
, flag
;
2853 register struct backtrace
*backlist
= backtrace_list
;
2856 CHECK_NUMBER (level
, 0);
2858 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
2860 backlist
= backlist
->next
;
2864 backlist
->debug_on_exit
= !NILP (flag
);
2869 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
2870 "Print a trace of Lisp function calls currently active.\n\
2871 Output stream used is value of `standard-output'.")
2874 register struct backtrace
*backlist
= backtrace_list
;
2878 extern Lisp_Object Vprint_level
;
2879 struct gcpro gcpro1
;
2881 XSETFASTINT (Vprint_level
, 3);
2888 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
2889 if (backlist
->nargs
== UNEVALLED
)
2891 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
2892 write_string ("\n", -1);
2896 tem
= *backlist
->function
;
2897 Fprin1 (tem
, Qnil
); /* This can QUIT */
2898 write_string ("(", -1);
2899 if (backlist
->nargs
== MANY
)
2901 for (tail
= *backlist
->args
, i
= 0;
2903 tail
= Fcdr (tail
), i
++)
2905 if (i
) write_string (" ", -1);
2906 Fprin1 (Fcar (tail
), Qnil
);
2911 for (i
= 0; i
< backlist
->nargs
; i
++)
2913 if (i
) write_string (" ", -1);
2914 Fprin1 (backlist
->args
[i
], Qnil
);
2917 write_string (")\n", -1);
2919 backlist
= backlist
->next
;
2922 Vprint_level
= Qnil
;
2927 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, "",
2928 "Return the function and arguments NFRAMES up from current execution point.\n\
2929 If that frame has not evaluated the arguments yet (or is a special form),\n\
2930 the value is (nil FUNCTION ARG-FORMS...).\n\
2931 If that frame has evaluated its arguments and called its function already,\n\
2932 the value is (t FUNCTION ARG-VALUES...).\n\
2933 A &rest arg is represented as the tail of the list ARG-VALUES.\n\
2934 FUNCTION is whatever was supplied as car of evaluated list,\n\
2935 or a lambda expression for macro calls.\n\
2936 If NFRAMES is more than the number of frames, the value is nil.")
2938 Lisp_Object nframes
;
2940 register struct backtrace
*backlist
= backtrace_list
;
2944 CHECK_NATNUM (nframes
, 0);
2946 /* Find the frame requested. */
2947 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
2948 backlist
= backlist
->next
;
2952 if (backlist
->nargs
== UNEVALLED
)
2953 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
2956 if (backlist
->nargs
== MANY
)
2957 tem
= *backlist
->args
;
2959 tem
= Flist (backlist
->nargs
, backlist
->args
);
2961 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
2968 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
2969 "*Limit on number of Lisp variable bindings & unwind-protects.\n\
2970 If Lisp code tries to make more than this many at once,\n\
2971 an error is signaled.");
2973 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
2974 "*Limit on depth in `eval', `apply' and `funcall' before error.\n\
2975 This limit is to catch infinite recursions for you before they cause\n\
2976 actual stack overflow in C, which would be fatal for Emacs.\n\
2977 You can safely make it considerably larger than its default value,\n\
2978 if that proves inconveniently small.");
2980 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
2981 "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
2982 Typing C-g sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
2985 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
2986 "Non-nil inhibits C-g quitting from happening immediately.\n\
2987 Note that `quit-flag' will still be set by typing C-g,\n\
2988 so a quit will be signaled as soon as `inhibit-quit' is nil.\n\
2989 To prevent this happening, set `quit-flag' to nil\n\
2990 before making `inhibit-quit' nil.");
2991 Vinhibit_quit
= Qnil
;
2993 Qinhibit_quit
= intern ("inhibit-quit");
2994 staticpro (&Qinhibit_quit
);
2996 Qautoload
= intern ("autoload");
2997 staticpro (&Qautoload
);
2999 Qdebug_on_error
= intern ("debug-on-error");
3000 staticpro (&Qdebug_on_error
);
3002 Qmacro
= intern ("macro");
3003 staticpro (&Qmacro
);
3005 /* Note that the process handling also uses Qexit, but we don't want
3006 to staticpro it twice, so we just do it here. */
3007 Qexit
= intern ("exit");
3010 Qinteractive
= intern ("interactive");
3011 staticpro (&Qinteractive
);
3013 Qcommandp
= intern ("commandp");
3014 staticpro (&Qcommandp
);
3016 Qdefun
= intern ("defun");
3017 staticpro (&Qdefun
);
3019 Qand_rest
= intern ("&rest");
3020 staticpro (&Qand_rest
);
3022 Qand_optional
= intern ("&optional");
3023 staticpro (&Qand_optional
);
3025 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
3026 "*Non-nil means automatically display a backtrace buffer\n\
3027 after any error that is handled by the editor command loop.\n\
3028 If the value is a list, an error only means to display a backtrace\n\
3029 if one of its condition symbols appears in the list.");
3030 Vstack_trace_on_error
= Qnil
;
3032 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
3033 "*Non-nil means enter debugger if an error is signaled.\n\
3034 Does not apply to errors handled by `condition-case'.\n\
3035 If the value is a list, an error only means to enter the debugger\n\
3036 if one of its condition symbols appears in the list.\n\
3037 See also variable `debug-on-quit'.");
3038 Vdebug_on_error
= Qnil
;
3040 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
3041 "*List of errors for which the debugger should not be called.\n\
3042 Each element may be a condition-name or a regexp that matches error messages.\n\
3043 If any element applies to a given error, that error skips the debugger\n\
3044 and just returns to top level.\n\
3045 This overrides the variable `debug-on-error'.\n\
3046 It does not apply to errors handled by `condition-case'.");
3047 Vdebug_ignored_errors
= Qnil
;
3049 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
3050 "*Non-nil means enter debugger if quit is signaled (C-g, for example).\n\
3051 Does not apply if quit is handled by a `condition-case'.");
3054 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
3055 "Non-nil means enter debugger before next `eval', `apply' or `funcall'.");
3057 DEFVAR_BOOL ("debugger-may-continue", &debugger_may_continue
,
3058 "Non-nil means debugger may continue execution.\n\
3059 This is nil when the debugger is called under circumstances where it\n\
3060 might not be safe to continue.");
3062 DEFVAR_LISP ("debugger", &Vdebugger
,
3063 "Function to call to invoke debugger.\n\
3064 If due to frame exit, args are `exit' and the value being returned;\n\
3065 this function's value will be returned instead of that.\n\
3066 If due to error, args are `error' and a list of the args to `signal'.\n\
3067 If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
3068 If due to `eval' entry, one arg, t.");
3071 DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function
,
3072 "If non-nil, this is a function for `signal' to call.\n\
3073 It receives the same arguments that `signal' was given.\n\
3074 The Edebug package uses this to regain control.");
3075 Vsignal_hook_function
= Qnil
;
3077 Qmocklisp_arguments
= intern ("mocklisp-arguments");
3078 staticpro (&Qmocklisp_arguments
);
3079 DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments
,
3080 "While in a mocklisp function, the list of its unevaluated args.");
3081 Vmocklisp_arguments
= Qt
;
3083 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal
,
3084 "*Non-nil means call the debugger regardless of condition handlers.\n\
3085 Note that `debug-on-error', `debug-on-quit' and friends\n\
3086 still determine whether to handle the particular condition.");
3087 Vdebug_on_signal
= Qnil
;
3089 Vrun_hooks
= intern ("run-hooks");
3090 staticpro (&Vrun_hooks
);
3092 staticpro (&Vautoload_queue
);
3093 Vautoload_queue
= Qnil
;
3104 defsubr (&Sfunction
);
3106 defsubr (&Sdefmacro
);
3108 defsubr (&Sdefconst
);
3109 defsubr (&Suser_variable_p
);
3113 defsubr (&Smacroexpand
);
3116 defsubr (&Sunwind_protect
);
3117 defsubr (&Scondition_case
);
3119 defsubr (&Sinteractive_p
);
3120 defsubr (&Scommandp
);
3121 defsubr (&Sautoload
);
3124 defsubr (&Sfuncall
);
3125 defsubr (&Srun_hooks
);
3126 defsubr (&Srun_hook_with_args
);
3127 defsubr (&Srun_hook_with_args_until_success
);
3128 defsubr (&Srun_hook_with_args_until_failure
);
3129 defsubr (&Sfetch_bytecode
);
3130 defsubr (&Sbacktrace_debug
);
3131 defsubr (&Sbacktrace
);
3132 defsubr (&Sbacktrace_frame
);