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 /* Nonzero means enter debugger if a quit signal
131 is handled by the command loop's error handler. */
134 /* The value of num_nonmacro_input_chars as of the last time we
135 started to enter the debugger. If we decide to enter the debugger
136 again when this is still equal to num_nonmacro_input_chars, then we
137 know that the debugger itself has an error, and we should just
138 signal the error instead of entering an infinite loop of debugger
140 int when_entered_debugger
;
142 Lisp_Object Vdebugger
;
144 void specbind (), record_unwind_protect ();
146 Lisp_Object
run_hook_with_args ();
148 Lisp_Object
funcall_lambda ();
149 extern Lisp_Object
ml_apply (); /* Apply a mocklisp function to unevaluated argument list */
154 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
155 max_specpdl_size
= 600;
156 max_lisp_eval_depth
= 200;
163 specpdl_ptr
= specpdl
;
168 debug_on_next_call
= 0;
170 /* This is less than the initial value of num_nonmacro_input_chars. */
171 when_entered_debugger
= -1;
178 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
179 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
180 if (specpdl_size
+ 40 > max_specpdl_size
)
181 max_specpdl_size
= specpdl_size
+ 40;
182 debug_on_next_call
= 0;
183 when_entered_debugger
= num_nonmacro_input_chars
;
184 return apply1 (Vdebugger
, arg
);
187 do_debug_on_call (code
)
190 debug_on_next_call
= 0;
191 backtrace_list
->debug_on_exit
= 1;
192 call_debugger (Fcons (code
, Qnil
));
195 /* NOTE!!! Every function that can call EVAL must protect its args
196 and temporaries from garbage collection while it needs them.
197 The definition of `For' shows what you have to do. */
199 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
200 "Eval args until one of them yields non-nil, then return that value.\n\
201 The remaining args are not evalled at all.\n\
202 If all args return nil, return nil.")
206 register Lisp_Object val
;
207 Lisp_Object args_left
;
218 val
= Feval (Fcar (args_left
));
221 args_left
= Fcdr (args_left
);
223 while (!NILP(args_left
));
229 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
230 "Eval args until one of them yields nil, then return nil.\n\
231 The remaining args are not evalled at all.\n\
232 If no arg yields nil, return the last arg's value.")
236 register Lisp_Object val
;
237 Lisp_Object args_left
;
248 val
= Feval (Fcar (args_left
));
251 args_left
= Fcdr (args_left
);
253 while (!NILP(args_left
));
259 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
260 "(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...\n\
261 Returns the value of THEN or the value of the last of the ELSE's.\n\
262 THEN must be one expression, but ELSE... can be zero or more expressions.\n\
263 If COND yields nil, and there are no ELSE's, the value is nil.")
267 register Lisp_Object cond
;
271 cond
= Feval (Fcar (args
));
275 return Feval (Fcar (Fcdr (args
)));
276 return Fprogn (Fcdr (Fcdr (args
)));
279 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
280 "(cond CLAUSES...): try each clause until one succeeds.\n\
281 Each clause looks like (CONDITION BODY...). CONDITION is evaluated\n\
282 and, if the value is non-nil, this clause succeeds:\n\
283 then the expressions in BODY are evaluated and the last one's\n\
284 value is the value of the cond-form.\n\
285 If no clause succeeds, cond returns nil.\n\
286 If a clause has one element, as in (CONDITION),\n\
287 CONDITION's value if non-nil is returned from the cond-form.")
291 register Lisp_Object clause
, val
;
298 clause
= Fcar (args
);
299 val
= Feval (Fcar (clause
));
302 if (!EQ (XCONS (clause
)->cdr
, Qnil
))
303 val
= Fprogn (XCONS (clause
)->cdr
);
306 args
= XCONS (args
)->cdr
;
313 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
314 "(progn BODY...): eval BODY forms sequentially and return value of last one.")
318 register Lisp_Object val
, tem
;
319 Lisp_Object args_left
;
322 /* In Mocklisp code, symbols at the front of the progn arglist
323 are to be bound to zero. */
324 if (!EQ (Vmocklisp_arguments
, Qt
))
326 val
= make_number (0);
327 while (!NILP (args
) && (tem
= Fcar (args
), SYMBOLP (tem
)))
330 specbind (tem
, val
), args
= Fcdr (args
);
342 val
= Feval (Fcar (args_left
));
343 args_left
= Fcdr (args_left
);
345 while (!NILP(args_left
));
351 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
352 "(prog1 FIRST BODY...): eval FIRST and BODY sequentially; value from FIRST.\n\
353 The value of FIRST is saved during the evaluation of the remaining args,\n\
354 whose values are discarded.")
359 register Lisp_Object args_left
;
360 struct gcpro gcpro1
, gcpro2
;
361 register int argnum
= 0;
373 val
= Feval (Fcar (args_left
));
375 Feval (Fcar (args_left
));
376 args_left
= Fcdr (args_left
);
378 while (!NILP(args_left
));
384 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
385 "(prog2 X Y BODY...): eval X, Y and BODY sequentially; value from Y.\n\
386 The value of Y is saved during the evaluation of the remaining args,\n\
387 whose values are discarded.")
392 register Lisp_Object args_left
;
393 struct gcpro gcpro1
, gcpro2
;
394 register int argnum
= -1;
408 val
= Feval (Fcar (args_left
));
410 Feval (Fcar (args_left
));
411 args_left
= Fcdr (args_left
);
413 while (!NILP (args_left
));
419 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
420 "(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.\n\
421 The symbols SYM are variables; they are literal (not evaluated).\n\
422 The values VAL are expressions; they are evaluated.\n\
423 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.\n\
424 The second VAL is not computed until after the first SYM is set, and so on;\n\
425 each VAL can use the new value of variables set earlier in the `setq'.\n\
426 The return value of the `setq' form is the value of the last VAL.")
430 register Lisp_Object args_left
;
431 register Lisp_Object val
, sym
;
442 val
= Feval (Fcar (Fcdr (args_left
)));
443 sym
= Fcar (args_left
);
445 args_left
= Fcdr (Fcdr (args_left
));
447 while (!NILP(args_left
));
453 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
454 "Return the argument, without evaluating it. `(quote x)' yields `x'.")
461 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
462 "Like `quote', but preferred for objects which are functions.\n\
463 In byte compilation, `function' causes its argument to be compiled.\n\
464 `quote' cannot do that.")
471 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
472 "Return t if function in which this appears was called interactively.\n\
473 This means that the function was called with call-interactively (which\n\
474 includes being called as the binding of a key)\n\
475 and input is currently coming from the keyboard (not in keyboard macro).")
478 register struct backtrace
*btp
;
479 register Lisp_Object fun
;
484 btp
= backtrace_list
;
486 /* If this isn't a byte-compiled function, there may be a frame at
487 the top for Finteractive_p itself. If so, skip it. */
488 fun
= Findirect_function (*btp
->function
);
489 if (SUBRP (fun
) && XSUBR (fun
) == &Sinteractive_p
)
492 /* If we're running an Emacs 18-style byte-compiled function, there
493 may be a frame for Fbytecode. Now, given the strictest
494 definition, this function isn't really being called
495 interactively, but because that's the way Emacs 18 always builds
496 byte-compiled functions, we'll accept it for now. */
497 if (EQ (*btp
->function
, Qbytecode
))
500 /* If this isn't a byte-compiled function, then we may now be
501 looking at several frames for special forms. Skip past them. */
503 btp
->nargs
== UNEVALLED
)
506 /* btp now points at the frame of the innermost function that isn't
507 a special form, ignoring frames for Finteractive_p and/or
508 Fbytecode at the top. If this frame is for a built-in function
509 (such as load or eval-region) return nil. */
510 fun
= Findirect_function (*btp
->function
);
513 /* btp points to the frame of a Lisp function that called interactive-p.
514 Return t if that function was called interactively. */
515 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
520 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
521 "(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.\n\
522 The definition is (lambda ARGLIST [DOCSTRING] BODY...).\n\
523 See also the function `interactive'.")
527 register Lisp_Object fn_name
;
528 register Lisp_Object defn
;
530 fn_name
= Fcar (args
);
531 defn
= Fcons (Qlambda
, Fcdr (args
));
532 if (!NILP (Vpurify_flag
))
533 defn
= Fpurecopy (defn
);
534 Ffset (fn_name
, defn
);
535 LOADHIST_ATTACH (fn_name
);
539 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
540 "(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.\n\
541 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).\n\
542 When the macro is called, as in (NAME ARGS...),\n\
543 the function (lambda ARGLIST BODY...) is applied to\n\
544 the list ARGS... as it appears in the expression,\n\
545 and the result should be a form to be evaluated instead of the original.")
549 register Lisp_Object fn_name
;
550 register Lisp_Object defn
;
552 fn_name
= Fcar (args
);
553 defn
= Fcons (Qmacro
, Fcons (Qlambda
, Fcdr (args
)));
554 if (!NILP (Vpurify_flag
))
555 defn
= Fpurecopy (defn
);
556 Ffset (fn_name
, defn
);
557 LOADHIST_ATTACH (fn_name
);
561 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
562 "(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.\n\
563 You are not required to define a variable in order to use it,\n\
564 but the definition can supply documentation and an initial value\n\
565 in a way that tags can recognize.\n\n\
566 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.\n\
567 If SYMBOL is buffer-local, its default value is what is set;\n\
568 buffer-local values are not affected.\n\
569 INITVALUE and DOCSTRING are optional.\n\
570 If DOCSTRING starts with *, this variable is identified as a user option.\n\
571 This means that M-x set-variable and M-x edit-options recognize it.\n\
572 If INITVALUE is missing, SYMBOL's value is not set.")
576 register Lisp_Object sym
, tem
, tail
;
580 if (!NILP (Fcdr (Fcdr (tail
))))
581 error ("too many arguments");
585 tem
= Fdefault_boundp (sym
);
587 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
589 tail
= Fcdr (Fcdr (args
));
590 if (!NILP (Fcar (tail
)))
593 if (!NILP (Vpurify_flag
))
594 tem
= Fpurecopy (tem
);
595 Fput (sym
, Qvariable_documentation
, tem
);
597 LOADHIST_ATTACH (sym
);
601 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
602 "(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant variable.\n\
603 The intent is that programs do not change this value, but users may.\n\
604 Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\
605 If SYMBOL is buffer-local, its default value is what is set;\n\
606 buffer-local values are not affected.\n\
607 DOCSTRING is optional.\n\
608 If DOCSTRING starts with *, this variable is identified as a user option.\n\
609 This means that M-x set-variable and M-x edit-options recognize it.\n\n\
610 Note: do not use `defconst' for user options in libraries that are not\n\
611 normally loaded, since it is useful for users to be able to specify\n\
612 their own values for such variables before loading the library.\n\
613 Since `defconst' unconditionally assigns the variable,\n\
614 it would override the user's choice.")
618 register Lisp_Object sym
, tem
;
621 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
622 error ("too many arguments");
624 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
625 tem
= Fcar (Fcdr (Fcdr (args
)));
628 if (!NILP (Vpurify_flag
))
629 tem
= Fpurecopy (tem
);
630 Fput (sym
, Qvariable_documentation
, tem
);
632 LOADHIST_ATTACH (sym
);
636 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
637 "Returns t if VARIABLE is intended to be set and modified by users.\n\
638 \(The alternative is a variable used internally in a Lisp program.)\n\
639 Determined by whether the first character of the documentation\n\
640 for the variable is `*'.")
642 Lisp_Object variable
;
644 Lisp_Object documentation
;
646 documentation
= Fget (variable
, Qvariable_documentation
);
647 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
649 if (STRINGP (documentation
)
650 && ((unsigned char) XSTRING (documentation
)->data
[0] == '*'))
652 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
653 if (CONSP (documentation
)
654 && STRINGP (XCONS (documentation
)->car
)
655 && INTEGERP (XCONS (documentation
)->cdr
)
656 && XINT (XCONS (documentation
)->cdr
) < 0)
661 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
662 "(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
663 The value of the last form in BODY is returned.\n\
664 Each element of VARLIST is a symbol (which is bound to nil)\n\
665 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
666 Each VALUEFORM can refer to the symbols already bound by this VARLIST.")
670 Lisp_Object varlist
, val
, elt
;
671 int count
= specpdl_ptr
- specpdl
;
672 struct gcpro gcpro1
, gcpro2
, gcpro3
;
674 GCPRO3 (args
, elt
, varlist
);
676 varlist
= Fcar (args
);
677 while (!NILP (varlist
))
680 elt
= Fcar (varlist
);
682 specbind (elt
, Qnil
);
683 else if (! NILP (Fcdr (Fcdr (elt
))))
685 Fcons (build_string ("`let' bindings can have only one value-form"),
689 val
= Feval (Fcar (Fcdr (elt
)));
690 specbind (Fcar (elt
), val
);
692 varlist
= Fcdr (varlist
);
695 val
= Fprogn (Fcdr (args
));
696 return unbind_to (count
, val
);
699 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
700 "(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
701 The value of the last form in BODY is returned.\n\
702 Each element of VARLIST is a symbol (which is bound to nil)\n\
703 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
704 All the VALUEFORMs are evalled before any symbols are bound.")
708 Lisp_Object
*temps
, tem
;
709 register Lisp_Object elt
, varlist
;
710 int count
= specpdl_ptr
- specpdl
;
712 struct gcpro gcpro1
, gcpro2
;
714 varlist
= Fcar (args
);
716 /* Make space to hold the values to give the bound variables */
717 elt
= Flength (varlist
);
718 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
720 /* Compute the values and store them in `temps' */
722 GCPRO2 (args
, *temps
);
725 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
728 elt
= Fcar (varlist
);
730 temps
[argnum
++] = Qnil
;
731 else if (! NILP (Fcdr (Fcdr (elt
))))
733 Fcons (build_string ("`let' bindings can have only one value-form"),
736 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
737 gcpro2
.nvars
= argnum
;
741 varlist
= Fcar (args
);
742 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
744 elt
= Fcar (varlist
);
745 tem
= temps
[argnum
++];
749 specbind (Fcar (elt
), tem
);
752 elt
= Fprogn (Fcdr (args
));
753 return unbind_to (count
, elt
);
756 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
757 "(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.\n\
758 The order of execution is thus TEST, BODY, TEST, BODY and so on\n\
759 until TEST returns nil.")
763 Lisp_Object test
, body
, tem
;
764 struct gcpro gcpro1
, gcpro2
;
770 while (tem
= Feval (test
),
771 (!EQ (Vmocklisp_arguments
, Qt
) ? XINT (tem
) : !NILP (tem
)))
781 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
782 "Return result of expanding macros at top level of FORM.\n\
783 If FORM is not a macro call, it is returned unchanged.\n\
784 Otherwise, the macro is expanded and the expansion is considered\n\
785 in place of FORM. When a non-macro-call results, it is returned.\n\n\
786 The second optional arg ENVIRONMENT species an environment of macro\n\
787 definitions to shadow the loaded ones for use in file byte-compilation.")
789 register Lisp_Object form
;
792 /* With cleanups from Hallvard Furuseth. */
793 register Lisp_Object expander
, sym
, def
, tem
;
797 /* Come back here each time we expand a macro call,
798 in case it expands into another macro call. */
801 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
802 def
= sym
= XCONS (form
)->car
;
804 /* Trace symbols aliases to other symbols
805 until we get a symbol that is not an alias. */
806 while (SYMBOLP (def
))
810 tem
= Fassq (sym
, env
);
813 def
= XSYMBOL (sym
)->function
;
814 if (!EQ (def
, Qunbound
))
819 /* Right now TEM is the result from SYM in ENV,
820 and if TEM is nil then DEF is SYM's function definition. */
823 /* SYM is not mentioned in ENV.
824 Look at its function definition. */
825 if (EQ (def
, Qunbound
) || !CONSP (def
))
826 /* Not defined or definition not suitable */
828 if (EQ (XCONS (def
)->car
, Qautoload
))
830 /* Autoloading function: will it be a macro when loaded? */
831 tem
= Fnth (make_number (4), def
);
832 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
833 /* Yes, load it and try again. */
835 do_autoload (def
, sym
);
841 else if (!EQ (XCONS (def
)->car
, Qmacro
))
843 else expander
= XCONS (def
)->cdr
;
847 expander
= XCONS (tem
)->cdr
;
851 form
= apply1 (expander
, XCONS (form
)->cdr
);
856 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
857 "(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.\n\
858 TAG is evalled to get the tag to use. Then the BODY is executed.\n\
859 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.\n\
860 If no throw happens, `catch' returns the value of the last BODY form.\n\
861 If a throw happens, it specifies the value to return from `catch'.")
865 register Lisp_Object tag
;
869 tag
= Feval (Fcar (args
));
871 return internal_catch (tag
, Fprogn
, Fcdr (args
));
874 /* Set up a catch, then call C function FUNC on argument ARG.
875 FUNC should return a Lisp_Object.
876 This is how catches are done from within C code. */
879 internal_catch (tag
, func
, arg
)
881 Lisp_Object (*func
) ();
884 /* This structure is made part of the chain `catchlist'. */
887 /* Fill in the components of c, and put it on the list. */
891 c
.backlist
= backtrace_list
;
892 c
.handlerlist
= handlerlist
;
893 c
.lisp_eval_depth
= lisp_eval_depth
;
894 c
.pdlcount
= specpdl_ptr
- specpdl
;
895 c
.poll_suppress_count
= poll_suppress_count
;
900 if (! _setjmp (c
.jmp
))
901 c
.val
= (*func
) (arg
);
903 /* Throw works by a longjmp that comes right here. */
908 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
909 jump to that CATCH, returning VALUE as the value of that catch.
911 This is the guts Fthrow and Fsignal; they differ only in the way
912 they choose the catch tag to throw to. A catch tag for a
913 condition-case form has a TAG of Qnil.
915 Before each catch is discarded, unbind all special bindings and
916 execute all unwind-protect clauses made above that catch. Unwind
917 the handler stack as we go, so that the proper handlers are in
918 effect for each unwind-protect clause we run. At the end, restore
919 some static info saved in CATCH, and longjmp to the location
922 This is used for correct unwinding in Fthrow and Fsignal. */
925 unwind_to_catch (catch, value
)
926 struct catchtag
*catch;
929 register int last_time
;
931 /* Save the value in the tag. */
934 /* Restore the polling-suppression count. */
935 set_poll_suppress_count (catch->poll_suppress_count
);
939 last_time
= catchlist
== catch;
941 /* Unwind the specpdl stack, and then restore the proper set of
943 unbind_to (catchlist
->pdlcount
, Qnil
);
944 handlerlist
= catchlist
->handlerlist
;
945 catchlist
= catchlist
->next
;
949 gcprolist
= catch->gcpro
;
950 backtrace_list
= catch->backlist
;
951 lisp_eval_depth
= catch->lisp_eval_depth
;
953 _longjmp (catch->jmp
, 1);
956 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
957 "(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.\n\
958 Both TAG and VALUE are evalled.")
960 register Lisp_Object tag
, val
;
962 register struct catchtag
*c
;
967 for (c
= catchlist
; c
; c
= c
->next
)
969 if (EQ (c
->tag
, tag
))
970 unwind_to_catch (c
, val
);
972 tag
= Fsignal (Qno_catch
, Fcons (tag
, Fcons (val
, Qnil
)));
977 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
978 "Do BODYFORM, protecting with UNWINDFORMS.\n\
979 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).\n\
980 If BODYFORM completes normally, its value is returned\n\
981 after executing the UNWINDFORMS.\n\
982 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.")
987 int count
= specpdl_ptr
- specpdl
;
989 record_unwind_protect (0, Fcdr (args
));
990 val
= Feval (Fcar (args
));
991 return unbind_to (count
, val
);
994 /* Chain of condition handlers currently in effect.
995 The elements of this chain are contained in the stack frames
996 of Fcondition_case and internal_condition_case.
997 When an error is signaled (by calling Fsignal, below),
998 this chain is searched for an element that applies. */
1000 struct handler
*handlerlist
;
1002 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1003 "Regain control when an error is signaled.\n\
1004 Usage looks like (condition-case VAR BODYFORM HANDLERS...).\n\
1005 executes BODYFORM and returns its value if no error happens.\n\
1006 Each element of HANDLERS looks like (CONDITION-NAME BODY...)\n\
1007 where the BODY is made of Lisp expressions.\n\n\
1008 A handler is applicable to an error\n\
1009 if CONDITION-NAME is one of the error's condition names.\n\
1010 If an error happens, the first applicable handler is run.\n\
1012 The car of a handler may be a list of condition names\n\
1013 instead of a single condition name.\n\
1015 When a handler handles an error,\n\
1016 control returns to the condition-case and the handler BODY... is executed\n\
1017 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\
1018 VAR may be nil; then you do not get access to the signal information.\n\
1020 The value of the last BODY form is returned from the condition-case.\n\
1021 See also the function `signal' for more info.")
1028 register Lisp_Object var
, bodyform
, handlers
;
1031 bodyform
= Fcar (Fcdr (args
));
1032 handlers
= Fcdr (Fcdr (args
));
1033 CHECK_SYMBOL (var
, 0);
1035 for (val
= handlers
; ! NILP (val
); val
= Fcdr (val
))
1041 && (SYMBOLP (XCONS (tem
)->car
)
1042 || CONSP (XCONS (tem
)->car
)))))
1043 error ("Invalid condition handler", tem
);
1048 c
.backlist
= backtrace_list
;
1049 c
.handlerlist
= handlerlist
;
1050 c
.lisp_eval_depth
= lisp_eval_depth
;
1051 c
.pdlcount
= specpdl_ptr
- specpdl
;
1052 c
.poll_suppress_count
= poll_suppress_count
;
1053 c
.gcpro
= gcprolist
;
1054 if (_setjmp (c
.jmp
))
1057 specbind (h
.var
, c
.val
);
1058 val
= Fprogn (Fcdr (h
.chosen_clause
));
1060 /* Note that this just undoes the binding of h.var; whoever
1061 longjumped to us unwound the stack to c.pdlcount before
1063 unbind_to (c
.pdlcount
, Qnil
);
1070 h
.handler
= handlers
;
1071 h
.next
= handlerlist
;
1075 val
= Feval (bodyform
);
1077 handlerlist
= h
.next
;
1082 internal_condition_case (bfun
, handlers
, hfun
)
1083 Lisp_Object (*bfun
) ();
1084 Lisp_Object handlers
;
1085 Lisp_Object (*hfun
) ();
1091 /* Since Fsignal resets this to 0, it had better be 0 now
1092 or else we have a potential bug. */
1093 if (interrupt_input_blocked
!= 0)
1098 c
.backlist
= backtrace_list
;
1099 c
.handlerlist
= handlerlist
;
1100 c
.lisp_eval_depth
= lisp_eval_depth
;
1101 c
.pdlcount
= specpdl_ptr
- specpdl
;
1102 c
.poll_suppress_count
= poll_suppress_count
;
1103 c
.gcpro
= gcprolist
;
1104 if (_setjmp (c
.jmp
))
1106 return (*hfun
) (c
.val
);
1110 h
.handler
= handlers
;
1112 h
.next
= handlerlist
;
1118 handlerlist
= h
.next
;
1123 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1124 Lisp_Object (*bfun
) ();
1126 Lisp_Object handlers
;
1127 Lisp_Object (*hfun
) ();
1135 c
.backlist
= backtrace_list
;
1136 c
.handlerlist
= handlerlist
;
1137 c
.lisp_eval_depth
= lisp_eval_depth
;
1138 c
.pdlcount
= specpdl_ptr
- specpdl
;
1139 c
.poll_suppress_count
= poll_suppress_count
;
1140 c
.gcpro
= gcprolist
;
1141 if (_setjmp (c
.jmp
))
1143 return (*hfun
) (c
.val
);
1147 h
.handler
= handlers
;
1149 h
.next
= handlerlist
;
1153 val
= (*bfun
) (arg
);
1155 handlerlist
= h
.next
;
1159 static Lisp_Object
find_handler_clause ();
1161 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1162 "Signal an error. Args are ERROR-SYMBOL and associated DATA.\n\
1163 This function does not return.\n\n\
1164 An error symbol is a symbol with an `error-conditions' property\n\
1165 that is a list of condition names.\n\
1166 A handler for any of those names will get to handle this signal.\n\
1167 The symbol `error' should normally be one of them.\n\
1169 DATA should be a list. Its elements are printed as part of the error message.\n\
1170 If the signal is handled, DATA is made available to the handler.\n\
1171 See also the function `condition-case'.")
1172 (error_symbol
, data
)
1173 Lisp_Object error_symbol
, data
;
1175 register struct handler
*allhandlers
= handlerlist
;
1176 Lisp_Object conditions
;
1177 extern int gc_in_progress
;
1178 extern int waiting_for_input
;
1179 Lisp_Object debugger_value
;
1181 quit_error_check ();
1183 if (gc_in_progress
|| waiting_for_input
)
1186 #ifdef HAVE_X_WINDOWS
1187 TOTALLY_UNBLOCK_INPUT
;
1190 conditions
= Fget (error_symbol
, Qerror_conditions
);
1192 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1194 register Lisp_Object clause
;
1195 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1196 error_symbol
, data
, &debugger_value
);
1198 #if 0 /* Most callers are not prepared to handle gc if this returns.
1199 So, since this feature is not very useful, take it out. */
1200 /* If have called debugger and user wants to continue,
1202 if (EQ (clause
, Qlambda
))
1203 return debugger_value
;
1205 if (EQ (clause
, Qlambda
))
1207 /* We can't return values to code which signalled an error, but we
1208 can continue code which has signalled a quit. */
1209 if (EQ (error_symbol
, Qquit
))
1212 error ("Cannot return from the debugger in an error");
1218 Lisp_Object unwind_data
;
1219 struct handler
*h
= handlerlist
;
1221 handlerlist
= allhandlers
;
1222 if (EQ (data
, memory_signal_data
))
1223 unwind_data
= memory_signal_data
;
1225 unwind_data
= Fcons (error_symbol
, data
);
1226 h
->chosen_clause
= clause
;
1227 unwind_to_catch (h
->tag
, unwind_data
);
1231 handlerlist
= allhandlers
;
1232 /* If no handler is present now, try to run the debugger,
1233 and if that fails, throw to top level. */
1234 find_handler_clause (Qerror
, conditions
, error_symbol
, data
, &debugger_value
);
1235 Fthrow (Qtop_level
, Qt
);
1238 /* Return nonzero iff LIST is a non-nil atom or
1239 a list containing one of CONDITIONS. */
1242 wants_debugger (list
, conditions
)
1243 Lisp_Object list
, conditions
;
1250 while (CONSP (conditions
))
1252 Lisp_Object
this, tail
;
1253 this = XCONS (conditions
)->car
;
1254 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1255 if (EQ (XCONS (tail
)->car
, this))
1257 conditions
= XCONS (conditions
)->cdr
;
1262 /* Value of Qlambda means we have called debugger and user has continued.
1263 Store value returned from debugger into *DEBUGGER_VALUE_PTR. */
1266 find_handler_clause (handlers
, conditions
, sig
, data
, debugger_value_ptr
)
1267 Lisp_Object handlers
, conditions
, sig
, data
;
1268 Lisp_Object
*debugger_value_ptr
;
1270 register Lisp_Object h
;
1271 register Lisp_Object tem
;
1273 if (EQ (handlers
, Qt
)) /* t is used by handlers for all conditions, set up by C code. */
1275 if (EQ (handlers
, Qerror
)) /* error is used similarly, but means display a backtrace too */
1277 if (wants_debugger (Vstack_trace_on_error
, conditions
))
1278 internal_with_output_to_temp_buffer ("*Backtrace*", Fbacktrace
, Qnil
);
1279 if ((EQ (sig
, Qquit
)
1281 : wants_debugger (Vdebug_on_error
, conditions
))
1282 && when_entered_debugger
< num_nonmacro_input_chars
)
1284 int count
= specpdl_ptr
- specpdl
;
1285 specbind (Qdebug_on_error
, Qnil
);
1286 *debugger_value_ptr
=
1287 call_debugger (Fcons (Qerror
,
1288 Fcons (Fcons (sig
, data
),
1290 return unbind_to (count
, Qlambda
);
1294 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1296 Lisp_Object handler
, condit
;
1299 if (!CONSP (handler
))
1301 condit
= Fcar (handler
);
1302 /* Handle a single condition name in handler HANDLER. */
1303 if (SYMBOLP (condit
))
1305 tem
= Fmemq (Fcar (handler
), conditions
);
1309 /* Handle a list of condition names in handler HANDLER. */
1310 else if (CONSP (condit
))
1312 while (CONSP (condit
))
1314 tem
= Fmemq (Fcar (condit
), conditions
);
1317 condit
= XCONS (condit
)->cdr
;
1324 /* dump an error message; called like printf */
1328 error (m
, a1
, a2
, a3
)
1348 int used
= doprnt (buf
, size
, m
, m
+ mlen
, 3, args
);
1353 buffer
= (char *) xrealloc (buffer
, size
);
1356 buffer
= (char *) xmalloc (size
);
1361 string
= build_string (buf
);
1365 Fsignal (Qerror
, Fcons (string
, Qnil
));
1368 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 1, 0,
1369 "T if FUNCTION makes provisions for interactive calling.\n\
1370 This means it contains a description for how to read arguments to give it.\n\
1371 The value is nil for an invalid function or a symbol with no function\n\
1374 Interactively callable functions include strings and vectors (treated\n\
1375 as keyboard macros), lambda-expressions that contain a top-level call\n\
1376 to `interactive', autoload definitions made by `autoload' with non-nil\n\
1377 fourth argument, and some of the built-in functions of Lisp.\n\
1379 Also, a symbol satisfies `commandp' if its function definition does so.")
1381 Lisp_Object function
;
1383 register Lisp_Object fun
;
1384 register Lisp_Object funcar
;
1385 register Lisp_Object tem
;
1390 fun
= indirect_function (fun
);
1391 if (EQ (fun
, Qunbound
))
1394 /* Emacs primitives are interactive if their DEFUN specifies an
1395 interactive spec. */
1398 if (XSUBR (fun
)->prompt
)
1404 /* Bytecode objects are interactive if they are long enough to
1405 have an element whose index is COMPILED_INTERACTIVE, which is
1406 where the interactive spec is stored. */
1407 else if (COMPILEDP (fun
))
1408 return ((XVECTOR (fun
)->size
& PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
1411 /* Strings and vectors are keyboard macros. */
1412 if (STRINGP (fun
) || VECTORP (fun
))
1415 /* Lists may represent commands. */
1418 funcar
= Fcar (fun
);
1419 if (!SYMBOLP (funcar
))
1420 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1421 if (EQ (funcar
, Qlambda
))
1422 return Fassq (Qinteractive
, Fcdr (Fcdr (fun
)));
1423 if (EQ (funcar
, Qmocklisp
))
1424 return Qt
; /* All mocklisp functions can be called interactively */
1425 if (EQ (funcar
, Qautoload
))
1426 return Fcar (Fcdr (Fcdr (Fcdr (fun
))));
1432 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1433 "Define FUNCTION to autoload from FILE.\n\
1434 FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\
1435 Third arg DOCSTRING is documentation for the function.\n\
1436 Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\
1437 Fifth arg TYPE indicates the type of the object:\n\
1438 nil or omitted says FUNCTION is a function,\n\
1439 `keymap' says FUNCTION is really a keymap, and\n\
1440 `macro' or t says FUNCTION is really a macro.\n\
1441 Third through fifth args give info about the real definition.\n\
1442 They default to nil.\n\
1443 If FUNCTION is already defined other than as an autoload,\n\
1444 this does nothing and returns nil.")
1445 (function
, file
, docstring
, interactive
, type
)
1446 Lisp_Object function
, file
, docstring
, interactive
, type
;
1449 Lisp_Object args
[4];
1452 CHECK_SYMBOL (function
, 0);
1453 CHECK_STRING (file
, 1);
1455 /* If function is defined and not as an autoload, don't override */
1456 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
1457 && !(CONSP (XSYMBOL (function
)->function
)
1458 && EQ (XCONS (XSYMBOL (function
)->function
)->car
, Qautoload
)))
1463 args
[1] = docstring
;
1464 args
[2] = interactive
;
1467 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
1468 #else /* NO_ARG_ARRAY */
1469 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
1470 #endif /* not NO_ARG_ARRAY */
1474 un_autoload (oldqueue
)
1475 Lisp_Object oldqueue
;
1477 register Lisp_Object queue
, first
, second
;
1479 /* Queue to unwind is current value of Vautoload_queue.
1480 oldqueue is the shadowed value to leave in Vautoload_queue. */
1481 queue
= Vautoload_queue
;
1482 Vautoload_queue
= oldqueue
;
1483 while (CONSP (queue
))
1485 first
= Fcar (queue
);
1486 second
= Fcdr (first
);
1487 first
= Fcar (first
);
1488 if (EQ (second
, Qnil
))
1491 Ffset (first
, second
);
1492 queue
= Fcdr (queue
);
1497 do_autoload (fundef
, funname
)
1498 Lisp_Object fundef
, funname
;
1500 int count
= specpdl_ptr
- specpdl
;
1501 Lisp_Object fun
, val
, queue
, first
, second
;
1504 CHECK_SYMBOL (funname
, 0);
1506 /* Value saved here is to be restored into Vautoload_queue */
1507 record_unwind_protect (un_autoload
, Vautoload_queue
);
1508 Vautoload_queue
= Qt
;
1509 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
);
1511 /* Save the old autoloads, in case we ever do an unload. */
1512 queue
= Vautoload_queue
;
1513 while (CONSP (queue
))
1515 first
= Fcar (queue
);
1516 second
= Fcdr (first
);
1517 first
= Fcar (first
);
1519 /* Note: This test is subtle. The cdr of an autoload-queue entry
1520 may be an atom if the autoload entry was generated by a defalias
1523 Fput (first
, Qautoload
, (Fcdr (second
)));
1525 queue
= Fcdr (queue
);
1528 /* Once loading finishes, don't undo it. */
1529 Vautoload_queue
= Qt
;
1530 unbind_to (count
, Qnil
);
1532 fun
= Findirect_function (fun
);
1534 if (!NILP (Fequal (fun
, fundef
)))
1535 error ("Autoloading failed to define function %s",
1536 XSYMBOL (funname
)->name
->data
);
1539 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
1540 "Evaluate FORM and return its value.")
1544 Lisp_Object fun
, val
, original_fun
, original_args
;
1546 struct backtrace backtrace
;
1547 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1551 if (EQ (Vmocklisp_arguments
, Qt
))
1552 return Fsymbol_value (form
);
1553 val
= Fsymbol_value (form
);
1555 XSETFASTINT (val
, 0);
1556 else if (EQ (val
, Qt
))
1557 XSETFASTINT (val
, 1);
1564 if (consing_since_gc
> gc_cons_threshold
)
1567 Fgarbage_collect ();
1571 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1573 if (max_lisp_eval_depth
< 100)
1574 max_lisp_eval_depth
= 100;
1575 if (lisp_eval_depth
> max_lisp_eval_depth
)
1576 error ("Lisp nesting exceeds max-lisp-eval-depth");
1579 original_fun
= Fcar (form
);
1580 original_args
= Fcdr (form
);
1582 backtrace
.next
= backtrace_list
;
1583 backtrace_list
= &backtrace
;
1584 backtrace
.function
= &original_fun
; /* This also protects them from gc */
1585 backtrace
.args
= &original_args
;
1586 backtrace
.nargs
= UNEVALLED
;
1587 backtrace
.evalargs
= 1;
1588 backtrace
.debug_on_exit
= 0;
1590 if (debug_on_next_call
)
1591 do_debug_on_call (Qt
);
1593 /* At this point, only original_fun and original_args
1594 have values that will be used below */
1596 fun
= Findirect_function (original_fun
);
1600 Lisp_Object numargs
;
1601 Lisp_Object argvals
[7];
1602 Lisp_Object args_left
;
1603 register int i
, maxargs
;
1605 args_left
= original_args
;
1606 numargs
= Flength (args_left
);
1608 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
1609 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
1610 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1612 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1614 backtrace
.evalargs
= 0;
1615 val
= (*XSUBR (fun
)->function
) (args_left
);
1619 if (XSUBR (fun
)->max_args
== MANY
)
1621 /* Pass a vector of evaluated arguments */
1623 register int argnum
= 0;
1625 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1627 GCPRO3 (args_left
, fun
, fun
);
1631 while (!NILP (args_left
))
1633 vals
[argnum
++] = Feval (Fcar (args_left
));
1634 args_left
= Fcdr (args_left
);
1635 gcpro3
.nvars
= argnum
;
1638 backtrace
.args
= vals
;
1639 backtrace
.nargs
= XINT (numargs
);
1641 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
1646 GCPRO3 (args_left
, fun
, fun
);
1647 gcpro3
.var
= argvals
;
1650 maxargs
= XSUBR (fun
)->max_args
;
1651 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
1653 argvals
[i
] = Feval (Fcar (args_left
));
1659 backtrace
.args
= argvals
;
1660 backtrace
.nargs
= XINT (numargs
);
1665 val
= (*XSUBR (fun
)->function
) ();
1668 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
1671 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
1674 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1678 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1679 argvals
[2], argvals
[3]);
1682 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1683 argvals
[3], argvals
[4]);
1686 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1687 argvals
[3], argvals
[4], argvals
[5]);
1690 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1691 argvals
[3], argvals
[4], argvals
[5],
1696 /* Someone has created a subr that takes more arguments than
1697 is supported by this code. We need to either rewrite the
1698 subr to use a different argument protocol, or add more
1699 cases to this switch. */
1703 if (COMPILEDP (fun
))
1704 val
= apply_lambda (fun
, original_args
, 1);
1708 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1709 funcar
= Fcar (fun
);
1710 if (!SYMBOLP (funcar
))
1711 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1712 if (EQ (funcar
, Qautoload
))
1714 do_autoload (fun
, original_fun
);
1717 if (EQ (funcar
, Qmacro
))
1718 val
= Feval (apply1 (Fcdr (fun
), original_args
));
1719 else if (EQ (funcar
, Qlambda
))
1720 val
= apply_lambda (fun
, original_args
, 1);
1721 else if (EQ (funcar
, Qmocklisp
))
1722 val
= ml_apply (fun
, original_args
);
1724 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1727 if (!EQ (Vmocklisp_arguments
, Qt
))
1730 XSETFASTINT (val
, 0);
1731 else if (EQ (val
, Qt
))
1732 XSETFASTINT (val
, 1);
1735 if (backtrace
.debug_on_exit
)
1736 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
1737 backtrace_list
= backtrace
.next
;
1741 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
1742 "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
1743 Then return the value FUNCTION returns.\n\
1744 Thus, (apply '+ 1 2 '(3 4)) returns 10.")
1749 register int i
, numargs
;
1750 register Lisp_Object spread_arg
;
1751 register Lisp_Object
*funcall_args
;
1753 struct gcpro gcpro1
;
1757 spread_arg
= args
[nargs
- 1];
1758 CHECK_LIST (spread_arg
, nargs
);
1760 numargs
= XINT (Flength (spread_arg
));
1763 return Ffuncall (nargs
- 1, args
);
1764 else if (numargs
== 1)
1766 args
[nargs
- 1] = XCONS (spread_arg
)->car
;
1767 return Ffuncall (nargs
, args
);
1770 numargs
+= nargs
- 2;
1772 fun
= indirect_function (fun
);
1773 if (EQ (fun
, Qunbound
))
1775 /* Let funcall get the error */
1782 if (numargs
< XSUBR (fun
)->min_args
1783 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
1784 goto funcall
; /* Let funcall get the error */
1785 else if (XSUBR (fun
)->max_args
> numargs
)
1787 /* Avoid making funcall cons up a yet another new vector of arguments
1788 by explicitly supplying nil's for optional values */
1789 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
1790 * sizeof (Lisp_Object
));
1791 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
1792 funcall_args
[++i
] = Qnil
;
1793 GCPRO1 (*funcall_args
);
1794 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
1798 /* We add 1 to numargs because funcall_args includes the
1799 function itself as well as its arguments. */
1802 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
1803 * sizeof (Lisp_Object
));
1804 GCPRO1 (*funcall_args
);
1805 gcpro1
.nvars
= 1 + numargs
;
1808 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
1809 /* Spread the last arg we got. Its first element goes in
1810 the slot that it used to occupy, hence this value of I. */
1812 while (!NILP (spread_arg
))
1814 funcall_args
[i
++] = XCONS (spread_arg
)->car
;
1815 spread_arg
= XCONS (spread_arg
)->cdr
;
1818 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
1821 /* Run hook variables in various ways. */
1823 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
1825 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 1, MANY
, 0,
1826 "Run each hook in HOOKS. Major mode functions use this.\n\
1827 Each argument should be a symbol, a hook variable.\n\
1828 These symbols are processed in the order specified.\n\
1829 If a hook symbol has a non-nil value, that value may be a function\n\
1830 or a list of functions to be called to run the hook.\n\
1831 If the value is a function, it is called with no arguments.\n\
1832 If it is a list, the elements are called, in order, with no arguments.\n\
1834 To make a hook variable buffer-local, use `make-local-hook',\n\
1835 not `make-local-variable'.")
1840 Lisp_Object hook
[1];
1843 for (i
= 0; i
< nargs
; i
++)
1846 run_hook_with_args (1, hook
, to_completion
);
1852 DEFUN ("run-hook-with-args",
1853 Frun_hook_with_args
, Srun_hook_with_args
, 1, MANY
, 0,
1854 "Run HOOK with the specified arguments ARGS.\n\
1855 HOOK should be a symbol, a hook variable. If HOOK has a non-nil\n\
1856 value, that value may be a function or a list of functions to be\n\
1857 called to run the hook. If the value is a function, it is called with\n\
1858 the given arguments and its return value is returned. If it is a list\n\
1859 of functions, those functions are called, in order,\n\
1860 with the given arguments ARGS.\n\
1861 It is best not to depend on the value return by `run-hook-with-args',\n\
1862 as that may change.\n\
1864 To make a hook variable buffer-local, use `make-local-hook',\n\
1865 not `make-local-variable'.")
1870 return run_hook_with_args (nargs
, args
, to_completion
);
1873 DEFUN ("run-hook-with-args-until-success",
1874 Frun_hook_with_args_until_success
, Srun_hook_with_args_until_success
,
1876 "Run HOOK with the specified arguments ARGS.\n\
1877 HOOK should be a symbol, a hook variable. Its value should\n\
1878 be a list of functions. We call those functions, one by one,\n\
1879 passing arguments ARGS to each of them, until one of them\n\
1880 returns a non-nil value. Then we return that value.\n\
1881 If all the functions return nil, we return nil.\n\
1883 To make a hook variable buffer-local, use `make-local-hook',\n\
1884 not `make-local-variable'.")
1889 return run_hook_with_args (nargs
, args
, until_success
);
1892 DEFUN ("run-hook-with-args-until-failure",
1893 Frun_hook_with_args_until_failure
, Srun_hook_with_args_until_failure
,
1895 "Run HOOK with the specified arguments ARGS.\n\
1896 HOOK should be a symbol, a hook variable. Its value should\n\
1897 be a list of functions. We call those functions, one by one,\n\
1898 passing arguments ARGS to each of them, until one of them\n\
1899 returns nil. Then we return nil.\n\
1900 If all the functions return non-nil, we return non-nil.\n\
1902 To make a hook variable buffer-local, use `make-local-hook',\n\
1903 not `make-local-variable'.")
1908 return run_hook_with_args (nargs
, args
, until_failure
);
1911 /* ARGS[0] should be a hook symbol.
1912 Call each of the functions in the hook value, passing each of them
1913 as arguments all the rest of ARGS (all NARGS - 1 elements).
1914 COND specifies a condition to test after each call
1915 to decide whether to stop.
1916 The caller (or its caller, etc) must gcpro all of ARGS,
1917 except that it isn't necessary to gcpro ARGS[0]. */
1920 run_hook_with_args (nargs
, args
, cond
)
1923 enum run_hooks_condition cond
;
1925 Lisp_Object sym
, val
, ret
;
1926 struct gcpro gcpro1
, gcpro2
;
1929 val
= find_symbol_value (sym
);
1930 ret
= (cond
== until_failure
? Qt
: Qnil
);
1932 if (EQ (val
, Qunbound
) || NILP (val
))
1934 else if (!CONSP (val
) || EQ (XCONS (val
)->car
, Qlambda
))
1937 return Ffuncall (nargs
, args
);
1944 CONSP (val
) && ((cond
== to_completion
)
1945 || (cond
== until_success
? NILP (ret
)
1947 val
= XCONS (val
)->cdr
)
1949 if (EQ (XCONS (val
)->car
, Qt
))
1951 /* t indicates this hook has a local binding;
1952 it means to run the global binding too. */
1953 Lisp_Object globals
;
1955 for (globals
= Fdefault_value (sym
);
1956 CONSP (globals
) && ((cond
== to_completion
)
1957 || (cond
== until_success
? NILP (ret
)
1959 globals
= XCONS (globals
)->cdr
)
1961 args
[0] = XCONS (globals
)->car
;
1962 ret
= Ffuncall (nargs
, args
);
1967 args
[0] = XCONS (val
)->car
;
1968 ret
= Ffuncall (nargs
, args
);
1977 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
1978 present value of that symbol.
1979 Call each element of FUNLIST,
1980 passing each of them the rest of ARGS.
1981 The caller (or its caller, etc) must gcpro all of ARGS,
1982 except that it isn't necessary to gcpro ARGS[0]. */
1985 run_hook_list_with_args (funlist
, nargs
, args
)
1986 Lisp_Object funlist
;
1992 struct gcpro gcpro1
, gcpro2
;
1997 for (val
= funlist
; CONSP (val
); val
= XCONS (val
)->cdr
)
1999 if (EQ (XCONS (val
)->car
, Qt
))
2001 /* t indicates this hook has a local binding;
2002 it means to run the global binding too. */
2003 Lisp_Object globals
;
2005 for (globals
= Fdefault_value (sym
);
2007 globals
= XCONS (globals
)->cdr
)
2009 args
[0] = XCONS (globals
)->car
;
2010 Ffuncall (nargs
, args
);
2015 args
[0] = XCONS (val
)->car
;
2016 Ffuncall (nargs
, args
);
2023 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2026 run_hook_with_args_2 (hook
, arg1
, arg2
)
2027 Lisp_Object hook
, arg1
, arg2
;
2029 Lisp_Object temp
[3];
2034 Frun_hook_with_args (3, temp
);
2037 /* Apply fn to arg */
2040 Lisp_Object fn
, arg
;
2042 struct gcpro gcpro1
;
2046 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2050 Lisp_Object args
[2];
2054 RETURN_UNGCPRO (Fapply (2, args
));
2056 #else /* not NO_ARG_ARRAY */
2057 RETURN_UNGCPRO (Fapply (2, &fn
));
2058 #endif /* not NO_ARG_ARRAY */
2061 /* Call function fn on no arguments */
2066 struct gcpro gcpro1
;
2069 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2072 /* Call function fn with 1 argument arg1 */
2076 Lisp_Object fn
, arg1
;
2078 struct gcpro gcpro1
;
2080 Lisp_Object args
[2];
2086 RETURN_UNGCPRO (Ffuncall (2, args
));
2087 #else /* not NO_ARG_ARRAY */
2090 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2091 #endif /* not NO_ARG_ARRAY */
2094 /* Call function fn with 2 arguments arg1, arg2 */
2097 call2 (fn
, arg1
, arg2
)
2098 Lisp_Object fn
, arg1
, arg2
;
2100 struct gcpro gcpro1
;
2102 Lisp_Object args
[3];
2108 RETURN_UNGCPRO (Ffuncall (3, args
));
2109 #else /* not NO_ARG_ARRAY */
2112 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2113 #endif /* not NO_ARG_ARRAY */
2116 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2119 call3 (fn
, arg1
, arg2
, arg3
)
2120 Lisp_Object fn
, arg1
, arg2
, arg3
;
2122 struct gcpro gcpro1
;
2124 Lisp_Object args
[4];
2131 RETURN_UNGCPRO (Ffuncall (4, args
));
2132 #else /* not NO_ARG_ARRAY */
2135 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2136 #endif /* not NO_ARG_ARRAY */
2139 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2142 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2143 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2145 struct gcpro gcpro1
;
2147 Lisp_Object args
[5];
2155 RETURN_UNGCPRO (Ffuncall (5, args
));
2156 #else /* not NO_ARG_ARRAY */
2159 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2160 #endif /* not NO_ARG_ARRAY */
2163 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2166 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2167 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2169 struct gcpro gcpro1
;
2171 Lisp_Object args
[6];
2180 RETURN_UNGCPRO (Ffuncall (6, args
));
2181 #else /* not NO_ARG_ARRAY */
2184 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2185 #endif /* not NO_ARG_ARRAY */
2188 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2191 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2192 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2194 struct gcpro gcpro1
;
2196 Lisp_Object args
[7];
2206 RETURN_UNGCPRO (Ffuncall (7, args
));
2207 #else /* not NO_ARG_ARRAY */
2210 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2211 #endif /* not NO_ARG_ARRAY */
2214 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2215 "Call first argument as a function, passing remaining arguments to it.\n\
2216 Return the value that function returns.\n\
2217 Thus, (funcall 'cons 'x 'y) returns (x . y).")
2224 int numargs
= nargs
- 1;
2225 Lisp_Object lisp_numargs
;
2227 struct backtrace backtrace
;
2228 register Lisp_Object
*internal_args
;
2232 if (consing_since_gc
> gc_cons_threshold
)
2233 Fgarbage_collect ();
2235 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2237 if (max_lisp_eval_depth
< 100)
2238 max_lisp_eval_depth
= 100;
2239 if (lisp_eval_depth
> max_lisp_eval_depth
)
2240 error ("Lisp nesting exceeds max-lisp-eval-depth");
2243 backtrace
.next
= backtrace_list
;
2244 backtrace_list
= &backtrace
;
2245 backtrace
.function
= &args
[0];
2246 backtrace
.args
= &args
[1];
2247 backtrace
.nargs
= nargs
- 1;
2248 backtrace
.evalargs
= 0;
2249 backtrace
.debug_on_exit
= 0;
2251 if (debug_on_next_call
)
2252 do_debug_on_call (Qlambda
);
2258 fun
= Findirect_function (fun
);
2262 if (numargs
< XSUBR (fun
)->min_args
2263 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2265 XSETFASTINT (lisp_numargs
, numargs
);
2266 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (lisp_numargs
, Qnil
)));
2269 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2270 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2272 if (XSUBR (fun
)->max_args
== MANY
)
2274 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
2278 if (XSUBR (fun
)->max_args
> numargs
)
2280 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2281 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
2282 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2283 internal_args
[i
] = Qnil
;
2286 internal_args
= args
+ 1;
2287 switch (XSUBR (fun
)->max_args
)
2290 val
= (*XSUBR (fun
)->function
) ();
2293 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
2296 val
= (*XSUBR (fun
)->function
) (internal_args
[0],
2300 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2304 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2309 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2310 internal_args
[2], internal_args
[3],
2314 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2315 internal_args
[2], internal_args
[3],
2316 internal_args
[4], internal_args
[5]);
2319 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2320 internal_args
[2], internal_args
[3],
2321 internal_args
[4], internal_args
[5],
2327 /* If a subr takes more than 6 arguments without using MANY
2328 or UNEVALLED, we need to extend this function to support it.
2329 Until this is done, there is no way to call the function. */
2333 if (COMPILEDP (fun
))
2334 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2338 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2339 funcar
= Fcar (fun
);
2340 if (!SYMBOLP (funcar
))
2341 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2342 if (EQ (funcar
, Qlambda
))
2343 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2344 else if (EQ (funcar
, Qmocklisp
))
2345 val
= ml_apply (fun
, Flist (numargs
, args
+ 1));
2346 else if (EQ (funcar
, Qautoload
))
2348 do_autoload (fun
, args
[0]);
2352 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2356 if (backtrace
.debug_on_exit
)
2357 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2358 backtrace_list
= backtrace
.next
;
2363 apply_lambda (fun
, args
, eval_flag
)
2364 Lisp_Object fun
, args
;
2367 Lisp_Object args_left
;
2368 Lisp_Object numargs
;
2369 register Lisp_Object
*arg_vector
;
2370 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2372 register Lisp_Object tem
;
2374 numargs
= Flength (args
);
2375 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2378 GCPRO3 (*arg_vector
, args_left
, fun
);
2381 for (i
= 0; i
< XINT (numargs
);)
2383 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2384 if (eval_flag
) tem
= Feval (tem
);
2385 arg_vector
[i
++] = tem
;
2393 backtrace_list
->args
= arg_vector
;
2394 backtrace_list
->nargs
= i
;
2396 backtrace_list
->evalargs
= 0;
2397 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
2399 /* Do the debug-on-exit now, while arg_vector still exists. */
2400 if (backtrace_list
->debug_on_exit
)
2401 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
2402 /* Don't do it again when we return to eval. */
2403 backtrace_list
->debug_on_exit
= 0;
2407 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2408 and return the result of evaluation.
2409 FUN must be either a lambda-expression or a compiled-code object. */
2412 funcall_lambda (fun
, nargs
, arg_vector
)
2415 register Lisp_Object
*arg_vector
;
2417 Lisp_Object val
, tem
;
2418 register Lisp_Object syms_left
;
2419 Lisp_Object numargs
;
2420 register Lisp_Object next
;
2421 int count
= specpdl_ptr
- specpdl
;
2423 int optional
= 0, rest
= 0;
2425 specbind (Qmocklisp_arguments
, Qt
); /* t means NOT mocklisp! */
2427 XSETFASTINT (numargs
, nargs
);
2430 syms_left
= Fcar (Fcdr (fun
));
2431 else if (COMPILEDP (fun
))
2432 syms_left
= XVECTOR (fun
)->contents
[COMPILED_ARGLIST
];
2436 for (; !NILP (syms_left
); syms_left
= Fcdr (syms_left
))
2439 next
= Fcar (syms_left
);
2440 while (!SYMBOLP (next
))
2441 next
= Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2442 if (EQ (next
, Qand_rest
))
2444 else if (EQ (next
, Qand_optional
))
2448 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
2453 tem
= arg_vector
[i
++];
2454 specbind (next
, tem
);
2457 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2459 specbind (next
, Qnil
);
2463 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2466 val
= Fprogn (Fcdr (Fcdr (fun
)));
2469 /* If we have not actually read the bytecode string
2470 and constants vector yet, fetch them from the file. */
2471 if (CONSP (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
]))
2472 Ffetch_bytecode (fun
);
2473 val
= Fbyte_code (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
],
2474 XVECTOR (fun
)->contents
[COMPILED_CONSTANTS
],
2475 XVECTOR (fun
)->contents
[COMPILED_STACK_DEPTH
]);
2477 return unbind_to (count
, val
);
2480 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
2482 "If byte-compiled OBJECT is lazy-loaded, fetch it now.")
2488 if (COMPILEDP (object
)
2489 && CONSP (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]))
2491 tem
= read_doc_string (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]);
2493 error ("invalid byte code");
2494 XVECTOR (object
)->contents
[COMPILED_BYTECODE
] = XCONS (tem
)->car
;
2495 XVECTOR (object
)->contents
[COMPILED_CONSTANTS
] = XCONS (tem
)->cdr
;
2503 register int count
= specpdl_ptr
- specpdl
;
2504 if (specpdl_size
>= max_specpdl_size
)
2506 if (max_specpdl_size
< 400)
2507 max_specpdl_size
= 400;
2508 if (specpdl_size
>= max_specpdl_size
)
2510 if (!NILP (Vdebug_on_error
))
2511 /* Leave room for some specpdl in the debugger. */
2512 max_specpdl_size
= specpdl_size
+ 100;
2514 Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil
));
2518 if (specpdl_size
> max_specpdl_size
)
2519 specpdl_size
= max_specpdl_size
;
2520 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
2521 specpdl_ptr
= specpdl
+ count
;
2525 specbind (symbol
, value
)
2526 Lisp_Object symbol
, value
;
2530 CHECK_SYMBOL (symbol
, 0);
2532 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2534 specpdl_ptr
->symbol
= symbol
;
2535 specpdl_ptr
->func
= 0;
2536 specpdl_ptr
->old_value
= ovalue
= find_symbol_value (symbol
);
2538 if (BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
))
2539 store_symval_forwarding (symbol
, ovalue
, value
);
2541 Fset (symbol
, value
);
2545 record_unwind_protect (function
, arg
)
2546 Lisp_Object (*function
)();
2549 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2551 specpdl_ptr
->func
= function
;
2552 specpdl_ptr
->symbol
= Qnil
;
2553 specpdl_ptr
->old_value
= arg
;
2558 unbind_to (count
, value
)
2562 int quitf
= !NILP (Vquit_flag
);
2563 struct gcpro gcpro1
;
2569 while (specpdl_ptr
!= specpdl
+ count
)
2572 if (specpdl_ptr
->func
!= 0)
2573 (*specpdl_ptr
->func
) (specpdl_ptr
->old_value
);
2574 /* Note that a "binding" of nil is really an unwind protect,
2575 so in that case the "old value" is a list of forms to evaluate. */
2576 else if (NILP (specpdl_ptr
->symbol
))
2577 Fprogn (specpdl_ptr
->old_value
);
2579 Fset (specpdl_ptr
->symbol
, specpdl_ptr
->old_value
);
2581 if (NILP (Vquit_flag
) && quitf
) Vquit_flag
= Qt
;
2590 /* Get the value of symbol's global binding, even if that binding
2591 is not now dynamically visible. */
2594 top_level_value (symbol
)
2597 register struct specbinding
*ptr
= specpdl
;
2599 CHECK_SYMBOL (symbol
, 0);
2600 for (; ptr
!= specpdl_ptr
; ptr
++)
2602 if (EQ (ptr
->symbol
, symbol
))
2603 return ptr
->old_value
;
2605 return Fsymbol_value (symbol
);
2609 top_level_set (symbol
, newval
)
2610 Lisp_Object symbol
, newval
;
2612 register struct specbinding
*ptr
= specpdl
;
2614 CHECK_SYMBOL (symbol
, 0);
2615 for (; ptr
!= specpdl_ptr
; ptr
++)
2617 if (EQ (ptr
->symbol
, symbol
))
2619 ptr
->old_value
= newval
;
2623 return Fset (symbol
, newval
);
2628 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
2629 "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\
2630 The debugger is entered when that frame exits, if the flag is non-nil.")
2632 Lisp_Object level
, flag
;
2634 register struct backtrace
*backlist
= backtrace_list
;
2637 CHECK_NUMBER (level
, 0);
2639 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
2641 backlist
= backlist
->next
;
2645 backlist
->debug_on_exit
= !NILP (flag
);
2650 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
2651 "Print a trace of Lisp function calls currently active.\n\
2652 Output stream used is value of `standard-output'.")
2655 register struct backtrace
*backlist
= backtrace_list
;
2659 extern Lisp_Object Vprint_level
;
2660 struct gcpro gcpro1
;
2662 XSETFASTINT (Vprint_level
, 3);
2669 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
2670 if (backlist
->nargs
== UNEVALLED
)
2672 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
2673 write_string ("\n", -1);
2677 tem
= *backlist
->function
;
2678 Fprin1 (tem
, Qnil
); /* This can QUIT */
2679 write_string ("(", -1);
2680 if (backlist
->nargs
== MANY
)
2682 for (tail
= *backlist
->args
, i
= 0;
2684 tail
= Fcdr (tail
), i
++)
2686 if (i
) write_string (" ", -1);
2687 Fprin1 (Fcar (tail
), Qnil
);
2692 for (i
= 0; i
< backlist
->nargs
; i
++)
2694 if (i
) write_string (" ", -1);
2695 Fprin1 (backlist
->args
[i
], Qnil
);
2698 write_string (")\n", -1);
2700 backlist
= backlist
->next
;
2703 Vprint_level
= Qnil
;
2708 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, "",
2709 "Return the function and arguments N frames up from current execution point.\n\
2710 If that frame has not evaluated the arguments yet (or is a special form),\n\
2711 the value is (nil FUNCTION ARG-FORMS...).\n\
2712 If that frame has evaluated its arguments and called its function already,\n\
2713 the value is (t FUNCTION ARG-VALUES...).\n\
2714 A &rest arg is represented as the tail of the list ARG-VALUES.\n\
2715 FUNCTION is whatever was supplied as car of evaluated list,\n\
2716 or a lambda expression for macro calls.\n\
2717 If N is more than the number of frames, the value is nil.")
2719 Lisp_Object nframes
;
2721 register struct backtrace
*backlist
= backtrace_list
;
2725 CHECK_NATNUM (nframes
, 0);
2727 /* Find the frame requested. */
2728 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
2729 backlist
= backlist
->next
;
2733 if (backlist
->nargs
== UNEVALLED
)
2734 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
2737 if (backlist
->nargs
== MANY
)
2738 tem
= *backlist
->args
;
2740 tem
= Flist (backlist
->nargs
, backlist
->args
);
2742 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
2748 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
2749 "Limit on number of Lisp variable bindings & unwind-protects before error.");
2751 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
2752 "Limit on depth in `eval', `apply' and `funcall' before error.\n\
2753 This limit is to catch infinite recursions for you before they cause\n\
2754 actual stack overflow in C, which would be fatal for Emacs.\n\
2755 You can safely make it considerably larger than its default value,\n\
2756 if that proves inconveniently small.");
2758 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
2759 "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
2760 Typing C-g sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
2763 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
2764 "Non-nil inhibits C-g quitting from happening immediately.\n\
2765 Note that `quit-flag' will still be set by typing C-g,\n\
2766 so a quit will be signalled as soon as `inhibit-quit' is nil.\n\
2767 To prevent this happening, set `quit-flag' to nil\n\
2768 before making `inhibit-quit' nil.");
2769 Vinhibit_quit
= Qnil
;
2771 Qinhibit_quit
= intern ("inhibit-quit");
2772 staticpro (&Qinhibit_quit
);
2774 Qautoload
= intern ("autoload");
2775 staticpro (&Qautoload
);
2777 Qdebug_on_error
= intern ("debug-on-error");
2778 staticpro (&Qdebug_on_error
);
2780 Qmacro
= intern ("macro");
2781 staticpro (&Qmacro
);
2783 /* Note that the process handling also uses Qexit, but we don't want
2784 to staticpro it twice, so we just do it here. */
2785 Qexit
= intern ("exit");
2788 Qinteractive
= intern ("interactive");
2789 staticpro (&Qinteractive
);
2791 Qcommandp
= intern ("commandp");
2792 staticpro (&Qcommandp
);
2794 Qdefun
= intern ("defun");
2795 staticpro (&Qdefun
);
2797 Qand_rest
= intern ("&rest");
2798 staticpro (&Qand_rest
);
2800 Qand_optional
= intern ("&optional");
2801 staticpro (&Qand_optional
);
2803 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
2804 "*Non-nil means automatically display a backtrace buffer\n\
2805 after any error that is handled by the editor command loop.\n\
2806 If the value is a list, an error only means to display a backtrace\n\
2807 if one of its condition symbols appears in the list.");
2808 Vstack_trace_on_error
= Qnil
;
2810 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
2811 "*Non-nil means enter debugger if an error is signaled.\n\
2812 Does not apply to errors handled by `condition-case'.\n\
2813 If the value is a list, an error only means to enter the debugger\n\
2814 if one of its condition symbols appears in the list.\n\
2815 See also variable `debug-on-quit'.");
2816 Vdebug_on_error
= Qnil
;
2818 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
2819 "*Non-nil means enter debugger if quit is signaled (C-g, for example).\n\
2820 Does not apply if quit is handled by a `condition-case'.");
2823 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
2824 "Non-nil means enter debugger before next `eval', `apply' or `funcall'.");
2826 DEFVAR_LISP ("debugger", &Vdebugger
,
2827 "Function to call to invoke debugger.\n\
2828 If due to frame exit, args are `exit' and the value being returned;\n\
2829 this function's value will be returned instead of that.\n\
2830 If due to error, args are `error' and a list of the args to `signal'.\n\
2831 If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
2832 If due to `eval' entry, one arg, t.");
2835 Qmocklisp_arguments
= intern ("mocklisp-arguments");
2836 staticpro (&Qmocklisp_arguments
);
2837 DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments
,
2838 "While in a mocklisp function, the list of its unevaluated args.");
2839 Vmocklisp_arguments
= Qt
;
2841 DEFVAR_LISP ("run-hooks", &Vrun_hooks
,
2842 "Set to the function `run-hooks', if that function has been defined.\n\
2843 Otherwise, nil (in a bare Emacs without preloaded Lisp code).");
2845 staticpro (&Vautoload_queue
);
2846 Vautoload_queue
= Qnil
;
2857 defsubr (&Sfunction
);
2859 defsubr (&Sdefmacro
);
2861 defsubr (&Sdefconst
);
2862 defsubr (&Suser_variable_p
);
2866 defsubr (&Smacroexpand
);
2869 defsubr (&Sunwind_protect
);
2870 defsubr (&Scondition_case
);
2872 defsubr (&Sinteractive_p
);
2873 defsubr (&Scommandp
);
2874 defsubr (&Sautoload
);
2877 defsubr (&Sfuncall
);
2878 defsubr (&Srun_hooks
);
2879 defsubr (&Srun_hook_with_args
);
2880 defsubr (&Srun_hook_with_args_until_success
);
2881 defsubr (&Srun_hook_with_args_until_failure
);
2882 defsubr (&Sfetch_bytecode
);
2883 defsubr (&Sbacktrace_debug
);
2884 defsubr (&Sbacktrace
);
2885 defsubr (&Sbacktrace_frame
);