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 /* Nonzero means enter debugger if a quit signal
139 is handled by the command loop's error handler. */
142 /* The value of num_nonmacro_input_chars as of the last time we
143 started to enter the debugger. If we decide to enter the debugger
144 again when this is still equal to num_nonmacro_input_chars, then we
145 know that the debugger itself has an error, and we should just
146 signal the error instead of entering an infinite loop of debugger
148 int when_entered_debugger
;
150 Lisp_Object Vdebugger
;
152 void specbind (), record_unwind_protect ();
154 Lisp_Object
run_hook_with_args ();
156 Lisp_Object
funcall_lambda ();
157 extern Lisp_Object
ml_apply (); /* Apply a mocklisp function to unevaluated argument list */
162 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
163 specpdl_ptr
= specpdl
;
164 max_specpdl_size
= 600;
165 max_lisp_eval_depth
= 200;
172 specpdl_ptr
= specpdl
;
177 debug_on_next_call
= 0;
179 /* This is less than the initial value of num_nonmacro_input_chars. */
180 when_entered_debugger
= -1;
187 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
188 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
189 if (specpdl_size
+ 40 > max_specpdl_size
)
190 max_specpdl_size
= specpdl_size
+ 40;
191 debug_on_next_call
= 0;
192 when_entered_debugger
= num_nonmacro_input_chars
;
193 return apply1 (Vdebugger
, arg
);
196 do_debug_on_call (code
)
199 debug_on_next_call
= 0;
200 backtrace_list
->debug_on_exit
= 1;
201 call_debugger (Fcons (code
, Qnil
));
204 /* NOTE!!! Every function that can call EVAL must protect its args
205 and temporaries from garbage collection while it needs them.
206 The definition of `For' shows what you have to do. */
208 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
209 "Eval args until one of them yields non-nil, then return that value.\n\
210 The remaining args are not evalled at all.\n\
211 If all args return nil, return nil.")
215 register Lisp_Object val
;
216 Lisp_Object args_left
;
227 val
= Feval (Fcar (args_left
));
230 args_left
= Fcdr (args_left
);
232 while (!NILP(args_left
));
238 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
239 "Eval args until one of them yields nil, then return nil.\n\
240 The remaining args are not evalled at all.\n\
241 If no arg yields nil, return the last arg's value.")
245 register Lisp_Object val
;
246 Lisp_Object args_left
;
257 val
= Feval (Fcar (args_left
));
260 args_left
= Fcdr (args_left
);
262 while (!NILP(args_left
));
268 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
269 "(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...\n\
270 Returns the value of THEN or the value of the last of the ELSE's.\n\
271 THEN must be one expression, but ELSE... can be zero or more expressions.\n\
272 If COND yields nil, and there are no ELSE's, the value is nil.")
276 register Lisp_Object cond
;
280 cond
= Feval (Fcar (args
));
284 return Feval (Fcar (Fcdr (args
)));
285 return Fprogn (Fcdr (Fcdr (args
)));
288 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
289 "(cond CLAUSES...): try each clause until one succeeds.\n\
290 Each clause looks like (CONDITION BODY...). CONDITION is evaluated\n\
291 and, if the value is non-nil, this clause succeeds:\n\
292 then the expressions in BODY are evaluated and the last one's\n\
293 value is the value of the cond-form.\n\
294 If no clause succeeds, cond returns nil.\n\
295 If a clause has one element, as in (CONDITION),\n\
296 CONDITION's value if non-nil is returned from the cond-form.")
300 register Lisp_Object clause
, val
;
307 clause
= Fcar (args
);
308 val
= Feval (Fcar (clause
));
311 if (!EQ (XCONS (clause
)->cdr
, Qnil
))
312 val
= Fprogn (XCONS (clause
)->cdr
);
315 args
= XCONS (args
)->cdr
;
322 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
323 "(progn BODY...): eval BODY forms sequentially and return value of last one.")
327 register Lisp_Object val
, tem
;
328 Lisp_Object args_left
;
331 /* In Mocklisp code, symbols at the front of the progn arglist
332 are to be bound to zero. */
333 if (!EQ (Vmocklisp_arguments
, Qt
))
335 val
= make_number (0);
336 while (!NILP (args
) && (tem
= Fcar (args
), SYMBOLP (tem
)))
339 specbind (tem
, val
), args
= Fcdr (args
);
351 val
= Feval (Fcar (args_left
));
352 args_left
= Fcdr (args_left
);
354 while (!NILP(args_left
));
360 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
361 "(prog1 FIRST BODY...): eval FIRST and BODY sequentially; value from FIRST.\n\
362 The value of FIRST is saved during the evaluation of the remaining args,\n\
363 whose values are discarded.")
368 register Lisp_Object args_left
;
369 struct gcpro gcpro1
, gcpro2
;
370 register int argnum
= 0;
382 val
= Feval (Fcar (args_left
));
384 Feval (Fcar (args_left
));
385 args_left
= Fcdr (args_left
);
387 while (!NILP(args_left
));
393 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
394 "(prog2 X Y BODY...): eval X, Y and BODY sequentially; value from Y.\n\
395 The value of Y is saved during the evaluation of the remaining args,\n\
396 whose values are discarded.")
401 register Lisp_Object args_left
;
402 struct gcpro gcpro1
, gcpro2
;
403 register int argnum
= -1;
417 val
= Feval (Fcar (args_left
));
419 Feval (Fcar (args_left
));
420 args_left
= Fcdr (args_left
);
422 while (!NILP (args_left
));
428 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
429 "(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.\n\
430 The symbols SYM are variables; they are literal (not evaluated).\n\
431 The values VAL are expressions; they are evaluated.\n\
432 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.\n\
433 The second VAL is not computed until after the first SYM is set, and so on;\n\
434 each VAL can use the new value of variables set earlier in the `setq'.\n\
435 The return value of the `setq' form is the value of the last VAL.")
439 register Lisp_Object args_left
;
440 register Lisp_Object val
, sym
;
451 val
= Feval (Fcar (Fcdr (args_left
)));
452 sym
= Fcar (args_left
);
454 args_left
= Fcdr (Fcdr (args_left
));
456 while (!NILP(args_left
));
462 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
463 "Return the argument, without evaluating it. `(quote x)' yields `x'.")
470 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
471 "Like `quote', but preferred for objects which are functions.\n\
472 In byte compilation, `function' causes its argument to be compiled.\n\
473 `quote' cannot do that.")
480 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
481 "Return t if function in which this appears was called interactively.\n\
482 This means that the function was called with call-interactively (which\n\
483 includes being called as the binding of a key)\n\
484 and input is currently coming from the keyboard (not in keyboard macro).")
487 register struct backtrace
*btp
;
488 register Lisp_Object fun
;
493 btp
= backtrace_list
;
495 /* If this isn't a byte-compiled function, there may be a frame at
496 the top for Finteractive_p itself. If so, skip it. */
497 fun
= Findirect_function (*btp
->function
);
498 if (SUBRP (fun
) && XSUBR (fun
) == &Sinteractive_p
)
501 /* If we're running an Emacs 18-style byte-compiled function, there
502 may be a frame for Fbytecode. Now, given the strictest
503 definition, this function isn't really being called
504 interactively, but because that's the way Emacs 18 always builds
505 byte-compiled functions, we'll accept it for now. */
506 if (EQ (*btp
->function
, Qbytecode
))
509 /* If this isn't a byte-compiled function, then we may now be
510 looking at several frames for special forms. Skip past them. */
512 btp
->nargs
== UNEVALLED
)
515 /* btp now points at the frame of the innermost function that isn't
516 a special form, ignoring frames for Finteractive_p and/or
517 Fbytecode at the top. If this frame is for a built-in function
518 (such as load or eval-region) return nil. */
519 fun
= Findirect_function (*btp
->function
);
522 /* btp points to the frame of a Lisp function that called interactive-p.
523 Return t if that function was called interactively. */
524 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
529 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
530 "(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.\n\
531 The definition is (lambda ARGLIST [DOCSTRING] BODY...).\n\
532 See also the function `interactive'.")
536 register Lisp_Object fn_name
;
537 register Lisp_Object defn
;
539 fn_name
= Fcar (args
);
540 defn
= Fcons (Qlambda
, Fcdr (args
));
541 if (!NILP (Vpurify_flag
))
542 defn
= Fpurecopy (defn
);
543 Ffset (fn_name
, defn
);
544 LOADHIST_ATTACH (fn_name
);
548 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
549 "(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.\n\
550 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).\n\
551 When the macro is called, as in (NAME ARGS...),\n\
552 the function (lambda ARGLIST BODY...) is applied to\n\
553 the list ARGS... as it appears in the expression,\n\
554 and the result should be a form to be evaluated instead of the original.")
558 register Lisp_Object fn_name
;
559 register Lisp_Object defn
;
561 fn_name
= Fcar (args
);
562 defn
= Fcons (Qmacro
, Fcons (Qlambda
, Fcdr (args
)));
563 if (!NILP (Vpurify_flag
))
564 defn
= Fpurecopy (defn
);
565 Ffset (fn_name
, defn
);
566 LOADHIST_ATTACH (fn_name
);
570 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
571 "(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.\n\
572 You are not required to define a variable in order to use it,\n\
573 but the definition can supply documentation and an initial value\n\
574 in a way that tags can recognize.\n\n\
575 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.\n\
576 If SYMBOL is buffer-local, its default value is what is set;\n\
577 buffer-local values are not affected.\n\
578 INITVALUE and DOCSTRING are optional.\n\
579 If DOCSTRING starts with *, this variable is identified as a user option.\n\
580 This means that M-x set-variable and M-x edit-options recognize it.\n\
581 If INITVALUE is missing, SYMBOL's value is not set.")
585 register Lisp_Object sym
, tem
, tail
;
589 if (!NILP (Fcdr (Fcdr (tail
))))
590 error ("too many arguments");
594 tem
= Fdefault_boundp (sym
);
596 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
598 tail
= Fcdr (Fcdr (args
));
599 if (!NILP (Fcar (tail
)))
602 if (!NILP (Vpurify_flag
))
603 tem
= Fpurecopy (tem
);
604 Fput (sym
, Qvariable_documentation
, tem
);
606 LOADHIST_ATTACH (sym
);
610 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
611 "(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant variable.\n\
612 The intent is that programs do not change this value, but users may.\n\
613 Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\
614 If SYMBOL is buffer-local, its default value is what is set;\n\
615 buffer-local values are not affected.\n\
616 DOCSTRING is optional.\n\
617 If DOCSTRING starts with *, this variable is identified as a user option.\n\
618 This means that M-x set-variable and M-x edit-options recognize it.\n\n\
619 Note: do not use `defconst' for user options in libraries that are not\n\
620 normally loaded, since it is useful for users to be able to specify\n\
621 their own values for such variables before loading the library.\n\
622 Since `defconst' unconditionally assigns the variable,\n\
623 it would override the user's choice.")
627 register Lisp_Object sym
, tem
;
630 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
631 error ("too many arguments");
633 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
634 tem
= Fcar (Fcdr (Fcdr (args
)));
637 if (!NILP (Vpurify_flag
))
638 tem
= Fpurecopy (tem
);
639 Fput (sym
, Qvariable_documentation
, tem
);
641 LOADHIST_ATTACH (sym
);
645 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
646 "Returns t if VARIABLE is intended to be set and modified by users.\n\
647 \(The alternative is a variable used internally in a Lisp program.)\n\
648 Determined by whether the first character of the documentation\n\
649 for the variable is `*'.")
651 Lisp_Object variable
;
653 Lisp_Object documentation
;
655 documentation
= Fget (variable
, Qvariable_documentation
);
656 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
658 if (STRINGP (documentation
)
659 && ((unsigned char) XSTRING (documentation
)->data
[0] == '*'))
661 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
662 if (CONSP (documentation
)
663 && STRINGP (XCONS (documentation
)->car
)
664 && INTEGERP (XCONS (documentation
)->cdr
)
665 && XINT (XCONS (documentation
)->cdr
) < 0)
670 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
671 "(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
672 The value of the last form in BODY is returned.\n\
673 Each element of VARLIST is a symbol (which is bound to nil)\n\
674 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
675 Each VALUEFORM can refer to the symbols already bound by this VARLIST.")
679 Lisp_Object varlist
, val
, elt
;
680 int count
= specpdl_ptr
- specpdl
;
681 struct gcpro gcpro1
, gcpro2
, gcpro3
;
683 GCPRO3 (args
, elt
, varlist
);
685 varlist
= Fcar (args
);
686 while (!NILP (varlist
))
689 elt
= Fcar (varlist
);
691 specbind (elt
, Qnil
);
692 else if (! NILP (Fcdr (Fcdr (elt
))))
694 Fcons (build_string ("`let' bindings can have only one value-form"),
698 val
= Feval (Fcar (Fcdr (elt
)));
699 specbind (Fcar (elt
), val
);
701 varlist
= Fcdr (varlist
);
704 val
= Fprogn (Fcdr (args
));
705 return unbind_to (count
, val
);
708 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
709 "(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
710 The value of the last form in BODY is returned.\n\
711 Each element of VARLIST is a symbol (which is bound to nil)\n\
712 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
713 All the VALUEFORMs are evalled before any symbols are bound.")
717 Lisp_Object
*temps
, tem
;
718 register Lisp_Object elt
, varlist
;
719 int count
= specpdl_ptr
- specpdl
;
721 struct gcpro gcpro1
, gcpro2
;
723 varlist
= Fcar (args
);
725 /* Make space to hold the values to give the bound variables */
726 elt
= Flength (varlist
);
727 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
729 /* Compute the values and store them in `temps' */
731 GCPRO2 (args
, *temps
);
734 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
737 elt
= Fcar (varlist
);
739 temps
[argnum
++] = Qnil
;
740 else if (! NILP (Fcdr (Fcdr (elt
))))
742 Fcons (build_string ("`let' bindings can have only one value-form"),
745 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
746 gcpro2
.nvars
= argnum
;
750 varlist
= Fcar (args
);
751 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
753 elt
= Fcar (varlist
);
754 tem
= temps
[argnum
++];
758 specbind (Fcar (elt
), tem
);
761 elt
= Fprogn (Fcdr (args
));
762 return unbind_to (count
, elt
);
765 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
766 "(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.\n\
767 The order of execution is thus TEST, BODY, TEST, BODY and so on\n\
768 until TEST returns nil.")
772 Lisp_Object test
, body
, tem
;
773 struct gcpro gcpro1
, gcpro2
;
779 while (tem
= Feval (test
),
780 (!EQ (Vmocklisp_arguments
, Qt
) ? XINT (tem
) : !NILP (tem
)))
790 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
791 "Return result of expanding macros at top level of FORM.\n\
792 If FORM is not a macro call, it is returned unchanged.\n\
793 Otherwise, the macro is expanded and the expansion is considered\n\
794 in place of FORM. When a non-macro-call results, it is returned.\n\n\
795 The second optional arg ENVIRONMENT species an environment of macro\n\
796 definitions to shadow the loaded ones for use in file byte-compilation.")
799 Lisp_Object environment
;
801 /* With cleanups from Hallvard Furuseth. */
802 register Lisp_Object expander
, sym
, def
, tem
;
806 /* Come back here each time we expand a macro call,
807 in case it expands into another macro call. */
810 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
811 def
= sym
= XCONS (form
)->car
;
813 /* Trace symbols aliases to other symbols
814 until we get a symbol that is not an alias. */
815 while (SYMBOLP (def
))
819 tem
= Fassq (sym
, environment
);
822 def
= XSYMBOL (sym
)->function
;
823 if (!EQ (def
, Qunbound
))
828 /* Right now TEM is the result from SYM in ENVIRONMENT,
829 and if TEM is nil then DEF is SYM's function definition. */
832 /* SYM is not mentioned in ENVIRONMENT.
833 Look at its function definition. */
834 if (EQ (def
, Qunbound
) || !CONSP (def
))
835 /* Not defined or definition not suitable */
837 if (EQ (XCONS (def
)->car
, Qautoload
))
839 /* Autoloading function: will it be a macro when loaded? */
840 tem
= Fnth (make_number (4), def
);
841 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
842 /* Yes, load it and try again. */
846 do_autoload (def
, sym
);
853 else if (!EQ (XCONS (def
)->car
, Qmacro
))
855 else expander
= XCONS (def
)->cdr
;
859 expander
= XCONS (tem
)->cdr
;
863 form
= apply1 (expander
, XCONS (form
)->cdr
);
868 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
869 "(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.\n\
870 TAG is evalled to get the tag to use. Then the BODY is executed.\n\
871 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.\n\
872 If no throw happens, `catch' returns the value of the last BODY form.\n\
873 If a throw happens, it specifies the value to return from `catch'.")
877 register Lisp_Object tag
;
881 tag
= Feval (Fcar (args
));
883 return internal_catch (tag
, Fprogn
, Fcdr (args
));
886 /* Set up a catch, then call C function FUNC on argument ARG.
887 FUNC should return a Lisp_Object.
888 This is how catches are done from within C code. */
891 internal_catch (tag
, func
, arg
)
893 Lisp_Object (*func
) ();
896 /* This structure is made part of the chain `catchlist'. */
899 /* Fill in the components of c, and put it on the list. */
903 c
.backlist
= backtrace_list
;
904 c
.handlerlist
= handlerlist
;
905 c
.lisp_eval_depth
= lisp_eval_depth
;
906 c
.pdlcount
= specpdl_ptr
- specpdl
;
907 c
.poll_suppress_count
= poll_suppress_count
;
912 if (! _setjmp (c
.jmp
))
913 c
.val
= (*func
) (arg
);
915 /* Throw works by a longjmp that comes right here. */
920 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
921 jump to that CATCH, returning VALUE as the value of that catch.
923 This is the guts Fthrow and Fsignal; they differ only in the way
924 they choose the catch tag to throw to. A catch tag for a
925 condition-case form has a TAG of Qnil.
927 Before each catch is discarded, unbind all special bindings and
928 execute all unwind-protect clauses made above that catch. Unwind
929 the handler stack as we go, so that the proper handlers are in
930 effect for each unwind-protect clause we run. At the end, restore
931 some static info saved in CATCH, and longjmp to the location
934 This is used for correct unwinding in Fthrow and Fsignal. */
937 unwind_to_catch (catch, value
)
938 struct catchtag
*catch;
941 register int last_time
;
943 /* Save the value in the tag. */
946 /* Restore the polling-suppression count. */
947 set_poll_suppress_count (catch->poll_suppress_count
);
951 last_time
= catchlist
== catch;
953 /* Unwind the specpdl stack, and then restore the proper set of
955 unbind_to (catchlist
->pdlcount
, Qnil
);
956 handlerlist
= catchlist
->handlerlist
;
957 catchlist
= catchlist
->next
;
961 gcprolist
= catch->gcpro
;
962 backtrace_list
= catch->backlist
;
963 lisp_eval_depth
= catch->lisp_eval_depth
;
965 _longjmp (catch->jmp
, 1);
968 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
969 "(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.\n\
970 Both TAG and VALUE are evalled.")
972 register Lisp_Object tag
, value
;
974 register struct catchtag
*c
;
979 for (c
= catchlist
; c
; c
= c
->next
)
981 if (EQ (c
->tag
, tag
))
982 unwind_to_catch (c
, value
);
984 tag
= Fsignal (Qno_catch
, Fcons (tag
, Fcons (value
, Qnil
)));
989 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
990 "Do BODYFORM, protecting with UNWINDFORMS.\n\
991 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).\n\
992 If BODYFORM completes normally, its value is returned\n\
993 after executing the UNWINDFORMS.\n\
994 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.")
999 int count
= specpdl_ptr
- specpdl
;
1001 record_unwind_protect (0, Fcdr (args
));
1002 val
= Feval (Fcar (args
));
1003 return unbind_to (count
, val
);
1006 /* Chain of condition handlers currently in effect.
1007 The elements of this chain are contained in the stack frames
1008 of Fcondition_case and internal_condition_case.
1009 When an error is signaled (by calling Fsignal, below),
1010 this chain is searched for an element that applies. */
1012 struct handler
*handlerlist
;
1014 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1015 "Regain control when an error is signaled.\n\
1016 Usage looks like (condition-case VAR BODYFORM HANDLERS...).\n\
1017 executes BODYFORM and returns its value if no error happens.\n\
1018 Each element of HANDLERS looks like (CONDITION-NAME BODY...)\n\
1019 where the BODY is made of Lisp expressions.\n\n\
1020 A handler is applicable to an error\n\
1021 if CONDITION-NAME is one of the error's condition names.\n\
1022 If an error happens, the first applicable handler is run.\n\
1024 The car of a handler may be a list of condition names\n\
1025 instead of a single condition name.\n\
1027 When a handler handles an error,\n\
1028 control returns to the condition-case and the handler BODY... is executed\n\
1029 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\
1030 VAR may be nil; then you do not get access to the signal information.\n\
1032 The value of the last BODY form is returned from the condition-case.\n\
1033 See also the function `signal' for more info.")
1040 register Lisp_Object var
, bodyform
, handlers
;
1043 bodyform
= Fcar (Fcdr (args
));
1044 handlers
= Fcdr (Fcdr (args
));
1045 CHECK_SYMBOL (var
, 0);
1047 for (val
= handlers
; ! NILP (val
); val
= Fcdr (val
))
1053 && (SYMBOLP (XCONS (tem
)->car
)
1054 || CONSP (XCONS (tem
)->car
)))))
1055 error ("Invalid condition handler", tem
);
1060 c
.backlist
= backtrace_list
;
1061 c
.handlerlist
= handlerlist
;
1062 c
.lisp_eval_depth
= lisp_eval_depth
;
1063 c
.pdlcount
= specpdl_ptr
- specpdl
;
1064 c
.poll_suppress_count
= poll_suppress_count
;
1065 c
.gcpro
= gcprolist
;
1066 if (_setjmp (c
.jmp
))
1069 specbind (h
.var
, c
.val
);
1070 val
= Fprogn (Fcdr (h
.chosen_clause
));
1072 /* Note that this just undoes the binding of h.var; whoever
1073 longjumped to us unwound the stack to c.pdlcount before
1075 unbind_to (c
.pdlcount
, Qnil
);
1082 h
.handler
= handlers
;
1083 h
.next
= handlerlist
;
1087 val
= Feval (bodyform
);
1089 handlerlist
= h
.next
;
1093 /* Call the function BFUN with no arguments, catching errors within it
1094 according to HANDLERS. If there is an error, call HFUN with
1095 one argument which is the data that describes the error:
1098 HANDLERS can be a list of conditions to catch.
1099 If HANDLERS is Qt, catch all errors.
1100 If HANDLERS is Qerror, catch all errors
1101 but allow the debugger to run if that is enabled. */
1104 internal_condition_case (bfun
, handlers
, hfun
)
1105 Lisp_Object (*bfun
) ();
1106 Lisp_Object handlers
;
1107 Lisp_Object (*hfun
) ();
1113 /* Since Fsignal resets this to 0, it had better be 0 now
1114 or else we have a potential bug. */
1115 if (interrupt_input_blocked
!= 0)
1120 c
.backlist
= backtrace_list
;
1121 c
.handlerlist
= handlerlist
;
1122 c
.lisp_eval_depth
= lisp_eval_depth
;
1123 c
.pdlcount
= specpdl_ptr
- specpdl
;
1124 c
.poll_suppress_count
= poll_suppress_count
;
1125 c
.gcpro
= gcprolist
;
1126 if (_setjmp (c
.jmp
))
1128 return (*hfun
) (c
.val
);
1132 h
.handler
= handlers
;
1134 h
.next
= handlerlist
;
1140 handlerlist
= h
.next
;
1144 /* Like internal_condition_case but call HFUN with ARG as its argument. */
1147 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1148 Lisp_Object (*bfun
) ();
1150 Lisp_Object handlers
;
1151 Lisp_Object (*hfun
) ();
1159 c
.backlist
= backtrace_list
;
1160 c
.handlerlist
= handlerlist
;
1161 c
.lisp_eval_depth
= lisp_eval_depth
;
1162 c
.pdlcount
= specpdl_ptr
- specpdl
;
1163 c
.poll_suppress_count
= poll_suppress_count
;
1164 c
.gcpro
= gcprolist
;
1165 if (_setjmp (c
.jmp
))
1167 return (*hfun
) (c
.val
);
1171 h
.handler
= handlers
;
1173 h
.next
= handlerlist
;
1177 val
= (*bfun
) (arg
);
1179 handlerlist
= h
.next
;
1183 static Lisp_Object
find_handler_clause ();
1185 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1186 "Signal an error. Args are ERROR-SYMBOL and associated DATA.\n\
1187 This function does not return.\n\n\
1188 An error symbol is a symbol with an `error-conditions' property\n\
1189 that is a list of condition names.\n\
1190 A handler for any of those names will get to handle this signal.\n\
1191 The symbol `error' should normally be one of them.\n\
1193 DATA should be a list. Its elements are printed as part of the error message.\n\
1194 If the signal is handled, DATA is made available to the handler.\n\
1195 See also the function `condition-case'.")
1196 (error_symbol
, data
)
1197 Lisp_Object error_symbol
, data
;
1199 register struct handler
*allhandlers
= handlerlist
;
1200 Lisp_Object conditions
;
1201 extern int gc_in_progress
;
1202 extern int waiting_for_input
;
1203 Lisp_Object debugger_value
;
1205 quit_error_check ();
1207 if (gc_in_progress
|| waiting_for_input
)
1210 #ifdef HAVE_WINDOW_SYSTEM
1211 TOTALLY_UNBLOCK_INPUT
;
1214 conditions
= Fget (error_symbol
, Qerror_conditions
);
1216 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1218 register Lisp_Object clause
;
1219 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1220 error_symbol
, data
, &debugger_value
);
1222 #if 0 /* Most callers are not prepared to handle gc if this returns.
1223 So, since this feature is not very useful, take it out. */
1224 /* If have called debugger and user wants to continue,
1226 if (EQ (clause
, Qlambda
))
1227 return debugger_value
;
1229 if (EQ (clause
, Qlambda
))
1231 /* We can't return values to code which signaled an error, but we
1232 can continue code which has signaled a quit. */
1233 if (EQ (error_symbol
, Qquit
))
1236 error ("Cannot return from the debugger in an error");
1242 Lisp_Object unwind_data
;
1243 struct handler
*h
= handlerlist
;
1245 handlerlist
= allhandlers
;
1246 if (EQ (data
, memory_signal_data
))
1247 unwind_data
= memory_signal_data
;
1249 unwind_data
= Fcons (error_symbol
, data
);
1250 h
->chosen_clause
= clause
;
1251 unwind_to_catch (h
->tag
, unwind_data
);
1255 handlerlist
= allhandlers
;
1256 /* If no handler is present now, try to run the debugger,
1257 and if that fails, throw to top level. */
1258 find_handler_clause (Qerror
, conditions
, error_symbol
, data
, &debugger_value
);
1259 Fthrow (Qtop_level
, Qt
);
1262 /* Return nonzero iff LIST is a non-nil atom or
1263 a list containing one of CONDITIONS. */
1266 wants_debugger (list
, conditions
)
1267 Lisp_Object list
, conditions
;
1274 while (CONSP (conditions
))
1276 Lisp_Object
this, tail
;
1277 this = XCONS (conditions
)->car
;
1278 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1279 if (EQ (XCONS (tail
)->car
, this))
1281 conditions
= XCONS (conditions
)->cdr
;
1286 /* Return 1 if an error with condition-symbols CONDITIONS,
1287 and described by SIGNAL-DATA, should skip the debugger
1288 according to debugger-ignore-errors. */
1291 skip_debugger (conditions
, data
)
1292 Lisp_Object conditions
, data
;
1295 int first_string
= 1;
1296 Lisp_Object error_message
;
1298 for (tail
= Vdebug_ignored_errors
; CONSP (tail
);
1299 tail
= XCONS (tail
)->cdr
)
1301 if (STRINGP (XCONS (tail
)->car
))
1305 error_message
= Ferror_message_string (data
);
1308 if (fast_string_match (XCONS (tail
)->car
, error_message
) >= 0)
1313 Lisp_Object contail
;
1315 for (contail
= conditions
; CONSP (contail
);
1316 contail
= XCONS (contail
)->cdr
)
1317 if (EQ (XCONS (tail
)->car
, XCONS (contail
)->car
))
1325 /* Value of Qlambda means we have called debugger and user has continued.
1326 Store value returned from debugger into *DEBUGGER_VALUE_PTR. */
1329 find_handler_clause (handlers
, conditions
, sig
, data
, debugger_value_ptr
)
1330 Lisp_Object handlers
, conditions
, sig
, data
;
1331 Lisp_Object
*debugger_value_ptr
;
1333 register Lisp_Object h
;
1334 register Lisp_Object tem
;
1336 if (EQ (handlers
, Qt
)) /* t is used by handlers for all conditions, set up by C code. */
1338 if (EQ (handlers
, Qerror
)) /* error is used similarly, but means display a backtrace too */
1340 if (wants_debugger (Vstack_trace_on_error
, conditions
))
1341 internal_with_output_to_temp_buffer ("*Backtrace*", Fbacktrace
, Qnil
);
1342 if ((EQ (sig
, Qquit
)
1344 : wants_debugger (Vdebug_on_error
, conditions
))
1345 && ! skip_debugger (conditions
, Fcons (sig
, data
))
1346 && when_entered_debugger
< num_nonmacro_input_chars
)
1348 int count
= specpdl_ptr
- specpdl
;
1349 specbind (Qdebug_on_error
, Qnil
);
1351 = call_debugger (Fcons (Qerror
,
1352 Fcons (Fcons (sig
, data
),
1354 return unbind_to (count
, Qlambda
);
1358 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1360 Lisp_Object handler
, condit
;
1363 if (!CONSP (handler
))
1365 condit
= Fcar (handler
);
1366 /* Handle a single condition name in handler HANDLER. */
1367 if (SYMBOLP (condit
))
1369 tem
= Fmemq (Fcar (handler
), conditions
);
1373 /* Handle a list of condition names in handler HANDLER. */
1374 else if (CONSP (condit
))
1376 while (CONSP (condit
))
1378 tem
= Fmemq (Fcar (condit
), conditions
);
1381 condit
= XCONS (condit
)->cdr
;
1388 /* dump an error message; called like printf */
1392 error (m
, a1
, a2
, a3
)
1412 int used
= doprnt (buf
, size
, m
, m
+ mlen
, 3, args
);
1417 buffer
= (char *) xrealloc (buffer
, size
);
1420 buffer
= (char *) xmalloc (size
);
1425 string
= build_string (buf
);
1429 Fsignal (Qerror
, Fcons (string
, Qnil
));
1432 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 1, 0,
1433 "T if FUNCTION makes provisions for interactive calling.\n\
1434 This means it contains a description for how to read arguments to give it.\n\
1435 The value is nil for an invalid function or a symbol with no function\n\
1438 Interactively callable functions include strings and vectors (treated\n\
1439 as keyboard macros), lambda-expressions that contain a top-level call\n\
1440 to `interactive', autoload definitions made by `autoload' with non-nil\n\
1441 fourth argument, and some of the built-in functions of Lisp.\n\
1443 Also, a symbol satisfies `commandp' if its function definition does so.")
1445 Lisp_Object function
;
1447 register Lisp_Object fun
;
1448 register Lisp_Object funcar
;
1449 register Lisp_Object tem
;
1454 fun
= indirect_function (fun
);
1455 if (EQ (fun
, Qunbound
))
1458 /* Emacs primitives are interactive if their DEFUN specifies an
1459 interactive spec. */
1462 if (XSUBR (fun
)->prompt
)
1468 /* Bytecode objects are interactive if they are long enough to
1469 have an element whose index is COMPILED_INTERACTIVE, which is
1470 where the interactive spec is stored. */
1471 else if (COMPILEDP (fun
))
1472 return ((XVECTOR (fun
)->size
& PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
1475 /* Strings and vectors are keyboard macros. */
1476 if (STRINGP (fun
) || VECTORP (fun
))
1479 /* Lists may represent commands. */
1482 funcar
= Fcar (fun
);
1483 if (!SYMBOLP (funcar
))
1484 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1485 if (EQ (funcar
, Qlambda
))
1486 return Fassq (Qinteractive
, Fcdr (Fcdr (fun
)));
1487 if (EQ (funcar
, Qmocklisp
))
1488 return Qt
; /* All mocklisp functions can be called interactively */
1489 if (EQ (funcar
, Qautoload
))
1490 return Fcar (Fcdr (Fcdr (Fcdr (fun
))));
1496 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1497 "Define FUNCTION to autoload from FILE.\n\
1498 FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\
1499 Third arg DOCSTRING is documentation for the function.\n\
1500 Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\
1501 Fifth arg TYPE indicates the type of the object:\n\
1502 nil or omitted says FUNCTION is a function,\n\
1503 `keymap' says FUNCTION is really a keymap, and\n\
1504 `macro' or t says FUNCTION is really a macro.\n\
1505 Third through fifth args give info about the real definition.\n\
1506 They default to nil.\n\
1507 If FUNCTION is already defined other than as an autoload,\n\
1508 this does nothing and returns nil.")
1509 (function
, file
, docstring
, interactive
, type
)
1510 Lisp_Object function
, file
, docstring
, interactive
, type
;
1513 Lisp_Object args
[4];
1516 CHECK_SYMBOL (function
, 0);
1517 CHECK_STRING (file
, 1);
1519 /* If function is defined and not as an autoload, don't override */
1520 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
1521 && !(CONSP (XSYMBOL (function
)->function
)
1522 && EQ (XCONS (XSYMBOL (function
)->function
)->car
, Qautoload
)))
1527 args
[1] = docstring
;
1528 args
[2] = interactive
;
1531 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
1532 #else /* NO_ARG_ARRAY */
1533 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
1534 #endif /* not NO_ARG_ARRAY */
1538 un_autoload (oldqueue
)
1539 Lisp_Object oldqueue
;
1541 register Lisp_Object queue
, first
, second
;
1543 /* Queue to unwind is current value of Vautoload_queue.
1544 oldqueue is the shadowed value to leave in Vautoload_queue. */
1545 queue
= Vautoload_queue
;
1546 Vautoload_queue
= oldqueue
;
1547 while (CONSP (queue
))
1549 first
= Fcar (queue
);
1550 second
= Fcdr (first
);
1551 first
= Fcar (first
);
1552 if (EQ (second
, Qnil
))
1555 Ffset (first
, second
);
1556 queue
= Fcdr (queue
);
1561 /* Load an autoloaded function.
1562 FUNNAME is the symbol which is the function's name.
1563 FUNDEF is the autoload definition (a list). */
1565 do_autoload (fundef
, funname
)
1566 Lisp_Object fundef
, funname
;
1568 int count
= specpdl_ptr
- specpdl
;
1569 Lisp_Object fun
, val
, queue
, first
, second
;
1570 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1573 CHECK_SYMBOL (funname
, 0);
1574 GCPRO3 (fun
, funname
, fundef
);
1576 /* Value saved here is to be restored into Vautoload_queue */
1577 record_unwind_protect (un_autoload
, Vautoload_queue
);
1578 Vautoload_queue
= Qt
;
1579 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
);
1581 /* Save the old autoloads, in case we ever do an unload. */
1582 queue
= Vautoload_queue
;
1583 while (CONSP (queue
))
1585 first
= Fcar (queue
);
1586 second
= Fcdr (first
);
1587 first
= Fcar (first
);
1589 /* Note: This test is subtle. The cdr of an autoload-queue entry
1590 may be an atom if the autoload entry was generated by a defalias
1593 Fput (first
, Qautoload
, (Fcdr (second
)));
1595 queue
= Fcdr (queue
);
1598 /* Once loading finishes, don't undo it. */
1599 Vautoload_queue
= Qt
;
1600 unbind_to (count
, Qnil
);
1602 fun
= Findirect_function (fun
);
1604 if (!NILP (Fequal (fun
, fundef
)))
1605 error ("Autoloading failed to define function %s",
1606 XSYMBOL (funname
)->name
->data
);
1610 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
1611 "Evaluate FORM and return its value.")
1615 Lisp_Object fun
, val
, original_fun
, original_args
;
1617 struct backtrace backtrace
;
1618 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1622 if (EQ (Vmocklisp_arguments
, Qt
))
1623 return Fsymbol_value (form
);
1624 val
= Fsymbol_value (form
);
1626 XSETFASTINT (val
, 0);
1627 else if (EQ (val
, Qt
))
1628 XSETFASTINT (val
, 1);
1635 if (consing_since_gc
> gc_cons_threshold
)
1638 Fgarbage_collect ();
1642 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1644 if (max_lisp_eval_depth
< 100)
1645 max_lisp_eval_depth
= 100;
1646 if (lisp_eval_depth
> max_lisp_eval_depth
)
1647 error ("Lisp nesting exceeds max-lisp-eval-depth");
1650 original_fun
= Fcar (form
);
1651 original_args
= Fcdr (form
);
1653 backtrace
.next
= backtrace_list
;
1654 backtrace_list
= &backtrace
;
1655 backtrace
.function
= &original_fun
; /* This also protects them from gc */
1656 backtrace
.args
= &original_args
;
1657 backtrace
.nargs
= UNEVALLED
;
1658 backtrace
.evalargs
= 1;
1659 backtrace
.debug_on_exit
= 0;
1661 if (debug_on_next_call
)
1662 do_debug_on_call (Qt
);
1664 /* At this point, only original_fun and original_args
1665 have values that will be used below */
1667 fun
= Findirect_function (original_fun
);
1671 Lisp_Object numargs
;
1672 Lisp_Object argvals
[7];
1673 Lisp_Object args_left
;
1674 register int i
, maxargs
;
1676 args_left
= original_args
;
1677 numargs
= Flength (args_left
);
1679 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
1680 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
1681 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1683 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1685 backtrace
.evalargs
= 0;
1686 val
= (*XSUBR (fun
)->function
) (args_left
);
1690 if (XSUBR (fun
)->max_args
== MANY
)
1692 /* Pass a vector of evaluated arguments */
1694 register int argnum
= 0;
1696 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1698 GCPRO3 (args_left
, fun
, fun
);
1702 while (!NILP (args_left
))
1704 vals
[argnum
++] = Feval (Fcar (args_left
));
1705 args_left
= Fcdr (args_left
);
1706 gcpro3
.nvars
= argnum
;
1709 backtrace
.args
= vals
;
1710 backtrace
.nargs
= XINT (numargs
);
1712 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
1717 GCPRO3 (args_left
, fun
, fun
);
1718 gcpro3
.var
= argvals
;
1721 maxargs
= XSUBR (fun
)->max_args
;
1722 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
1724 argvals
[i
] = Feval (Fcar (args_left
));
1730 backtrace
.args
= argvals
;
1731 backtrace
.nargs
= XINT (numargs
);
1736 val
= (*XSUBR (fun
)->function
) ();
1739 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
1742 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
1745 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1749 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1750 argvals
[2], argvals
[3]);
1753 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1754 argvals
[3], argvals
[4]);
1757 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1758 argvals
[3], argvals
[4], argvals
[5]);
1761 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1762 argvals
[3], argvals
[4], argvals
[5],
1767 /* Someone has created a subr that takes more arguments than
1768 is supported by this code. We need to either rewrite the
1769 subr to use a different argument protocol, or add more
1770 cases to this switch. */
1774 if (COMPILEDP (fun
))
1775 val
= apply_lambda (fun
, original_args
, 1);
1779 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1780 funcar
= Fcar (fun
);
1781 if (!SYMBOLP (funcar
))
1782 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1783 if (EQ (funcar
, Qautoload
))
1785 do_autoload (fun
, original_fun
);
1788 if (EQ (funcar
, Qmacro
))
1789 val
= Feval (apply1 (Fcdr (fun
), original_args
));
1790 else if (EQ (funcar
, Qlambda
))
1791 val
= apply_lambda (fun
, original_args
, 1);
1792 else if (EQ (funcar
, Qmocklisp
))
1793 val
= ml_apply (fun
, original_args
);
1795 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1798 if (!EQ (Vmocklisp_arguments
, Qt
))
1801 XSETFASTINT (val
, 0);
1802 else if (EQ (val
, Qt
))
1803 XSETFASTINT (val
, 1);
1806 if (backtrace
.debug_on_exit
)
1807 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
1808 backtrace_list
= backtrace
.next
;
1812 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
1813 "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
1814 Then return the value FUNCTION returns.\n\
1815 Thus, (apply '+ 1 2 '(3 4)) returns 10.")
1820 register int i
, numargs
;
1821 register Lisp_Object spread_arg
;
1822 register Lisp_Object
*funcall_args
;
1824 struct gcpro gcpro1
;
1828 spread_arg
= args
[nargs
- 1];
1829 CHECK_LIST (spread_arg
, nargs
);
1831 numargs
= XINT (Flength (spread_arg
));
1834 return Ffuncall (nargs
- 1, args
);
1835 else if (numargs
== 1)
1837 args
[nargs
- 1] = XCONS (spread_arg
)->car
;
1838 return Ffuncall (nargs
, args
);
1841 numargs
+= nargs
- 2;
1843 fun
= indirect_function (fun
);
1844 if (EQ (fun
, Qunbound
))
1846 /* Let funcall get the error */
1853 if (numargs
< XSUBR (fun
)->min_args
1854 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
1855 goto funcall
; /* Let funcall get the error */
1856 else if (XSUBR (fun
)->max_args
> numargs
)
1858 /* Avoid making funcall cons up a yet another new vector of arguments
1859 by explicitly supplying nil's for optional values */
1860 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
1861 * sizeof (Lisp_Object
));
1862 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
1863 funcall_args
[++i
] = Qnil
;
1864 GCPRO1 (*funcall_args
);
1865 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
1869 /* We add 1 to numargs because funcall_args includes the
1870 function itself as well as its arguments. */
1873 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
1874 * sizeof (Lisp_Object
));
1875 GCPRO1 (*funcall_args
);
1876 gcpro1
.nvars
= 1 + numargs
;
1879 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
1880 /* Spread the last arg we got. Its first element goes in
1881 the slot that it used to occupy, hence this value of I. */
1883 while (!NILP (spread_arg
))
1885 funcall_args
[i
++] = XCONS (spread_arg
)->car
;
1886 spread_arg
= XCONS (spread_arg
)->cdr
;
1889 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
1892 /* Run hook variables in various ways. */
1894 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
1896 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 1, MANY
, 0,
1897 "Run each hook in HOOKS. Major mode functions use this.\n\
1898 Each argument should be a symbol, a hook variable.\n\
1899 These symbols are processed in the order specified.\n\
1900 If a hook symbol has a non-nil value, that value may be a function\n\
1901 or a list of functions to be called to run the hook.\n\
1902 If the value is a function, it is called with no arguments.\n\
1903 If it is a list, the elements are called, in order, with no arguments.\n\
1905 To make a hook variable buffer-local, use `make-local-hook',\n\
1906 not `make-local-variable'.")
1911 Lisp_Object hook
[1];
1914 for (i
= 0; i
< nargs
; i
++)
1917 run_hook_with_args (1, hook
, to_completion
);
1923 DEFUN ("run-hook-with-args",
1924 Frun_hook_with_args
, Srun_hook_with_args
, 1, MANY
, 0,
1925 "Run HOOK with the specified arguments ARGS.\n\
1926 HOOK should be a symbol, a hook variable. If HOOK has a non-nil\n\
1927 value, that value may be a function or a list of functions to be\n\
1928 called to run the hook. If the value is a function, it is called with\n\
1929 the given arguments and its return value is returned. If it is a list\n\
1930 of functions, those functions are called, in order,\n\
1931 with the given arguments ARGS.\n\
1932 It is best not to depend on the value return by `run-hook-with-args',\n\
1933 as that may change.\n\
1935 To make a hook variable buffer-local, use `make-local-hook',\n\
1936 not `make-local-variable'.")
1941 return run_hook_with_args (nargs
, args
, to_completion
);
1944 DEFUN ("run-hook-with-args-until-success",
1945 Frun_hook_with_args_until_success
, Srun_hook_with_args_until_success
,
1947 "Run HOOK with the specified arguments ARGS.\n\
1948 HOOK should be a symbol, a hook variable. Its value should\n\
1949 be a list of functions. We call those functions, one by one,\n\
1950 passing arguments ARGS to each of them, until one of them\n\
1951 returns a non-nil value. Then we return that value.\n\
1952 If all the functions return nil, we return nil.\n\
1954 To make a hook variable buffer-local, use `make-local-hook',\n\
1955 not `make-local-variable'.")
1960 return run_hook_with_args (nargs
, args
, until_success
);
1963 DEFUN ("run-hook-with-args-until-failure",
1964 Frun_hook_with_args_until_failure
, Srun_hook_with_args_until_failure
,
1966 "Run HOOK with the specified arguments ARGS.\n\
1967 HOOK should be a symbol, a hook variable. Its value should\n\
1968 be a list of functions. We call those functions, one by one,\n\
1969 passing arguments ARGS to each of them, until one of them\n\
1970 returns nil. Then we return nil.\n\
1971 If all the functions return non-nil, we return non-nil.\n\
1973 To make a hook variable buffer-local, use `make-local-hook',\n\
1974 not `make-local-variable'.")
1979 return run_hook_with_args (nargs
, args
, until_failure
);
1982 /* ARGS[0] should be a hook symbol.
1983 Call each of the functions in the hook value, passing each of them
1984 as arguments all the rest of ARGS (all NARGS - 1 elements).
1985 COND specifies a condition to test after each call
1986 to decide whether to stop.
1987 The caller (or its caller, etc) must gcpro all of ARGS,
1988 except that it isn't necessary to gcpro ARGS[0]. */
1991 run_hook_with_args (nargs
, args
, cond
)
1994 enum run_hooks_condition cond
;
1996 Lisp_Object sym
, val
, ret
;
1997 struct gcpro gcpro1
, gcpro2
;
1999 /* If we are dying or still initializing,
2000 don't do anything--it would probably crash if we tried. */
2001 if (NILP (Vrun_hooks
))
2005 val
= find_symbol_value (sym
);
2006 ret
= (cond
== until_failure
? Qt
: Qnil
);
2008 if (EQ (val
, Qunbound
) || NILP (val
))
2010 else if (!CONSP (val
) || EQ (XCONS (val
)->car
, Qlambda
))
2013 return Ffuncall (nargs
, args
);
2020 CONSP (val
) && ((cond
== to_completion
)
2021 || (cond
== until_success
? NILP (ret
)
2023 val
= XCONS (val
)->cdr
)
2025 if (EQ (XCONS (val
)->car
, Qt
))
2027 /* t indicates this hook has a local binding;
2028 it means to run the global binding too. */
2029 Lisp_Object globals
;
2031 for (globals
= Fdefault_value (sym
);
2032 CONSP (globals
) && ((cond
== to_completion
)
2033 || (cond
== until_success
? NILP (ret
)
2035 globals
= XCONS (globals
)->cdr
)
2037 args
[0] = XCONS (globals
)->car
;
2038 /* In a global value, t should not occur. If it does, we
2039 must ignore it to avoid an endless loop. */
2040 if (!EQ (args
[0], Qt
))
2041 ret
= Ffuncall (nargs
, args
);
2046 args
[0] = XCONS (val
)->car
;
2047 ret
= Ffuncall (nargs
, args
);
2056 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2057 present value of that symbol.
2058 Call each element of FUNLIST,
2059 passing each of them the rest of ARGS.
2060 The caller (or its caller, etc) must gcpro all of ARGS,
2061 except that it isn't necessary to gcpro ARGS[0]. */
2064 run_hook_list_with_args (funlist
, nargs
, args
)
2065 Lisp_Object funlist
;
2071 struct gcpro gcpro1
, gcpro2
;
2076 for (val
= funlist
; CONSP (val
); val
= XCONS (val
)->cdr
)
2078 if (EQ (XCONS (val
)->car
, Qt
))
2080 /* t indicates this hook has a local binding;
2081 it means to run the global binding too. */
2082 Lisp_Object globals
;
2084 for (globals
= Fdefault_value (sym
);
2086 globals
= XCONS (globals
)->cdr
)
2088 args
[0] = XCONS (globals
)->car
;
2089 /* In a global value, t should not occur. If it does, we
2090 must ignore it to avoid an endless loop. */
2091 if (!EQ (args
[0], Qt
))
2092 Ffuncall (nargs
, args
);
2097 args
[0] = XCONS (val
)->car
;
2098 Ffuncall (nargs
, args
);
2105 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2108 run_hook_with_args_2 (hook
, arg1
, arg2
)
2109 Lisp_Object hook
, arg1
, arg2
;
2111 Lisp_Object temp
[3];
2116 Frun_hook_with_args (3, temp
);
2119 /* Apply fn to arg */
2122 Lisp_Object fn
, arg
;
2124 struct gcpro gcpro1
;
2128 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2132 Lisp_Object args
[2];
2136 RETURN_UNGCPRO (Fapply (2, args
));
2138 #else /* not NO_ARG_ARRAY */
2139 RETURN_UNGCPRO (Fapply (2, &fn
));
2140 #endif /* not NO_ARG_ARRAY */
2143 /* Call function fn on no arguments */
2148 struct gcpro gcpro1
;
2151 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2154 /* Call function fn with 1 argument arg1 */
2158 Lisp_Object fn
, arg1
;
2160 struct gcpro gcpro1
;
2162 Lisp_Object args
[2];
2168 RETURN_UNGCPRO (Ffuncall (2, args
));
2169 #else /* not NO_ARG_ARRAY */
2172 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2173 #endif /* not NO_ARG_ARRAY */
2176 /* Call function fn with 2 arguments arg1, arg2 */
2179 call2 (fn
, arg1
, arg2
)
2180 Lisp_Object fn
, arg1
, arg2
;
2182 struct gcpro gcpro1
;
2184 Lisp_Object args
[3];
2190 RETURN_UNGCPRO (Ffuncall (3, args
));
2191 #else /* not NO_ARG_ARRAY */
2194 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2195 #endif /* not NO_ARG_ARRAY */
2198 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2201 call3 (fn
, arg1
, arg2
, arg3
)
2202 Lisp_Object fn
, arg1
, arg2
, arg3
;
2204 struct gcpro gcpro1
;
2206 Lisp_Object args
[4];
2213 RETURN_UNGCPRO (Ffuncall (4, args
));
2214 #else /* not NO_ARG_ARRAY */
2217 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2218 #endif /* not NO_ARG_ARRAY */
2221 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2224 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2225 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2227 struct gcpro gcpro1
;
2229 Lisp_Object args
[5];
2237 RETURN_UNGCPRO (Ffuncall (5, args
));
2238 #else /* not NO_ARG_ARRAY */
2241 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2242 #endif /* not NO_ARG_ARRAY */
2245 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2248 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2249 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2251 struct gcpro gcpro1
;
2253 Lisp_Object args
[6];
2262 RETURN_UNGCPRO (Ffuncall (6, args
));
2263 #else /* not NO_ARG_ARRAY */
2266 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2267 #endif /* not NO_ARG_ARRAY */
2270 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2273 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2274 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2276 struct gcpro gcpro1
;
2278 Lisp_Object args
[7];
2288 RETURN_UNGCPRO (Ffuncall (7, args
));
2289 #else /* not NO_ARG_ARRAY */
2292 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2293 #endif /* not NO_ARG_ARRAY */
2296 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2297 "Call first argument as a function, passing remaining arguments to it.\n\
2298 Return the value that function returns.\n\
2299 Thus, (funcall 'cons 'x 'y) returns (x . y).")
2306 int numargs
= nargs
- 1;
2307 Lisp_Object lisp_numargs
;
2309 struct backtrace backtrace
;
2310 register Lisp_Object
*internal_args
;
2314 if (consing_since_gc
> gc_cons_threshold
)
2315 Fgarbage_collect ();
2317 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2319 if (max_lisp_eval_depth
< 100)
2320 max_lisp_eval_depth
= 100;
2321 if (lisp_eval_depth
> max_lisp_eval_depth
)
2322 error ("Lisp nesting exceeds max-lisp-eval-depth");
2325 backtrace
.next
= backtrace_list
;
2326 backtrace_list
= &backtrace
;
2327 backtrace
.function
= &args
[0];
2328 backtrace
.args
= &args
[1];
2329 backtrace
.nargs
= nargs
- 1;
2330 backtrace
.evalargs
= 0;
2331 backtrace
.debug_on_exit
= 0;
2333 if (debug_on_next_call
)
2334 do_debug_on_call (Qlambda
);
2340 fun
= Findirect_function (fun
);
2344 if (numargs
< XSUBR (fun
)->min_args
2345 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2347 XSETFASTINT (lisp_numargs
, numargs
);
2348 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (lisp_numargs
, Qnil
)));
2351 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2352 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2354 if (XSUBR (fun
)->max_args
== MANY
)
2356 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
2360 if (XSUBR (fun
)->max_args
> numargs
)
2362 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2363 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
2364 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2365 internal_args
[i
] = Qnil
;
2368 internal_args
= args
+ 1;
2369 switch (XSUBR (fun
)->max_args
)
2372 val
= (*XSUBR (fun
)->function
) ();
2375 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
2378 val
= (*XSUBR (fun
)->function
) (internal_args
[0],
2382 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2386 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2391 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2392 internal_args
[2], internal_args
[3],
2396 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2397 internal_args
[2], internal_args
[3],
2398 internal_args
[4], internal_args
[5]);
2401 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2402 internal_args
[2], internal_args
[3],
2403 internal_args
[4], internal_args
[5],
2409 /* If a subr takes more than 6 arguments without using MANY
2410 or UNEVALLED, we need to extend this function to support it.
2411 Until this is done, there is no way to call the function. */
2415 if (COMPILEDP (fun
))
2416 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2420 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2421 funcar
= Fcar (fun
);
2422 if (!SYMBOLP (funcar
))
2423 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2424 if (EQ (funcar
, Qlambda
))
2425 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2426 else if (EQ (funcar
, Qmocklisp
))
2427 val
= ml_apply (fun
, Flist (numargs
, args
+ 1));
2428 else if (EQ (funcar
, Qautoload
))
2430 do_autoload (fun
, args
[0]);
2434 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2438 if (backtrace
.debug_on_exit
)
2439 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2440 backtrace_list
= backtrace
.next
;
2445 apply_lambda (fun
, args
, eval_flag
)
2446 Lisp_Object fun
, args
;
2449 Lisp_Object args_left
;
2450 Lisp_Object numargs
;
2451 register Lisp_Object
*arg_vector
;
2452 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2454 register Lisp_Object tem
;
2456 numargs
= Flength (args
);
2457 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2460 GCPRO3 (*arg_vector
, args_left
, fun
);
2463 for (i
= 0; i
< XINT (numargs
);)
2465 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2466 if (eval_flag
) tem
= Feval (tem
);
2467 arg_vector
[i
++] = tem
;
2475 backtrace_list
->args
= arg_vector
;
2476 backtrace_list
->nargs
= i
;
2478 backtrace_list
->evalargs
= 0;
2479 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
2481 /* Do the debug-on-exit now, while arg_vector still exists. */
2482 if (backtrace_list
->debug_on_exit
)
2483 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
2484 /* Don't do it again when we return to eval. */
2485 backtrace_list
->debug_on_exit
= 0;
2489 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2490 and return the result of evaluation.
2491 FUN must be either a lambda-expression or a compiled-code object. */
2494 funcall_lambda (fun
, nargs
, arg_vector
)
2497 register Lisp_Object
*arg_vector
;
2499 Lisp_Object val
, tem
;
2500 register Lisp_Object syms_left
;
2501 Lisp_Object numargs
;
2502 register Lisp_Object next
;
2503 int count
= specpdl_ptr
- specpdl
;
2505 int optional
= 0, rest
= 0;
2507 specbind (Qmocklisp_arguments
, Qt
); /* t means NOT mocklisp! */
2509 XSETFASTINT (numargs
, nargs
);
2512 syms_left
= Fcar (Fcdr (fun
));
2513 else if (COMPILEDP (fun
))
2514 syms_left
= XVECTOR (fun
)->contents
[COMPILED_ARGLIST
];
2518 for (; !NILP (syms_left
); syms_left
= Fcdr (syms_left
))
2521 next
= Fcar (syms_left
);
2522 while (!SYMBOLP (next
))
2523 next
= Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2524 if (EQ (next
, Qand_rest
))
2526 else if (EQ (next
, Qand_optional
))
2530 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
2535 tem
= arg_vector
[i
++];
2536 specbind (next
, tem
);
2539 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2541 specbind (next
, Qnil
);
2545 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2548 val
= Fprogn (Fcdr (Fcdr (fun
)));
2551 /* If we have not actually read the bytecode string
2552 and constants vector yet, fetch them from the file. */
2553 if (CONSP (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
]))
2554 Ffetch_bytecode (fun
);
2555 val
= Fbyte_code (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
],
2556 XVECTOR (fun
)->contents
[COMPILED_CONSTANTS
],
2557 XVECTOR (fun
)->contents
[COMPILED_STACK_DEPTH
]);
2559 return unbind_to (count
, val
);
2562 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
2564 "If byte-compiled OBJECT is lazy-loaded, fetch it now.")
2570 if (COMPILEDP (object
)
2571 && CONSP (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]))
2573 tem
= read_doc_string (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]);
2575 error ("invalid byte code");
2576 XVECTOR (object
)->contents
[COMPILED_BYTECODE
] = XCONS (tem
)->car
;
2577 XVECTOR (object
)->contents
[COMPILED_CONSTANTS
] = XCONS (tem
)->cdr
;
2585 register int count
= specpdl_ptr
- specpdl
;
2586 if (specpdl_size
>= max_specpdl_size
)
2588 if (max_specpdl_size
< 400)
2589 max_specpdl_size
= 400;
2590 if (specpdl_size
>= max_specpdl_size
)
2592 if (!NILP (Vdebug_on_error
))
2593 /* Leave room for some specpdl in the debugger. */
2594 max_specpdl_size
= specpdl_size
+ 100;
2596 Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil
));
2600 if (specpdl_size
> max_specpdl_size
)
2601 specpdl_size
= max_specpdl_size
;
2602 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
2603 specpdl_ptr
= specpdl
+ count
;
2607 specbind (symbol
, value
)
2608 Lisp_Object symbol
, value
;
2612 CHECK_SYMBOL (symbol
, 0);
2614 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2616 specpdl_ptr
->symbol
= symbol
;
2617 specpdl_ptr
->func
= 0;
2618 specpdl_ptr
->old_value
= ovalue
= find_symbol_value (symbol
);
2620 if (BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
))
2621 store_symval_forwarding (symbol
, ovalue
, value
);
2623 Fset (symbol
, value
);
2627 record_unwind_protect (function
, arg
)
2628 Lisp_Object (*function
)();
2631 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2633 specpdl_ptr
->func
= function
;
2634 specpdl_ptr
->symbol
= Qnil
;
2635 specpdl_ptr
->old_value
= arg
;
2640 unbind_to (count
, value
)
2644 int quitf
= !NILP (Vquit_flag
);
2645 struct gcpro gcpro1
;
2651 while (specpdl_ptr
!= specpdl
+ count
)
2654 if (specpdl_ptr
->func
!= 0)
2655 (*specpdl_ptr
->func
) (specpdl_ptr
->old_value
);
2656 /* Note that a "binding" of nil is really an unwind protect,
2657 so in that case the "old value" is a list of forms to evaluate. */
2658 else if (NILP (specpdl_ptr
->symbol
))
2659 Fprogn (specpdl_ptr
->old_value
);
2661 Fset (specpdl_ptr
->symbol
, specpdl_ptr
->old_value
);
2663 if (NILP (Vquit_flag
) && quitf
) Vquit_flag
= Qt
;
2672 /* Get the value of symbol's global binding, even if that binding
2673 is not now dynamically visible. */
2676 top_level_value (symbol
)
2679 register struct specbinding
*ptr
= specpdl
;
2681 CHECK_SYMBOL (symbol
, 0);
2682 for (; ptr
!= specpdl_ptr
; ptr
++)
2684 if (EQ (ptr
->symbol
, symbol
))
2685 return ptr
->old_value
;
2687 return Fsymbol_value (symbol
);
2691 top_level_set (symbol
, newval
)
2692 Lisp_Object symbol
, newval
;
2694 register struct specbinding
*ptr
= specpdl
;
2696 CHECK_SYMBOL (symbol
, 0);
2697 for (; ptr
!= specpdl_ptr
; ptr
++)
2699 if (EQ (ptr
->symbol
, symbol
))
2701 ptr
->old_value
= newval
;
2705 return Fset (symbol
, newval
);
2710 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
2711 "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\
2712 The debugger is entered when that frame exits, if the flag is non-nil.")
2714 Lisp_Object level
, flag
;
2716 register struct backtrace
*backlist
= backtrace_list
;
2719 CHECK_NUMBER (level
, 0);
2721 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
2723 backlist
= backlist
->next
;
2727 backlist
->debug_on_exit
= !NILP (flag
);
2732 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
2733 "Print a trace of Lisp function calls currently active.\n\
2734 Output stream used is value of `standard-output'.")
2737 register struct backtrace
*backlist
= backtrace_list
;
2741 extern Lisp_Object Vprint_level
;
2742 struct gcpro gcpro1
;
2744 XSETFASTINT (Vprint_level
, 3);
2751 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
2752 if (backlist
->nargs
== UNEVALLED
)
2754 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
2755 write_string ("\n", -1);
2759 tem
= *backlist
->function
;
2760 Fprin1 (tem
, Qnil
); /* This can QUIT */
2761 write_string ("(", -1);
2762 if (backlist
->nargs
== MANY
)
2764 for (tail
= *backlist
->args
, i
= 0;
2766 tail
= Fcdr (tail
), i
++)
2768 if (i
) write_string (" ", -1);
2769 Fprin1 (Fcar (tail
), Qnil
);
2774 for (i
= 0; i
< backlist
->nargs
; i
++)
2776 if (i
) write_string (" ", -1);
2777 Fprin1 (backlist
->args
[i
], Qnil
);
2780 write_string (")\n", -1);
2782 backlist
= backlist
->next
;
2785 Vprint_level
= Qnil
;
2790 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, "",
2791 "Return the function and arguments NFRAMES up from current execution point.\n\
2792 If that frame has not evaluated the arguments yet (or is a special form),\n\
2793 the value is (nil FUNCTION ARG-FORMS...).\n\
2794 If that frame has evaluated its arguments and called its function already,\n\
2795 the value is (t FUNCTION ARG-VALUES...).\n\
2796 A &rest arg is represented as the tail of the list ARG-VALUES.\n\
2797 FUNCTION is whatever was supplied as car of evaluated list,\n\
2798 or a lambda expression for macro calls.\n\
2799 If NFRAMES is more than the number of frames, the value is nil.")
2801 Lisp_Object nframes
;
2803 register struct backtrace
*backlist
= backtrace_list
;
2807 CHECK_NATNUM (nframes
, 0);
2809 /* Find the frame requested. */
2810 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
2811 backlist
= backlist
->next
;
2815 if (backlist
->nargs
== UNEVALLED
)
2816 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
2819 if (backlist
->nargs
== MANY
)
2820 tem
= *backlist
->args
;
2822 tem
= Flist (backlist
->nargs
, backlist
->args
);
2824 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
2830 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
2831 "Limit on number of Lisp variable bindings & unwind-protects before error.");
2833 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
2834 "Limit on depth in `eval', `apply' and `funcall' before error.\n\
2835 This limit is to catch infinite recursions for you before they cause\n\
2836 actual stack overflow in C, which would be fatal for Emacs.\n\
2837 You can safely make it considerably larger than its default value,\n\
2838 if that proves inconveniently small.");
2840 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
2841 "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
2842 Typing C-g sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
2845 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
2846 "Non-nil inhibits C-g quitting from happening immediately.\n\
2847 Note that `quit-flag' will still be set by typing C-g,\n\
2848 so a quit will be signaled as soon as `inhibit-quit' is nil.\n\
2849 To prevent this happening, set `quit-flag' to nil\n\
2850 before making `inhibit-quit' nil.");
2851 Vinhibit_quit
= Qnil
;
2853 Qinhibit_quit
= intern ("inhibit-quit");
2854 staticpro (&Qinhibit_quit
);
2856 Qautoload
= intern ("autoload");
2857 staticpro (&Qautoload
);
2859 Qdebug_on_error
= intern ("debug-on-error");
2860 staticpro (&Qdebug_on_error
);
2862 Qmacro
= intern ("macro");
2863 staticpro (&Qmacro
);
2865 /* Note that the process handling also uses Qexit, but we don't want
2866 to staticpro it twice, so we just do it here. */
2867 Qexit
= intern ("exit");
2870 Qinteractive
= intern ("interactive");
2871 staticpro (&Qinteractive
);
2873 Qcommandp
= intern ("commandp");
2874 staticpro (&Qcommandp
);
2876 Qdefun
= intern ("defun");
2877 staticpro (&Qdefun
);
2879 Qand_rest
= intern ("&rest");
2880 staticpro (&Qand_rest
);
2882 Qand_optional
= intern ("&optional");
2883 staticpro (&Qand_optional
);
2885 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
2886 "*Non-nil means automatically display a backtrace buffer\n\
2887 after any error that is handled by the editor command loop.\n\
2888 If the value is a list, an error only means to display a backtrace\n\
2889 if one of its condition symbols appears in the list.");
2890 Vstack_trace_on_error
= Qnil
;
2892 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
2893 "*Non-nil means enter debugger if an error is signaled.\n\
2894 Does not apply to errors handled by `condition-case'.\n\
2895 If the value is a list, an error only means to enter the debugger\n\
2896 if one of its condition symbols appears in the list.\n\
2897 See also variable `debug-on-quit'.");
2898 Vdebug_on_error
= Qnil
;
2900 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
2901 "*List of errors for which the debugger should not be called.\n\
2902 Each element may be a condition-name or a regexp that matches error messages.\n\
2903 If any element applies to a given error, that error skips the debugger\n\
2904 and just returns to top level.\n\
2905 This overrides the variable `debug-on-error'.\n\
2906 It does not apply to errors handled by `condition-case'.");
2907 Vdebug_ignored_errors
= Qnil
;
2909 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
2910 "*Non-nil means enter debugger if quit is signaled (C-g, for example).\n\
2911 Does not apply if quit is handled by a `condition-case'.");
2914 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
2915 "Non-nil means enter debugger before next `eval', `apply' or `funcall'.");
2917 DEFVAR_LISP ("debugger", &Vdebugger
,
2918 "Function to call to invoke debugger.\n\
2919 If due to frame exit, args are `exit' and the value being returned;\n\
2920 this function's value will be returned instead of that.\n\
2921 If due to error, args are `error' and a list of the args to `signal'.\n\
2922 If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
2923 If due to `eval' entry, one arg, t.");
2926 Qmocklisp_arguments
= intern ("mocklisp-arguments");
2927 staticpro (&Qmocklisp_arguments
);
2928 DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments
,
2929 "While in a mocklisp function, the list of its unevaluated args.");
2930 Vmocklisp_arguments
= Qt
;
2932 Vrun_hooks
= intern ("run-hooks");
2933 staticpro (&Vrun_hooks
);
2935 staticpro (&Vautoload_queue
);
2936 Vautoload_queue
= Qnil
;
2947 defsubr (&Sfunction
);
2949 defsubr (&Sdefmacro
);
2951 defsubr (&Sdefconst
);
2952 defsubr (&Suser_variable_p
);
2956 defsubr (&Smacroexpand
);
2959 defsubr (&Sunwind_protect
);
2960 defsubr (&Scondition_case
);
2962 defsubr (&Sinteractive_p
);
2963 defsubr (&Scommandp
);
2964 defsubr (&Sautoload
);
2967 defsubr (&Sfuncall
);
2968 defsubr (&Srun_hooks
);
2969 defsubr (&Srun_hook_with_args
);
2970 defsubr (&Srun_hook_with_args_until_success
);
2971 defsubr (&Srun_hook_with_args_until_failure
);
2972 defsubr (&Sfetch_bytecode
);
2973 defsubr (&Sbacktrace_debug
);
2974 defsubr (&Sbacktrace
);
2975 defsubr (&Sbacktrace_frame
);