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
funcall_lambda ();
147 extern Lisp_Object
ml_apply (); /* Apply a mocklisp function to unevaluated argument list */
152 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
153 max_specpdl_size
= 600;
154 max_lisp_eval_depth
= 200;
161 specpdl_ptr
= specpdl
;
166 debug_on_next_call
= 0;
168 /* This is less than the initial value of num_nonmacro_input_chars. */
169 when_entered_debugger
= -1;
176 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
177 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
178 if (specpdl_size
+ 40 > max_specpdl_size
)
179 max_specpdl_size
= specpdl_size
+ 40;
180 debug_on_next_call
= 0;
181 when_entered_debugger
= num_nonmacro_input_chars
;
182 return apply1 (Vdebugger
, arg
);
185 do_debug_on_call (code
)
188 debug_on_next_call
= 0;
189 backtrace_list
->debug_on_exit
= 1;
190 call_debugger (Fcons (code
, Qnil
));
193 /* NOTE!!! Every function that can call EVAL must protect its args
194 and temporaries from garbage collection while it needs them.
195 The definition of `For' shows what you have to do. */
197 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
198 "Eval args until one of them yields non-nil, then return that value.\n\
199 The remaining args are not evalled at all.\n\
200 If all args return nil, return nil.")
204 register Lisp_Object val
;
205 Lisp_Object args_left
;
216 val
= Feval (Fcar (args_left
));
219 args_left
= Fcdr (args_left
);
221 while (!NILP(args_left
));
227 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
228 "Eval args until one of them yields nil, then return nil.\n\
229 The remaining args are not evalled at all.\n\
230 If no arg yields nil, return the last arg's value.")
234 register Lisp_Object val
;
235 Lisp_Object args_left
;
246 val
= Feval (Fcar (args_left
));
249 args_left
= Fcdr (args_left
);
251 while (!NILP(args_left
));
257 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
258 "(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...\n\
259 Returns the value of THEN or the value of the last of the ELSE's.\n\
260 THEN must be one expression, but ELSE... can be zero or more expressions.\n\
261 If COND yields nil, and there are no ELSE's, the value is nil.")
265 register Lisp_Object cond
;
269 cond
= Feval (Fcar (args
));
273 return Feval (Fcar (Fcdr (args
)));
274 return Fprogn (Fcdr (Fcdr (args
)));
277 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
278 "(cond CLAUSES...): try each clause until one succeeds.\n\
279 Each clause looks like (CONDITION BODY...). CONDITION is evaluated\n\
280 and, if the value is non-nil, this clause succeeds:\n\
281 then the expressions in BODY are evaluated and the last one's\n\
282 value is the value of the cond-form.\n\
283 If no clause succeeds, cond returns nil.\n\
284 If a clause has one element, as in (CONDITION),\n\
285 CONDITION's value if non-nil is returned from the cond-form.")
289 register Lisp_Object clause
, val
;
296 clause
= Fcar (args
);
297 val
= Feval (Fcar (clause
));
300 if (!EQ (XCONS (clause
)->cdr
, Qnil
))
301 val
= Fprogn (XCONS (clause
)->cdr
);
304 args
= XCONS (args
)->cdr
;
311 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
312 "(progn BODY...): eval BODY forms sequentially and return value of last one.")
316 register Lisp_Object val
, tem
;
317 Lisp_Object args_left
;
320 /* In Mocklisp code, symbols at the front of the progn arglist
321 are to be bound to zero. */
322 if (!EQ (Vmocklisp_arguments
, Qt
))
324 val
= make_number (0);
325 while (!NILP (args
) && (tem
= Fcar (args
), SYMBOLP (tem
)))
328 specbind (tem
, val
), args
= Fcdr (args
);
340 val
= Feval (Fcar (args_left
));
341 args_left
= Fcdr (args_left
);
343 while (!NILP(args_left
));
349 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
350 "(prog1 FIRST BODY...): eval FIRST and BODY sequentially; value from FIRST.\n\
351 The value of FIRST is saved during the evaluation of the remaining args,\n\
352 whose values are discarded.")
357 register Lisp_Object args_left
;
358 struct gcpro gcpro1
, gcpro2
;
359 register int argnum
= 0;
371 val
= Feval (Fcar (args_left
));
373 Feval (Fcar (args_left
));
374 args_left
= Fcdr (args_left
);
376 while (!NILP(args_left
));
382 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
383 "(prog2 X Y BODY...): eval X, Y and BODY sequentially; value from Y.\n\
384 The value of Y is saved during the evaluation of the remaining args,\n\
385 whose values are discarded.")
390 register Lisp_Object args_left
;
391 struct gcpro gcpro1
, gcpro2
;
392 register int argnum
= -1;
406 val
= Feval (Fcar (args_left
));
408 Feval (Fcar (args_left
));
409 args_left
= Fcdr (args_left
);
411 while (!NILP (args_left
));
417 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
418 "(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.\n\
419 The symbols SYM are variables; they are literal (not evaluated).\n\
420 The values VAL are expressions; they are evaluated.\n\
421 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.\n\
422 The second VAL is not computed until after the first SYM is set, and so on;\n\
423 each VAL can use the new value of variables set earlier in the `setq'.\n\
424 The return value of the `setq' form is the value of the last VAL.")
428 register Lisp_Object args_left
;
429 register Lisp_Object val
, sym
;
440 val
= Feval (Fcar (Fcdr (args_left
)));
441 sym
= Fcar (args_left
);
443 args_left
= Fcdr (Fcdr (args_left
));
445 while (!NILP(args_left
));
451 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
452 "Return the argument, without evaluating it. `(quote x)' yields `x'.")
459 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
460 "Like `quote', but preferred for objects which are functions.\n\
461 In byte compilation, `function' causes its argument to be compiled.\n\
462 `quote' cannot do that.")
469 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
470 "Return t if function in which this appears was called interactively.\n\
471 This means that the function was called with call-interactively (which\n\
472 includes being called as the binding of a key)\n\
473 and input is currently coming from the keyboard (not in keyboard macro).")
476 register struct backtrace
*btp
;
477 register Lisp_Object fun
;
482 btp
= backtrace_list
;
484 /* If this isn't a byte-compiled function, there may be a frame at
485 the top for Finteractive_p itself. If so, skip it. */
486 fun
= Findirect_function (*btp
->function
);
487 if (SUBRP (fun
) && XSUBR (fun
) == &Sinteractive_p
)
490 /* If we're running an Emacs 18-style byte-compiled function, there
491 may be a frame for Fbytecode. Now, given the strictest
492 definition, this function isn't really being called
493 interactively, but because that's the way Emacs 18 always builds
494 byte-compiled functions, we'll accept it for now. */
495 if (EQ (*btp
->function
, Qbytecode
))
498 /* If this isn't a byte-compiled function, then we may now be
499 looking at several frames for special forms. Skip past them. */
501 btp
->nargs
== UNEVALLED
)
504 /* btp now points at the frame of the innermost function that isn't
505 a special form, ignoring frames for Finteractive_p and/or
506 Fbytecode at the top. If this frame is for a built-in function
507 (such as load or eval-region) return nil. */
508 fun
= Findirect_function (*btp
->function
);
511 /* btp points to the frame of a Lisp function that called interactive-p.
512 Return t if that function was called interactively. */
513 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
518 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
519 "(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.\n\
520 The definition is (lambda ARGLIST [DOCSTRING] BODY...).\n\
521 See also the function `interactive'.")
525 register Lisp_Object fn_name
;
526 register Lisp_Object defn
;
528 fn_name
= Fcar (args
);
529 defn
= Fcons (Qlambda
, Fcdr (args
));
530 if (!NILP (Vpurify_flag
))
531 defn
= Fpurecopy (defn
);
532 Ffset (fn_name
, defn
);
533 LOADHIST_ATTACH (fn_name
);
537 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
538 "(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.\n\
539 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).\n\
540 When the macro is called, as in (NAME ARGS...),\n\
541 the function (lambda ARGLIST BODY...) is applied to\n\
542 the list ARGS... as it appears in the expression,\n\
543 and the result should be a form to be evaluated instead of the original.")
547 register Lisp_Object fn_name
;
548 register Lisp_Object defn
;
550 fn_name
= Fcar (args
);
551 defn
= Fcons (Qmacro
, Fcons (Qlambda
, Fcdr (args
)));
552 if (!NILP (Vpurify_flag
))
553 defn
= Fpurecopy (defn
);
554 Ffset (fn_name
, defn
);
555 LOADHIST_ATTACH (fn_name
);
559 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
560 "(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.\n\
561 You are not required to define a variable in order to use it,\n\
562 but the definition can supply documentation and an initial value\n\
563 in a way that tags can recognize.\n\n\
564 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.\n\
565 If SYMBOL is buffer-local, its default value is what is set;\n\
566 buffer-local values are not affected.\n\
567 INITVALUE and DOCSTRING are optional.\n\
568 If DOCSTRING starts with *, this variable is identified as a user option.\n\
569 This means that M-x set-variable and M-x edit-options recognize it.\n\
570 If INITVALUE is missing, SYMBOL's value is not set.")
574 register Lisp_Object sym
, tem
, tail
;
578 if (!NILP (Fcdr (Fcdr (tail
))))
579 error ("too many arguments");
583 tem
= Fdefault_boundp (sym
);
585 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
587 tail
= Fcdr (Fcdr (args
));
588 if (!NILP (Fcar (tail
)))
591 if (!NILP (Vpurify_flag
))
592 tem
= Fpurecopy (tem
);
593 Fput (sym
, Qvariable_documentation
, tem
);
595 LOADHIST_ATTACH (sym
);
599 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
600 "(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant variable.\n\
601 The intent is that programs do not change this value, but users may.\n\
602 Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\
603 If SYMBOL is buffer-local, its default value is what is set;\n\
604 buffer-local values are not affected.\n\
605 DOCSTRING is optional.\n\
606 If DOCSTRING starts with *, this variable is identified as a user option.\n\
607 This means that M-x set-variable and M-x edit-options recognize it.\n\n\
608 Note: do not use `defconst' for user options in libraries that are not\n\
609 normally loaded, since it is useful for users to be able to specify\n\
610 their own values for such variables before loading the library.\n\
611 Since `defconst' unconditionally assigns the variable,\n\
612 it would override the user's choice.")
616 register Lisp_Object sym
, tem
;
619 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
620 error ("too many arguments");
622 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
623 tem
= Fcar (Fcdr (Fcdr (args
)));
626 if (!NILP (Vpurify_flag
))
627 tem
= Fpurecopy (tem
);
628 Fput (sym
, Qvariable_documentation
, tem
);
630 LOADHIST_ATTACH (sym
);
634 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
635 "Returns t if VARIABLE is intended to be set and modified by users.\n\
636 \(The alternative is a variable used internally in a Lisp program.)\n\
637 Determined by whether the first character of the documentation\n\
638 for the variable is `*'.")
640 Lisp_Object variable
;
642 Lisp_Object documentation
;
644 documentation
= Fget (variable
, Qvariable_documentation
);
645 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
647 if (STRINGP (documentation
)
648 && ((unsigned char) XSTRING (documentation
)->data
[0] == '*'))
650 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
651 if (CONSP (documentation
)
652 && STRINGP (XCONS (documentation
)->car
)
653 && INTEGERP (XCONS (documentation
)->cdr
)
654 && XINT (XCONS (documentation
)->cdr
) < 0)
659 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
660 "(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
661 The value of the last form in BODY is returned.\n\
662 Each element of VARLIST is a symbol (which is bound to nil)\n\
663 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
664 Each VALUEFORM can refer to the symbols already bound by this VARLIST.")
668 Lisp_Object varlist
, val
, elt
;
669 int count
= specpdl_ptr
- specpdl
;
670 struct gcpro gcpro1
, gcpro2
, gcpro3
;
672 GCPRO3 (args
, elt
, varlist
);
674 varlist
= Fcar (args
);
675 while (!NILP (varlist
))
678 elt
= Fcar (varlist
);
680 specbind (elt
, Qnil
);
681 else if (! NILP (Fcdr (Fcdr (elt
))))
683 Fcons (build_string ("`let' bindings can have only one value-form"),
687 val
= Feval (Fcar (Fcdr (elt
)));
688 specbind (Fcar (elt
), val
);
690 varlist
= Fcdr (varlist
);
693 val
= Fprogn (Fcdr (args
));
694 return unbind_to (count
, val
);
697 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
698 "(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
699 The value of the last form in BODY is returned.\n\
700 Each element of VARLIST is a symbol (which is bound to nil)\n\
701 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
702 All the VALUEFORMs are evalled before any symbols are bound.")
706 Lisp_Object
*temps
, tem
;
707 register Lisp_Object elt
, varlist
;
708 int count
= specpdl_ptr
- specpdl
;
710 struct gcpro gcpro1
, gcpro2
;
712 varlist
= Fcar (args
);
714 /* Make space to hold the values to give the bound variables */
715 elt
= Flength (varlist
);
716 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
718 /* Compute the values and store them in `temps' */
720 GCPRO2 (args
, *temps
);
723 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
726 elt
= Fcar (varlist
);
728 temps
[argnum
++] = Qnil
;
729 else if (! NILP (Fcdr (Fcdr (elt
))))
731 Fcons (build_string ("`let' bindings can have only one value-form"),
734 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
735 gcpro2
.nvars
= argnum
;
739 varlist
= Fcar (args
);
740 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
742 elt
= Fcar (varlist
);
743 tem
= temps
[argnum
++];
747 specbind (Fcar (elt
), tem
);
750 elt
= Fprogn (Fcdr (args
));
751 return unbind_to (count
, elt
);
754 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
755 "(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.\n\
756 The order of execution is thus TEST, BODY, TEST, BODY and so on\n\
757 until TEST returns nil.")
761 Lisp_Object test
, body
, tem
;
762 struct gcpro gcpro1
, gcpro2
;
768 while (tem
= Feval (test
),
769 (!EQ (Vmocklisp_arguments
, Qt
) ? XINT (tem
) : !NILP (tem
)))
779 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
780 "Return result of expanding macros at top level of FORM.\n\
781 If FORM is not a macro call, it is returned unchanged.\n\
782 Otherwise, the macro is expanded and the expansion is considered\n\
783 in place of FORM. When a non-macro-call results, it is returned.\n\n\
784 The second optional arg ENVIRONMENT species an environment of macro\n\
785 definitions to shadow the loaded ones for use in file byte-compilation.")
787 register Lisp_Object form
;
790 /* With cleanups from Hallvard Furuseth. */
791 register Lisp_Object expander
, sym
, def
, tem
;
795 /* Come back here each time we expand a macro call,
796 in case it expands into another macro call. */
799 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
800 def
= sym
= XCONS (form
)->car
;
802 /* Trace symbols aliases to other symbols
803 until we get a symbol that is not an alias. */
804 while (SYMBOLP (def
))
808 tem
= Fassq (sym
, env
);
811 def
= XSYMBOL (sym
)->function
;
812 if (!EQ (def
, Qunbound
))
817 /* Right now TEM is the result from SYM in ENV,
818 and if TEM is nil then DEF is SYM's function definition. */
821 /* SYM is not mentioned in ENV.
822 Look at its function definition. */
823 if (EQ (def
, Qunbound
) || !CONSP (def
))
824 /* Not defined or definition not suitable */
826 if (EQ (XCONS (def
)->car
, Qautoload
))
828 /* Autoloading function: will it be a macro when loaded? */
829 tem
= Fnth (make_number (4), def
);
830 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
831 /* Yes, load it and try again. */
833 do_autoload (def
, sym
);
839 else if (!EQ (XCONS (def
)->car
, Qmacro
))
841 else expander
= XCONS (def
)->cdr
;
845 expander
= XCONS (tem
)->cdr
;
849 form
= apply1 (expander
, XCONS (form
)->cdr
);
854 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
855 "(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.\n\
856 TAG is evalled to get the tag to use. Then the BODY is executed.\n\
857 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.\n\
858 If no throw happens, `catch' returns the value of the last BODY form.\n\
859 If a throw happens, it specifies the value to return from `catch'.")
863 register Lisp_Object tag
;
867 tag
= Feval (Fcar (args
));
869 return internal_catch (tag
, Fprogn
, Fcdr (args
));
872 /* Set up a catch, then call C function FUNC on argument ARG.
873 FUNC should return a Lisp_Object.
874 This is how catches are done from within C code. */
877 internal_catch (tag
, func
, arg
)
879 Lisp_Object (*func
) ();
882 /* This structure is made part of the chain `catchlist'. */
885 /* Fill in the components of c, and put it on the list. */
889 c
.backlist
= backtrace_list
;
890 c
.handlerlist
= handlerlist
;
891 c
.lisp_eval_depth
= lisp_eval_depth
;
892 c
.pdlcount
= specpdl_ptr
- specpdl
;
893 c
.poll_suppress_count
= poll_suppress_count
;
898 if (! _setjmp (c
.jmp
))
899 c
.val
= (*func
) (arg
);
901 /* Throw works by a longjmp that comes right here. */
906 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
907 jump to that CATCH, returning VALUE as the value of that catch.
909 This is the guts Fthrow and Fsignal; they differ only in the way
910 they choose the catch tag to throw to. A catch tag for a
911 condition-case form has a TAG of Qnil.
913 Before each catch is discarded, unbind all special bindings and
914 execute all unwind-protect clauses made above that catch. Unwind
915 the handler stack as we go, so that the proper handlers are in
916 effect for each unwind-protect clause we run. At the end, restore
917 some static info saved in CATCH, and longjmp to the location
920 This is used for correct unwinding in Fthrow and Fsignal. */
923 unwind_to_catch (catch, value
)
924 struct catchtag
*catch;
927 register int last_time
;
929 /* Save the value in the tag. */
932 /* Restore the polling-suppression count. */
933 set_poll_suppress_count (catch->poll_suppress_count
);
937 last_time
= catchlist
== catch;
939 /* Unwind the specpdl stack, and then restore the proper set of
941 unbind_to (catchlist
->pdlcount
, Qnil
);
942 handlerlist
= catchlist
->handlerlist
;
943 catchlist
= catchlist
->next
;
947 gcprolist
= catch->gcpro
;
948 backtrace_list
= catch->backlist
;
949 lisp_eval_depth
= catch->lisp_eval_depth
;
951 _longjmp (catch->jmp
, 1);
954 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
955 "(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.\n\
956 Both TAG and VALUE are evalled.")
958 register Lisp_Object tag
, val
;
960 register struct catchtag
*c
;
965 for (c
= catchlist
; c
; c
= c
->next
)
967 if (EQ (c
->tag
, tag
))
968 unwind_to_catch (c
, val
);
970 tag
= Fsignal (Qno_catch
, Fcons (tag
, Fcons (val
, Qnil
)));
975 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
976 "Do BODYFORM, protecting with UNWINDFORMS.\n\
977 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).\n\
978 If BODYFORM completes normally, its value is returned\n\
979 after executing the UNWINDFORMS.\n\
980 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.")
985 int count
= specpdl_ptr
- specpdl
;
987 record_unwind_protect (0, Fcdr (args
));
988 val
= Feval (Fcar (args
));
989 return unbind_to (count
, val
);
992 /* Chain of condition handlers currently in effect.
993 The elements of this chain are contained in the stack frames
994 of Fcondition_case and internal_condition_case.
995 When an error is signaled (by calling Fsignal, below),
996 this chain is searched for an element that applies. */
998 struct handler
*handlerlist
;
1000 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1001 "Regain control when an error is signaled.\n\
1002 Usage looks like (condition-case VAR BODYFORM HANDLERS...).\n\
1003 executes BODYFORM and returns its value if no error happens.\n\
1004 Each element of HANDLERS looks like (CONDITION-NAME BODY...)\n\
1005 where the BODY is made of Lisp expressions.\n\n\
1006 A handler is applicable to an error\n\
1007 if CONDITION-NAME is one of the error's condition names.\n\
1008 If an error happens, the first applicable handler is run.\n\
1010 The car of a handler may be a list of condition names\n\
1011 instead of a single condition name.\n\
1013 When a handler handles an error,\n\
1014 control returns to the condition-case and the handler BODY... is executed\n\
1015 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\
1016 VAR may be nil; then you do not get access to the signal information.\n\
1018 The value of the last BODY form is returned from the condition-case.\n\
1019 See also the function `signal' for more info.")
1026 register Lisp_Object var
, bodyform
, handlers
;
1029 bodyform
= Fcar (Fcdr (args
));
1030 handlers
= Fcdr (Fcdr (args
));
1031 CHECK_SYMBOL (var
, 0);
1033 for (val
= handlers
; ! NILP (val
); val
= Fcdr (val
))
1039 && (SYMBOLP (XCONS (tem
)->car
)
1040 || CONSP (XCONS (tem
)->car
)))))
1041 error ("Invalid condition handler", tem
);
1046 c
.backlist
= backtrace_list
;
1047 c
.handlerlist
= handlerlist
;
1048 c
.lisp_eval_depth
= lisp_eval_depth
;
1049 c
.pdlcount
= specpdl_ptr
- specpdl
;
1050 c
.poll_suppress_count
= poll_suppress_count
;
1051 c
.gcpro
= gcprolist
;
1052 if (_setjmp (c
.jmp
))
1055 specbind (h
.var
, c
.val
);
1056 val
= Fprogn (Fcdr (h
.chosen_clause
));
1058 /* Note that this just undoes the binding of h.var; whoever
1059 longjumped to us unwound the stack to c.pdlcount before
1061 unbind_to (c
.pdlcount
, Qnil
);
1068 h
.handler
= handlers
;
1069 h
.next
= handlerlist
;
1073 val
= Feval (bodyform
);
1075 handlerlist
= h
.next
;
1080 internal_condition_case (bfun
, handlers
, hfun
)
1081 Lisp_Object (*bfun
) ();
1082 Lisp_Object handlers
;
1083 Lisp_Object (*hfun
) ();
1089 /* Since Fsignal resets this to 0, it had better be 0 now
1090 or else we have a potential bug. */
1091 if (interrupt_input_blocked
!= 0)
1096 c
.backlist
= backtrace_list
;
1097 c
.handlerlist
= handlerlist
;
1098 c
.lisp_eval_depth
= lisp_eval_depth
;
1099 c
.pdlcount
= specpdl_ptr
- specpdl
;
1100 c
.poll_suppress_count
= poll_suppress_count
;
1101 c
.gcpro
= gcprolist
;
1102 if (_setjmp (c
.jmp
))
1104 return (*hfun
) (c
.val
);
1108 h
.handler
= handlers
;
1110 h
.next
= handlerlist
;
1116 handlerlist
= h
.next
;
1121 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1122 Lisp_Object (*bfun
) ();
1124 Lisp_Object handlers
;
1125 Lisp_Object (*hfun
) ();
1133 c
.backlist
= backtrace_list
;
1134 c
.handlerlist
= handlerlist
;
1135 c
.lisp_eval_depth
= lisp_eval_depth
;
1136 c
.pdlcount
= specpdl_ptr
- specpdl
;
1137 c
.poll_suppress_count
= poll_suppress_count
;
1138 c
.gcpro
= gcprolist
;
1139 if (_setjmp (c
.jmp
))
1141 return (*hfun
) (c
.val
);
1145 h
.handler
= handlers
;
1147 h
.next
= handlerlist
;
1151 val
= (*bfun
) (arg
);
1153 handlerlist
= h
.next
;
1157 static Lisp_Object
find_handler_clause ();
1159 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1160 "Signal an error. Args are ERROR-SYMBOL and associated DATA.\n\
1161 This function does not return.\n\n\
1162 An error symbol is a symbol with an `error-conditions' property\n\
1163 that is a list of condition names.\n\
1164 A handler for any of those names will get to handle this signal.\n\
1165 The symbol `error' should normally be one of them.\n\
1167 DATA should be a list. Its elements are printed as part of the error message.\n\
1168 If the signal is handled, DATA is made available to the handler.\n\
1169 See also the function `condition-case'.")
1170 (error_symbol
, data
)
1171 Lisp_Object error_symbol
, data
;
1173 register struct handler
*allhandlers
= handlerlist
;
1174 Lisp_Object conditions
;
1175 extern int gc_in_progress
;
1176 extern int waiting_for_input
;
1177 Lisp_Object debugger_value
;
1179 quit_error_check ();
1181 if (gc_in_progress
|| waiting_for_input
)
1184 #ifdef HAVE_X_WINDOWS
1185 TOTALLY_UNBLOCK_INPUT
;
1188 conditions
= Fget (error_symbol
, Qerror_conditions
);
1190 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1192 register Lisp_Object clause
;
1193 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1194 error_symbol
, data
, &debugger_value
);
1196 #if 0 /* Most callers are not prepared to handle gc if this returns.
1197 So, since this feature is not very useful, take it out. */
1198 /* If have called debugger and user wants to continue,
1200 if (EQ (clause
, Qlambda
))
1201 return debugger_value
;
1203 if (EQ (clause
, Qlambda
))
1205 /* We can't return values to code which signalled an error, but we
1206 can continue code which has signalled a quit. */
1207 if (EQ (error_symbol
, Qquit
))
1210 error ("Cannot return from the debugger in an error");
1216 Lisp_Object unwind_data
;
1217 struct handler
*h
= handlerlist
;
1219 handlerlist
= allhandlers
;
1220 if (EQ (data
, memory_signal_data
))
1221 unwind_data
= memory_signal_data
;
1223 unwind_data
= Fcons (error_symbol
, data
);
1224 h
->chosen_clause
= clause
;
1225 unwind_to_catch (h
->tag
, unwind_data
);
1229 handlerlist
= allhandlers
;
1230 /* If no handler is present now, try to run the debugger,
1231 and if that fails, throw to top level. */
1232 find_handler_clause (Qerror
, conditions
, error_symbol
, data
, &debugger_value
);
1233 Fthrow (Qtop_level
, Qt
);
1236 /* Return nonzero iff LIST is a non-nil atom or
1237 a list containing one of CONDITIONS. */
1240 wants_debugger (list
, conditions
)
1241 Lisp_Object list
, conditions
;
1248 while (CONSP (conditions
))
1250 Lisp_Object
this, tail
;
1251 this = XCONS (conditions
)->car
;
1252 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1253 if (EQ (XCONS (tail
)->car
, this))
1255 conditions
= XCONS (conditions
)->cdr
;
1260 /* Value of Qlambda means we have called debugger and user has continued.
1261 Store value returned from debugger into *DEBUGGER_VALUE_PTR. */
1264 find_handler_clause (handlers
, conditions
, sig
, data
, debugger_value_ptr
)
1265 Lisp_Object handlers
, conditions
, sig
, data
;
1266 Lisp_Object
*debugger_value_ptr
;
1268 register Lisp_Object h
;
1269 register Lisp_Object tem
;
1271 if (EQ (handlers
, Qt
)) /* t is used by handlers for all conditions, set up by C code. */
1273 if (EQ (handlers
, Qerror
)) /* error is used similarly, but means display a backtrace too */
1275 if (wants_debugger (Vstack_trace_on_error
, conditions
))
1276 internal_with_output_to_temp_buffer ("*Backtrace*", Fbacktrace
, Qnil
);
1277 if ((EQ (sig
, Qquit
)
1279 : wants_debugger (Vdebug_on_error
, conditions
))
1280 && when_entered_debugger
< num_nonmacro_input_chars
)
1282 int count
= specpdl_ptr
- specpdl
;
1283 specbind (Qdebug_on_error
, Qnil
);
1284 *debugger_value_ptr
=
1285 call_debugger (Fcons (Qerror
,
1286 Fcons (Fcons (sig
, data
),
1288 return unbind_to (count
, Qlambda
);
1292 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1294 Lisp_Object handler
, condit
;
1297 if (!CONSP (handler
))
1299 condit
= Fcar (handler
);
1300 /* Handle a single condition name in handler HANDLER. */
1301 if (SYMBOLP (condit
))
1303 tem
= Fmemq (Fcar (handler
), conditions
);
1307 /* Handle a list of condition names in handler HANDLER. */
1308 else if (CONSP (condit
))
1310 while (CONSP (condit
))
1312 tem
= Fmemq (Fcar (condit
), conditions
);
1315 condit
= XCONS (condit
)->cdr
;
1322 /* dump an error message; called like printf */
1326 error (m
, a1
, a2
, a3
)
1346 int used
= doprnt (buf
, size
, m
, m
+ mlen
, 3, args
);
1351 buffer
= (char *) xrealloc (buffer
, size
);
1354 buffer
= (char *) xmalloc (size
);
1359 string
= build_string (buf
);
1363 Fsignal (Qerror
, Fcons (string
, Qnil
));
1366 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 1, 0,
1367 "T if FUNCTION makes provisions for interactive calling.\n\
1368 This means it contains a description for how to read arguments to give it.\n\
1369 The value is nil for an invalid function or a symbol with no function\n\
1372 Interactively callable functions include strings and vectors (treated\n\
1373 as keyboard macros), lambda-expressions that contain a top-level call\n\
1374 to `interactive', autoload definitions made by `autoload' with non-nil\n\
1375 fourth argument, and some of the built-in functions of Lisp.\n\
1377 Also, a symbol satisfies `commandp' if its function definition does so.")
1379 Lisp_Object function
;
1381 register Lisp_Object fun
;
1382 register Lisp_Object funcar
;
1383 register Lisp_Object tem
;
1388 fun
= indirect_function (fun
);
1389 if (EQ (fun
, Qunbound
))
1392 /* Emacs primitives are interactive if their DEFUN specifies an
1393 interactive spec. */
1396 if (XSUBR (fun
)->prompt
)
1402 /* Bytecode objects are interactive if they are long enough to
1403 have an element whose index is COMPILED_INTERACTIVE, which is
1404 where the interactive spec is stored. */
1405 else if (COMPILEDP (fun
))
1406 return ((XVECTOR (fun
)->size
& PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
1409 /* Strings and vectors are keyboard macros. */
1410 if (STRINGP (fun
) || VECTORP (fun
))
1413 /* Lists may represent commands. */
1416 funcar
= Fcar (fun
);
1417 if (!SYMBOLP (funcar
))
1418 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1419 if (EQ (funcar
, Qlambda
))
1420 return Fassq (Qinteractive
, Fcdr (Fcdr (fun
)));
1421 if (EQ (funcar
, Qmocklisp
))
1422 return Qt
; /* All mocklisp functions can be called interactively */
1423 if (EQ (funcar
, Qautoload
))
1424 return Fcar (Fcdr (Fcdr (Fcdr (fun
))));
1430 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1431 "Define FUNCTION to autoload from FILE.\n\
1432 FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\
1433 Third arg DOCSTRING is documentation for the function.\n\
1434 Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\
1435 Fifth arg TYPE indicates the type of the object:\n\
1436 nil or omitted says FUNCTION is a function,\n\
1437 `keymap' says FUNCTION is really a keymap, and\n\
1438 `macro' or t says FUNCTION is really a macro.\n\
1439 Third through fifth args give info about the real definition.\n\
1440 They default to nil.\n\
1441 If FUNCTION is already defined other than as an autoload,\n\
1442 this does nothing and returns nil.")
1443 (function
, file
, docstring
, interactive
, type
)
1444 Lisp_Object function
, file
, docstring
, interactive
, type
;
1447 Lisp_Object args
[4];
1450 CHECK_SYMBOL (function
, 0);
1451 CHECK_STRING (file
, 1);
1453 /* If function is defined and not as an autoload, don't override */
1454 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
1455 && !(CONSP (XSYMBOL (function
)->function
)
1456 && EQ (XCONS (XSYMBOL (function
)->function
)->car
, Qautoload
)))
1461 args
[1] = docstring
;
1462 args
[2] = interactive
;
1465 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
1466 #else /* NO_ARG_ARRAY */
1467 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
1468 #endif /* not NO_ARG_ARRAY */
1472 un_autoload (oldqueue
)
1473 Lisp_Object oldqueue
;
1475 register Lisp_Object queue
, first
, second
;
1477 /* Queue to unwind is current value of Vautoload_queue.
1478 oldqueue is the shadowed value to leave in Vautoload_queue. */
1479 queue
= Vautoload_queue
;
1480 Vautoload_queue
= oldqueue
;
1481 while (CONSP (queue
))
1483 first
= Fcar (queue
);
1484 second
= Fcdr (first
);
1485 first
= Fcar (first
);
1486 if (EQ (second
, Qnil
))
1489 Ffset (first
, second
);
1490 queue
= Fcdr (queue
);
1495 do_autoload (fundef
, funname
)
1496 Lisp_Object fundef
, funname
;
1498 int count
= specpdl_ptr
- specpdl
;
1499 Lisp_Object fun
, val
, queue
, first
, second
;
1502 CHECK_SYMBOL (funname
, 0);
1504 /* Value saved here is to be restored into Vautoload_queue */
1505 record_unwind_protect (un_autoload
, Vautoload_queue
);
1506 Vautoload_queue
= Qt
;
1507 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
);
1509 /* Save the old autoloads, in case we ever do an unload. */
1510 queue
= Vautoload_queue
;
1511 while (CONSP (queue
))
1513 first
= Fcar (queue
);
1514 second
= Fcdr (first
);
1515 first
= Fcar (first
);
1517 /* Note: This test is subtle. The cdr of an autoload-queue entry
1518 may be an atom if the autoload entry was generated by a defalias
1521 Fput (first
, Qautoload
, (Fcdr (second
)));
1523 queue
= Fcdr (queue
);
1526 /* Once loading finishes, don't undo it. */
1527 Vautoload_queue
= Qt
;
1528 unbind_to (count
, Qnil
);
1530 fun
= Findirect_function (fun
);
1532 if (!NILP (Fequal (fun
, fundef
)))
1533 error ("Autoloading failed to define function %s",
1534 XSYMBOL (funname
)->name
->data
);
1537 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
1538 "Evaluate FORM and return its value.")
1542 Lisp_Object fun
, val
, original_fun
, original_args
;
1544 struct backtrace backtrace
;
1545 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1549 if (EQ (Vmocklisp_arguments
, Qt
))
1550 return Fsymbol_value (form
);
1551 val
= Fsymbol_value (form
);
1553 XSETFASTINT (val
, 0);
1554 else if (EQ (val
, Qt
))
1555 XSETFASTINT (val
, 1);
1562 if (consing_since_gc
> gc_cons_threshold
)
1565 Fgarbage_collect ();
1569 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1571 if (max_lisp_eval_depth
< 100)
1572 max_lisp_eval_depth
= 100;
1573 if (lisp_eval_depth
> max_lisp_eval_depth
)
1574 error ("Lisp nesting exceeds max-lisp-eval-depth");
1577 original_fun
= Fcar (form
);
1578 original_args
= Fcdr (form
);
1580 backtrace
.next
= backtrace_list
;
1581 backtrace_list
= &backtrace
;
1582 backtrace
.function
= &original_fun
; /* This also protects them from gc */
1583 backtrace
.args
= &original_args
;
1584 backtrace
.nargs
= UNEVALLED
;
1585 backtrace
.evalargs
= 1;
1586 backtrace
.debug_on_exit
= 0;
1588 if (debug_on_next_call
)
1589 do_debug_on_call (Qt
);
1591 /* At this point, only original_fun and original_args
1592 have values that will be used below */
1594 fun
= Findirect_function (original_fun
);
1598 Lisp_Object numargs
;
1599 Lisp_Object argvals
[7];
1600 Lisp_Object args_left
;
1601 register int i
, maxargs
;
1603 args_left
= original_args
;
1604 numargs
= Flength (args_left
);
1606 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
1607 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
1608 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1610 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1612 backtrace
.evalargs
= 0;
1613 val
= (*XSUBR (fun
)->function
) (args_left
);
1617 if (XSUBR (fun
)->max_args
== MANY
)
1619 /* Pass a vector of evaluated arguments */
1621 register int argnum
= 0;
1623 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1625 GCPRO3 (args_left
, fun
, fun
);
1629 while (!NILP (args_left
))
1631 vals
[argnum
++] = Feval (Fcar (args_left
));
1632 args_left
= Fcdr (args_left
);
1633 gcpro3
.nvars
= argnum
;
1636 backtrace
.args
= vals
;
1637 backtrace
.nargs
= XINT (numargs
);
1639 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
1644 GCPRO3 (args_left
, fun
, fun
);
1645 gcpro3
.var
= argvals
;
1648 maxargs
= XSUBR (fun
)->max_args
;
1649 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
1651 argvals
[i
] = Feval (Fcar (args_left
));
1657 backtrace
.args
= argvals
;
1658 backtrace
.nargs
= XINT (numargs
);
1663 val
= (*XSUBR (fun
)->function
) ();
1666 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
1669 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
1672 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1676 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1677 argvals
[2], argvals
[3]);
1680 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1681 argvals
[3], argvals
[4]);
1684 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1685 argvals
[3], argvals
[4], argvals
[5]);
1688 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1689 argvals
[3], argvals
[4], argvals
[5],
1694 /* Someone has created a subr that takes more arguments than
1695 is supported by this code. We need to either rewrite the
1696 subr to use a different argument protocol, or add more
1697 cases to this switch. */
1701 if (COMPILEDP (fun
))
1702 val
= apply_lambda (fun
, original_args
, 1);
1706 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1707 funcar
= Fcar (fun
);
1708 if (!SYMBOLP (funcar
))
1709 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1710 if (EQ (funcar
, Qautoload
))
1712 do_autoload (fun
, original_fun
);
1715 if (EQ (funcar
, Qmacro
))
1716 val
= Feval (apply1 (Fcdr (fun
), original_args
));
1717 else if (EQ (funcar
, Qlambda
))
1718 val
= apply_lambda (fun
, original_args
, 1);
1719 else if (EQ (funcar
, Qmocklisp
))
1720 val
= ml_apply (fun
, original_args
);
1722 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1725 if (!EQ (Vmocklisp_arguments
, Qt
))
1728 XSETFASTINT (val
, 0);
1729 else if (EQ (val
, Qt
))
1730 XSETFASTINT (val
, 1);
1733 if (backtrace
.debug_on_exit
)
1734 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
1735 backtrace_list
= backtrace
.next
;
1739 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
1740 "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
1741 Then return the value FUNCTION returns.\n\
1742 Thus, (apply '+ 1 2 '(3 4)) returns 10.")
1747 register int i
, numargs
;
1748 register Lisp_Object spread_arg
;
1749 register Lisp_Object
*funcall_args
;
1751 struct gcpro gcpro1
;
1755 spread_arg
= args
[nargs
- 1];
1756 CHECK_LIST (spread_arg
, nargs
);
1758 numargs
= XINT (Flength (spread_arg
));
1761 return Ffuncall (nargs
- 1, args
);
1762 else if (numargs
== 1)
1764 args
[nargs
- 1] = XCONS (spread_arg
)->car
;
1765 return Ffuncall (nargs
, args
);
1768 numargs
+= nargs
- 2;
1770 fun
= indirect_function (fun
);
1771 if (EQ (fun
, Qunbound
))
1773 /* Let funcall get the error */
1780 if (numargs
< XSUBR (fun
)->min_args
1781 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
1782 goto funcall
; /* Let funcall get the error */
1783 else if (XSUBR (fun
)->max_args
> numargs
)
1785 /* Avoid making funcall cons up a yet another new vector of arguments
1786 by explicitly supplying nil's for optional values */
1787 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
1788 * sizeof (Lisp_Object
));
1789 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
1790 funcall_args
[++i
] = Qnil
;
1791 GCPRO1 (*funcall_args
);
1792 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
1796 /* We add 1 to numargs because funcall_args includes the
1797 function itself as well as its arguments. */
1800 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
1801 * sizeof (Lisp_Object
));
1802 GCPRO1 (*funcall_args
);
1803 gcpro1
.nvars
= 1 + numargs
;
1806 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
1807 /* Spread the last arg we got. Its first element goes in
1808 the slot that it used to occupy, hence this value of I. */
1810 while (!NILP (spread_arg
))
1812 funcall_args
[i
++] = XCONS (spread_arg
)->car
;
1813 spread_arg
= XCONS (spread_arg
)->cdr
;
1816 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
1819 /* Run hook variables in various ways. */
1821 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
1823 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 1, MANY
, 0,
1824 "Run each hook in HOOKS. Major mode functions use this.\n\
1825 Each argument should be a symbol, a hook variable.\n\
1826 These symbols are processed in the order specified.\n\
1827 If a hook symbol has a non-nil value, that value may be a function\n\
1828 or a list of functions to be called to run the hook.\n\
1829 If the value is a function, it is called with no arguments.\n\
1830 If it is a list, the elements are called, in order, with no arguments.\n\
1832 To make a hook variable buffer-local, use `make-local-hook',\n\
1833 not `make-local-variable'.")
1838 Lisp_Object hook
[1];
1841 for (i
= 0; i
< nargs
; i
++)
1844 run_hook_with_args (1, hook
, to_completion
);
1850 DEFUN ("run-hook-with-args",
1851 Frun_hook_with_args
, Srun_hook_with_args
, 1, MANY
, 0,
1852 "Run HOOK with the specified arguments ARGS.\n\
1853 HOOK should be a symbol, a hook variable. If HOOK has a non-nil\n\
1854 value, that value may be a function or a list of functions to be\n\
1855 called to run the hook. If the value is a function, it is called with\n\
1856 the given arguments and its return value is returned. If it is a list\n\
1857 of functions, those functions are called, in order,\n\
1858 with the given arguments ARGS.\n\
1859 It is best not to depend on the value return by `run-hook-with-args',\n\
1860 as that may change.\n\
1862 To make a hook variable buffer-local, use `make-local-hook',\n\
1863 not `make-local-variable'.")
1868 return run_hook_with_args (nargs
, args
, to_completion
);
1871 DEFUN ("run-hook-with-args-until-success",
1872 Frun_hook_with_args_until_success
, Srun_hook_with_args_until_success
,
1874 "Run HOOK with the specified arguments ARGS.\n\
1875 HOOK should be a symbol, a hook variable. Its value should\n\
1876 be a list of functions. We call those functions, one by one,\n\
1877 passing arguments ARGS to each of them, until one of them\n\
1878 returns a non-nil value. Then we return that value.\n\
1879 If all the functions return nil, we return nil.\n\
1881 To make a hook variable buffer-local, use `make-local-hook',\n\
1882 not `make-local-variable'.")
1887 return run_hook_with_args (nargs
, args
, until_success
);
1890 DEFUN ("run-hook-with-args-until-failure",
1891 Frun_hook_with_args_until_failure
, Srun_hook_with_args_until_failure
,
1893 "Run HOOK with the specified arguments ARGS.\n\
1894 HOOK should be a symbol, a hook variable. Its value should\n\
1895 be a list of functions. We call those functions, one by one,\n\
1896 passing arguments ARGS to each of them, until one of them\n\
1897 returns nil. Then we return nil.\n\
1898 If all the functions return non-nil, we return non-nil.\n\
1900 To make a hook variable buffer-local, use `make-local-hook',\n\
1901 not `make-local-variable'.")
1906 return run_hook_with_args (nargs
, args
, until_failure
);
1909 /* ARGS[0] should be a hook symbol.
1910 Call each of the functions in the hook value, passing each of them
1911 as arguments all the rest of ARGS (all NARGS - 1 elements).
1912 COND specifies a condition to test after each call
1913 to decide whether to stop.
1914 The caller (or its caller, etc) must gcpro all of ARGS,
1915 except that it isn't necessary to gcpro ARGS[0]. */
1918 run_hook_with_args (nargs
, args
, cond
)
1921 enum run_hooks_condition cond
;
1923 Lisp_Object sym
, val
, ret
;
1924 struct gcpro gcpro1
, gcpro2
;
1927 val
= find_symbol_value (sym
);
1928 ret
= (cond
== until_failure
? Qt
: Qnil
);
1930 if (EQ (val
, Qunbound
) || NILP (val
))
1932 else if (!CONSP (val
) || EQ (XCONS (val
)->car
, Qlambda
))
1935 return Ffuncall (nargs
, args
);
1942 CONSP (val
) && ((cond
== to_completion
)
1943 || (cond
== until_success
? NILP (ret
)
1945 val
= XCONS (val
)->cdr
)
1947 if (EQ (XCONS (val
)->car
, Qt
))
1949 /* t indicates this hook has a local binding;
1950 it means to run the global binding too. */
1951 Lisp_Object globals
;
1953 for (globals
= Fdefault_value (sym
);
1954 CONSP (globals
) && ((cond
== to_completion
)
1955 || (cond
== until_success
? NILP (ret
)
1957 globals
= XCONS (globals
)->cdr
)
1959 args
[0] = XCONS (globals
)->car
;
1960 ret
= Ffuncall (nargs
, args
);
1965 args
[0] = XCONS (val
)->car
;
1966 ret
= Ffuncall (nargs
, args
);
1975 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
1976 present value of that symbol.
1977 Call each element of FUNLIST,
1978 passing each of them the rest of ARGS.
1979 The caller (or its caller, etc) must gcpro all of ARGS,
1980 except that it isn't necessary to gcpro ARGS[0]. */
1983 run_hook_list_with_args (funlist
, nargs
, args
)
1984 Lisp_Object funlist
;
1990 struct gcpro gcpro1
, gcpro2
;
1995 for (val
= funlist
; CONSP (val
); val
= XCONS (val
)->cdr
)
1997 if (EQ (XCONS (val
)->car
, Qt
))
1999 /* t indicates this hook has a local binding;
2000 it means to run the global binding too. */
2001 Lisp_Object globals
;
2003 for (globals
= Fdefault_value (sym
);
2005 globals
= XCONS (globals
)->cdr
)
2007 args
[0] = XCONS (globals
)->car
;
2008 Ffuncall (nargs
, args
);
2013 args
[0] = XCONS (val
)->car
;
2014 Ffuncall (nargs
, args
);
2021 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2024 run_hook_with_args_2 (hook
, arg1
, arg2
)
2025 Lisp_Object hook
, arg1
, arg2
;
2027 Lisp_Object temp
[3];
2032 Frun_hook_with_args (3, temp
);
2035 /* Apply fn to arg */
2038 Lisp_Object fn
, arg
;
2040 struct gcpro gcpro1
;
2044 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2048 Lisp_Object args
[2];
2052 RETURN_UNGCPRO (Fapply (2, args
));
2054 #else /* not NO_ARG_ARRAY */
2055 RETURN_UNGCPRO (Fapply (2, &fn
));
2056 #endif /* not NO_ARG_ARRAY */
2059 /* Call function fn on no arguments */
2064 struct gcpro gcpro1
;
2067 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2070 /* Call function fn with 1 argument arg1 */
2074 Lisp_Object fn
, arg1
;
2076 struct gcpro gcpro1
;
2078 Lisp_Object args
[2];
2084 RETURN_UNGCPRO (Ffuncall (2, args
));
2085 #else /* not NO_ARG_ARRAY */
2088 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2089 #endif /* not NO_ARG_ARRAY */
2092 /* Call function fn with 2 arguments arg1, arg2 */
2095 call2 (fn
, arg1
, arg2
)
2096 Lisp_Object fn
, arg1
, arg2
;
2098 struct gcpro gcpro1
;
2100 Lisp_Object args
[3];
2106 RETURN_UNGCPRO (Ffuncall (3, args
));
2107 #else /* not NO_ARG_ARRAY */
2110 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2111 #endif /* not NO_ARG_ARRAY */
2114 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2117 call3 (fn
, arg1
, arg2
, arg3
)
2118 Lisp_Object fn
, arg1
, arg2
, arg3
;
2120 struct gcpro gcpro1
;
2122 Lisp_Object args
[4];
2129 RETURN_UNGCPRO (Ffuncall (4, args
));
2130 #else /* not NO_ARG_ARRAY */
2133 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2134 #endif /* not NO_ARG_ARRAY */
2137 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2140 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2141 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2143 struct gcpro gcpro1
;
2145 Lisp_Object args
[5];
2153 RETURN_UNGCPRO (Ffuncall (5, args
));
2154 #else /* not NO_ARG_ARRAY */
2157 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2158 #endif /* not NO_ARG_ARRAY */
2161 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2164 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2165 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2167 struct gcpro gcpro1
;
2169 Lisp_Object args
[6];
2178 RETURN_UNGCPRO (Ffuncall (6, args
));
2179 #else /* not NO_ARG_ARRAY */
2182 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2183 #endif /* not NO_ARG_ARRAY */
2186 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2189 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2190 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2192 struct gcpro gcpro1
;
2194 Lisp_Object args
[7];
2204 RETURN_UNGCPRO (Ffuncall (7, args
));
2205 #else /* not NO_ARG_ARRAY */
2208 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2209 #endif /* not NO_ARG_ARRAY */
2212 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2213 "Call first argument as a function, passing remaining arguments to it.\n\
2214 Return the value that function returns.\n\
2215 Thus, (funcall 'cons 'x 'y) returns (x . y).")
2222 int numargs
= nargs
- 1;
2223 Lisp_Object lisp_numargs
;
2225 struct backtrace backtrace
;
2226 register Lisp_Object
*internal_args
;
2230 if (consing_since_gc
> gc_cons_threshold
)
2231 Fgarbage_collect ();
2233 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2235 if (max_lisp_eval_depth
< 100)
2236 max_lisp_eval_depth
= 100;
2237 if (lisp_eval_depth
> max_lisp_eval_depth
)
2238 error ("Lisp nesting exceeds max-lisp-eval-depth");
2241 backtrace
.next
= backtrace_list
;
2242 backtrace_list
= &backtrace
;
2243 backtrace
.function
= &args
[0];
2244 backtrace
.args
= &args
[1];
2245 backtrace
.nargs
= nargs
- 1;
2246 backtrace
.evalargs
= 0;
2247 backtrace
.debug_on_exit
= 0;
2249 if (debug_on_next_call
)
2250 do_debug_on_call (Qlambda
);
2256 fun
= Findirect_function (fun
);
2260 if (numargs
< XSUBR (fun
)->min_args
2261 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2263 XSETFASTINT (lisp_numargs
, numargs
);
2264 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (lisp_numargs
, Qnil
)));
2267 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2268 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2270 if (XSUBR (fun
)->max_args
== MANY
)
2272 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
2276 if (XSUBR (fun
)->max_args
> numargs
)
2278 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2279 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
2280 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2281 internal_args
[i
] = Qnil
;
2284 internal_args
= args
+ 1;
2285 switch (XSUBR (fun
)->max_args
)
2288 val
= (*XSUBR (fun
)->function
) ();
2291 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
2294 val
= (*XSUBR (fun
)->function
) (internal_args
[0],
2298 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2302 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2307 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2308 internal_args
[2], internal_args
[3],
2312 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2313 internal_args
[2], internal_args
[3],
2314 internal_args
[4], internal_args
[5]);
2317 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2318 internal_args
[2], internal_args
[3],
2319 internal_args
[4], internal_args
[5],
2325 /* If a subr takes more than 6 arguments without using MANY
2326 or UNEVALLED, we need to extend this function to support it.
2327 Until this is done, there is no way to call the function. */
2331 if (COMPILEDP (fun
))
2332 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2336 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2337 funcar
= Fcar (fun
);
2338 if (!SYMBOLP (funcar
))
2339 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2340 if (EQ (funcar
, Qlambda
))
2341 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2342 else if (EQ (funcar
, Qmocklisp
))
2343 val
= ml_apply (fun
, Flist (numargs
, args
+ 1));
2344 else if (EQ (funcar
, Qautoload
))
2346 do_autoload (fun
, args
[0]);
2350 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2354 if (backtrace
.debug_on_exit
)
2355 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2356 backtrace_list
= backtrace
.next
;
2361 apply_lambda (fun
, args
, eval_flag
)
2362 Lisp_Object fun
, args
;
2365 Lisp_Object args_left
;
2366 Lisp_Object numargs
;
2367 register Lisp_Object
*arg_vector
;
2368 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2370 register Lisp_Object tem
;
2372 numargs
= Flength (args
);
2373 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2376 GCPRO3 (*arg_vector
, args_left
, fun
);
2379 for (i
= 0; i
< XINT (numargs
);)
2381 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2382 if (eval_flag
) tem
= Feval (tem
);
2383 arg_vector
[i
++] = tem
;
2391 backtrace_list
->args
= arg_vector
;
2392 backtrace_list
->nargs
= i
;
2394 backtrace_list
->evalargs
= 0;
2395 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
2397 /* Do the debug-on-exit now, while arg_vector still exists. */
2398 if (backtrace_list
->debug_on_exit
)
2399 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
2400 /* Don't do it again when we return to eval. */
2401 backtrace_list
->debug_on_exit
= 0;
2405 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2406 and return the result of evaluation.
2407 FUN must be either a lambda-expression or a compiled-code object. */
2410 funcall_lambda (fun
, nargs
, arg_vector
)
2413 register Lisp_Object
*arg_vector
;
2415 Lisp_Object val
, tem
;
2416 register Lisp_Object syms_left
;
2417 Lisp_Object numargs
;
2418 register Lisp_Object next
;
2419 int count
= specpdl_ptr
- specpdl
;
2421 int optional
= 0, rest
= 0;
2423 specbind (Qmocklisp_arguments
, Qt
); /* t means NOT mocklisp! */
2425 XSETFASTINT (numargs
, nargs
);
2428 syms_left
= Fcar (Fcdr (fun
));
2429 else if (COMPILEDP (fun
))
2430 syms_left
= XVECTOR (fun
)->contents
[COMPILED_ARGLIST
];
2434 for (; !NILP (syms_left
); syms_left
= Fcdr (syms_left
))
2437 next
= Fcar (syms_left
);
2438 while (!SYMBOLP (next
))
2439 next
= Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2440 if (EQ (next
, Qand_rest
))
2442 else if (EQ (next
, Qand_optional
))
2446 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
2451 tem
= arg_vector
[i
++];
2452 specbind (next
, tem
);
2455 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2457 specbind (next
, Qnil
);
2461 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2464 val
= Fprogn (Fcdr (Fcdr (fun
)));
2467 /* If we have not actually read the bytecode string
2468 and constants vector yet, fetch them from the file. */
2469 if (CONSP (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
]))
2470 Ffetch_bytecode (fun
);
2471 val
= Fbyte_code (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
],
2472 XVECTOR (fun
)->contents
[COMPILED_CONSTANTS
],
2473 XVECTOR (fun
)->contents
[COMPILED_STACK_DEPTH
]);
2475 return unbind_to (count
, val
);
2478 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
2480 "If byte-compiled OBJECT is lazy-loaded, fetch it now.")
2486 if (COMPILEDP (object
)
2487 && CONSP (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]))
2489 tem
= read_doc_string (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]);
2491 error ("invalid byte code");
2492 XVECTOR (object
)->contents
[COMPILED_BYTECODE
] = XCONS (tem
)->car
;
2493 XVECTOR (object
)->contents
[COMPILED_CONSTANTS
] = XCONS (tem
)->cdr
;
2501 register int count
= specpdl_ptr
- specpdl
;
2502 if (specpdl_size
>= max_specpdl_size
)
2504 if (max_specpdl_size
< 400)
2505 max_specpdl_size
= 400;
2506 if (specpdl_size
>= max_specpdl_size
)
2508 if (!NILP (Vdebug_on_error
))
2509 /* Leave room for some specpdl in the debugger. */
2510 max_specpdl_size
= specpdl_size
+ 100;
2512 Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil
));
2516 if (specpdl_size
> max_specpdl_size
)
2517 specpdl_size
= max_specpdl_size
;
2518 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
2519 specpdl_ptr
= specpdl
+ count
;
2523 specbind (symbol
, value
)
2524 Lisp_Object symbol
, value
;
2528 CHECK_SYMBOL (symbol
, 0);
2530 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2532 specpdl_ptr
->symbol
= symbol
;
2533 specpdl_ptr
->func
= 0;
2534 specpdl_ptr
->old_value
= ovalue
= find_symbol_value (symbol
);
2536 if (BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
))
2537 store_symval_forwarding (symbol
, ovalue
, value
);
2539 Fset (symbol
, value
);
2543 record_unwind_protect (function
, arg
)
2544 Lisp_Object (*function
)();
2547 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2549 specpdl_ptr
->func
= function
;
2550 specpdl_ptr
->symbol
= Qnil
;
2551 specpdl_ptr
->old_value
= arg
;
2556 unbind_to (count
, value
)
2560 int quitf
= !NILP (Vquit_flag
);
2561 struct gcpro gcpro1
;
2567 while (specpdl_ptr
!= specpdl
+ count
)
2570 if (specpdl_ptr
->func
!= 0)
2571 (*specpdl_ptr
->func
) (specpdl_ptr
->old_value
);
2572 /* Note that a "binding" of nil is really an unwind protect,
2573 so in that case the "old value" is a list of forms to evaluate. */
2574 else if (NILP (specpdl_ptr
->symbol
))
2575 Fprogn (specpdl_ptr
->old_value
);
2577 Fset (specpdl_ptr
->symbol
, specpdl_ptr
->old_value
);
2579 if (NILP (Vquit_flag
) && quitf
) Vquit_flag
= Qt
;
2588 /* Get the value of symbol's global binding, even if that binding
2589 is not now dynamically visible. */
2592 top_level_value (symbol
)
2595 register struct specbinding
*ptr
= specpdl
;
2597 CHECK_SYMBOL (symbol
, 0);
2598 for (; ptr
!= specpdl_ptr
; ptr
++)
2600 if (EQ (ptr
->symbol
, symbol
))
2601 return ptr
->old_value
;
2603 return Fsymbol_value (symbol
);
2607 top_level_set (symbol
, newval
)
2608 Lisp_Object symbol
, newval
;
2610 register struct specbinding
*ptr
= specpdl
;
2612 CHECK_SYMBOL (symbol
, 0);
2613 for (; ptr
!= specpdl_ptr
; ptr
++)
2615 if (EQ (ptr
->symbol
, symbol
))
2617 ptr
->old_value
= newval
;
2621 return Fset (symbol
, newval
);
2626 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
2627 "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\
2628 The debugger is entered when that frame exits, if the flag is non-nil.")
2630 Lisp_Object level
, flag
;
2632 register struct backtrace
*backlist
= backtrace_list
;
2635 CHECK_NUMBER (level
, 0);
2637 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
2639 backlist
= backlist
->next
;
2643 backlist
->debug_on_exit
= !NILP (flag
);
2648 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
2649 "Print a trace of Lisp function calls currently active.\n\
2650 Output stream used is value of `standard-output'.")
2653 register struct backtrace
*backlist
= backtrace_list
;
2657 extern Lisp_Object Vprint_level
;
2658 struct gcpro gcpro1
;
2660 XSETFASTINT (Vprint_level
, 3);
2667 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
2668 if (backlist
->nargs
== UNEVALLED
)
2670 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
2671 write_string ("\n", -1);
2675 tem
= *backlist
->function
;
2676 Fprin1 (tem
, Qnil
); /* This can QUIT */
2677 write_string ("(", -1);
2678 if (backlist
->nargs
== MANY
)
2680 for (tail
= *backlist
->args
, i
= 0;
2682 tail
= Fcdr (tail
), i
++)
2684 if (i
) write_string (" ", -1);
2685 Fprin1 (Fcar (tail
), Qnil
);
2690 for (i
= 0; i
< backlist
->nargs
; i
++)
2692 if (i
) write_string (" ", -1);
2693 Fprin1 (backlist
->args
[i
], Qnil
);
2696 write_string (")\n", -1);
2698 backlist
= backlist
->next
;
2701 Vprint_level
= Qnil
;
2706 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, "",
2707 "Return the function and arguments N frames up from current execution point.\n\
2708 If that frame has not evaluated the arguments yet (or is a special form),\n\
2709 the value is (nil FUNCTION ARG-FORMS...).\n\
2710 If that frame has evaluated its arguments and called its function already,\n\
2711 the value is (t FUNCTION ARG-VALUES...).\n\
2712 A &rest arg is represented as the tail of the list ARG-VALUES.\n\
2713 FUNCTION is whatever was supplied as car of evaluated list,\n\
2714 or a lambda expression for macro calls.\n\
2715 If N is more than the number of frames, the value is nil.")
2717 Lisp_Object nframes
;
2719 register struct backtrace
*backlist
= backtrace_list
;
2723 CHECK_NATNUM (nframes
, 0);
2725 /* Find the frame requested. */
2726 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
2727 backlist
= backlist
->next
;
2731 if (backlist
->nargs
== UNEVALLED
)
2732 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
2735 if (backlist
->nargs
== MANY
)
2736 tem
= *backlist
->args
;
2738 tem
= Flist (backlist
->nargs
, backlist
->args
);
2740 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
2746 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
2747 "Limit on number of Lisp variable bindings & unwind-protects before error.");
2749 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
2750 "Limit on depth in `eval', `apply' and `funcall' before error.\n\
2751 This limit is to catch infinite recursions for you before they cause\n\
2752 actual stack overflow in C, which would be fatal for Emacs.\n\
2753 You can safely make it considerably larger than its default value,\n\
2754 if that proves inconveniently small.");
2756 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
2757 "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
2758 Typing C-g sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
2761 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
2762 "Non-nil inhibits C-g quitting from happening immediately.\n\
2763 Note that `quit-flag' will still be set by typing C-g,\n\
2764 so a quit will be signalled as soon as `inhibit-quit' is nil.\n\
2765 To prevent this happening, set `quit-flag' to nil\n\
2766 before making `inhibit-quit' nil.");
2767 Vinhibit_quit
= Qnil
;
2769 Qinhibit_quit
= intern ("inhibit-quit");
2770 staticpro (&Qinhibit_quit
);
2772 Qautoload
= intern ("autoload");
2773 staticpro (&Qautoload
);
2775 Qdebug_on_error
= intern ("debug-on-error");
2776 staticpro (&Qdebug_on_error
);
2778 Qmacro
= intern ("macro");
2779 staticpro (&Qmacro
);
2781 /* Note that the process handling also uses Qexit, but we don't want
2782 to staticpro it twice, so we just do it here. */
2783 Qexit
= intern ("exit");
2786 Qinteractive
= intern ("interactive");
2787 staticpro (&Qinteractive
);
2789 Qcommandp
= intern ("commandp");
2790 staticpro (&Qcommandp
);
2792 Qdefun
= intern ("defun");
2793 staticpro (&Qdefun
);
2795 Qand_rest
= intern ("&rest");
2796 staticpro (&Qand_rest
);
2798 Qand_optional
= intern ("&optional");
2799 staticpro (&Qand_optional
);
2801 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
2802 "*Non-nil means automatically display a backtrace buffer\n\
2803 after any error that is handled by the editor command loop.\n\
2804 If the value is a list, an error only means to display a backtrace\n\
2805 if one of its condition symbols appears in the list.");
2806 Vstack_trace_on_error
= Qnil
;
2808 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
2809 "*Non-nil means enter debugger if an error is signaled.\n\
2810 Does not apply to errors handled by `condition-case'.\n\
2811 If the value is a list, an error only means to enter the debugger\n\
2812 if one of its condition symbols appears in the list.\n\
2813 See also variable `debug-on-quit'.");
2814 Vdebug_on_error
= Qnil
;
2816 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
2817 "*Non-nil means enter debugger if quit is signaled (C-g, for example).\n\
2818 Does not apply if quit is handled by a `condition-case'.");
2821 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
2822 "Non-nil means enter debugger before next `eval', `apply' or `funcall'.");
2824 DEFVAR_LISP ("debugger", &Vdebugger
,
2825 "Function to call to invoke debugger.\n\
2826 If due to frame exit, args are `exit' and the value being returned;\n\
2827 this function's value will be returned instead of that.\n\
2828 If due to error, args are `error' and a list of the args to `signal'.\n\
2829 If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
2830 If due to `eval' entry, one arg, t.");
2833 Qmocklisp_arguments
= intern ("mocklisp-arguments");
2834 staticpro (&Qmocklisp_arguments
);
2835 DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments
,
2836 "While in a mocklisp function, the list of its unevaluated args.");
2837 Vmocklisp_arguments
= Qt
;
2839 DEFVAR_LISP ("run-hooks", &Vrun_hooks
,
2840 "Set to the function `run-hooks', if that function has been defined.\n\
2841 Otherwise, nil (in a bare Emacs without preloaded Lisp code).");
2843 staticpro (&Vautoload_queue
);
2844 Vautoload_queue
= Qnil
;
2855 defsubr (&Sfunction
);
2857 defsubr (&Sdefmacro
);
2859 defsubr (&Sdefconst
);
2860 defsubr (&Suser_variable_p
);
2864 defsubr (&Smacroexpand
);
2867 defsubr (&Sunwind_protect
);
2868 defsubr (&Scondition_case
);
2870 defsubr (&Sinteractive_p
);
2871 defsubr (&Scommandp
);
2872 defsubr (&Sautoload
);
2875 defsubr (&Sfuncall
);
2876 defsubr (&Srun_hooks
);
2877 defsubr (&Srun_hook_with_args
);
2878 defsubr (&Srun_hook_with_args_until_success
);
2879 defsubr (&Srun_hook_with_args_until_failure
);
2880 defsubr (&Sfetch_bytecode
);
2881 defsubr (&Sbacktrace_debug
);
2882 defsubr (&Sbacktrace
);
2883 defsubr (&Sbacktrace_frame
);