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, 675 Mass Ave, Cambridge, MA 02139, USA. */
23 #include "blockinput.h"
34 /* This definition is duplicated in alloc.c and keyboard.c */
35 /* Putting it in lisp.h makes cc bomb out! */
39 struct backtrace
*next
;
40 Lisp_Object
*function
;
41 Lisp_Object
*args
; /* Points to vector of args. */
42 int nargs
; /* Length of vector.
43 If nargs is UNEVALLED, args points to slot holding
44 list of unevalled args */
46 /* Nonzero means call value of debugger when done with this operation. */
50 struct backtrace
*backtrace_list
;
52 /* This structure helps implement the `catch' and `throw' control
53 structure. A struct catchtag contains all the information needed
54 to restore the state of the interpreter after a non-local jump.
56 Handlers for error conditions (represented by `struct handler'
57 structures) just point to a catch tag to do the cleanup required
60 catchtag structures are chained together in the C calling stack;
61 the `next' member points to the next outer catchtag.
63 A call like (throw TAG VAL) searches for a catchtag whose `tag'
64 member is TAG, and then unbinds to it. The `val' member is used to
65 hold VAL while the stack is unwound; `val' is returned as the value
68 All the other members are concerned with restoring the interpreter
74 struct catchtag
*next
;
77 struct backtrace
*backlist
;
78 struct handler
*handlerlist
;
81 int poll_suppress_count
;
84 struct catchtag
*catchlist
;
86 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
87 Lisp_Object Qinhibit_quit
, Vinhibit_quit
, Vquit_flag
;
88 Lisp_Object Qmocklisp_arguments
, Vmocklisp_arguments
, Qmocklisp
;
89 Lisp_Object Qand_rest
, Qand_optional
;
90 Lisp_Object Qdebug_on_error
;
92 Lisp_Object Vrun_hooks
;
94 /* Non-nil means record all fset's and provide's, to be undone
95 if the file being autoloaded is not fully loaded.
96 They are recorded by being consed onto the front of Vautoload_queue:
97 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */
99 Lisp_Object Vautoload_queue
;
101 /* Current number of specbindings allocated in specpdl. */
104 /* Pointer to beginning of specpdl. */
105 struct specbinding
*specpdl
;
107 /* Pointer to first unused element in specpdl. */
108 struct specbinding
*specpdl_ptr
;
110 /* Maximum size allowed for specpdl allocation */
111 int max_specpdl_size
;
113 /* Depth in Lisp evaluations and function calls. */
116 /* Maximum allowed depth in Lisp evaluations and function calls. */
117 int max_lisp_eval_depth
;
119 /* Nonzero means enter debugger before next function call */
120 int debug_on_next_call
;
122 /* List of conditions (non-nil atom means all) which cause a backtrace
123 if an error is handled by the command loop's error handler. */
124 Lisp_Object Vstack_trace_on_error
;
126 /* List of conditions (non-nil atom means all) which enter the debugger
127 if an error is handled by the command loop's error handler. */
128 Lisp_Object Vdebug_on_error
;
130 /* List of conditions and regexps specifying error messages which
131 do not enter the debugger even if Vdebug_on_errors says they should. */
132 Lisp_Object Vdebug_ignored_errors
;
134 /* Nonzero means enter debugger if a quit signal
135 is handled by the command loop's error handler. */
138 /* The value of num_nonmacro_input_chars as of the last time we
139 started to enter the debugger. If we decide to enter the debugger
140 again when this is still equal to num_nonmacro_input_chars, then we
141 know that the debugger itself has an error, and we should just
142 signal the error instead of entering an infinite loop of debugger
144 int when_entered_debugger
;
146 Lisp_Object Vdebugger
;
148 void specbind (), record_unwind_protect ();
150 Lisp_Object
run_hook_with_args ();
152 Lisp_Object
funcall_lambda ();
153 extern Lisp_Object
ml_apply (); /* Apply a mocklisp function to unevaluated argument list */
158 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
159 max_specpdl_size
= 600;
160 max_lisp_eval_depth
= 200;
167 specpdl_ptr
= specpdl
;
172 debug_on_next_call
= 0;
174 /* This is less than the initial value of num_nonmacro_input_chars. */
175 when_entered_debugger
= -1;
182 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
183 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
184 if (specpdl_size
+ 40 > max_specpdl_size
)
185 max_specpdl_size
= specpdl_size
+ 40;
186 debug_on_next_call
= 0;
187 when_entered_debugger
= num_nonmacro_input_chars
;
188 return apply1 (Vdebugger
, arg
);
191 do_debug_on_call (code
)
194 debug_on_next_call
= 0;
195 backtrace_list
->debug_on_exit
= 1;
196 call_debugger (Fcons (code
, Qnil
));
199 /* NOTE!!! Every function that can call EVAL must protect its args
200 and temporaries from garbage collection while it needs them.
201 The definition of `For' shows what you have to do. */
203 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
204 "Eval args until one of them yields non-nil, then return that value.\n\
205 The remaining args are not evalled at all.\n\
206 If all args return nil, return nil.")
210 register Lisp_Object val
;
211 Lisp_Object args_left
;
222 val
= Feval (Fcar (args_left
));
225 args_left
= Fcdr (args_left
);
227 while (!NILP(args_left
));
233 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
234 "Eval args until one of them yields nil, then return nil.\n\
235 The remaining args are not evalled at all.\n\
236 If no arg yields nil, return the last arg's value.")
240 register Lisp_Object val
;
241 Lisp_Object args_left
;
252 val
= Feval (Fcar (args_left
));
255 args_left
= Fcdr (args_left
);
257 while (!NILP(args_left
));
263 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
264 "(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...\n\
265 Returns the value of THEN or the value of the last of the ELSE's.\n\
266 THEN must be one expression, but ELSE... can be zero or more expressions.\n\
267 If COND yields nil, and there are no ELSE's, the value is nil.")
271 register Lisp_Object cond
;
275 cond
= Feval (Fcar (args
));
279 return Feval (Fcar (Fcdr (args
)));
280 return Fprogn (Fcdr (Fcdr (args
)));
283 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
284 "(cond CLAUSES...): try each clause until one succeeds.\n\
285 Each clause looks like (CONDITION BODY...). CONDITION is evaluated\n\
286 and, if the value is non-nil, this clause succeeds:\n\
287 then the expressions in BODY are evaluated and the last one's\n\
288 value is the value of the cond-form.\n\
289 If no clause succeeds, cond returns nil.\n\
290 If a clause has one element, as in (CONDITION),\n\
291 CONDITION's value if non-nil is returned from the cond-form.")
295 register Lisp_Object clause
, val
;
302 clause
= Fcar (args
);
303 val
= Feval (Fcar (clause
));
306 if (!EQ (XCONS (clause
)->cdr
, Qnil
))
307 val
= Fprogn (XCONS (clause
)->cdr
);
310 args
= XCONS (args
)->cdr
;
317 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
318 "(progn BODY...): eval BODY forms sequentially and return value of last one.")
322 register Lisp_Object val
, tem
;
323 Lisp_Object args_left
;
326 /* In Mocklisp code, symbols at the front of the progn arglist
327 are to be bound to zero. */
328 if (!EQ (Vmocklisp_arguments
, Qt
))
330 val
= make_number (0);
331 while (!NILP (args
) && (tem
= Fcar (args
), SYMBOLP (tem
)))
334 specbind (tem
, val
), args
= Fcdr (args
);
346 val
= Feval (Fcar (args_left
));
347 args_left
= Fcdr (args_left
);
349 while (!NILP(args_left
));
355 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
356 "(prog1 FIRST BODY...): eval FIRST and BODY sequentially; value from FIRST.\n\
357 The value of FIRST is saved during the evaluation of the remaining args,\n\
358 whose values are discarded.")
363 register Lisp_Object args_left
;
364 struct gcpro gcpro1
, gcpro2
;
365 register int argnum
= 0;
377 val
= Feval (Fcar (args_left
));
379 Feval (Fcar (args_left
));
380 args_left
= Fcdr (args_left
);
382 while (!NILP(args_left
));
388 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
389 "(prog2 X Y BODY...): eval X, Y and BODY sequentially; value from Y.\n\
390 The value of Y is saved during the evaluation of the remaining args,\n\
391 whose values are discarded.")
396 register Lisp_Object args_left
;
397 struct gcpro gcpro1
, gcpro2
;
398 register int argnum
= -1;
412 val
= Feval (Fcar (args_left
));
414 Feval (Fcar (args_left
));
415 args_left
= Fcdr (args_left
);
417 while (!NILP (args_left
));
423 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
424 "(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.\n\
425 The symbols SYM are variables; they are literal (not evaluated).\n\
426 The values VAL are expressions; they are evaluated.\n\
427 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.\n\
428 The second VAL is not computed until after the first SYM is set, and so on;\n\
429 each VAL can use the new value of variables set earlier in the `setq'.\n\
430 The return value of the `setq' form is the value of the last VAL.")
434 register Lisp_Object args_left
;
435 register Lisp_Object val
, sym
;
446 val
= Feval (Fcar (Fcdr (args_left
)));
447 sym
= Fcar (args_left
);
449 args_left
= Fcdr (Fcdr (args_left
));
451 while (!NILP(args_left
));
457 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
458 "Return the argument, without evaluating it. `(quote x)' yields `x'.")
465 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
466 "Like `quote', but preferred for objects which are functions.\n\
467 In byte compilation, `function' causes its argument to be compiled.\n\
468 `quote' cannot do that.")
475 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
476 "Return t if function in which this appears was called interactively.\n\
477 This means that the function was called with call-interactively (which\n\
478 includes being called as the binding of a key)\n\
479 and input is currently coming from the keyboard (not in keyboard macro).")
482 register struct backtrace
*btp
;
483 register Lisp_Object fun
;
488 btp
= backtrace_list
;
490 /* If this isn't a byte-compiled function, there may be a frame at
491 the top for Finteractive_p itself. If so, skip it. */
492 fun
= Findirect_function (*btp
->function
);
493 if (SUBRP (fun
) && XSUBR (fun
) == &Sinteractive_p
)
496 /* If we're running an Emacs 18-style byte-compiled function, there
497 may be a frame for Fbytecode. Now, given the strictest
498 definition, this function isn't really being called
499 interactively, but because that's the way Emacs 18 always builds
500 byte-compiled functions, we'll accept it for now. */
501 if (EQ (*btp
->function
, Qbytecode
))
504 /* If this isn't a byte-compiled function, then we may now be
505 looking at several frames for special forms. Skip past them. */
507 btp
->nargs
== UNEVALLED
)
510 /* btp now points at the frame of the innermost function that isn't
511 a special form, ignoring frames for Finteractive_p and/or
512 Fbytecode at the top. If this frame is for a built-in function
513 (such as load or eval-region) return nil. */
514 fun
= Findirect_function (*btp
->function
);
517 /* btp points to the frame of a Lisp function that called interactive-p.
518 Return t if that function was called interactively. */
519 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
524 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
525 "(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.\n\
526 The definition is (lambda ARGLIST [DOCSTRING] BODY...).\n\
527 See also the function `interactive'.")
531 register Lisp_Object fn_name
;
532 register Lisp_Object defn
;
534 fn_name
= Fcar (args
);
535 defn
= Fcons (Qlambda
, Fcdr (args
));
536 if (!NILP (Vpurify_flag
))
537 defn
= Fpurecopy (defn
);
538 Ffset (fn_name
, defn
);
539 LOADHIST_ATTACH (fn_name
);
543 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
544 "(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.\n\
545 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).\n\
546 When the macro is called, as in (NAME ARGS...),\n\
547 the function (lambda ARGLIST BODY...) is applied to\n\
548 the list ARGS... as it appears in the expression,\n\
549 and the result should be a form to be evaluated instead of the original.")
553 register Lisp_Object fn_name
;
554 register Lisp_Object defn
;
556 fn_name
= Fcar (args
);
557 defn
= Fcons (Qmacro
, Fcons (Qlambda
, Fcdr (args
)));
558 if (!NILP (Vpurify_flag
))
559 defn
= Fpurecopy (defn
);
560 Ffset (fn_name
, defn
);
561 LOADHIST_ATTACH (fn_name
);
565 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
566 "(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.\n\
567 You are not required to define a variable in order to use it,\n\
568 but the definition can supply documentation and an initial value\n\
569 in a way that tags can recognize.\n\n\
570 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.\n\
571 If SYMBOL is buffer-local, its default value is what is set;\n\
572 buffer-local values are not affected.\n\
573 INITVALUE and DOCSTRING are optional.\n\
574 If DOCSTRING starts with *, this variable is identified as a user option.\n\
575 This means that M-x set-variable and M-x edit-options recognize it.\n\
576 If INITVALUE is missing, SYMBOL's value is not set.")
580 register Lisp_Object sym
, tem
, tail
;
584 if (!NILP (Fcdr (Fcdr (tail
))))
585 error ("too many arguments");
589 tem
= Fdefault_boundp (sym
);
591 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
593 tail
= Fcdr (Fcdr (args
));
594 if (!NILP (Fcar (tail
)))
597 if (!NILP (Vpurify_flag
))
598 tem
= Fpurecopy (tem
);
599 Fput (sym
, Qvariable_documentation
, tem
);
601 LOADHIST_ATTACH (sym
);
605 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
606 "(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant variable.\n\
607 The intent is that programs do not change this value, but users may.\n\
608 Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\
609 If SYMBOL is buffer-local, its default value is what is set;\n\
610 buffer-local values are not affected.\n\
611 DOCSTRING is optional.\n\
612 If DOCSTRING starts with *, this variable is identified as a user option.\n\
613 This means that M-x set-variable and M-x edit-options recognize it.\n\n\
614 Note: do not use `defconst' for user options in libraries that are not\n\
615 normally loaded, since it is useful for users to be able to specify\n\
616 their own values for such variables before loading the library.\n\
617 Since `defconst' unconditionally assigns the variable,\n\
618 it would override the user's choice.")
622 register Lisp_Object sym
, tem
;
625 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
626 error ("too many arguments");
628 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
629 tem
= Fcar (Fcdr (Fcdr (args
)));
632 if (!NILP (Vpurify_flag
))
633 tem
= Fpurecopy (tem
);
634 Fput (sym
, Qvariable_documentation
, tem
);
636 LOADHIST_ATTACH (sym
);
640 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
641 "Returns t if VARIABLE is intended to be set and modified by users.\n\
642 \(The alternative is a variable used internally in a Lisp program.)\n\
643 Determined by whether the first character of the documentation\n\
644 for the variable is `*'.")
646 Lisp_Object variable
;
648 Lisp_Object documentation
;
650 documentation
= Fget (variable
, Qvariable_documentation
);
651 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
653 if (STRINGP (documentation
)
654 && ((unsigned char) XSTRING (documentation
)->data
[0] == '*'))
656 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
657 if (CONSP (documentation
)
658 && STRINGP (XCONS (documentation
)->car
)
659 && INTEGERP (XCONS (documentation
)->cdr
)
660 && XINT (XCONS (documentation
)->cdr
) < 0)
665 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
666 "(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
667 The value of the last form in BODY is returned.\n\
668 Each element of VARLIST is a symbol (which is bound to nil)\n\
669 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
670 Each VALUEFORM can refer to the symbols already bound by this VARLIST.")
674 Lisp_Object varlist
, val
, elt
;
675 int count
= specpdl_ptr
- specpdl
;
676 struct gcpro gcpro1
, gcpro2
, gcpro3
;
678 GCPRO3 (args
, elt
, varlist
);
680 varlist
= Fcar (args
);
681 while (!NILP (varlist
))
684 elt
= Fcar (varlist
);
686 specbind (elt
, Qnil
);
687 else if (! NILP (Fcdr (Fcdr (elt
))))
689 Fcons (build_string ("`let' bindings can have only one value-form"),
693 val
= Feval (Fcar (Fcdr (elt
)));
694 specbind (Fcar (elt
), val
);
696 varlist
= Fcdr (varlist
);
699 val
= Fprogn (Fcdr (args
));
700 return unbind_to (count
, val
);
703 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
704 "(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
705 The value of the last form in BODY is returned.\n\
706 Each element of VARLIST is a symbol (which is bound to nil)\n\
707 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
708 All the VALUEFORMs are evalled before any symbols are bound.")
712 Lisp_Object
*temps
, tem
;
713 register Lisp_Object elt
, varlist
;
714 int count
= specpdl_ptr
- specpdl
;
716 struct gcpro gcpro1
, gcpro2
;
718 varlist
= Fcar (args
);
720 /* Make space to hold the values to give the bound variables */
721 elt
= Flength (varlist
);
722 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
724 /* Compute the values and store them in `temps' */
726 GCPRO2 (args
, *temps
);
729 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
732 elt
= Fcar (varlist
);
734 temps
[argnum
++] = Qnil
;
735 else if (! NILP (Fcdr (Fcdr (elt
))))
737 Fcons (build_string ("`let' bindings can have only one value-form"),
740 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
741 gcpro2
.nvars
= argnum
;
745 varlist
= Fcar (args
);
746 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
748 elt
= Fcar (varlist
);
749 tem
= temps
[argnum
++];
753 specbind (Fcar (elt
), tem
);
756 elt
= Fprogn (Fcdr (args
));
757 return unbind_to (count
, elt
);
760 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
761 "(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.\n\
762 The order of execution is thus TEST, BODY, TEST, BODY and so on\n\
763 until TEST returns nil.")
767 Lisp_Object test
, body
, tem
;
768 struct gcpro gcpro1
, gcpro2
;
774 while (tem
= Feval (test
),
775 (!EQ (Vmocklisp_arguments
, Qt
) ? XINT (tem
) : !NILP (tem
)))
785 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
786 "Return result of expanding macros at top level of FORM.\n\
787 If FORM is not a macro call, it is returned unchanged.\n\
788 Otherwise, the macro is expanded and the expansion is considered\n\
789 in place of FORM. When a non-macro-call results, it is returned.\n\n\
790 The second optional arg ENVIRONMENT species an environment of macro\n\
791 definitions to shadow the loaded ones for use in file byte-compilation.")
793 register Lisp_Object form
;
796 /* With cleanups from Hallvard Furuseth. */
797 register Lisp_Object expander
, sym
, def
, tem
;
801 /* Come back here each time we expand a macro call,
802 in case it expands into another macro call. */
805 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
806 def
= sym
= XCONS (form
)->car
;
808 /* Trace symbols aliases to other symbols
809 until we get a symbol that is not an alias. */
810 while (SYMBOLP (def
))
814 tem
= Fassq (sym
, env
);
817 def
= XSYMBOL (sym
)->function
;
818 if (!EQ (def
, Qunbound
))
823 /* Right now TEM is the result from SYM in ENV,
824 and if TEM is nil then DEF is SYM's function definition. */
827 /* SYM is not mentioned in ENV.
828 Look at its function definition. */
829 if (EQ (def
, Qunbound
) || !CONSP (def
))
830 /* Not defined or definition not suitable */
832 if (EQ (XCONS (def
)->car
, Qautoload
))
834 /* Autoloading function: will it be a macro when loaded? */
835 tem
= Fnth (make_number (4), def
);
836 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
837 /* Yes, load it and try again. */
839 do_autoload (def
, sym
);
845 else if (!EQ (XCONS (def
)->car
, Qmacro
))
847 else expander
= XCONS (def
)->cdr
;
851 expander
= XCONS (tem
)->cdr
;
855 form
= apply1 (expander
, XCONS (form
)->cdr
);
860 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
861 "(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.\n\
862 TAG is evalled to get the tag to use. Then the BODY is executed.\n\
863 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.\n\
864 If no throw happens, `catch' returns the value of the last BODY form.\n\
865 If a throw happens, it specifies the value to return from `catch'.")
869 register Lisp_Object tag
;
873 tag
= Feval (Fcar (args
));
875 return internal_catch (tag
, Fprogn
, Fcdr (args
));
878 /* Set up a catch, then call C function FUNC on argument ARG.
879 FUNC should return a Lisp_Object.
880 This is how catches are done from within C code. */
883 internal_catch (tag
, func
, arg
)
885 Lisp_Object (*func
) ();
888 /* This structure is made part of the chain `catchlist'. */
891 /* Fill in the components of c, and put it on the list. */
895 c
.backlist
= backtrace_list
;
896 c
.handlerlist
= handlerlist
;
897 c
.lisp_eval_depth
= lisp_eval_depth
;
898 c
.pdlcount
= specpdl_ptr
- specpdl
;
899 c
.poll_suppress_count
= poll_suppress_count
;
904 if (! _setjmp (c
.jmp
))
905 c
.val
= (*func
) (arg
);
907 /* Throw works by a longjmp that comes right here. */
912 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
913 jump to that CATCH, returning VALUE as the value of that catch.
915 This is the guts Fthrow and Fsignal; they differ only in the way
916 they choose the catch tag to throw to. A catch tag for a
917 condition-case form has a TAG of Qnil.
919 Before each catch is discarded, unbind all special bindings and
920 execute all unwind-protect clauses made above that catch. Unwind
921 the handler stack as we go, so that the proper handlers are in
922 effect for each unwind-protect clause we run. At the end, restore
923 some static info saved in CATCH, and longjmp to the location
926 This is used for correct unwinding in Fthrow and Fsignal. */
929 unwind_to_catch (catch, value
)
930 struct catchtag
*catch;
933 register int last_time
;
935 /* Save the value in the tag. */
938 /* Restore the polling-suppression count. */
939 set_poll_suppress_count (catch->poll_suppress_count
);
943 last_time
= catchlist
== catch;
945 /* Unwind the specpdl stack, and then restore the proper set of
947 unbind_to (catchlist
->pdlcount
, Qnil
);
948 handlerlist
= catchlist
->handlerlist
;
949 catchlist
= catchlist
->next
;
953 gcprolist
= catch->gcpro
;
954 backtrace_list
= catch->backlist
;
955 lisp_eval_depth
= catch->lisp_eval_depth
;
957 _longjmp (catch->jmp
, 1);
960 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
961 "(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.\n\
962 Both TAG and VALUE are evalled.")
964 register Lisp_Object tag
, val
;
966 register struct catchtag
*c
;
971 for (c
= catchlist
; c
; c
= c
->next
)
973 if (EQ (c
->tag
, tag
))
974 unwind_to_catch (c
, val
);
976 tag
= Fsignal (Qno_catch
, Fcons (tag
, Fcons (val
, Qnil
)));
981 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
982 "Do BODYFORM, protecting with UNWINDFORMS.\n\
983 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).\n\
984 If BODYFORM completes normally, its value is returned\n\
985 after executing the UNWINDFORMS.\n\
986 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.")
991 int count
= specpdl_ptr
- specpdl
;
993 record_unwind_protect (0, Fcdr (args
));
994 val
= Feval (Fcar (args
));
995 return unbind_to (count
, val
);
998 /* Chain of condition handlers currently in effect.
999 The elements of this chain are contained in the stack frames
1000 of Fcondition_case and internal_condition_case.
1001 When an error is signaled (by calling Fsignal, below),
1002 this chain is searched for an element that applies. */
1004 struct handler
*handlerlist
;
1006 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1007 "Regain control when an error is signaled.\n\
1008 Usage looks like (condition-case VAR BODYFORM HANDLERS...).\n\
1009 executes BODYFORM and returns its value if no error happens.\n\
1010 Each element of HANDLERS looks like (CONDITION-NAME BODY...)\n\
1011 where the BODY is made of Lisp expressions.\n\n\
1012 A handler is applicable to an error\n\
1013 if CONDITION-NAME is one of the error's condition names.\n\
1014 If an error happens, the first applicable handler is run.\n\
1016 The car of a handler may be a list of condition names\n\
1017 instead of a single condition name.\n\
1019 When a handler handles an error,\n\
1020 control returns to the condition-case and the handler BODY... is executed\n\
1021 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\
1022 VAR may be nil; then you do not get access to the signal information.\n\
1024 The value of the last BODY form is returned from the condition-case.\n\
1025 See also the function `signal' for more info.")
1032 register Lisp_Object var
, bodyform
, handlers
;
1035 bodyform
= Fcar (Fcdr (args
));
1036 handlers
= Fcdr (Fcdr (args
));
1037 CHECK_SYMBOL (var
, 0);
1039 for (val
= handlers
; ! NILP (val
); val
= Fcdr (val
))
1045 && (SYMBOLP (XCONS (tem
)->car
)
1046 || CONSP (XCONS (tem
)->car
)))))
1047 error ("Invalid condition handler", tem
);
1052 c
.backlist
= backtrace_list
;
1053 c
.handlerlist
= handlerlist
;
1054 c
.lisp_eval_depth
= lisp_eval_depth
;
1055 c
.pdlcount
= specpdl_ptr
- specpdl
;
1056 c
.poll_suppress_count
= poll_suppress_count
;
1057 c
.gcpro
= gcprolist
;
1058 if (_setjmp (c
.jmp
))
1061 specbind (h
.var
, c
.val
);
1062 val
= Fprogn (Fcdr (h
.chosen_clause
));
1064 /* Note that this just undoes the binding of h.var; whoever
1065 longjumped to us unwound the stack to c.pdlcount before
1067 unbind_to (c
.pdlcount
, Qnil
);
1074 h
.handler
= handlers
;
1075 h
.next
= handlerlist
;
1079 val
= Feval (bodyform
);
1081 handlerlist
= h
.next
;
1086 internal_condition_case (bfun
, handlers
, hfun
)
1087 Lisp_Object (*bfun
) ();
1088 Lisp_Object handlers
;
1089 Lisp_Object (*hfun
) ();
1095 /* Since Fsignal resets this to 0, it had better be 0 now
1096 or else we have a potential bug. */
1097 if (interrupt_input_blocked
!= 0)
1102 c
.backlist
= backtrace_list
;
1103 c
.handlerlist
= handlerlist
;
1104 c
.lisp_eval_depth
= lisp_eval_depth
;
1105 c
.pdlcount
= specpdl_ptr
- specpdl
;
1106 c
.poll_suppress_count
= poll_suppress_count
;
1107 c
.gcpro
= gcprolist
;
1108 if (_setjmp (c
.jmp
))
1110 return (*hfun
) (c
.val
);
1114 h
.handler
= handlers
;
1116 h
.next
= handlerlist
;
1122 handlerlist
= h
.next
;
1127 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1128 Lisp_Object (*bfun
) ();
1130 Lisp_Object handlers
;
1131 Lisp_Object (*hfun
) ();
1139 c
.backlist
= backtrace_list
;
1140 c
.handlerlist
= handlerlist
;
1141 c
.lisp_eval_depth
= lisp_eval_depth
;
1142 c
.pdlcount
= specpdl_ptr
- specpdl
;
1143 c
.poll_suppress_count
= poll_suppress_count
;
1144 c
.gcpro
= gcprolist
;
1145 if (_setjmp (c
.jmp
))
1147 return (*hfun
) (c
.val
);
1151 h
.handler
= handlers
;
1153 h
.next
= handlerlist
;
1157 val
= (*bfun
) (arg
);
1159 handlerlist
= h
.next
;
1163 static Lisp_Object
find_handler_clause ();
1165 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1166 "Signal an error. Args are ERROR-SYMBOL and associated DATA.\n\
1167 This function does not return.\n\n\
1168 An error symbol is a symbol with an `error-conditions' property\n\
1169 that is a list of condition names.\n\
1170 A handler for any of those names will get to handle this signal.\n\
1171 The symbol `error' should normally be one of them.\n\
1173 DATA should be a list. Its elements are printed as part of the error message.\n\
1174 If the signal is handled, DATA is made available to the handler.\n\
1175 See also the function `condition-case'.")
1176 (error_symbol
, data
)
1177 Lisp_Object error_symbol
, data
;
1179 register struct handler
*allhandlers
= handlerlist
;
1180 Lisp_Object conditions
;
1181 extern int gc_in_progress
;
1182 extern int waiting_for_input
;
1183 Lisp_Object debugger_value
;
1185 quit_error_check ();
1187 if (gc_in_progress
|| waiting_for_input
)
1190 #ifdef HAVE_X_WINDOWS
1191 TOTALLY_UNBLOCK_INPUT
;
1194 conditions
= Fget (error_symbol
, Qerror_conditions
);
1196 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1198 register Lisp_Object clause
;
1199 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1200 error_symbol
, data
, &debugger_value
);
1202 #if 0 /* Most callers are not prepared to handle gc if this returns.
1203 So, since this feature is not very useful, take it out. */
1204 /* If have called debugger and user wants to continue,
1206 if (EQ (clause
, Qlambda
))
1207 return debugger_value
;
1209 if (EQ (clause
, Qlambda
))
1211 /* We can't return values to code which signaled an error, but we
1212 can continue code which has signaled a quit. */
1213 if (EQ (error_symbol
, Qquit
))
1216 error ("Cannot return from the debugger in an error");
1222 Lisp_Object unwind_data
;
1223 struct handler
*h
= handlerlist
;
1225 handlerlist
= allhandlers
;
1226 if (EQ (data
, memory_signal_data
))
1227 unwind_data
= memory_signal_data
;
1229 unwind_data
= Fcons (error_symbol
, data
);
1230 h
->chosen_clause
= clause
;
1231 unwind_to_catch (h
->tag
, unwind_data
);
1235 handlerlist
= allhandlers
;
1236 /* If no handler is present now, try to run the debugger,
1237 and if that fails, throw to top level. */
1238 find_handler_clause (Qerror
, conditions
, error_symbol
, data
, &debugger_value
);
1239 Fthrow (Qtop_level
, Qt
);
1242 /* Return nonzero iff LIST is a non-nil atom or
1243 a list containing one of CONDITIONS. */
1246 wants_debugger (list
, conditions
)
1247 Lisp_Object list
, conditions
;
1254 while (CONSP (conditions
))
1256 Lisp_Object
this, tail
;
1257 this = XCONS (conditions
)->car
;
1258 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1259 if (EQ (XCONS (tail
)->car
, this))
1261 conditions
= XCONS (conditions
)->cdr
;
1266 /* Return 1 if an error with condition-symbols CONDITIONS,
1267 and described by SIGNAL-DATA, should skip the debugger
1268 according to debugger-ignore-errors. */
1271 skip_debugger (conditions
, data
)
1272 Lisp_Object conditions
, data
;
1275 int first_string
= 1;
1276 Lisp_Object error_message
;
1278 for (tail
= Vdebug_ignored_errors
; CONSP (tail
);
1279 tail
= XCONS (tail
)->cdr
)
1281 if (STRINGP (XCONS (tail
)->car
))
1285 error_message
= Ferror_message_string (data
);
1288 if (fast_string_match (XCONS (tail
)->car
, error_message
) >= 0)
1293 Lisp_Object contail
;
1295 for (contail
= conditions
; CONSP (contail
);
1296 contail
= XCONS (contail
)->cdr
)
1297 if (EQ (XCONS (tail
)->car
, XCONS (contail
)->car
))
1305 /* Value of Qlambda means we have called debugger and user has continued.
1306 Store value returned from debugger into *DEBUGGER_VALUE_PTR. */
1309 find_handler_clause (handlers
, conditions
, sig
, data
, debugger_value_ptr
)
1310 Lisp_Object handlers
, conditions
, sig
, data
;
1311 Lisp_Object
*debugger_value_ptr
;
1313 register Lisp_Object h
;
1314 register Lisp_Object tem
;
1316 if (EQ (handlers
, Qt
)) /* t is used by handlers for all conditions, set up by C code. */
1318 if (EQ (handlers
, Qerror
)) /* error is used similarly, but means display a backtrace too */
1320 if (wants_debugger (Vstack_trace_on_error
, conditions
))
1321 internal_with_output_to_temp_buffer ("*Backtrace*", Fbacktrace
, Qnil
);
1322 if ((EQ (sig
, Qquit
)
1324 : wants_debugger (Vdebug_on_error
, conditions
))
1325 && ! skip_debugger (conditions
, Fcons (sig
, data
))
1326 && when_entered_debugger
< num_nonmacro_input_chars
)
1328 int count
= specpdl_ptr
- specpdl
;
1329 specbind (Qdebug_on_error
, Qnil
);
1331 = call_debugger (Fcons (Qerror
,
1332 Fcons (Fcons (sig
, data
),
1334 return unbind_to (count
, Qlambda
);
1338 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1340 Lisp_Object handler
, condit
;
1343 if (!CONSP (handler
))
1345 condit
= Fcar (handler
);
1346 /* Handle a single condition name in handler HANDLER. */
1347 if (SYMBOLP (condit
))
1349 tem
= Fmemq (Fcar (handler
), conditions
);
1353 /* Handle a list of condition names in handler HANDLER. */
1354 else if (CONSP (condit
))
1356 while (CONSP (condit
))
1358 tem
= Fmemq (Fcar (condit
), conditions
);
1361 condit
= XCONS (condit
)->cdr
;
1368 /* dump an error message; called like printf */
1372 error (m
, a1
, a2
, a3
)
1392 int used
= doprnt (buf
, size
, m
, m
+ mlen
, 3, args
);
1397 buffer
= (char *) xrealloc (buffer
, size
);
1400 buffer
= (char *) xmalloc (size
);
1405 string
= build_string (buf
);
1409 Fsignal (Qerror
, Fcons (string
, Qnil
));
1412 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 1, 0,
1413 "T if FUNCTION makes provisions for interactive calling.\n\
1414 This means it contains a description for how to read arguments to give it.\n\
1415 The value is nil for an invalid function or a symbol with no function\n\
1418 Interactively callable functions include strings and vectors (treated\n\
1419 as keyboard macros), lambda-expressions that contain a top-level call\n\
1420 to `interactive', autoload definitions made by `autoload' with non-nil\n\
1421 fourth argument, and some of the built-in functions of Lisp.\n\
1423 Also, a symbol satisfies `commandp' if its function definition does so.")
1425 Lisp_Object function
;
1427 register Lisp_Object fun
;
1428 register Lisp_Object funcar
;
1429 register Lisp_Object tem
;
1434 fun
= indirect_function (fun
);
1435 if (EQ (fun
, Qunbound
))
1438 /* Emacs primitives are interactive if their DEFUN specifies an
1439 interactive spec. */
1442 if (XSUBR (fun
)->prompt
)
1448 /* Bytecode objects are interactive if they are long enough to
1449 have an element whose index is COMPILED_INTERACTIVE, which is
1450 where the interactive spec is stored. */
1451 else if (COMPILEDP (fun
))
1452 return ((XVECTOR (fun
)->size
& PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
1455 /* Strings and vectors are keyboard macros. */
1456 if (STRINGP (fun
) || VECTORP (fun
))
1459 /* Lists may represent commands. */
1462 funcar
= Fcar (fun
);
1463 if (!SYMBOLP (funcar
))
1464 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1465 if (EQ (funcar
, Qlambda
))
1466 return Fassq (Qinteractive
, Fcdr (Fcdr (fun
)));
1467 if (EQ (funcar
, Qmocklisp
))
1468 return Qt
; /* All mocklisp functions can be called interactively */
1469 if (EQ (funcar
, Qautoload
))
1470 return Fcar (Fcdr (Fcdr (Fcdr (fun
))));
1476 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1477 "Define FUNCTION to autoload from FILE.\n\
1478 FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\
1479 Third arg DOCSTRING is documentation for the function.\n\
1480 Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\
1481 Fifth arg TYPE indicates the type of the object:\n\
1482 nil or omitted says FUNCTION is a function,\n\
1483 `keymap' says FUNCTION is really a keymap, and\n\
1484 `macro' or t says FUNCTION is really a macro.\n\
1485 Third through fifth args give info about the real definition.\n\
1486 They default to nil.\n\
1487 If FUNCTION is already defined other than as an autoload,\n\
1488 this does nothing and returns nil.")
1489 (function
, file
, docstring
, interactive
, type
)
1490 Lisp_Object function
, file
, docstring
, interactive
, type
;
1493 Lisp_Object args
[4];
1496 CHECK_SYMBOL (function
, 0);
1497 CHECK_STRING (file
, 1);
1499 /* If function is defined and not as an autoload, don't override */
1500 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
1501 && !(CONSP (XSYMBOL (function
)->function
)
1502 && EQ (XCONS (XSYMBOL (function
)->function
)->car
, Qautoload
)))
1507 args
[1] = docstring
;
1508 args
[2] = interactive
;
1511 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
1512 #else /* NO_ARG_ARRAY */
1513 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
1514 #endif /* not NO_ARG_ARRAY */
1518 un_autoload (oldqueue
)
1519 Lisp_Object oldqueue
;
1521 register Lisp_Object queue
, first
, second
;
1523 /* Queue to unwind is current value of Vautoload_queue.
1524 oldqueue is the shadowed value to leave in Vautoload_queue. */
1525 queue
= Vautoload_queue
;
1526 Vautoload_queue
= oldqueue
;
1527 while (CONSP (queue
))
1529 first
= Fcar (queue
);
1530 second
= Fcdr (first
);
1531 first
= Fcar (first
);
1532 if (EQ (second
, Qnil
))
1535 Ffset (first
, second
);
1536 queue
= Fcdr (queue
);
1541 do_autoload (fundef
, funname
)
1542 Lisp_Object fundef
, funname
;
1544 int count
= specpdl_ptr
- specpdl
;
1545 Lisp_Object fun
, val
, queue
, first
, second
;
1548 CHECK_SYMBOL (funname
, 0);
1550 /* Value saved here is to be restored into Vautoload_queue */
1551 record_unwind_protect (un_autoload
, Vautoload_queue
);
1552 Vautoload_queue
= Qt
;
1553 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
);
1555 /* Save the old autoloads, in case we ever do an unload. */
1556 queue
= Vautoload_queue
;
1557 while (CONSP (queue
))
1559 first
= Fcar (queue
);
1560 second
= Fcdr (first
);
1561 first
= Fcar (first
);
1563 /* Note: This test is subtle. The cdr of an autoload-queue entry
1564 may be an atom if the autoload entry was generated by a defalias
1567 Fput (first
, Qautoload
, (Fcdr (second
)));
1569 queue
= Fcdr (queue
);
1572 /* Once loading finishes, don't undo it. */
1573 Vautoload_queue
= Qt
;
1574 unbind_to (count
, Qnil
);
1576 fun
= Findirect_function (fun
);
1578 if (!NILP (Fequal (fun
, fundef
)))
1579 error ("Autoloading failed to define function %s",
1580 XSYMBOL (funname
)->name
->data
);
1583 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
1584 "Evaluate FORM and return its value.")
1588 Lisp_Object fun
, val
, original_fun
, original_args
;
1590 struct backtrace backtrace
;
1591 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1595 if (EQ (Vmocklisp_arguments
, Qt
))
1596 return Fsymbol_value (form
);
1597 val
= Fsymbol_value (form
);
1599 XSETFASTINT (val
, 0);
1600 else if (EQ (val
, Qt
))
1601 XSETFASTINT (val
, 1);
1608 if (consing_since_gc
> gc_cons_threshold
)
1611 Fgarbage_collect ();
1615 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1617 if (max_lisp_eval_depth
< 100)
1618 max_lisp_eval_depth
= 100;
1619 if (lisp_eval_depth
> max_lisp_eval_depth
)
1620 error ("Lisp nesting exceeds max-lisp-eval-depth");
1623 original_fun
= Fcar (form
);
1624 original_args
= Fcdr (form
);
1626 backtrace
.next
= backtrace_list
;
1627 backtrace_list
= &backtrace
;
1628 backtrace
.function
= &original_fun
; /* This also protects them from gc */
1629 backtrace
.args
= &original_args
;
1630 backtrace
.nargs
= UNEVALLED
;
1631 backtrace
.evalargs
= 1;
1632 backtrace
.debug_on_exit
= 0;
1634 if (debug_on_next_call
)
1635 do_debug_on_call (Qt
);
1637 /* At this point, only original_fun and original_args
1638 have values that will be used below */
1640 fun
= Findirect_function (original_fun
);
1644 Lisp_Object numargs
;
1645 Lisp_Object argvals
[7];
1646 Lisp_Object args_left
;
1647 register int i
, maxargs
;
1649 args_left
= original_args
;
1650 numargs
= Flength (args_left
);
1652 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
1653 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
1654 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1656 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1658 backtrace
.evalargs
= 0;
1659 val
= (*XSUBR (fun
)->function
) (args_left
);
1663 if (XSUBR (fun
)->max_args
== MANY
)
1665 /* Pass a vector of evaluated arguments */
1667 register int argnum
= 0;
1669 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1671 GCPRO3 (args_left
, fun
, fun
);
1675 while (!NILP (args_left
))
1677 vals
[argnum
++] = Feval (Fcar (args_left
));
1678 args_left
= Fcdr (args_left
);
1679 gcpro3
.nvars
= argnum
;
1682 backtrace
.args
= vals
;
1683 backtrace
.nargs
= XINT (numargs
);
1685 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
1690 GCPRO3 (args_left
, fun
, fun
);
1691 gcpro3
.var
= argvals
;
1694 maxargs
= XSUBR (fun
)->max_args
;
1695 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
1697 argvals
[i
] = Feval (Fcar (args_left
));
1703 backtrace
.args
= argvals
;
1704 backtrace
.nargs
= XINT (numargs
);
1709 val
= (*XSUBR (fun
)->function
) ();
1712 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
1715 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
1718 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1722 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1723 argvals
[2], argvals
[3]);
1726 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1727 argvals
[3], argvals
[4]);
1730 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1731 argvals
[3], argvals
[4], argvals
[5]);
1734 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1735 argvals
[3], argvals
[4], argvals
[5],
1740 /* Someone has created a subr that takes more arguments than
1741 is supported by this code. We need to either rewrite the
1742 subr to use a different argument protocol, or add more
1743 cases to this switch. */
1747 if (COMPILEDP (fun
))
1748 val
= apply_lambda (fun
, original_args
, 1);
1752 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1753 funcar
= Fcar (fun
);
1754 if (!SYMBOLP (funcar
))
1755 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1756 if (EQ (funcar
, Qautoload
))
1758 do_autoload (fun
, original_fun
);
1761 if (EQ (funcar
, Qmacro
))
1762 val
= Feval (apply1 (Fcdr (fun
), original_args
));
1763 else if (EQ (funcar
, Qlambda
))
1764 val
= apply_lambda (fun
, original_args
, 1);
1765 else if (EQ (funcar
, Qmocklisp
))
1766 val
= ml_apply (fun
, original_args
);
1768 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1771 if (!EQ (Vmocklisp_arguments
, Qt
))
1774 XSETFASTINT (val
, 0);
1775 else if (EQ (val
, Qt
))
1776 XSETFASTINT (val
, 1);
1779 if (backtrace
.debug_on_exit
)
1780 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
1781 backtrace_list
= backtrace
.next
;
1785 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
1786 "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
1787 Then return the value FUNCTION returns.\n\
1788 Thus, (apply '+ 1 2 '(3 4)) returns 10.")
1793 register int i
, numargs
;
1794 register Lisp_Object spread_arg
;
1795 register Lisp_Object
*funcall_args
;
1797 struct gcpro gcpro1
;
1801 spread_arg
= args
[nargs
- 1];
1802 CHECK_LIST (spread_arg
, nargs
);
1804 numargs
= XINT (Flength (spread_arg
));
1807 return Ffuncall (nargs
- 1, args
);
1808 else if (numargs
== 1)
1810 args
[nargs
- 1] = XCONS (spread_arg
)->car
;
1811 return Ffuncall (nargs
, args
);
1814 numargs
+= nargs
- 2;
1816 fun
= indirect_function (fun
);
1817 if (EQ (fun
, Qunbound
))
1819 /* Let funcall get the error */
1826 if (numargs
< XSUBR (fun
)->min_args
1827 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
1828 goto funcall
; /* Let funcall get the error */
1829 else if (XSUBR (fun
)->max_args
> numargs
)
1831 /* Avoid making funcall cons up a yet another new vector of arguments
1832 by explicitly supplying nil's for optional values */
1833 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
1834 * sizeof (Lisp_Object
));
1835 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
1836 funcall_args
[++i
] = Qnil
;
1837 GCPRO1 (*funcall_args
);
1838 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
1842 /* We add 1 to numargs because funcall_args includes the
1843 function itself as well as its arguments. */
1846 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
1847 * sizeof (Lisp_Object
));
1848 GCPRO1 (*funcall_args
);
1849 gcpro1
.nvars
= 1 + numargs
;
1852 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
1853 /* Spread the last arg we got. Its first element goes in
1854 the slot that it used to occupy, hence this value of I. */
1856 while (!NILP (spread_arg
))
1858 funcall_args
[i
++] = XCONS (spread_arg
)->car
;
1859 spread_arg
= XCONS (spread_arg
)->cdr
;
1862 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
1865 /* Run hook variables in various ways. */
1867 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
1869 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 1, MANY
, 0,
1870 "Run each hook in HOOKS. Major mode functions use this.\n\
1871 Each argument should be a symbol, a hook variable.\n\
1872 These symbols are processed in the order specified.\n\
1873 If a hook symbol has a non-nil value, that value may be a function\n\
1874 or a list of functions to be called to run the hook.\n\
1875 If the value is a function, it is called with no arguments.\n\
1876 If it is a list, the elements are called, in order, with no arguments.\n\
1878 To make a hook variable buffer-local, use `make-local-hook',\n\
1879 not `make-local-variable'.")
1884 Lisp_Object hook
[1];
1887 for (i
= 0; i
< nargs
; i
++)
1890 run_hook_with_args (1, hook
, to_completion
);
1896 DEFUN ("run-hook-with-args",
1897 Frun_hook_with_args
, Srun_hook_with_args
, 1, MANY
, 0,
1898 "Run HOOK with the specified arguments ARGS.\n\
1899 HOOK should be a symbol, a hook variable. If HOOK has a non-nil\n\
1900 value, that value may be a function or a list of functions to be\n\
1901 called to run the hook. If the value is a function, it is called with\n\
1902 the given arguments and its return value is returned. If it is a list\n\
1903 of functions, those functions are called, in order,\n\
1904 with the given arguments ARGS.\n\
1905 It is best not to depend on the value return by `run-hook-with-args',\n\
1906 as that may change.\n\
1908 To make a hook variable buffer-local, use `make-local-hook',\n\
1909 not `make-local-variable'.")
1914 return run_hook_with_args (nargs
, args
, to_completion
);
1917 DEFUN ("run-hook-with-args-until-success",
1918 Frun_hook_with_args_until_success
, Srun_hook_with_args_until_success
,
1920 "Run HOOK with the specified arguments ARGS.\n\
1921 HOOK should be a symbol, a hook variable. Its value should\n\
1922 be a list of functions. We call those functions, one by one,\n\
1923 passing arguments ARGS to each of them, until one of them\n\
1924 returns a non-nil value. Then we return that value.\n\
1925 If all the functions return nil, we return nil.\n\
1927 To make a hook variable buffer-local, use `make-local-hook',\n\
1928 not `make-local-variable'.")
1933 return run_hook_with_args (nargs
, args
, until_success
);
1936 DEFUN ("run-hook-with-args-until-failure",
1937 Frun_hook_with_args_until_failure
, Srun_hook_with_args_until_failure
,
1939 "Run HOOK with the specified arguments ARGS.\n\
1940 HOOK should be a symbol, a hook variable. Its value should\n\
1941 be a list of functions. We call those functions, one by one,\n\
1942 passing arguments ARGS to each of them, until one of them\n\
1943 returns nil. Then we return nil.\n\
1944 If all the functions return non-nil, we return non-nil.\n\
1946 To make a hook variable buffer-local, use `make-local-hook',\n\
1947 not `make-local-variable'.")
1952 return run_hook_with_args (nargs
, args
, until_failure
);
1955 /* ARGS[0] should be a hook symbol.
1956 Call each of the functions in the hook value, passing each of them
1957 as arguments all the rest of ARGS (all NARGS - 1 elements).
1958 COND specifies a condition to test after each call
1959 to decide whether to stop.
1960 The caller (or its caller, etc) must gcpro all of ARGS,
1961 except that it isn't necessary to gcpro ARGS[0]. */
1964 run_hook_with_args (nargs
, args
, cond
)
1967 enum run_hooks_condition cond
;
1969 Lisp_Object sym
, val
, ret
;
1970 struct gcpro gcpro1
, gcpro2
;
1973 val
= find_symbol_value (sym
);
1974 ret
= (cond
== until_failure
? Qt
: Qnil
);
1976 if (EQ (val
, Qunbound
) || NILP (val
))
1978 else if (!CONSP (val
) || EQ (XCONS (val
)->car
, Qlambda
))
1981 return Ffuncall (nargs
, args
);
1988 CONSP (val
) && ((cond
== to_completion
)
1989 || (cond
== until_success
? NILP (ret
)
1991 val
= XCONS (val
)->cdr
)
1993 if (EQ (XCONS (val
)->car
, Qt
))
1995 /* t indicates this hook has a local binding;
1996 it means to run the global binding too. */
1997 Lisp_Object globals
;
1999 for (globals
= Fdefault_value (sym
);
2000 CONSP (globals
) && ((cond
== to_completion
)
2001 || (cond
== until_success
? NILP (ret
)
2003 globals
= XCONS (globals
)->cdr
)
2005 args
[0] = XCONS (globals
)->car
;
2006 /* In a global value, t should not occur. If it does, we
2007 must ignore it to avoid an endless loop. */
2008 if (!EQ (args
[0], Qt
))
2009 ret
= Ffuncall (nargs
, args
);
2014 args
[0] = XCONS (val
)->car
;
2015 ret
= Ffuncall (nargs
, args
);
2024 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2025 present value of that symbol.
2026 Call each element of FUNLIST,
2027 passing each of them the rest of ARGS.
2028 The caller (or its caller, etc) must gcpro all of ARGS,
2029 except that it isn't necessary to gcpro ARGS[0]. */
2032 run_hook_list_with_args (funlist
, nargs
, args
)
2033 Lisp_Object funlist
;
2039 struct gcpro gcpro1
, gcpro2
;
2044 for (val
= funlist
; CONSP (val
); val
= XCONS (val
)->cdr
)
2046 if (EQ (XCONS (val
)->car
, Qt
))
2048 /* t indicates this hook has a local binding;
2049 it means to run the global binding too. */
2050 Lisp_Object globals
;
2052 for (globals
= Fdefault_value (sym
);
2054 globals
= XCONS (globals
)->cdr
)
2056 args
[0] = XCONS (globals
)->car
;
2057 /* In a global value, t should not occur. If it does, we
2058 must ignore it to avoid an endless loop. */
2059 if (!EQ (args
[0], Qt
))
2060 Ffuncall (nargs
, args
);
2065 args
[0] = XCONS (val
)->car
;
2066 Ffuncall (nargs
, args
);
2073 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2076 run_hook_with_args_2 (hook
, arg1
, arg2
)
2077 Lisp_Object hook
, arg1
, arg2
;
2079 Lisp_Object temp
[3];
2084 Frun_hook_with_args (3, temp
);
2087 /* Apply fn to arg */
2090 Lisp_Object fn
, arg
;
2092 struct gcpro gcpro1
;
2096 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2100 Lisp_Object args
[2];
2104 RETURN_UNGCPRO (Fapply (2, args
));
2106 #else /* not NO_ARG_ARRAY */
2107 RETURN_UNGCPRO (Fapply (2, &fn
));
2108 #endif /* not NO_ARG_ARRAY */
2111 /* Call function fn on no arguments */
2116 struct gcpro gcpro1
;
2119 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2122 /* Call function fn with 1 argument arg1 */
2126 Lisp_Object fn
, arg1
;
2128 struct gcpro gcpro1
;
2130 Lisp_Object args
[2];
2136 RETURN_UNGCPRO (Ffuncall (2, args
));
2137 #else /* not NO_ARG_ARRAY */
2140 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2141 #endif /* not NO_ARG_ARRAY */
2144 /* Call function fn with 2 arguments arg1, arg2 */
2147 call2 (fn
, arg1
, arg2
)
2148 Lisp_Object fn
, arg1
, arg2
;
2150 struct gcpro gcpro1
;
2152 Lisp_Object args
[3];
2158 RETURN_UNGCPRO (Ffuncall (3, args
));
2159 #else /* not NO_ARG_ARRAY */
2162 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2163 #endif /* not NO_ARG_ARRAY */
2166 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2169 call3 (fn
, arg1
, arg2
, arg3
)
2170 Lisp_Object fn
, arg1
, arg2
, arg3
;
2172 struct gcpro gcpro1
;
2174 Lisp_Object args
[4];
2181 RETURN_UNGCPRO (Ffuncall (4, args
));
2182 #else /* not NO_ARG_ARRAY */
2185 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2186 #endif /* not NO_ARG_ARRAY */
2189 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2192 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2193 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2195 struct gcpro gcpro1
;
2197 Lisp_Object args
[5];
2205 RETURN_UNGCPRO (Ffuncall (5, args
));
2206 #else /* not NO_ARG_ARRAY */
2209 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2210 #endif /* not NO_ARG_ARRAY */
2213 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2216 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2217 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2219 struct gcpro gcpro1
;
2221 Lisp_Object args
[6];
2230 RETURN_UNGCPRO (Ffuncall (6, args
));
2231 #else /* not NO_ARG_ARRAY */
2234 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2235 #endif /* not NO_ARG_ARRAY */
2238 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2241 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2242 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2244 struct gcpro gcpro1
;
2246 Lisp_Object args
[7];
2256 RETURN_UNGCPRO (Ffuncall (7, args
));
2257 #else /* not NO_ARG_ARRAY */
2260 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2261 #endif /* not NO_ARG_ARRAY */
2264 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2265 "Call first argument as a function, passing remaining arguments to it.\n\
2266 Return the value that function returns.\n\
2267 Thus, (funcall 'cons 'x 'y) returns (x . y).")
2274 int numargs
= nargs
- 1;
2275 Lisp_Object lisp_numargs
;
2277 struct backtrace backtrace
;
2278 register Lisp_Object
*internal_args
;
2282 if (consing_since_gc
> gc_cons_threshold
)
2283 Fgarbage_collect ();
2285 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2287 if (max_lisp_eval_depth
< 100)
2288 max_lisp_eval_depth
= 100;
2289 if (lisp_eval_depth
> max_lisp_eval_depth
)
2290 error ("Lisp nesting exceeds max-lisp-eval-depth");
2293 backtrace
.next
= backtrace_list
;
2294 backtrace_list
= &backtrace
;
2295 backtrace
.function
= &args
[0];
2296 backtrace
.args
= &args
[1];
2297 backtrace
.nargs
= nargs
- 1;
2298 backtrace
.evalargs
= 0;
2299 backtrace
.debug_on_exit
= 0;
2301 if (debug_on_next_call
)
2302 do_debug_on_call (Qlambda
);
2308 fun
= Findirect_function (fun
);
2312 if (numargs
< XSUBR (fun
)->min_args
2313 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2315 XSETFASTINT (lisp_numargs
, numargs
);
2316 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (lisp_numargs
, Qnil
)));
2319 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2320 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2322 if (XSUBR (fun
)->max_args
== MANY
)
2324 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
2328 if (XSUBR (fun
)->max_args
> numargs
)
2330 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2331 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
2332 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2333 internal_args
[i
] = Qnil
;
2336 internal_args
= args
+ 1;
2337 switch (XSUBR (fun
)->max_args
)
2340 val
= (*XSUBR (fun
)->function
) ();
2343 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
2346 val
= (*XSUBR (fun
)->function
) (internal_args
[0],
2350 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2354 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2359 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2360 internal_args
[2], internal_args
[3],
2364 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2365 internal_args
[2], internal_args
[3],
2366 internal_args
[4], internal_args
[5]);
2369 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2370 internal_args
[2], internal_args
[3],
2371 internal_args
[4], internal_args
[5],
2377 /* If a subr takes more than 6 arguments without using MANY
2378 or UNEVALLED, we need to extend this function to support it.
2379 Until this is done, there is no way to call the function. */
2383 if (COMPILEDP (fun
))
2384 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2388 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2389 funcar
= Fcar (fun
);
2390 if (!SYMBOLP (funcar
))
2391 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2392 if (EQ (funcar
, Qlambda
))
2393 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2394 else if (EQ (funcar
, Qmocklisp
))
2395 val
= ml_apply (fun
, Flist (numargs
, args
+ 1));
2396 else if (EQ (funcar
, Qautoload
))
2398 do_autoload (fun
, args
[0]);
2402 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2406 if (backtrace
.debug_on_exit
)
2407 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2408 backtrace_list
= backtrace
.next
;
2413 apply_lambda (fun
, args
, eval_flag
)
2414 Lisp_Object fun
, args
;
2417 Lisp_Object args_left
;
2418 Lisp_Object numargs
;
2419 register Lisp_Object
*arg_vector
;
2420 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2422 register Lisp_Object tem
;
2424 numargs
= Flength (args
);
2425 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2428 GCPRO3 (*arg_vector
, args_left
, fun
);
2431 for (i
= 0; i
< XINT (numargs
);)
2433 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2434 if (eval_flag
) tem
= Feval (tem
);
2435 arg_vector
[i
++] = tem
;
2443 backtrace_list
->args
= arg_vector
;
2444 backtrace_list
->nargs
= i
;
2446 backtrace_list
->evalargs
= 0;
2447 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
2449 /* Do the debug-on-exit now, while arg_vector still exists. */
2450 if (backtrace_list
->debug_on_exit
)
2451 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
2452 /* Don't do it again when we return to eval. */
2453 backtrace_list
->debug_on_exit
= 0;
2457 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2458 and return the result of evaluation.
2459 FUN must be either a lambda-expression or a compiled-code object. */
2462 funcall_lambda (fun
, nargs
, arg_vector
)
2465 register Lisp_Object
*arg_vector
;
2467 Lisp_Object val
, tem
;
2468 register Lisp_Object syms_left
;
2469 Lisp_Object numargs
;
2470 register Lisp_Object next
;
2471 int count
= specpdl_ptr
- specpdl
;
2473 int optional
= 0, rest
= 0;
2475 specbind (Qmocklisp_arguments
, Qt
); /* t means NOT mocklisp! */
2477 XSETFASTINT (numargs
, nargs
);
2480 syms_left
= Fcar (Fcdr (fun
));
2481 else if (COMPILEDP (fun
))
2482 syms_left
= XVECTOR (fun
)->contents
[COMPILED_ARGLIST
];
2486 for (; !NILP (syms_left
); syms_left
= Fcdr (syms_left
))
2489 next
= Fcar (syms_left
);
2490 while (!SYMBOLP (next
))
2491 next
= Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2492 if (EQ (next
, Qand_rest
))
2494 else if (EQ (next
, Qand_optional
))
2498 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
2503 tem
= arg_vector
[i
++];
2504 specbind (next
, tem
);
2507 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2509 specbind (next
, Qnil
);
2513 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2516 val
= Fprogn (Fcdr (Fcdr (fun
)));
2519 /* If we have not actually read the bytecode string
2520 and constants vector yet, fetch them from the file. */
2521 if (CONSP (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
]))
2522 Ffetch_bytecode (fun
);
2523 val
= Fbyte_code (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
],
2524 XVECTOR (fun
)->contents
[COMPILED_CONSTANTS
],
2525 XVECTOR (fun
)->contents
[COMPILED_STACK_DEPTH
]);
2527 return unbind_to (count
, val
);
2530 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
2532 "If byte-compiled OBJECT is lazy-loaded, fetch it now.")
2538 if (COMPILEDP (object
)
2539 && CONSP (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]))
2541 tem
= read_doc_string (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]);
2543 error ("invalid byte code");
2544 XVECTOR (object
)->contents
[COMPILED_BYTECODE
] = XCONS (tem
)->car
;
2545 XVECTOR (object
)->contents
[COMPILED_CONSTANTS
] = XCONS (tem
)->cdr
;
2553 register int count
= specpdl_ptr
- specpdl
;
2554 if (specpdl_size
>= max_specpdl_size
)
2556 if (max_specpdl_size
< 400)
2557 max_specpdl_size
= 400;
2558 if (specpdl_size
>= max_specpdl_size
)
2560 if (!NILP (Vdebug_on_error
))
2561 /* Leave room for some specpdl in the debugger. */
2562 max_specpdl_size
= specpdl_size
+ 100;
2564 Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil
));
2568 if (specpdl_size
> max_specpdl_size
)
2569 specpdl_size
= max_specpdl_size
;
2570 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
2571 specpdl_ptr
= specpdl
+ count
;
2575 specbind (symbol
, value
)
2576 Lisp_Object symbol
, value
;
2580 CHECK_SYMBOL (symbol
, 0);
2582 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2584 specpdl_ptr
->symbol
= symbol
;
2585 specpdl_ptr
->func
= 0;
2586 specpdl_ptr
->old_value
= ovalue
= find_symbol_value (symbol
);
2588 if (BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
))
2589 store_symval_forwarding (symbol
, ovalue
, value
);
2591 Fset (symbol
, value
);
2595 record_unwind_protect (function
, arg
)
2596 Lisp_Object (*function
)();
2599 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2601 specpdl_ptr
->func
= function
;
2602 specpdl_ptr
->symbol
= Qnil
;
2603 specpdl_ptr
->old_value
= arg
;
2608 unbind_to (count
, value
)
2612 int quitf
= !NILP (Vquit_flag
);
2613 struct gcpro gcpro1
;
2619 while (specpdl_ptr
!= specpdl
+ count
)
2622 if (specpdl_ptr
->func
!= 0)
2623 (*specpdl_ptr
->func
) (specpdl_ptr
->old_value
);
2624 /* Note that a "binding" of nil is really an unwind protect,
2625 so in that case the "old value" is a list of forms to evaluate. */
2626 else if (NILP (specpdl_ptr
->symbol
))
2627 Fprogn (specpdl_ptr
->old_value
);
2629 Fset (specpdl_ptr
->symbol
, specpdl_ptr
->old_value
);
2631 if (NILP (Vquit_flag
) && quitf
) Vquit_flag
= Qt
;
2640 /* Get the value of symbol's global binding, even if that binding
2641 is not now dynamically visible. */
2644 top_level_value (symbol
)
2647 register struct specbinding
*ptr
= specpdl
;
2649 CHECK_SYMBOL (symbol
, 0);
2650 for (; ptr
!= specpdl_ptr
; ptr
++)
2652 if (EQ (ptr
->symbol
, symbol
))
2653 return ptr
->old_value
;
2655 return Fsymbol_value (symbol
);
2659 top_level_set (symbol
, newval
)
2660 Lisp_Object symbol
, newval
;
2662 register struct specbinding
*ptr
= specpdl
;
2664 CHECK_SYMBOL (symbol
, 0);
2665 for (; ptr
!= specpdl_ptr
; ptr
++)
2667 if (EQ (ptr
->symbol
, symbol
))
2669 ptr
->old_value
= newval
;
2673 return Fset (symbol
, newval
);
2678 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
2679 "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\
2680 The debugger is entered when that frame exits, if the flag is non-nil.")
2682 Lisp_Object level
, flag
;
2684 register struct backtrace
*backlist
= backtrace_list
;
2687 CHECK_NUMBER (level
, 0);
2689 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
2691 backlist
= backlist
->next
;
2695 backlist
->debug_on_exit
= !NILP (flag
);
2700 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
2701 "Print a trace of Lisp function calls currently active.\n\
2702 Output stream used is value of `standard-output'.")
2705 register struct backtrace
*backlist
= backtrace_list
;
2709 extern Lisp_Object Vprint_level
;
2710 struct gcpro gcpro1
;
2712 XSETFASTINT (Vprint_level
, 3);
2719 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
2720 if (backlist
->nargs
== UNEVALLED
)
2722 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
2723 write_string ("\n", -1);
2727 tem
= *backlist
->function
;
2728 Fprin1 (tem
, Qnil
); /* This can QUIT */
2729 write_string ("(", -1);
2730 if (backlist
->nargs
== MANY
)
2732 for (tail
= *backlist
->args
, i
= 0;
2734 tail
= Fcdr (tail
), i
++)
2736 if (i
) write_string (" ", -1);
2737 Fprin1 (Fcar (tail
), Qnil
);
2742 for (i
= 0; i
< backlist
->nargs
; i
++)
2744 if (i
) write_string (" ", -1);
2745 Fprin1 (backlist
->args
[i
], Qnil
);
2748 write_string (")\n", -1);
2750 backlist
= backlist
->next
;
2753 Vprint_level
= Qnil
;
2758 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, "",
2759 "Return the function and arguments N frames up from current execution point.\n\
2760 If that frame has not evaluated the arguments yet (or is a special form),\n\
2761 the value is (nil FUNCTION ARG-FORMS...).\n\
2762 If that frame has evaluated its arguments and called its function already,\n\
2763 the value is (t FUNCTION ARG-VALUES...).\n\
2764 A &rest arg is represented as the tail of the list ARG-VALUES.\n\
2765 FUNCTION is whatever was supplied as car of evaluated list,\n\
2766 or a lambda expression for macro calls.\n\
2767 If N is more than the number of frames, the value is nil.")
2769 Lisp_Object nframes
;
2771 register struct backtrace
*backlist
= backtrace_list
;
2775 CHECK_NATNUM (nframes
, 0);
2777 /* Find the frame requested. */
2778 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
2779 backlist
= backlist
->next
;
2783 if (backlist
->nargs
== UNEVALLED
)
2784 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
2787 if (backlist
->nargs
== MANY
)
2788 tem
= *backlist
->args
;
2790 tem
= Flist (backlist
->nargs
, backlist
->args
);
2792 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
2798 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
2799 "Limit on number of Lisp variable bindings & unwind-protects before error.");
2801 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
2802 "Limit on depth in `eval', `apply' and `funcall' before error.\n\
2803 This limit is to catch infinite recursions for you before they cause\n\
2804 actual stack overflow in C, which would be fatal for Emacs.\n\
2805 You can safely make it considerably larger than its default value,\n\
2806 if that proves inconveniently small.");
2808 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
2809 "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
2810 Typing C-g sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
2813 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
2814 "Non-nil inhibits C-g quitting from happening immediately.\n\
2815 Note that `quit-flag' will still be set by typing C-g,\n\
2816 so a quit will be signaled as soon as `inhibit-quit' is nil.\n\
2817 To prevent this happening, set `quit-flag' to nil\n\
2818 before making `inhibit-quit' nil.");
2819 Vinhibit_quit
= Qnil
;
2821 Qinhibit_quit
= intern ("inhibit-quit");
2822 staticpro (&Qinhibit_quit
);
2824 Qautoload
= intern ("autoload");
2825 staticpro (&Qautoload
);
2827 Qdebug_on_error
= intern ("debug-on-error");
2828 staticpro (&Qdebug_on_error
);
2830 Qmacro
= intern ("macro");
2831 staticpro (&Qmacro
);
2833 /* Note that the process handling also uses Qexit, but we don't want
2834 to staticpro it twice, so we just do it here. */
2835 Qexit
= intern ("exit");
2838 Qinteractive
= intern ("interactive");
2839 staticpro (&Qinteractive
);
2841 Qcommandp
= intern ("commandp");
2842 staticpro (&Qcommandp
);
2844 Qdefun
= intern ("defun");
2845 staticpro (&Qdefun
);
2847 Qand_rest
= intern ("&rest");
2848 staticpro (&Qand_rest
);
2850 Qand_optional
= intern ("&optional");
2851 staticpro (&Qand_optional
);
2853 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
2854 "*Non-nil means automatically display a backtrace buffer\n\
2855 after any error that is handled by the editor command loop.\n\
2856 If the value is a list, an error only means to display a backtrace\n\
2857 if one of its condition symbols appears in the list.");
2858 Vstack_trace_on_error
= Qnil
;
2860 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
2861 "*Non-nil means enter debugger if an error is signaled.\n\
2862 Does not apply to errors handled by `condition-case'.\n\
2863 If the value is a list, an error only means to enter the debugger\n\
2864 if one of its condition symbols appears in the list.\n\
2865 See also variable `debug-on-quit'.");
2866 Vdebug_on_error
= Qnil
;
2868 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
2869 "*List of errors for which the debugger should not be called.\n\
2870 Each element may be a condition-name or a regexp that matches error messages.\n\
2871 If any element applies to a given error, that error skips the debugger\n\
2872 and just returns to top level.\n\
2873 This overrides the variable `debug-on-error'.\n\
2874 It does not apply to errors handled by `condition-case'.");
2875 Vdebug_ignored_errors
= Qnil
;
2877 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
2878 "*Non-nil means enter debugger if quit is signaled (C-g, for example).\n\
2879 Does not apply if quit is handled by a `condition-case'.");
2882 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
2883 "Non-nil means enter debugger before next `eval', `apply' or `funcall'.");
2885 DEFVAR_LISP ("debugger", &Vdebugger
,
2886 "Function to call to invoke debugger.\n\
2887 If due to frame exit, args are `exit' and the value being returned;\n\
2888 this function's value will be returned instead of that.\n\
2889 If due to error, args are `error' and a list of the args to `signal'.\n\
2890 If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
2891 If due to `eval' entry, one arg, t.");
2894 Qmocklisp_arguments
= intern ("mocklisp-arguments");
2895 staticpro (&Qmocklisp_arguments
);
2896 DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments
,
2897 "While in a mocklisp function, the list of its unevaluated args.");
2898 Vmocklisp_arguments
= Qt
;
2900 DEFVAR_LISP ("run-hooks", &Vrun_hooks
,
2901 "Set to the function `run-hooks', if that function has been defined.\n\
2902 Otherwise, nil (in a bare Emacs without preloaded Lisp code).");
2904 staticpro (&Vautoload_queue
);
2905 Vautoload_queue
= Qnil
;
2916 defsubr (&Sfunction
);
2918 defsubr (&Sdefmacro
);
2920 defsubr (&Sdefconst
);
2921 defsubr (&Suser_variable_p
);
2925 defsubr (&Smacroexpand
);
2928 defsubr (&Sunwind_protect
);
2929 defsubr (&Scondition_case
);
2931 defsubr (&Sinteractive_p
);
2932 defsubr (&Scommandp
);
2933 defsubr (&Sautoload
);
2936 defsubr (&Sfuncall
);
2937 defsubr (&Srun_hooks
);
2938 defsubr (&Srun_hook_with_args
);
2939 defsubr (&Srun_hook_with_args_until_success
);
2940 defsubr (&Srun_hook_with_args_until_failure
);
2941 defsubr (&Sfetch_bytecode
);
2942 defsubr (&Sbacktrace_debug
);
2943 defsubr (&Sbacktrace
);
2944 defsubr (&Sbacktrace_frame
);