1 /* Evaluator for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
24 #include "blockinput.h"
35 /* This definition is duplicated in alloc.c and keyboard.c */
36 /* Putting it in lisp.h makes cc bomb out! */
40 struct backtrace
*next
;
41 Lisp_Object
*function
;
42 Lisp_Object
*args
; /* Points to vector of args. */
43 int nargs
; /* Length of vector.
44 If nargs is UNEVALLED, args points to slot holding
45 list of unevalled args */
47 /* Nonzero means call value of debugger when done with this operation. */
51 struct backtrace
*backtrace_list
;
53 /* This structure helps implement the `catch' and `throw' control
54 structure. A struct catchtag contains all the information needed
55 to restore the state of the interpreter after a non-local jump.
57 Handlers for error conditions (represented by `struct handler'
58 structures) just point to a catch tag to do the cleanup required
61 catchtag structures are chained together in the C calling stack;
62 the `next' member points to the next outer catchtag.
64 A call like (throw TAG VAL) searches for a catchtag whose `tag'
65 member is TAG, and then unbinds to it. The `val' member is used to
66 hold VAL while the stack is unwound; `val' is returned as the value
69 All the other members are concerned with restoring the interpreter
75 struct catchtag
*next
;
78 struct backtrace
*backlist
;
79 struct handler
*handlerlist
;
82 int poll_suppress_count
;
85 struct catchtag
*catchlist
;
87 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
88 Lisp_Object Qinhibit_quit
, Vinhibit_quit
, Vquit_flag
;
89 Lisp_Object Qmocklisp_arguments
, Vmocklisp_arguments
, Qmocklisp
;
90 Lisp_Object Qand_rest
, Qand_optional
;
91 Lisp_Object Qdebug_on_error
;
93 /* This holds either the symbol `run-hooks' or nil.
94 It is nil at an early stage of startup, and when Emacs
96 Lisp_Object Vrun_hooks
;
98 /* Non-nil means record all fset's and provide's, to be undone
99 if the file being autoloaded is not fully loaded.
100 They are recorded by being consed onto the front of Vautoload_queue:
101 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */
103 Lisp_Object Vautoload_queue
;
105 /* Current number of specbindings allocated in specpdl. */
108 /* Pointer to beginning of specpdl. */
109 struct specbinding
*specpdl
;
111 /* Pointer to first unused element in specpdl. */
112 struct specbinding
*specpdl_ptr
;
114 /* Maximum size allowed for specpdl allocation */
115 int max_specpdl_size
;
117 /* Depth in Lisp evaluations and function calls. */
120 /* Maximum allowed depth in Lisp evaluations and function calls. */
121 int max_lisp_eval_depth
;
123 /* Nonzero means enter debugger before next function call */
124 int debug_on_next_call
;
126 /* List of conditions (non-nil atom means all) which cause a backtrace
127 if an error is handled by the command loop's error handler. */
128 Lisp_Object Vstack_trace_on_error
;
130 /* List of conditions (non-nil atom means all) which enter the debugger
131 if an error is handled by the command loop's error handler. */
132 Lisp_Object Vdebug_on_error
;
134 /* List of conditions and regexps specifying error messages which
135 do not enter the debugger even if Vdebug_on_errors says they should. */
136 Lisp_Object Vdebug_ignored_errors
;
138 /* Non-nil means call the debugger even if the error will be handled. */
139 Lisp_Object Vdebug_on_signal
;
141 /* Hook for edebug to use. */
142 Lisp_Object Vsignal_hook_function
;
144 /* Nonzero means enter debugger if a quit signal
145 is handled by the command loop's error handler. */
148 /* The value of num_nonmacro_input_chars as of the last time we
149 started to enter the debugger. If we decide to enter the debugger
150 again when this is still equal to num_nonmacro_input_chars, then we
151 know that the debugger itself has an error, and we should just
152 signal the error instead of entering an infinite loop of debugger
154 int when_entered_debugger
;
156 Lisp_Object Vdebugger
;
158 void specbind (), record_unwind_protect ();
160 Lisp_Object
run_hook_with_args ();
162 Lisp_Object
funcall_lambda ();
163 extern Lisp_Object
ml_apply (); /* Apply a mocklisp function to unevaluated argument list */
168 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
169 specpdl_ptr
= specpdl
;
170 max_specpdl_size
= 600;
171 max_lisp_eval_depth
= 300;
178 specpdl_ptr
= specpdl
;
183 debug_on_next_call
= 0;
185 /* This is less than the initial value of num_nonmacro_input_chars. */
186 when_entered_debugger
= -1;
193 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
194 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
195 if (specpdl_size
+ 40 > max_specpdl_size
)
196 max_specpdl_size
= specpdl_size
+ 40;
197 debug_on_next_call
= 0;
198 when_entered_debugger
= num_nonmacro_input_chars
;
199 return apply1 (Vdebugger
, arg
);
202 do_debug_on_call (code
)
205 debug_on_next_call
= 0;
206 backtrace_list
->debug_on_exit
= 1;
207 call_debugger (Fcons (code
, Qnil
));
210 /* NOTE!!! Every function that can call EVAL must protect its args
211 and temporaries from garbage collection while it needs them.
212 The definition of `For' shows what you have to do. */
214 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
215 "Eval args until one of them yields non-nil, then return that value.\n\
216 The remaining args are not evalled at all.\n\
217 If all args return nil, return nil.")
221 register Lisp_Object val
;
222 Lisp_Object args_left
;
233 val
= Feval (Fcar (args_left
));
236 args_left
= Fcdr (args_left
);
238 while (!NILP(args_left
));
244 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
245 "Eval args until one of them yields nil, then return nil.\n\
246 The remaining args are not evalled at all.\n\
247 If no arg yields nil, return the last arg's value.")
251 register Lisp_Object val
;
252 Lisp_Object args_left
;
263 val
= Feval (Fcar (args_left
));
266 args_left
= Fcdr (args_left
);
268 while (!NILP(args_left
));
274 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
275 "(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...\n\
276 Returns the value of THEN or the value of the last of the ELSE's.\n\
277 THEN must be one expression, but ELSE... can be zero or more expressions.\n\
278 If COND yields nil, and there are no ELSE's, the value is nil.")
282 register Lisp_Object cond
;
286 cond
= Feval (Fcar (args
));
290 return Feval (Fcar (Fcdr (args
)));
291 return Fprogn (Fcdr (Fcdr (args
)));
294 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
295 "(cond CLAUSES...): try each clause until one succeeds.\n\
296 Each clause looks like (CONDITION BODY...). CONDITION is evaluated\n\
297 and, if the value is non-nil, this clause succeeds:\n\
298 then the expressions in BODY are evaluated and the last one's\n\
299 value is the value of the cond-form.\n\
300 If no clause succeeds, cond returns nil.\n\
301 If a clause has one element, as in (CONDITION),\n\
302 CONDITION's value if non-nil is returned from the cond-form.")
306 register Lisp_Object clause
, val
;
313 clause
= Fcar (args
);
314 val
= Feval (Fcar (clause
));
317 if (!EQ (XCONS (clause
)->cdr
, Qnil
))
318 val
= Fprogn (XCONS (clause
)->cdr
);
321 args
= XCONS (args
)->cdr
;
328 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
329 "(progn BODY...): eval BODY forms sequentially and return value of last one.")
333 register Lisp_Object val
, tem
;
334 Lisp_Object args_left
;
337 /* In Mocklisp code, symbols at the front of the progn arglist
338 are to be bound to zero. */
339 if (!EQ (Vmocklisp_arguments
, Qt
))
341 val
= make_number (0);
342 while (!NILP (args
) && (tem
= Fcar (args
), SYMBOLP (tem
)))
345 specbind (tem
, val
), args
= Fcdr (args
);
357 val
= Feval (Fcar (args_left
));
358 args_left
= Fcdr (args_left
);
360 while (!NILP(args_left
));
366 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
367 "(prog1 FIRST BODY...): eval FIRST and BODY sequentially; value from FIRST.\n\
368 The value of FIRST is saved during the evaluation of the remaining args,\n\
369 whose values are discarded.")
374 register Lisp_Object args_left
;
375 struct gcpro gcpro1
, gcpro2
;
376 register int argnum
= 0;
388 val
= Feval (Fcar (args_left
));
390 Feval (Fcar (args_left
));
391 args_left
= Fcdr (args_left
);
393 while (!NILP(args_left
));
399 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
400 "(prog2 X Y BODY...): eval X, Y and BODY sequentially; value from Y.\n\
401 The value of Y is saved during the evaluation of the remaining args,\n\
402 whose values are discarded.")
407 register Lisp_Object args_left
;
408 struct gcpro gcpro1
, gcpro2
;
409 register int argnum
= -1;
423 val
= Feval (Fcar (args_left
));
425 Feval (Fcar (args_left
));
426 args_left
= Fcdr (args_left
);
428 while (!NILP (args_left
));
434 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
435 "(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.\n\
436 The symbols SYM are variables; they are literal (not evaluated).\n\
437 The values VAL are expressions; they are evaluated.\n\
438 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.\n\
439 The second VAL is not computed until after the first SYM is set, and so on;\n\
440 each VAL can use the new value of variables set earlier in the `setq'.\n\
441 The return value of the `setq' form is the value of the last VAL.")
445 register Lisp_Object args_left
;
446 register Lisp_Object val
, sym
;
457 val
= Feval (Fcar (Fcdr (args_left
)));
458 sym
= Fcar (args_left
);
460 args_left
= Fcdr (Fcdr (args_left
));
462 while (!NILP(args_left
));
468 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
469 "Return the argument, without evaluating it. `(quote x)' yields `x'.")
476 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
477 "Like `quote', but preferred for objects which are functions.\n\
478 In byte compilation, `function' causes its argument to be compiled.\n\
479 `quote' cannot do that.")
486 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
487 "Return t if function in which this appears was called interactively.\n\
488 This means that the function was called with call-interactively (which\n\
489 includes being called as the binding of a key)\n\
490 and input is currently coming from the keyboard (not in keyboard macro).")
493 register struct backtrace
*btp
;
494 register Lisp_Object fun
;
499 btp
= backtrace_list
;
501 /* If this isn't a byte-compiled function, there may be a frame at
502 the top for Finteractive_p itself. If so, skip it. */
503 fun
= Findirect_function (*btp
->function
);
504 if (SUBRP (fun
) && XSUBR (fun
) == &Sinteractive_p
)
507 /* If we're running an Emacs 18-style byte-compiled function, there
508 may be a frame for Fbytecode. Now, given the strictest
509 definition, this function isn't really being called
510 interactively, but because that's the way Emacs 18 always builds
511 byte-compiled functions, we'll accept it for now. */
512 if (EQ (*btp
->function
, Qbytecode
))
515 /* If this isn't a byte-compiled function, then we may now be
516 looking at several frames for special forms. Skip past them. */
518 btp
->nargs
== UNEVALLED
)
521 /* btp now points at the frame of the innermost function that isn't
522 a special form, ignoring frames for Finteractive_p and/or
523 Fbytecode at the top. If this frame is for a built-in function
524 (such as load or eval-region) return nil. */
525 fun
= Findirect_function (*btp
->function
);
528 /* btp points to the frame of a Lisp function that called interactive-p.
529 Return t if that function was called interactively. */
530 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
535 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
536 "(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.\n\
537 The definition is (lambda ARGLIST [DOCSTRING] BODY...).\n\
538 See also the function `interactive'.")
542 register Lisp_Object fn_name
;
543 register Lisp_Object defn
;
545 fn_name
= Fcar (args
);
546 defn
= Fcons (Qlambda
, Fcdr (args
));
547 if (!NILP (Vpurify_flag
))
548 defn
= Fpurecopy (defn
);
549 Ffset (fn_name
, defn
);
550 LOADHIST_ATTACH (fn_name
);
554 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
555 "(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.\n\
556 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).\n\
557 When the macro is called, as in (NAME ARGS...),\n\
558 the function (lambda ARGLIST BODY...) is applied to\n\
559 the list ARGS... as it appears in the expression,\n\
560 and the result should be a form to be evaluated instead of the original.")
564 register Lisp_Object fn_name
;
565 register Lisp_Object defn
;
567 fn_name
= Fcar (args
);
568 defn
= Fcons (Qmacro
, Fcons (Qlambda
, Fcdr (args
)));
569 if (!NILP (Vpurify_flag
))
570 defn
= Fpurecopy (defn
);
571 Ffset (fn_name
, defn
);
572 LOADHIST_ATTACH (fn_name
);
576 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
577 "(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.\n\
578 You are not required to define a variable in order to use it,\n\
579 but the definition can supply documentation and an initial value\n\
580 in a way that tags can recognize.\n\n\
581 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.\n\
582 If SYMBOL is buffer-local, its default value is what is set;\n\
583 buffer-local values are not affected.\n\
584 INITVALUE and DOCSTRING are optional.\n\
585 If DOCSTRING starts with *, this variable is identified as a user option.\n\
586 This means that M-x set-variable and M-x edit-options recognize it.\n\
587 If INITVALUE is missing, SYMBOL's value is not set.")
591 register Lisp_Object sym
, tem
, tail
;
595 if (!NILP (Fcdr (Fcdr (tail
))))
596 error ("too many arguments");
600 tem
= Fdefault_boundp (sym
);
602 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
604 tail
= Fcdr (Fcdr (args
));
605 if (!NILP (Fcar (tail
)))
608 if (!NILP (Vpurify_flag
))
609 tem
= Fpurecopy (tem
);
610 Fput (sym
, Qvariable_documentation
, tem
);
612 LOADHIST_ATTACH (sym
);
616 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
617 "(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant variable.\n\
618 The intent is that programs do not change this value, but users may.\n\
619 Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\
620 If SYMBOL is buffer-local, its default value is what is set;\n\
621 buffer-local values are not affected.\n\
622 DOCSTRING is optional.\n\
623 If DOCSTRING starts with *, this variable is identified as a user option.\n\
624 This means that M-x set-variable and M-x edit-options recognize it.\n\n\
625 Note: do not use `defconst' for user options in libraries that are not\n\
626 normally loaded, since it is useful for users to be able to specify\n\
627 their own values for such variables before loading the library.\n\
628 Since `defconst' unconditionally assigns the variable,\n\
629 it would override the user's choice.")
633 register Lisp_Object sym
, tem
;
636 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
637 error ("too many arguments");
639 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
640 tem
= Fcar (Fcdr (Fcdr (args
)));
643 if (!NILP (Vpurify_flag
))
644 tem
= Fpurecopy (tem
);
645 Fput (sym
, Qvariable_documentation
, tem
);
647 LOADHIST_ATTACH (sym
);
651 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
652 "Returns t if VARIABLE is intended to be set and modified by users.\n\
653 \(The alternative is a variable used internally in a Lisp program.)\n\
654 Determined by whether the first character of the documentation\n\
655 for the variable is `*'.")
657 Lisp_Object variable
;
659 Lisp_Object documentation
;
661 documentation
= Fget (variable
, Qvariable_documentation
);
662 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
664 if (STRINGP (documentation
)
665 && ((unsigned char) XSTRING (documentation
)->data
[0] == '*'))
667 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
668 if (CONSP (documentation
)
669 && STRINGP (XCONS (documentation
)->car
)
670 && INTEGERP (XCONS (documentation
)->cdr
)
671 && XINT (XCONS (documentation
)->cdr
) < 0)
676 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
677 "(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
678 The value of the last form in BODY is returned.\n\
679 Each element of VARLIST is a symbol (which is bound to nil)\n\
680 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
681 Each VALUEFORM can refer to the symbols already bound by this VARLIST.")
685 Lisp_Object varlist
, val
, elt
;
686 int count
= specpdl_ptr
- specpdl
;
687 struct gcpro gcpro1
, gcpro2
, gcpro3
;
689 GCPRO3 (args
, elt
, varlist
);
691 varlist
= Fcar (args
);
692 while (!NILP (varlist
))
695 elt
= Fcar (varlist
);
697 specbind (elt
, Qnil
);
698 else if (! NILP (Fcdr (Fcdr (elt
))))
700 Fcons (build_string ("`let' bindings can have only one value-form"),
704 val
= Feval (Fcar (Fcdr (elt
)));
705 specbind (Fcar (elt
), val
);
707 varlist
= Fcdr (varlist
);
710 val
= Fprogn (Fcdr (args
));
711 return unbind_to (count
, val
);
714 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
715 "(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
716 The value of the last form in BODY is returned.\n\
717 Each element of VARLIST is a symbol (which is bound to nil)\n\
718 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
719 All the VALUEFORMs are evalled before any symbols are bound.")
723 Lisp_Object
*temps
, tem
;
724 register Lisp_Object elt
, varlist
;
725 int count
= specpdl_ptr
- specpdl
;
727 struct gcpro gcpro1
, gcpro2
;
729 varlist
= Fcar (args
);
731 /* Make space to hold the values to give the bound variables */
732 elt
= Flength (varlist
);
733 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
735 /* Compute the values and store them in `temps' */
737 GCPRO2 (args
, *temps
);
740 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
743 elt
= Fcar (varlist
);
745 temps
[argnum
++] = Qnil
;
746 else if (! NILP (Fcdr (Fcdr (elt
))))
748 Fcons (build_string ("`let' bindings can have only one value-form"),
751 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
752 gcpro2
.nvars
= argnum
;
756 varlist
= Fcar (args
);
757 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
759 elt
= Fcar (varlist
);
760 tem
= temps
[argnum
++];
764 specbind (Fcar (elt
), tem
);
767 elt
= Fprogn (Fcdr (args
));
768 return unbind_to (count
, elt
);
771 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
772 "(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.\n\
773 The order of execution is thus TEST, BODY, TEST, BODY and so on\n\
774 until TEST returns nil.")
778 Lisp_Object test
, body
, tem
;
779 struct gcpro gcpro1
, gcpro2
;
785 while (tem
= Feval (test
),
786 (!EQ (Vmocklisp_arguments
, Qt
) ? XINT (tem
) : !NILP (tem
)))
796 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
797 "Return result of expanding macros at top level of FORM.\n\
798 If FORM is not a macro call, it is returned unchanged.\n\
799 Otherwise, the macro is expanded and the expansion is considered\n\
800 in place of FORM. When a non-macro-call results, it is returned.\n\n\
801 The second optional arg ENVIRONMENT species an environment of macro\n\
802 definitions to shadow the loaded ones for use in file byte-compilation.")
805 Lisp_Object environment
;
807 /* With cleanups from Hallvard Furuseth. */
808 register Lisp_Object expander
, sym
, def
, tem
;
812 /* Come back here each time we expand a macro call,
813 in case it expands into another macro call. */
816 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
817 def
= sym
= XCONS (form
)->car
;
819 /* Trace symbols aliases to other symbols
820 until we get a symbol that is not an alias. */
821 while (SYMBOLP (def
))
825 tem
= Fassq (sym
, environment
);
828 def
= XSYMBOL (sym
)->function
;
829 if (!EQ (def
, Qunbound
))
834 /* Right now TEM is the result from SYM in ENVIRONMENT,
835 and if TEM is nil then DEF is SYM's function definition. */
838 /* SYM is not mentioned in ENVIRONMENT.
839 Look at its function definition. */
840 if (EQ (def
, Qunbound
) || !CONSP (def
))
841 /* Not defined or definition not suitable */
843 if (EQ (XCONS (def
)->car
, Qautoload
))
845 /* Autoloading function: will it be a macro when loaded? */
846 tem
= Fnth (make_number (4), def
);
847 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
848 /* Yes, load it and try again. */
852 do_autoload (def
, sym
);
859 else if (!EQ (XCONS (def
)->car
, Qmacro
))
861 else expander
= XCONS (def
)->cdr
;
865 expander
= XCONS (tem
)->cdr
;
869 form
= apply1 (expander
, XCONS (form
)->cdr
);
874 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
875 "(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.\n\
876 TAG is evalled to get the tag to use. Then the BODY is executed.\n\
877 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.\n\
878 If no throw happens, `catch' returns the value of the last BODY form.\n\
879 If a throw happens, it specifies the value to return from `catch'.")
883 register Lisp_Object tag
;
887 tag
= Feval (Fcar (args
));
889 return internal_catch (tag
, Fprogn
, Fcdr (args
));
892 /* Set up a catch, then call C function FUNC on argument ARG.
893 FUNC should return a Lisp_Object.
894 This is how catches are done from within C code. */
897 internal_catch (tag
, func
, arg
)
899 Lisp_Object (*func
) ();
902 /* This structure is made part of the chain `catchlist'. */
905 /* Fill in the components of c, and put it on the list. */
909 c
.backlist
= backtrace_list
;
910 c
.handlerlist
= handlerlist
;
911 c
.lisp_eval_depth
= lisp_eval_depth
;
912 c
.pdlcount
= specpdl_ptr
- specpdl
;
913 c
.poll_suppress_count
= poll_suppress_count
;
918 if (! _setjmp (c
.jmp
))
919 c
.val
= (*func
) (arg
);
921 /* Throw works by a longjmp that comes right here. */
926 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
927 jump to that CATCH, returning VALUE as the value of that catch.
929 This is the guts Fthrow and Fsignal; they differ only in the way
930 they choose the catch tag to throw to. A catch tag for a
931 condition-case form has a TAG of Qnil.
933 Before each catch is discarded, unbind all special bindings and
934 execute all unwind-protect clauses made above that catch. Unwind
935 the handler stack as we go, so that the proper handlers are in
936 effect for each unwind-protect clause we run. At the end, restore
937 some static info saved in CATCH, and longjmp to the location
940 This is used for correct unwinding in Fthrow and Fsignal. */
943 unwind_to_catch (catch, value
)
944 struct catchtag
*catch;
947 register int last_time
;
949 /* Save the value in the tag. */
952 /* Restore the polling-suppression count. */
953 set_poll_suppress_count (catch->poll_suppress_count
);
957 last_time
= catchlist
== catch;
959 /* Unwind the specpdl stack, and then restore the proper set of
961 unbind_to (catchlist
->pdlcount
, Qnil
);
962 handlerlist
= catchlist
->handlerlist
;
963 catchlist
= catchlist
->next
;
967 gcprolist
= catch->gcpro
;
968 backtrace_list
= catch->backlist
;
969 lisp_eval_depth
= catch->lisp_eval_depth
;
971 _longjmp (catch->jmp
, 1);
974 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
975 "(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.\n\
976 Both TAG and VALUE are evalled.")
978 register Lisp_Object tag
, value
;
980 register struct catchtag
*c
;
985 for (c
= catchlist
; c
; c
= c
->next
)
987 if (EQ (c
->tag
, tag
))
988 unwind_to_catch (c
, value
);
990 tag
= Fsignal (Qno_catch
, Fcons (tag
, Fcons (value
, Qnil
)));
995 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
996 "Do BODYFORM, protecting with UNWINDFORMS.\n\
997 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).\n\
998 If BODYFORM completes normally, its value is returned\n\
999 after executing the UNWINDFORMS.\n\
1000 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.")
1005 int count
= specpdl_ptr
- specpdl
;
1007 record_unwind_protect (0, Fcdr (args
));
1008 val
= Feval (Fcar (args
));
1009 return unbind_to (count
, val
);
1012 /* Chain of condition handlers currently in effect.
1013 The elements of this chain are contained in the stack frames
1014 of Fcondition_case and internal_condition_case.
1015 When an error is signaled (by calling Fsignal, below),
1016 this chain is searched for an element that applies. */
1018 struct handler
*handlerlist
;
1020 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1021 "Regain control when an error is signaled.\n\
1022 Usage looks like (condition-case VAR BODYFORM HANDLERS...).\n\
1023 executes BODYFORM and returns its value if no error happens.\n\
1024 Each element of HANDLERS looks like (CONDITION-NAME BODY...)\n\
1025 where the BODY is made of Lisp expressions.\n\n\
1026 A handler is applicable to an error\n\
1027 if CONDITION-NAME is one of the error's condition names.\n\
1028 If an error happens, the first applicable handler is run.\n\
1030 The car of a handler may be a list of condition names\n\
1031 instead of a single condition name.\n\
1033 When a handler handles an error,\n\
1034 control returns to the condition-case and the handler BODY... is executed\n\
1035 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\
1036 VAR may be nil; then you do not get access to the signal information.\n\
1038 The value of the last BODY form is returned from the condition-case.\n\
1039 See also the function `signal' for more info.")
1046 register Lisp_Object var
, bodyform
, handlers
;
1049 bodyform
= Fcar (Fcdr (args
));
1050 handlers
= Fcdr (Fcdr (args
));
1051 CHECK_SYMBOL (var
, 0);
1053 for (val
= handlers
; ! NILP (val
); val
= Fcdr (val
))
1059 && (SYMBOLP (XCONS (tem
)->car
)
1060 || CONSP (XCONS (tem
)->car
)))))
1061 error ("Invalid condition handler", tem
);
1066 c
.backlist
= backtrace_list
;
1067 c
.handlerlist
= handlerlist
;
1068 c
.lisp_eval_depth
= lisp_eval_depth
;
1069 c
.pdlcount
= specpdl_ptr
- specpdl
;
1070 c
.poll_suppress_count
= poll_suppress_count
;
1071 c
.gcpro
= gcprolist
;
1072 if (_setjmp (c
.jmp
))
1075 specbind (h
.var
, c
.val
);
1076 val
= Fprogn (Fcdr (h
.chosen_clause
));
1078 /* Note that this just undoes the binding of h.var; whoever
1079 longjumped to us unwound the stack to c.pdlcount before
1081 unbind_to (c
.pdlcount
, Qnil
);
1088 h
.handler
= handlers
;
1089 h
.next
= handlerlist
;
1093 val
= Feval (bodyform
);
1095 handlerlist
= h
.next
;
1099 /* Call the function BFUN with no arguments, catching errors within it
1100 according to HANDLERS. If there is an error, call HFUN with
1101 one argument which is the data that describes the error:
1104 HANDLERS can be a list of conditions to catch.
1105 If HANDLERS is Qt, catch all errors.
1106 If HANDLERS is Qerror, catch all errors
1107 but allow the debugger to run if that is enabled. */
1110 internal_condition_case (bfun
, handlers
, hfun
)
1111 Lisp_Object (*bfun
) ();
1112 Lisp_Object handlers
;
1113 Lisp_Object (*hfun
) ();
1119 /* Since Fsignal resets this to 0, it had better be 0 now
1120 or else we have a potential bug. */
1121 if (interrupt_input_blocked
!= 0)
1126 c
.backlist
= backtrace_list
;
1127 c
.handlerlist
= handlerlist
;
1128 c
.lisp_eval_depth
= lisp_eval_depth
;
1129 c
.pdlcount
= specpdl_ptr
- specpdl
;
1130 c
.poll_suppress_count
= poll_suppress_count
;
1131 c
.gcpro
= gcprolist
;
1132 if (_setjmp (c
.jmp
))
1134 return (*hfun
) (c
.val
);
1138 h
.handler
= handlers
;
1140 h
.next
= handlerlist
;
1146 handlerlist
= h
.next
;
1150 /* Like internal_condition_case but call HFUN with ARG as its argument. */
1153 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1154 Lisp_Object (*bfun
) ();
1156 Lisp_Object handlers
;
1157 Lisp_Object (*hfun
) ();
1165 c
.backlist
= backtrace_list
;
1166 c
.handlerlist
= handlerlist
;
1167 c
.lisp_eval_depth
= lisp_eval_depth
;
1168 c
.pdlcount
= specpdl_ptr
- specpdl
;
1169 c
.poll_suppress_count
= poll_suppress_count
;
1170 c
.gcpro
= gcprolist
;
1171 if (_setjmp (c
.jmp
))
1173 return (*hfun
) (c
.val
);
1177 h
.handler
= handlers
;
1179 h
.next
= handlerlist
;
1183 val
= (*bfun
) (arg
);
1185 handlerlist
= h
.next
;
1189 static Lisp_Object
find_handler_clause ();
1191 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1192 "Signal an error. Args are ERROR-SYMBOL and associated DATA.\n\
1193 This function does not return.\n\n\
1194 An error symbol is a symbol with an `error-conditions' property\n\
1195 that is a list of condition names.\n\
1196 A handler for any of those names will get to handle this signal.\n\
1197 The symbol `error' should normally be one of them.\n\
1199 DATA should be a list. Its elements are printed as part of the error message.\n\
1200 If the signal is handled, DATA is made available to the handler.\n\
1201 See also the function `condition-case'.")
1202 (error_symbol
, data
)
1203 Lisp_Object error_symbol
, data
;
1205 register struct handler
*allhandlers
= handlerlist
;
1206 Lisp_Object conditions
;
1207 extern int gc_in_progress
;
1208 extern int waiting_for_input
;
1209 Lisp_Object debugger_value
;
1212 quit_error_check ();
1214 if (gc_in_progress
|| waiting_for_input
)
1217 #ifdef HAVE_WINDOW_SYSTEM
1218 TOTALLY_UNBLOCK_INPUT
;
1221 /* This hook is used by edebug. */
1222 if (! NILP (Vsignal_hook_function
))
1223 Ffuncall (Vsignal_hook_function
, error_symbol
, data
);
1225 conditions
= Fget (error_symbol
, Qerror_conditions
);
1227 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1229 register Lisp_Object clause
;
1230 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1231 error_symbol
, data
, &debugger_value
);
1233 #if 0 /* Most callers are not prepared to handle gc if this returns.
1234 So, since this feature is not very useful, take it out. */
1235 /* If have called debugger and user wants to continue,
1237 if (EQ (clause
, Qlambda
))
1238 return debugger_value
;
1240 if (EQ (clause
, Qlambda
))
1242 /* We can't return values to code which signaled an error, but we
1243 can continue code which has signaled a quit. */
1244 if (EQ (error_symbol
, Qquit
))
1247 error ("Cannot return from the debugger in an error");
1253 Lisp_Object unwind_data
;
1254 struct handler
*h
= handlerlist
;
1256 handlerlist
= allhandlers
;
1257 if (EQ (data
, memory_signal_data
))
1258 unwind_data
= memory_signal_data
;
1260 unwind_data
= Fcons (error_symbol
, data
);
1261 h
->chosen_clause
= clause
;
1262 unwind_to_catch (h
->tag
, unwind_data
);
1266 handlerlist
= allhandlers
;
1267 /* If no handler is present now, try to run the debugger,
1268 and if that fails, throw to top level. */
1269 find_handler_clause (Qerror
, conditions
, error_symbol
, data
, &debugger_value
);
1271 Fthrow (Qtop_level
, Qt
);
1273 if (! EQ (data
, memory_signal_data
))
1274 data
= Fcons (error_symbol
, data
);
1276 string
= Ferror_message_string (data
);
1277 fatal (XSTRING (string
)->data
, 0, 0);
1280 /* Return nonzero iff LIST is a non-nil atom or
1281 a list containing one of CONDITIONS. */
1284 wants_debugger (list
, conditions
)
1285 Lisp_Object list
, conditions
;
1292 while (CONSP (conditions
))
1294 Lisp_Object
this, tail
;
1295 this = XCONS (conditions
)->car
;
1296 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1297 if (EQ (XCONS (tail
)->car
, this))
1299 conditions
= XCONS (conditions
)->cdr
;
1304 /* Return 1 if an error with condition-symbols CONDITIONS,
1305 and described by SIGNAL-DATA, should skip the debugger
1306 according to debugger-ignore-errors. */
1309 skip_debugger (conditions
, data
)
1310 Lisp_Object conditions
, data
;
1313 int first_string
= 1;
1314 Lisp_Object error_message
;
1316 for (tail
= Vdebug_ignored_errors
; CONSP (tail
);
1317 tail
= XCONS (tail
)->cdr
)
1319 if (STRINGP (XCONS (tail
)->car
))
1323 error_message
= Ferror_message_string (data
);
1326 if (fast_string_match (XCONS (tail
)->car
, error_message
) >= 0)
1331 Lisp_Object contail
;
1333 for (contail
= conditions
; CONSP (contail
);
1334 contail
= XCONS (contail
)->cdr
)
1335 if (EQ (XCONS (tail
)->car
, XCONS (contail
)->car
))
1343 /* Value of Qlambda means we have called debugger and user has continued.
1344 Store value returned from debugger into *DEBUGGER_VALUE_PTR. */
1347 find_handler_clause (handlers
, conditions
, sig
, data
, debugger_value_ptr
)
1348 Lisp_Object handlers
, conditions
, sig
, data
;
1349 Lisp_Object
*debugger_value_ptr
;
1351 register Lisp_Object h
;
1352 register Lisp_Object tem
;
1354 if (EQ (handlers
, Qt
)) /* t is used by handlers for all conditions, set up by C code. */
1356 /* error is used similarly, but means print an error message
1357 and run the debugger if that is enabled. */
1358 if (EQ (handlers
, Qerror
)
1359 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1360 there is a handler. */
1362 int count
= specpdl_ptr
- specpdl
;
1363 int debugger_called
= 0;
1365 if (wants_debugger (Vstack_trace_on_error
, conditions
))
1366 internal_with_output_to_temp_buffer ("*Backtrace*", Fbacktrace
, Qnil
);
1367 if ((EQ (sig
, Qquit
)
1369 : wants_debugger (Vdebug_on_error
, conditions
))
1370 && ! skip_debugger (conditions
, Fcons (sig
, data
))
1371 && when_entered_debugger
< num_nonmacro_input_chars
)
1373 specbind (Qdebug_on_error
, Qnil
);
1375 = call_debugger (Fcons (Qerror
,
1376 Fcons (Fcons (sig
, data
),
1378 debugger_called
= 1;
1380 /* If there is no handler, return saying whether we ran the debugger. */
1381 if (EQ (handlers
, Qerror
))
1383 if (debugger_called
)
1384 return unbind_to (count
, Qlambda
);
1388 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1390 Lisp_Object handler
, condit
;
1393 if (!CONSP (handler
))
1395 condit
= Fcar (handler
);
1396 /* Handle a single condition name in handler HANDLER. */
1397 if (SYMBOLP (condit
))
1399 tem
= Fmemq (Fcar (handler
), conditions
);
1403 /* Handle a list of condition names in handler HANDLER. */
1404 else if (CONSP (condit
))
1406 while (CONSP (condit
))
1408 tem
= Fmemq (Fcar (condit
), conditions
);
1411 condit
= XCONS (condit
)->cdr
;
1418 /* dump an error message; called like printf */
1422 error (m
, a1
, a2
, a3
)
1442 int used
= doprnt (buf
, size
, m
, m
+ mlen
, 3, args
);
1447 buffer
= (char *) xrealloc (buffer
, size
);
1450 buffer
= (char *) xmalloc (size
);
1455 string
= build_string (buf
);
1459 Fsignal (Qerror
, Fcons (string
, Qnil
));
1462 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 1, 0,
1463 "T if FUNCTION makes provisions for interactive calling.\n\
1464 This means it contains a description for how to read arguments to give it.\n\
1465 The value is nil for an invalid function or a symbol with no function\n\
1468 Interactively callable functions include strings and vectors (treated\n\
1469 as keyboard macros), lambda-expressions that contain a top-level call\n\
1470 to `interactive', autoload definitions made by `autoload' with non-nil\n\
1471 fourth argument, and some of the built-in functions of Lisp.\n\
1473 Also, a symbol satisfies `commandp' if its function definition does so.")
1475 Lisp_Object function
;
1477 register Lisp_Object fun
;
1478 register Lisp_Object funcar
;
1479 register Lisp_Object tem
;
1484 fun
= indirect_function (fun
);
1485 if (EQ (fun
, Qunbound
))
1488 /* Emacs primitives are interactive if their DEFUN specifies an
1489 interactive spec. */
1492 if (XSUBR (fun
)->prompt
)
1498 /* Bytecode objects are interactive if they are long enough to
1499 have an element whose index is COMPILED_INTERACTIVE, which is
1500 where the interactive spec is stored. */
1501 else if (COMPILEDP (fun
))
1502 return ((XVECTOR (fun
)->size
& PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
1505 /* Strings and vectors are keyboard macros. */
1506 if (STRINGP (fun
) || VECTORP (fun
))
1509 /* Lists may represent commands. */
1512 funcar
= Fcar (fun
);
1513 if (!SYMBOLP (funcar
))
1514 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1515 if (EQ (funcar
, Qlambda
))
1516 return Fassq (Qinteractive
, Fcdr (Fcdr (fun
)));
1517 if (EQ (funcar
, Qmocklisp
))
1518 return Qt
; /* All mocklisp functions can be called interactively */
1519 if (EQ (funcar
, Qautoload
))
1520 return Fcar (Fcdr (Fcdr (Fcdr (fun
))));
1526 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1527 "Define FUNCTION to autoload from FILE.\n\
1528 FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\
1529 Third arg DOCSTRING is documentation for the function.\n\
1530 Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\
1531 Fifth arg TYPE indicates the type of the object:\n\
1532 nil or omitted says FUNCTION is a function,\n\
1533 `keymap' says FUNCTION is really a keymap, and\n\
1534 `macro' or t says FUNCTION is really a macro.\n\
1535 Third through fifth args give info about the real definition.\n\
1536 They default to nil.\n\
1537 If FUNCTION is already defined other than as an autoload,\n\
1538 this does nothing and returns nil.")
1539 (function
, file
, docstring
, interactive
, type
)
1540 Lisp_Object function
, file
, docstring
, interactive
, type
;
1543 Lisp_Object args
[4];
1546 CHECK_SYMBOL (function
, 0);
1547 CHECK_STRING (file
, 1);
1549 /* If function is defined and not as an autoload, don't override */
1550 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
1551 && !(CONSP (XSYMBOL (function
)->function
)
1552 && EQ (XCONS (XSYMBOL (function
)->function
)->car
, Qautoload
)))
1557 args
[1] = docstring
;
1558 args
[2] = interactive
;
1561 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
1562 #else /* NO_ARG_ARRAY */
1563 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
1564 #endif /* not NO_ARG_ARRAY */
1568 un_autoload (oldqueue
)
1569 Lisp_Object oldqueue
;
1571 register Lisp_Object queue
, first
, second
;
1573 /* Queue to unwind is current value of Vautoload_queue.
1574 oldqueue is the shadowed value to leave in Vautoload_queue. */
1575 queue
= Vautoload_queue
;
1576 Vautoload_queue
= oldqueue
;
1577 while (CONSP (queue
))
1579 first
= Fcar (queue
);
1580 second
= Fcdr (first
);
1581 first
= Fcar (first
);
1582 if (EQ (second
, Qnil
))
1585 Ffset (first
, second
);
1586 queue
= Fcdr (queue
);
1591 /* Load an autoloaded function.
1592 FUNNAME is the symbol which is the function's name.
1593 FUNDEF is the autoload definition (a list). */
1595 do_autoload (fundef
, funname
)
1596 Lisp_Object fundef
, funname
;
1598 int count
= specpdl_ptr
- specpdl
;
1599 Lisp_Object fun
, val
, queue
, first
, second
;
1600 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1603 CHECK_SYMBOL (funname
, 0);
1604 GCPRO3 (fun
, funname
, fundef
);
1606 /* Value saved here is to be restored into Vautoload_queue */
1607 record_unwind_protect (un_autoload
, Vautoload_queue
);
1608 Vautoload_queue
= Qt
;
1609 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
);
1611 /* Save the old autoloads, in case we ever do an unload. */
1612 queue
= Vautoload_queue
;
1613 while (CONSP (queue
))
1615 first
= Fcar (queue
);
1616 second
= Fcdr (first
);
1617 first
= Fcar (first
);
1619 /* Note: This test is subtle. The cdr of an autoload-queue entry
1620 may be an atom if the autoload entry was generated by a defalias
1623 Fput (first
, Qautoload
, (Fcdr (second
)));
1625 queue
= Fcdr (queue
);
1628 /* Once loading finishes, don't undo it. */
1629 Vautoload_queue
= Qt
;
1630 unbind_to (count
, Qnil
);
1632 fun
= Findirect_function (fun
);
1634 if (!NILP (Fequal (fun
, fundef
)))
1635 error ("Autoloading failed to define function %s",
1636 XSYMBOL (funname
)->name
->data
);
1640 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
1641 "Evaluate FORM and return its value.")
1645 Lisp_Object fun
, val
, original_fun
, original_args
;
1647 struct backtrace backtrace
;
1648 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1652 if (EQ (Vmocklisp_arguments
, Qt
))
1653 return Fsymbol_value (form
);
1654 val
= Fsymbol_value (form
);
1656 XSETFASTINT (val
, 0);
1657 else if (EQ (val
, Qt
))
1658 XSETFASTINT (val
, 1);
1665 if (consing_since_gc
> gc_cons_threshold
)
1668 Fgarbage_collect ();
1672 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1674 if (max_lisp_eval_depth
< 100)
1675 max_lisp_eval_depth
= 100;
1676 if (lisp_eval_depth
> max_lisp_eval_depth
)
1677 error ("Lisp nesting exceeds max-lisp-eval-depth");
1680 original_fun
= Fcar (form
);
1681 original_args
= Fcdr (form
);
1683 backtrace
.next
= backtrace_list
;
1684 backtrace_list
= &backtrace
;
1685 backtrace
.function
= &original_fun
; /* This also protects them from gc */
1686 backtrace
.args
= &original_args
;
1687 backtrace
.nargs
= UNEVALLED
;
1688 backtrace
.evalargs
= 1;
1689 backtrace
.debug_on_exit
= 0;
1691 if (debug_on_next_call
)
1692 do_debug_on_call (Qt
);
1694 /* At this point, only original_fun and original_args
1695 have values that will be used below */
1697 fun
= Findirect_function (original_fun
);
1701 Lisp_Object numargs
;
1702 Lisp_Object argvals
[7];
1703 Lisp_Object args_left
;
1704 register int i
, maxargs
;
1706 args_left
= original_args
;
1707 numargs
= Flength (args_left
);
1709 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
1710 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
1711 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1713 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1715 backtrace
.evalargs
= 0;
1716 val
= (*XSUBR (fun
)->function
) (args_left
);
1720 if (XSUBR (fun
)->max_args
== MANY
)
1722 /* Pass a vector of evaluated arguments */
1724 register int argnum
= 0;
1726 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1728 GCPRO3 (args_left
, fun
, fun
);
1732 while (!NILP (args_left
))
1734 vals
[argnum
++] = Feval (Fcar (args_left
));
1735 args_left
= Fcdr (args_left
);
1736 gcpro3
.nvars
= argnum
;
1739 backtrace
.args
= vals
;
1740 backtrace
.nargs
= XINT (numargs
);
1742 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
1747 GCPRO3 (args_left
, fun
, fun
);
1748 gcpro3
.var
= argvals
;
1751 maxargs
= XSUBR (fun
)->max_args
;
1752 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
1754 argvals
[i
] = Feval (Fcar (args_left
));
1760 backtrace
.args
= argvals
;
1761 backtrace
.nargs
= XINT (numargs
);
1766 val
= (*XSUBR (fun
)->function
) ();
1769 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
1772 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
1775 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1779 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1780 argvals
[2], argvals
[3]);
1783 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1784 argvals
[3], argvals
[4]);
1787 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1788 argvals
[3], argvals
[4], argvals
[5]);
1791 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1792 argvals
[3], argvals
[4], argvals
[5],
1797 /* Someone has created a subr that takes more arguments than
1798 is supported by this code. We need to either rewrite the
1799 subr to use a different argument protocol, or add more
1800 cases to this switch. */
1804 if (COMPILEDP (fun
))
1805 val
= apply_lambda (fun
, original_args
, 1);
1809 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1810 funcar
= Fcar (fun
);
1811 if (!SYMBOLP (funcar
))
1812 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1813 if (EQ (funcar
, Qautoload
))
1815 do_autoload (fun
, original_fun
);
1818 if (EQ (funcar
, Qmacro
))
1819 val
= Feval (apply1 (Fcdr (fun
), original_args
));
1820 else if (EQ (funcar
, Qlambda
))
1821 val
= apply_lambda (fun
, original_args
, 1);
1822 else if (EQ (funcar
, Qmocklisp
))
1823 val
= ml_apply (fun
, original_args
);
1825 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1828 if (!EQ (Vmocklisp_arguments
, Qt
))
1831 XSETFASTINT (val
, 0);
1832 else if (EQ (val
, Qt
))
1833 XSETFASTINT (val
, 1);
1836 if (backtrace
.debug_on_exit
)
1837 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
1838 backtrace_list
= backtrace
.next
;
1842 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
1843 "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
1844 Then return the value FUNCTION returns.\n\
1845 Thus, (apply '+ 1 2 '(3 4)) returns 10.")
1850 register int i
, numargs
;
1851 register Lisp_Object spread_arg
;
1852 register Lisp_Object
*funcall_args
;
1854 struct gcpro gcpro1
;
1858 spread_arg
= args
[nargs
- 1];
1859 CHECK_LIST (spread_arg
, nargs
);
1861 numargs
= XINT (Flength (spread_arg
));
1864 return Ffuncall (nargs
- 1, args
);
1865 else if (numargs
== 1)
1867 args
[nargs
- 1] = XCONS (spread_arg
)->car
;
1868 return Ffuncall (nargs
, args
);
1871 numargs
+= nargs
- 2;
1873 fun
= indirect_function (fun
);
1874 if (EQ (fun
, Qunbound
))
1876 /* Let funcall get the error */
1883 if (numargs
< XSUBR (fun
)->min_args
1884 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
1885 goto funcall
; /* Let funcall get the error */
1886 else if (XSUBR (fun
)->max_args
> numargs
)
1888 /* Avoid making funcall cons up a yet another new vector of arguments
1889 by explicitly supplying nil's for optional values */
1890 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
1891 * sizeof (Lisp_Object
));
1892 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
1893 funcall_args
[++i
] = Qnil
;
1894 GCPRO1 (*funcall_args
);
1895 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
1899 /* We add 1 to numargs because funcall_args includes the
1900 function itself as well as its arguments. */
1903 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
1904 * sizeof (Lisp_Object
));
1905 GCPRO1 (*funcall_args
);
1906 gcpro1
.nvars
= 1 + numargs
;
1909 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
1910 /* Spread the last arg we got. Its first element goes in
1911 the slot that it used to occupy, hence this value of I. */
1913 while (!NILP (spread_arg
))
1915 funcall_args
[i
++] = XCONS (spread_arg
)->car
;
1916 spread_arg
= XCONS (spread_arg
)->cdr
;
1919 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
1922 /* Run hook variables in various ways. */
1924 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
1926 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 1, MANY
, 0,
1927 "Run each hook in HOOKS. Major mode functions use this.\n\
1928 Each argument should be a symbol, a hook variable.\n\
1929 These symbols are processed in the order specified.\n\
1930 If a hook symbol has a non-nil value, that value may be a function\n\
1931 or a list of functions to be called to run the hook.\n\
1932 If the value is a function, it is called with no arguments.\n\
1933 If it is a list, the elements are called, in order, with no arguments.\n\
1935 To make a hook variable buffer-local, use `make-local-hook',\n\
1936 not `make-local-variable'.")
1941 Lisp_Object hook
[1];
1944 for (i
= 0; i
< nargs
; i
++)
1947 run_hook_with_args (1, hook
, to_completion
);
1953 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
1954 Srun_hook_with_args
, 1, MANY
, 0,
1955 "Run HOOK with the specified arguments ARGS.\n\
1956 HOOK should be a symbol, a hook variable. If HOOK has a non-nil\n\
1957 value, that value may be a function or a list of functions to be\n\
1958 called to run the hook. If the value is a function, it is called with\n\
1959 the given arguments and its return value is returned. If it is a list\n\
1960 of functions, those functions are called, in order,\n\
1961 with the given arguments ARGS.\n\
1962 It is best not to depend on the value return by `run-hook-with-args',\n\
1963 as that may change.\n\
1965 To make a hook variable buffer-local, use `make-local-hook',\n\
1966 not `make-local-variable'.")
1971 return run_hook_with_args (nargs
, args
, to_completion
);
1974 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
1975 Srun_hook_with_args_until_success
, 1, MANY
, 0,
1976 "Run HOOK with the specified arguments ARGS.\n\
1977 HOOK should be a symbol, a hook variable. Its value should\n\
1978 be a list of functions. We call those functions, one by one,\n\
1979 passing arguments ARGS to each of them, until one of them\n\
1980 returns a non-nil value. Then we return that value.\n\
1981 If all the functions return nil, we return nil.\n\
1983 To make a hook variable buffer-local, use `make-local-hook',\n\
1984 not `make-local-variable'.")
1989 return run_hook_with_args (nargs
, args
, until_success
);
1992 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
1993 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
1994 "Run HOOK with the specified arguments ARGS.\n\
1995 HOOK should be a symbol, a hook variable. Its value should\n\
1996 be a list of functions. We call those functions, one by one,\n\
1997 passing arguments ARGS to each of them, until one of them\n\
1998 returns nil. Then we return nil.\n\
1999 If all the functions return non-nil, we return non-nil.\n\
2001 To make a hook variable buffer-local, use `make-local-hook',\n\
2002 not `make-local-variable'.")
2007 return run_hook_with_args (nargs
, args
, until_failure
);
2010 /* ARGS[0] should be a hook symbol.
2011 Call each of the functions in the hook value, passing each of them
2012 as arguments all the rest of ARGS (all NARGS - 1 elements).
2013 COND specifies a condition to test after each call
2014 to decide whether to stop.
2015 The caller (or its caller, etc) must gcpro all of ARGS,
2016 except that it isn't necessary to gcpro ARGS[0]. */
2019 run_hook_with_args (nargs
, args
, cond
)
2022 enum run_hooks_condition cond
;
2024 Lisp_Object sym
, val
, ret
;
2025 struct gcpro gcpro1
, gcpro2
;
2027 /* If we are dying or still initializing,
2028 don't do anything--it would probably crash if we tried. */
2029 if (NILP (Vrun_hooks
))
2033 val
= find_symbol_value (sym
);
2034 ret
= (cond
== until_failure
? Qt
: Qnil
);
2036 if (EQ (val
, Qunbound
) || NILP (val
))
2038 else if (!CONSP (val
) || EQ (XCONS (val
)->car
, Qlambda
))
2041 return Ffuncall (nargs
, args
);
2048 CONSP (val
) && ((cond
== to_completion
)
2049 || (cond
== until_success
? NILP (ret
)
2051 val
= XCONS (val
)->cdr
)
2053 if (EQ (XCONS (val
)->car
, Qt
))
2055 /* t indicates this hook has a local binding;
2056 it means to run the global binding too. */
2057 Lisp_Object globals
;
2059 for (globals
= Fdefault_value (sym
);
2060 CONSP (globals
) && ((cond
== to_completion
)
2061 || (cond
== until_success
? NILP (ret
)
2063 globals
= XCONS (globals
)->cdr
)
2065 args
[0] = XCONS (globals
)->car
;
2066 /* In a global value, t should not occur. If it does, we
2067 must ignore it to avoid an endless loop. */
2068 if (!EQ (args
[0], Qt
))
2069 ret
= Ffuncall (nargs
, args
);
2074 args
[0] = XCONS (val
)->car
;
2075 ret
= Ffuncall (nargs
, args
);
2084 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2085 present value of that symbol.
2086 Call each element of FUNLIST,
2087 passing each of them the rest of ARGS.
2088 The caller (or its caller, etc) must gcpro all of ARGS,
2089 except that it isn't necessary to gcpro ARGS[0]. */
2092 run_hook_list_with_args (funlist
, nargs
, args
)
2093 Lisp_Object funlist
;
2099 struct gcpro gcpro1
, gcpro2
;
2104 for (val
= funlist
; CONSP (val
); val
= XCONS (val
)->cdr
)
2106 if (EQ (XCONS (val
)->car
, Qt
))
2108 /* t indicates this hook has a local binding;
2109 it means to run the global binding too. */
2110 Lisp_Object globals
;
2112 for (globals
= Fdefault_value (sym
);
2114 globals
= XCONS (globals
)->cdr
)
2116 args
[0] = XCONS (globals
)->car
;
2117 /* In a global value, t should not occur. If it does, we
2118 must ignore it to avoid an endless loop. */
2119 if (!EQ (args
[0], Qt
))
2120 Ffuncall (nargs
, args
);
2125 args
[0] = XCONS (val
)->car
;
2126 Ffuncall (nargs
, args
);
2133 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2136 run_hook_with_args_2 (hook
, arg1
, arg2
)
2137 Lisp_Object hook
, arg1
, arg2
;
2139 Lisp_Object temp
[3];
2144 Frun_hook_with_args (3, temp
);
2147 /* Apply fn to arg */
2150 Lisp_Object fn
, arg
;
2152 struct gcpro gcpro1
;
2156 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2160 Lisp_Object args
[2];
2164 RETURN_UNGCPRO (Fapply (2, args
));
2166 #else /* not NO_ARG_ARRAY */
2167 RETURN_UNGCPRO (Fapply (2, &fn
));
2168 #endif /* not NO_ARG_ARRAY */
2171 /* Call function fn on no arguments */
2176 struct gcpro gcpro1
;
2179 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2182 /* Call function fn with 1 argument arg1 */
2186 Lisp_Object fn
, arg1
;
2188 struct gcpro gcpro1
;
2190 Lisp_Object args
[2];
2196 RETURN_UNGCPRO (Ffuncall (2, args
));
2197 #else /* not NO_ARG_ARRAY */
2200 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2201 #endif /* not NO_ARG_ARRAY */
2204 /* Call function fn with 2 arguments arg1, arg2 */
2207 call2 (fn
, arg1
, arg2
)
2208 Lisp_Object fn
, arg1
, arg2
;
2210 struct gcpro gcpro1
;
2212 Lisp_Object args
[3];
2218 RETURN_UNGCPRO (Ffuncall (3, args
));
2219 #else /* not NO_ARG_ARRAY */
2222 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2223 #endif /* not NO_ARG_ARRAY */
2226 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2229 call3 (fn
, arg1
, arg2
, arg3
)
2230 Lisp_Object fn
, arg1
, arg2
, arg3
;
2232 struct gcpro gcpro1
;
2234 Lisp_Object args
[4];
2241 RETURN_UNGCPRO (Ffuncall (4, args
));
2242 #else /* not NO_ARG_ARRAY */
2245 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2246 #endif /* not NO_ARG_ARRAY */
2249 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2252 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2253 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2255 struct gcpro gcpro1
;
2257 Lisp_Object args
[5];
2265 RETURN_UNGCPRO (Ffuncall (5, args
));
2266 #else /* not NO_ARG_ARRAY */
2269 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2270 #endif /* not NO_ARG_ARRAY */
2273 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2276 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2277 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2279 struct gcpro gcpro1
;
2281 Lisp_Object args
[6];
2290 RETURN_UNGCPRO (Ffuncall (6, args
));
2291 #else /* not NO_ARG_ARRAY */
2294 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2295 #endif /* not NO_ARG_ARRAY */
2298 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2301 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2302 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2304 struct gcpro gcpro1
;
2306 Lisp_Object args
[7];
2316 RETURN_UNGCPRO (Ffuncall (7, args
));
2317 #else /* not NO_ARG_ARRAY */
2320 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2321 #endif /* not NO_ARG_ARRAY */
2324 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2325 "Call first argument as a function, passing remaining arguments to it.\n\
2326 Return the value that function returns.\n\
2327 Thus, (funcall 'cons 'x 'y) returns (x . y).")
2334 int numargs
= nargs
- 1;
2335 Lisp_Object lisp_numargs
;
2337 struct backtrace backtrace
;
2338 register Lisp_Object
*internal_args
;
2342 if (consing_since_gc
> gc_cons_threshold
)
2343 Fgarbage_collect ();
2345 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2347 if (max_lisp_eval_depth
< 100)
2348 max_lisp_eval_depth
= 100;
2349 if (lisp_eval_depth
> max_lisp_eval_depth
)
2350 error ("Lisp nesting exceeds max-lisp-eval-depth");
2353 backtrace
.next
= backtrace_list
;
2354 backtrace_list
= &backtrace
;
2355 backtrace
.function
= &args
[0];
2356 backtrace
.args
= &args
[1];
2357 backtrace
.nargs
= nargs
- 1;
2358 backtrace
.evalargs
= 0;
2359 backtrace
.debug_on_exit
= 0;
2361 if (debug_on_next_call
)
2362 do_debug_on_call (Qlambda
);
2368 fun
= Findirect_function (fun
);
2372 if (numargs
< XSUBR (fun
)->min_args
2373 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2375 XSETFASTINT (lisp_numargs
, numargs
);
2376 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (lisp_numargs
, Qnil
)));
2379 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2380 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2382 if (XSUBR (fun
)->max_args
== MANY
)
2384 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
2388 if (XSUBR (fun
)->max_args
> numargs
)
2390 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2391 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
2392 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2393 internal_args
[i
] = Qnil
;
2396 internal_args
= args
+ 1;
2397 switch (XSUBR (fun
)->max_args
)
2400 val
= (*XSUBR (fun
)->function
) ();
2403 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
2406 val
= (*XSUBR (fun
)->function
) (internal_args
[0],
2410 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2414 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2419 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2420 internal_args
[2], internal_args
[3],
2424 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2425 internal_args
[2], internal_args
[3],
2426 internal_args
[4], internal_args
[5]);
2429 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2430 internal_args
[2], internal_args
[3],
2431 internal_args
[4], internal_args
[5],
2437 /* If a subr takes more than 6 arguments without using MANY
2438 or UNEVALLED, we need to extend this function to support it.
2439 Until this is done, there is no way to call the function. */
2443 if (COMPILEDP (fun
))
2444 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2448 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2449 funcar
= Fcar (fun
);
2450 if (!SYMBOLP (funcar
))
2451 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2452 if (EQ (funcar
, Qlambda
))
2453 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2454 else if (EQ (funcar
, Qmocklisp
))
2455 val
= ml_apply (fun
, Flist (numargs
, args
+ 1));
2456 else if (EQ (funcar
, Qautoload
))
2458 do_autoload (fun
, args
[0]);
2462 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2466 if (backtrace
.debug_on_exit
)
2467 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2468 backtrace_list
= backtrace
.next
;
2473 apply_lambda (fun
, args
, eval_flag
)
2474 Lisp_Object fun
, args
;
2477 Lisp_Object args_left
;
2478 Lisp_Object numargs
;
2479 register Lisp_Object
*arg_vector
;
2480 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2482 register Lisp_Object tem
;
2484 numargs
= Flength (args
);
2485 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2488 GCPRO3 (*arg_vector
, args_left
, fun
);
2491 for (i
= 0; i
< XINT (numargs
);)
2493 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2494 if (eval_flag
) tem
= Feval (tem
);
2495 arg_vector
[i
++] = tem
;
2503 backtrace_list
->args
= arg_vector
;
2504 backtrace_list
->nargs
= i
;
2506 backtrace_list
->evalargs
= 0;
2507 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
2509 /* Do the debug-on-exit now, while arg_vector still exists. */
2510 if (backtrace_list
->debug_on_exit
)
2511 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
2512 /* Don't do it again when we return to eval. */
2513 backtrace_list
->debug_on_exit
= 0;
2517 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2518 and return the result of evaluation.
2519 FUN must be either a lambda-expression or a compiled-code object. */
2522 funcall_lambda (fun
, nargs
, arg_vector
)
2525 register Lisp_Object
*arg_vector
;
2527 Lisp_Object val
, tem
;
2528 register Lisp_Object syms_left
;
2529 Lisp_Object numargs
;
2530 register Lisp_Object next
;
2531 int count
= specpdl_ptr
- specpdl
;
2533 int optional
= 0, rest
= 0;
2535 specbind (Qmocklisp_arguments
, Qt
); /* t means NOT mocklisp! */
2537 XSETFASTINT (numargs
, nargs
);
2540 syms_left
= Fcar (Fcdr (fun
));
2541 else if (COMPILEDP (fun
))
2542 syms_left
= XVECTOR (fun
)->contents
[COMPILED_ARGLIST
];
2546 for (; !NILP (syms_left
); syms_left
= Fcdr (syms_left
))
2549 next
= Fcar (syms_left
);
2550 while (!SYMBOLP (next
))
2551 next
= Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2552 if (EQ (next
, Qand_rest
))
2554 else if (EQ (next
, Qand_optional
))
2558 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
2563 tem
= arg_vector
[i
++];
2564 specbind (next
, tem
);
2567 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2569 specbind (next
, Qnil
);
2573 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2576 val
= Fprogn (Fcdr (Fcdr (fun
)));
2579 /* If we have not actually read the bytecode string
2580 and constants vector yet, fetch them from the file. */
2581 if (CONSP (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
]))
2582 Ffetch_bytecode (fun
);
2583 val
= Fbyte_code (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
],
2584 XVECTOR (fun
)->contents
[COMPILED_CONSTANTS
],
2585 XVECTOR (fun
)->contents
[COMPILED_STACK_DEPTH
]);
2587 return unbind_to (count
, val
);
2590 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
2592 "If byte-compiled OBJECT is lazy-loaded, fetch it now.")
2598 if (COMPILEDP (object
)
2599 && CONSP (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]))
2601 tem
= read_doc_string (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]);
2603 error ("invalid byte code");
2604 XVECTOR (object
)->contents
[COMPILED_BYTECODE
] = XCONS (tem
)->car
;
2605 XVECTOR (object
)->contents
[COMPILED_CONSTANTS
] = XCONS (tem
)->cdr
;
2613 register int count
= specpdl_ptr
- specpdl
;
2614 if (specpdl_size
>= max_specpdl_size
)
2616 if (max_specpdl_size
< 400)
2617 max_specpdl_size
= 400;
2618 if (specpdl_size
>= max_specpdl_size
)
2620 if (!NILP (Vdebug_on_error
))
2621 /* Leave room for some specpdl in the debugger. */
2622 max_specpdl_size
= specpdl_size
+ 100;
2624 Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil
));
2628 if (specpdl_size
> max_specpdl_size
)
2629 specpdl_size
= max_specpdl_size
;
2630 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
2631 specpdl_ptr
= specpdl
+ count
;
2635 specbind (symbol
, value
)
2636 Lisp_Object symbol
, value
;
2640 CHECK_SYMBOL (symbol
, 0);
2642 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2644 specpdl_ptr
->symbol
= symbol
;
2645 specpdl_ptr
->func
= 0;
2646 specpdl_ptr
->old_value
= ovalue
= find_symbol_value (symbol
);
2648 if (BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
))
2649 store_symval_forwarding (symbol
, ovalue
, value
);
2651 set_internal (symbol
, value
, 1);
2655 record_unwind_protect (function
, arg
)
2656 Lisp_Object (*function
)();
2659 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2661 specpdl_ptr
->func
= function
;
2662 specpdl_ptr
->symbol
= Qnil
;
2663 specpdl_ptr
->old_value
= arg
;
2668 unbind_to (count
, value
)
2672 int quitf
= !NILP (Vquit_flag
);
2673 struct gcpro gcpro1
;
2679 while (specpdl_ptr
!= specpdl
+ count
)
2682 if (specpdl_ptr
->func
!= 0)
2683 (*specpdl_ptr
->func
) (specpdl_ptr
->old_value
);
2684 /* Note that a "binding" of nil is really an unwind protect,
2685 so in that case the "old value" is a list of forms to evaluate. */
2686 else if (NILP (specpdl_ptr
->symbol
))
2687 Fprogn (specpdl_ptr
->old_value
);
2689 set_internal (specpdl_ptr
->symbol
, specpdl_ptr
->old_value
, 1);
2691 if (NILP (Vquit_flag
) && quitf
) Vquit_flag
= Qt
;
2700 /* Get the value of symbol's global binding, even if that binding
2701 is not now dynamically visible. */
2704 top_level_value (symbol
)
2707 register struct specbinding
*ptr
= specpdl
;
2709 CHECK_SYMBOL (symbol
, 0);
2710 for (; ptr
!= specpdl_ptr
; ptr
++)
2712 if (EQ (ptr
->symbol
, symbol
))
2713 return ptr
->old_value
;
2715 return Fsymbol_value (symbol
);
2719 top_level_set (symbol
, newval
)
2720 Lisp_Object symbol
, newval
;
2722 register struct specbinding
*ptr
= specpdl
;
2724 CHECK_SYMBOL (symbol
, 0);
2725 for (; ptr
!= specpdl_ptr
; ptr
++)
2727 if (EQ (ptr
->symbol
, symbol
))
2729 ptr
->old_value
= newval
;
2733 return Fset (symbol
, newval
);
2738 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
2739 "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\
2740 The debugger is entered when that frame exits, if the flag is non-nil.")
2742 Lisp_Object level
, flag
;
2744 register struct backtrace
*backlist
= backtrace_list
;
2747 CHECK_NUMBER (level
, 0);
2749 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
2751 backlist
= backlist
->next
;
2755 backlist
->debug_on_exit
= !NILP (flag
);
2760 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
2761 "Print a trace of Lisp function calls currently active.\n\
2762 Output stream used is value of `standard-output'.")
2765 register struct backtrace
*backlist
= backtrace_list
;
2769 extern Lisp_Object Vprint_level
;
2770 struct gcpro gcpro1
;
2772 XSETFASTINT (Vprint_level
, 3);
2779 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
2780 if (backlist
->nargs
== UNEVALLED
)
2782 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
2783 write_string ("\n", -1);
2787 tem
= *backlist
->function
;
2788 Fprin1 (tem
, Qnil
); /* This can QUIT */
2789 write_string ("(", -1);
2790 if (backlist
->nargs
== MANY
)
2792 for (tail
= *backlist
->args
, i
= 0;
2794 tail
= Fcdr (tail
), i
++)
2796 if (i
) write_string (" ", -1);
2797 Fprin1 (Fcar (tail
), Qnil
);
2802 for (i
= 0; i
< backlist
->nargs
; i
++)
2804 if (i
) write_string (" ", -1);
2805 Fprin1 (backlist
->args
[i
], Qnil
);
2808 write_string (")\n", -1);
2810 backlist
= backlist
->next
;
2813 Vprint_level
= Qnil
;
2818 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, "",
2819 "Return the function and arguments NFRAMES up from current execution point.\n\
2820 If that frame has not evaluated the arguments yet (or is a special form),\n\
2821 the value is (nil FUNCTION ARG-FORMS...).\n\
2822 If that frame has evaluated its arguments and called its function already,\n\
2823 the value is (t FUNCTION ARG-VALUES...).\n\
2824 A &rest arg is represented as the tail of the list ARG-VALUES.\n\
2825 FUNCTION is whatever was supplied as car of evaluated list,\n\
2826 or a lambda expression for macro calls.\n\
2827 If NFRAMES is more than the number of frames, the value is nil.")
2829 Lisp_Object nframes
;
2831 register struct backtrace
*backlist
= backtrace_list
;
2835 CHECK_NATNUM (nframes
, 0);
2837 /* Find the frame requested. */
2838 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
2839 backlist
= backlist
->next
;
2843 if (backlist
->nargs
== UNEVALLED
)
2844 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
2847 if (backlist
->nargs
== MANY
)
2848 tem
= *backlist
->args
;
2850 tem
= Flist (backlist
->nargs
, backlist
->args
);
2852 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
2858 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
2859 "Limit on number of Lisp variable bindings & unwind-protects before error.");
2861 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
2862 "Limit on depth in `eval', `apply' and `funcall' before error.\n\
2863 This limit is to catch infinite recursions for you before they cause\n\
2864 actual stack overflow in C, which would be fatal for Emacs.\n\
2865 You can safely make it considerably larger than its default value,\n\
2866 if that proves inconveniently small.");
2868 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
2869 "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
2870 Typing C-g sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
2873 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
2874 "Non-nil inhibits C-g quitting from happening immediately.\n\
2875 Note that `quit-flag' will still be set by typing C-g,\n\
2876 so a quit will be signaled as soon as `inhibit-quit' is nil.\n\
2877 To prevent this happening, set `quit-flag' to nil\n\
2878 before making `inhibit-quit' nil.");
2879 Vinhibit_quit
= Qnil
;
2881 Qinhibit_quit
= intern ("inhibit-quit");
2882 staticpro (&Qinhibit_quit
);
2884 Qautoload
= intern ("autoload");
2885 staticpro (&Qautoload
);
2887 Qdebug_on_error
= intern ("debug-on-error");
2888 staticpro (&Qdebug_on_error
);
2890 Qmacro
= intern ("macro");
2891 staticpro (&Qmacro
);
2893 /* Note that the process handling also uses Qexit, but we don't want
2894 to staticpro it twice, so we just do it here. */
2895 Qexit
= intern ("exit");
2898 Qinteractive
= intern ("interactive");
2899 staticpro (&Qinteractive
);
2901 Qcommandp
= intern ("commandp");
2902 staticpro (&Qcommandp
);
2904 Qdefun
= intern ("defun");
2905 staticpro (&Qdefun
);
2907 Qand_rest
= intern ("&rest");
2908 staticpro (&Qand_rest
);
2910 Qand_optional
= intern ("&optional");
2911 staticpro (&Qand_optional
);
2913 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
2914 "*Non-nil means automatically display a backtrace buffer\n\
2915 after any error that is handled by the editor command loop.\n\
2916 If the value is a list, an error only means to display a backtrace\n\
2917 if one of its condition symbols appears in the list.");
2918 Vstack_trace_on_error
= Qnil
;
2920 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
2921 "*Non-nil means enter debugger if an error is signaled.\n\
2922 Does not apply to errors handled by `condition-case'.\n\
2923 If the value is a list, an error only means to enter the debugger\n\
2924 if one of its condition symbols appears in the list.\n\
2925 See also variable `debug-on-quit'.");
2926 Vdebug_on_error
= Qnil
;
2928 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
2929 "*List of errors for which the debugger should not be called.\n\
2930 Each element may be a condition-name or a regexp that matches error messages.\n\
2931 If any element applies to a given error, that error skips the debugger\n\
2932 and just returns to top level.\n\
2933 This overrides the variable `debug-on-error'.\n\
2934 It does not apply to errors handled by `condition-case'.");
2935 Vdebug_ignored_errors
= Qnil
;
2937 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
2938 "*Non-nil means enter debugger if quit is signaled (C-g, for example).\n\
2939 Does not apply if quit is handled by a `condition-case'.");
2942 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
2943 "Non-nil means enter debugger before next `eval', `apply' or `funcall'.");
2945 DEFVAR_LISP ("debugger", &Vdebugger
,
2946 "Function to call to invoke debugger.\n\
2947 If due to frame exit, args are `exit' and the value being returned;\n\
2948 this function's value will be returned instead of that.\n\
2949 If due to error, args are `error' and a list of the args to `signal'.\n\
2950 If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
2951 If due to `eval' entry, one arg, t.");
2954 DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function
,
2955 "If non-nil, this is a function for `signal' to call.\n\
2956 It receives the same arguments that `signal' was given.\n\
2957 The Edebug package uses this to regain control.");
2958 Vsignal_hook_function
= Qnil
;
2960 Qmocklisp_arguments
= intern ("mocklisp-arguments");
2961 staticpro (&Qmocklisp_arguments
);
2962 DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments
,
2963 "While in a mocklisp function, the list of its unevaluated args.");
2964 Vmocklisp_arguments
= Qt
;
2966 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal
,
2967 "*Non-nil means call the debugger regardless of condition handlers.\n\
2968 Note that `debug-on-error', `debug-on-quit' and friends\n\
2969 still determine whether to handle the particular condition.");
2970 Vdebug_on_signal
= Qnil
;
2972 Vrun_hooks
= intern ("run-hooks");
2973 staticpro (&Vrun_hooks
);
2975 staticpro (&Vautoload_queue
);
2976 Vautoload_queue
= Qnil
;
2987 defsubr (&Sfunction
);
2989 defsubr (&Sdefmacro
);
2991 defsubr (&Sdefconst
);
2992 defsubr (&Suser_variable_p
);
2996 defsubr (&Smacroexpand
);
2999 defsubr (&Sunwind_protect
);
3000 defsubr (&Scondition_case
);
3002 defsubr (&Sinteractive_p
);
3003 defsubr (&Scommandp
);
3004 defsubr (&Sautoload
);
3007 defsubr (&Sfuncall
);
3008 defsubr (&Srun_hooks
);
3009 defsubr (&Srun_hook_with_args
);
3010 defsubr (&Srun_hook_with_args_until_success
);
3011 defsubr (&Srun_hook_with_args_until_failure
);
3012 defsubr (&Sfetch_bytecode
);
3013 defsubr (&Sbacktrace_debug
);
3014 defsubr (&Sbacktrace
);
3015 defsubr (&Sbacktrace_frame
);