1 /* Evaluator for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1987, 1992 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 1, 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
*) malloc (specpdl_size
* sizeof (struct specbinding
));
153 max_specpdl_size
= 600;
154 max_lisp_eval_depth
= 200;
159 specpdl_ptr
= specpdl
;
164 debug_on_next_call
= 0;
166 when_entered_debugger
= 0;
173 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
174 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
175 if (specpdl_size
+ 40 > max_specpdl_size
)
176 max_specpdl_size
= specpdl_size
+ 40;
177 debug_on_next_call
= 0;
178 when_entered_debugger
= num_nonmacro_input_chars
;
179 return apply1 (Vdebugger
, arg
);
182 do_debug_on_call (code
)
185 debug_on_next_call
= 0;
186 backtrace_list
->debug_on_exit
= 1;
187 call_debugger (Fcons (code
, Qnil
));
190 /* NOTE!!! Every function that can call EVAL must protect its args
191 and temporaries from garbage collection while it needs them.
192 The definition of `For' shows what you have to do. */
194 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
195 "Eval args until one of them yields non-nil, then return that value.\n\
196 The remaining args are not evalled at all.\n\
197 If all args return nil, return nil.")
201 register Lisp_Object val
;
202 Lisp_Object args_left
;
213 val
= Feval (Fcar (args_left
));
216 args_left
= Fcdr (args_left
);
218 while (!NILP(args_left
));
224 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
225 "Eval args until one of them yields nil, then return nil.\n\
226 The remaining args are not evalled at all.\n\
227 If no arg yields nil, return the last arg's value.")
231 register Lisp_Object val
;
232 Lisp_Object args_left
;
243 val
= Feval (Fcar (args_left
));
246 args_left
= Fcdr (args_left
);
248 while (!NILP(args_left
));
254 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
255 "(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...\n\
256 Returns the value of THEN or the value of the last of the ELSE's.\n\
257 THEN must be one expression, but ELSE... can be zero or more expressions.\n\
258 If COND yields nil, and there are no ELSE's, the value is nil.")
262 register Lisp_Object cond
;
266 cond
= Feval (Fcar (args
));
270 return Feval (Fcar (Fcdr (args
)));
271 return Fprogn (Fcdr (Fcdr (args
)));
274 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
275 "(cond CLAUSES...): try each clause until one succeeds.\n\
276 Each clause looks like (CONDITION BODY...). CONDITION is evaluated\n\
277 and, if the value is non-nil, this clause succeeds:\n\
278 then the expressions in BODY are evaluated and the last one's\n\
279 value is the value of the cond-form.\n\
280 If no clause succeeds, cond returns nil.\n\
281 If a clause has one element, as in (CONDITION),\n\
282 CONDITION's value if non-nil is returned from the cond-form.")
286 register Lisp_Object clause
, val
;
293 clause
= Fcar (args
);
294 val
= Feval (Fcar (clause
));
297 if (!EQ (XCONS (clause
)->cdr
, Qnil
))
298 val
= Fprogn (XCONS (clause
)->cdr
);
301 args
= XCONS (args
)->cdr
;
308 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
309 "(progn BODY...): eval BODY forms sequentially and return value of last one.")
313 register Lisp_Object val
, tem
;
314 Lisp_Object args_left
;
317 /* In Mocklisp code, symbols at the front of the progn arglist
318 are to be bound to zero. */
319 if (!EQ (Vmocklisp_arguments
, Qt
))
321 val
= make_number (0);
322 while (!NILP (args
) && (tem
= Fcar (args
), XTYPE (tem
) == Lisp_Symbol
))
325 specbind (tem
, val
), args
= Fcdr (args
);
337 val
= Feval (Fcar (args_left
));
338 args_left
= Fcdr (args_left
);
340 while (!NILP(args_left
));
346 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
347 "(prog1 FIRST BODY...): eval FIRST and BODY sequentially; value from FIRST.\n\
348 The value of FIRST is saved during the evaluation of the remaining args,\n\
349 whose values are discarded.")
354 register Lisp_Object args_left
;
355 struct gcpro gcpro1
, gcpro2
;
356 register int argnum
= 0;
368 val
= Feval (Fcar (args_left
));
370 Feval (Fcar (args_left
));
371 args_left
= Fcdr (args_left
);
373 while (!NILP(args_left
));
379 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
380 "(prog1 X Y BODY...): eval X, Y and BODY sequentially; value from Y.\n\
381 The value of Y is saved during the evaluation of the remaining args,\n\
382 whose values are discarded.")
387 register Lisp_Object args_left
;
388 struct gcpro gcpro1
, gcpro2
;
389 register int argnum
= -1;
403 val
= Feval (Fcar (args_left
));
405 Feval (Fcar (args_left
));
406 args_left
= Fcdr (args_left
);
408 while (!NILP(args_left
));
414 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
415 "(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.\n\
416 The SYMs are not evaluated. Thus (setq x y) sets x to the value of y.\n\
417 Each SYM is set before the next VAL is computed.")
421 register Lisp_Object args_left
;
422 register Lisp_Object val
, sym
;
433 val
= Feval (Fcar (Fcdr (args_left
)));
434 sym
= Fcar (args_left
);
436 args_left
= Fcdr (Fcdr (args_left
));
438 while (!NILP(args_left
));
444 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
445 "Return the argument, without evaluating it. `(quote x)' yields `x'.")
452 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
453 "Like `quote', but preferred for objects which are functions.\n\
454 In byte compilation, `function' causes its argument to be compiled.\n\
455 `quote' cannot do that.")
462 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
463 "Return t if function in which this appears was called interactively.\n\
464 This means that the function was called with call-interactively (which\n\
465 includes being called as the binding of a key)\n\
466 and input is currently coming from the keyboard (not in keyboard macro).")
469 register struct backtrace
*btp
;
470 register Lisp_Object fun
;
475 btp
= backtrace_list
;
477 /* If this isn't a byte-compiled function, there may be a frame at
478 the top for Finteractive_p itself. If so, skip it. */
479 fun
= Findirect_function (*btp
->function
);
480 if (XTYPE (fun
) == Lisp_Subr
481 && (struct Lisp_Subr
*) XPNTR (fun
) == &Sinteractive_p
)
484 /* If we're running an Emacs 18-style byte-compiled function, there
485 may be a frame for Fbytecode. Now, given the strictest
486 definition, this function isn't really being called
487 interactively, but because that's the way Emacs 18 always builds
488 byte-compiled functions, we'll accept it for now. */
489 if (EQ (*btp
->function
, Qbytecode
))
492 /* If this isn't a byte-compiled function, then we may now be
493 looking at several frames for special forms. Skip past them. */
495 btp
->nargs
== UNEVALLED
)
498 /* btp now points at the frame of the innermost function that isn't
499 a special form, ignoring frames for Finteractive_p and/or
500 Fbytecode at the top. If this frame is for a built-in function
501 (such as load or eval-region) return nil. */
502 fun
= Findirect_function (*btp
->function
);
503 if (XTYPE (fun
) == Lisp_Subr
)
505 /* btp points to the frame of a Lisp function that called interactive-p.
506 Return t if that function was called interactively. */
507 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
512 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
513 "(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.\n\
514 The definition is (lambda ARGLIST [DOCSTRING] BODY...).\n\
515 See also the function `interactive'.")
519 register Lisp_Object fn_name
;
520 register Lisp_Object defn
;
522 fn_name
= Fcar (args
);
523 defn
= Fcons (Qlambda
, Fcdr (args
));
524 if (!NILP (Vpurify_flag
))
525 defn
= Fpurecopy (defn
);
526 Ffset (fn_name
, defn
);
527 LOADHIST_ATTACH (fn_name
);
531 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
532 "(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.\n\
533 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).\n\
534 When the macro is called, as in (NAME ARGS...),\n\
535 the function (lambda ARGLIST BODY...) is applied to\n\
536 the list ARGS... as it appears in the expression,\n\
537 and the result should be a form to be evaluated instead of the original.")
541 register Lisp_Object fn_name
;
542 register Lisp_Object defn
;
544 fn_name
= Fcar (args
);
545 defn
= Fcons (Qmacro
, Fcons (Qlambda
, Fcdr (args
)));
546 if (!NILP (Vpurify_flag
))
547 defn
= Fpurecopy (defn
);
548 Ffset (fn_name
, defn
);
549 LOADHIST_ATTACH (fn_name
);
553 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
554 "(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.\n\
555 You are not required to define a variable in order to use it,\n\
556 but the definition can supply documentation and an initial value\n\
557 in a way that tags can recognize.\n\n\
558 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.\n\
559 If SYMBOL is buffer-local, its default value is what is set;\n\
560 buffer-local values are not affected.\n\
561 INITVALUE and DOCSTRING are optional.\n\
562 If DOCSTRING starts with *, this variable is identified as a user option.\n\
563 This means that M-x set-variable and M-x edit-options recognize it.\n\
564 If INITVALUE is missing, SYMBOL's value is not set.")
568 register Lisp_Object sym
, tem
;
574 tem
= Fdefault_boundp (sym
);
576 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
578 tem
= Fcar (Fcdr (Fcdr (args
)));
581 if (!NILP (Vpurify_flag
))
582 tem
= Fpurecopy (tem
);
583 Fput (sym
, Qvariable_documentation
, tem
);
585 LOADHIST_ATTACH (sym
);
589 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
590 "(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant variable.\n\
591 The intent is that programs do not change this value, but users may.\n\
592 Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\
593 If SYMBOL is buffer-local, its default value is what is set;\n\
594 buffer-local values are not affected.\n\
595 DOCSTRING is optional.\n\
596 If DOCSTRING starts with *, this variable is identified as a user option.\n\
597 This means that M-x set-variable and M-x edit-options recognize it.\n\n\
598 Note: do not use `defconst' for user options in libraries that are not\n\
599 normally loaded, since it is useful for users to be able to specify\n\
600 their own values for such variables before loading the library.\n\
601 Since `defconst' unconditionally assigns the variable,\n\
602 it would override the user's choice.")
606 register Lisp_Object sym
, tem
;
609 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
610 tem
= Fcar (Fcdr (Fcdr (args
)));
613 if (!NILP (Vpurify_flag
))
614 tem
= Fpurecopy (tem
);
615 Fput (sym
, Qvariable_documentation
, tem
);
617 LOADHIST_ATTACH (sym
);
621 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
622 "Returns t if VARIABLE is intended to be set and modified by users.\n\
623 \(The alternative is a variable used internally in a Lisp program.)\n\
624 Determined by whether the first character of the documentation\n\
625 for the variable is \"*\"")
627 Lisp_Object variable
;
629 Lisp_Object documentation
;
631 documentation
= Fget (variable
, Qvariable_documentation
);
632 if (XTYPE (documentation
) == Lisp_Int
&& XINT (documentation
) < 0)
634 if ((XTYPE (documentation
) == Lisp_String
) &&
635 ((unsigned char) XSTRING (documentation
)->data
[0] == '*'))
640 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
641 "(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
642 The value of the last form in BODY is returned.\n\
643 Each element of VARLIST is a symbol (which is bound to nil)\n\
644 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
645 Each VALUEFORM can refer to the symbols already bound by this VARLIST.")
649 Lisp_Object varlist
, val
, elt
;
650 int count
= specpdl_ptr
- specpdl
;
651 struct gcpro gcpro1
, gcpro2
, gcpro3
;
653 GCPRO3 (args
, elt
, varlist
);
655 varlist
= Fcar (args
);
656 while (!NILP (varlist
))
659 elt
= Fcar (varlist
);
660 if (XTYPE (elt
) == Lisp_Symbol
)
661 specbind (elt
, Qnil
);
662 else if (! NILP (Fcdr (Fcdr (elt
))))
664 Fcons (build_string ("`let' bindings can have only one value-form"),
668 val
= Feval (Fcar (Fcdr (elt
)));
669 specbind (Fcar (elt
), val
);
671 varlist
= Fcdr (varlist
);
674 val
= Fprogn (Fcdr (args
));
675 return unbind_to (count
, val
);
678 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
679 "(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
680 The value of the last form in BODY is returned.\n\
681 Each element of VARLIST is a symbol (which is bound to nil)\n\
682 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
683 All the VALUEFORMs are evalled before any symbols are bound.")
687 Lisp_Object
*temps
, tem
;
688 register Lisp_Object elt
, varlist
;
689 int count
= specpdl_ptr
- specpdl
;
691 struct gcpro gcpro1
, gcpro2
;
693 varlist
= Fcar (args
);
695 /* Make space to hold the values to give the bound variables */
696 elt
= Flength (varlist
);
697 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
699 /* Compute the values and store them in `temps' */
701 GCPRO2 (args
, *temps
);
704 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
707 elt
= Fcar (varlist
);
708 if (XTYPE (elt
) == Lisp_Symbol
)
709 temps
[argnum
++] = Qnil
;
710 else if (! NILP (Fcdr (Fcdr (elt
))))
712 Fcons (build_string ("`let' bindings can have only one value-form"),
715 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
716 gcpro2
.nvars
= argnum
;
720 varlist
= Fcar (args
);
721 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
723 elt
= Fcar (varlist
);
724 tem
= temps
[argnum
++];
725 if (XTYPE (elt
) == Lisp_Symbol
)
728 specbind (Fcar (elt
), tem
);
731 elt
= Fprogn (Fcdr (args
));
732 return unbind_to (count
, elt
);
735 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
736 "(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.\n\
737 The order of execution is thus TEST, BODY, TEST, BODY and so on\n\
738 until TEST returns nil.")
742 Lisp_Object test
, body
, tem
;
743 struct gcpro gcpro1
, gcpro2
;
749 while (tem
= Feval (test
), !NILP (tem
))
759 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
760 "Return result of expanding macros at top level of FORM.\n\
761 If FORM is not a macro call, it is returned unchanged.\n\
762 Otherwise, the macro is expanded and the expansion is considered\n\
763 in place of FORM. When a non-macro-call results, it is returned.\n\n\
764 The second optional arg ENVIRONMENT species an environment of macro\n\
765 definitions to shadow the loaded ones for use in file byte-compilation.")
767 register Lisp_Object form
;
770 /* With cleanups from Hallvard Furuseth. */
771 register Lisp_Object expander
, sym
, def
, tem
;
775 /* Come back here each time we expand a macro call,
776 in case it expands into another macro call. */
777 if (XTYPE (form
) != Lisp_Cons
)
779 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
780 def
= sym
= XCONS (form
)->car
;
782 /* Trace symbols aliases to other symbols
783 until we get a symbol that is not an alias. */
784 while (XTYPE (def
) == Lisp_Symbol
)
788 tem
= Fassq (sym
, env
);
791 def
= XSYMBOL (sym
)->function
;
792 if (!EQ (def
, Qunbound
))
797 /* Right now TEM is the result from SYM in ENV,
798 and if TEM is nil then DEF is SYM's function definition. */
801 /* SYM is not mentioned in ENV.
802 Look at its function definition. */
803 if (EQ (def
, Qunbound
)
804 || XTYPE (def
) != Lisp_Cons
)
805 /* Not defined or definition not suitable */
807 if (EQ (XCONS (def
)->car
, Qautoload
))
809 /* Autoloading function: will it be a macro when loaded? */
810 tem
= Fnth (make_number (4), def
);
811 if (EQ (XCONS (tem
)->car
, Qt
)
812 || EQ (XCONS (tem
)->car
, Qmacro
))
813 /* Yes, load it and try again. */
815 do_autoload (def
, sym
);
821 else if (!EQ (XCONS (def
)->car
, Qmacro
))
823 else expander
= XCONS (def
)->cdr
;
827 expander
= XCONS (tem
)->cdr
;
831 form
= apply1 (expander
, XCONS (form
)->cdr
);
836 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
837 "(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.\n\
838 TAG is evalled to get the tag to use. Then the BODY is executed.\n\
839 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.\n\
840 If no throw happens, `catch' returns the value of the last BODY form.\n\
841 If a throw happens, it specifies the value to return from `catch'.")
845 register Lisp_Object tag
;
849 tag
= Feval (Fcar (args
));
851 return internal_catch (tag
, Fprogn
, Fcdr (args
));
854 /* Set up a catch, then call C function FUNC on argument ARG.
855 FUNC should return a Lisp_Object.
856 This is how catches are done from within C code. */
859 internal_catch (tag
, func
, arg
)
861 Lisp_Object (*func
) ();
864 /* This structure is made part of the chain `catchlist'. */
867 /* Fill in the components of c, and put it on the list. */
871 c
.backlist
= backtrace_list
;
872 c
.handlerlist
= handlerlist
;
873 c
.lisp_eval_depth
= lisp_eval_depth
;
874 c
.pdlcount
= specpdl_ptr
- specpdl
;
875 c
.poll_suppress_count
= poll_suppress_count
;
880 if (! _setjmp (c
.jmp
))
881 c
.val
= (*func
) (arg
);
883 /* Throw works by a longjmp that comes right here. */
888 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
889 jump to that CATCH, returning VALUE as the value of that catch.
891 This is the guts Fthrow and Fsignal; they differ only in the way
892 they choose the catch tag to throw to. A catch tag for a
893 condition-case form has a TAG of Qnil.
895 Before each catch is discarded, unbind all special bindings and
896 execute all unwind-protect clauses made above that catch. Unwind
897 the handler stack as we go, so that the proper handlers are in
898 effect for each unwind-protect clause we run. At the end, restore
899 some static info saved in CATCH, and longjmp to the location
902 This is used for correct unwinding in Fthrow and Fsignal. */
905 unwind_to_catch (catch, value
)
906 struct catchtag
*catch;
909 register int last_time
;
911 /* Save the value in the tag. */
914 /* Restore the polling-suppression count. */
915 if (catch->poll_suppress_count
> poll_suppress_count
)
917 while (catch->poll_suppress_count
< poll_suppress_count
)
922 last_time
= catchlist
== catch;
924 /* Unwind the specpdl stack, and then restore the proper set of
926 unbind_to (catchlist
->pdlcount
, Qnil
);
927 handlerlist
= catchlist
->handlerlist
;
928 catchlist
= catchlist
->next
;
932 gcprolist
= catch->gcpro
;
933 backtrace_list
= catch->backlist
;
934 lisp_eval_depth
= catch->lisp_eval_depth
;
936 _longjmp (catch->jmp
, 1);
939 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
940 "(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.\n\
941 Both TAG and VALUE are evalled.")
943 register Lisp_Object tag
, val
;
945 register struct catchtag
*c
;
950 for (c
= catchlist
; c
; c
= c
->next
)
952 if (EQ (c
->tag
, tag
))
953 unwind_to_catch (c
, val
);
955 tag
= Fsignal (Qno_catch
, Fcons (tag
, Fcons (val
, Qnil
)));
960 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
961 "Do BODYFORM, protecting with UNWINDFORMS.\n\
962 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).\n\
963 If BODYFORM completes normally, its value is returned\n\
964 after executing the UNWINDFORMS.\n\
965 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.")
970 int count
= specpdl_ptr
- specpdl
;
972 record_unwind_protect (0, Fcdr (args
));
973 val
= Feval (Fcar (args
));
974 return unbind_to (count
, val
);
977 /* Chain of condition handlers currently in effect.
978 The elements of this chain are contained in the stack frames
979 of Fcondition_case and internal_condition_case.
980 When an error is signaled (by calling Fsignal, below),
981 this chain is searched for an element that applies. */
983 struct handler
*handlerlist
;
985 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
986 "Regain control when an error is signaled.\n\
987 Usage looks like (condition-case VAR BODYFORM HANDLERS...).\n\
988 executes BODYFORM and returns its value if no error happens.\n\
989 Each element of HANDLERS looks like (CONDITION-NAME BODY...)\n\
990 where the BODY is made of Lisp expressions.\n\n\
991 A handler is applicable to an error\n\
992 if CONDITION-NAME is one of the error's condition names.\n\
993 If an error happens, the first applicable handler is run.\n\
995 When a handler handles an error,\n\
996 control returns to the condition-case and the handler BODY... is executed\n\
997 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\
998 VAR may be nil; then you do not get access to the signal information.\n\
1000 The value of the last BODY form is returned from the condition-case.\n\
1001 See also the function `signal' for more info.")
1008 register Lisp_Object var
, bodyform
, handlers
;
1011 bodyform
= Fcar (Fcdr (args
));
1012 handlers
= Fcdr (Fcdr (args
));
1013 CHECK_SYMBOL (var
, 0);
1015 for (val
= handlers
; ! NILP (val
); val
= Fcdr (val
))
1019 if ((!NILP (tem
)) &&
1020 (!CONSP (tem
) || (XTYPE (XCONS (tem
)->car
) != Lisp_Symbol
)))
1021 error ("Invalid condition handler", tem
);
1026 c
.backlist
= backtrace_list
;
1027 c
.handlerlist
= handlerlist
;
1028 c
.lisp_eval_depth
= lisp_eval_depth
;
1029 c
.pdlcount
= specpdl_ptr
- specpdl
;
1030 c
.poll_suppress_count
= poll_suppress_count
;
1031 c
.gcpro
= gcprolist
;
1032 if (_setjmp (c
.jmp
))
1035 specbind (h
.var
, Fcdr (c
.val
));
1036 val
= Fprogn (Fcdr (Fcar (c
.val
)));
1038 /* Note that this just undoes the binding of h.var; whoever
1039 longjumped to us unwound the stack to c.pdlcount before
1041 unbind_to (c
.pdlcount
, Qnil
);
1048 h
.handler
= handlers
;
1049 h
.next
= handlerlist
;
1053 val
= Feval (bodyform
);
1055 handlerlist
= h
.next
;
1060 internal_condition_case (bfun
, handlers
, hfun
)
1061 Lisp_Object (*bfun
) ();
1062 Lisp_Object handlers
;
1063 Lisp_Object (*hfun
) ();
1071 c
.backlist
= backtrace_list
;
1072 c
.handlerlist
= handlerlist
;
1073 c
.lisp_eval_depth
= lisp_eval_depth
;
1074 c
.pdlcount
= specpdl_ptr
- specpdl
;
1075 c
.poll_suppress_count
= poll_suppress_count
;
1076 c
.gcpro
= gcprolist
;
1077 if (_setjmp (c
.jmp
))
1079 return (*hfun
) (Fcdr (c
.val
));
1083 h
.handler
= handlers
;
1085 h
.next
= handlerlist
;
1091 handlerlist
= h
.next
;
1095 static Lisp_Object
find_handler_clause ();
1097 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1098 "Signal an error. Args are SIGNAL-NAME, and associated DATA.\n\
1099 This function does not return.\n\n\
1100 A signal name is a symbol with an `error-conditions' property\n\
1101 that is a list of condition names.\n\
1102 A handler for any of those names will get to handle this signal.\n\
1103 The symbol `error' should normally be one of them.\n\
1105 DATA should be a list. Its elements are printed as part of the error message.\n\
1106 If the signal is handled, DATA is made available to the handler.\n\
1107 See also the function `condition-case'.")
1109 Lisp_Object sig
, data
;
1111 register struct handler
*allhandlers
= handlerlist
;
1112 Lisp_Object conditions
;
1113 extern int gc_in_progress
;
1114 extern int waiting_for_input
;
1115 Lisp_Object debugger_value
;
1117 quit_error_check ();
1119 if (gc_in_progress
|| waiting_for_input
)
1122 #ifdef HAVE_X_WINDOWS
1123 TOTALLY_UNBLOCK_INPUT
;
1126 conditions
= Fget (sig
, Qerror_conditions
);
1128 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1130 register Lisp_Object clause
;
1131 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1132 sig
, data
, &debugger_value
);
1134 #if 0 /* Most callers are not prepared to handle gc if this returns.
1135 So, since this feature is not very useful, take it out. */
1136 /* If have called debugger and user wants to continue,
1138 if (EQ (clause
, Qlambda
))
1139 return debugger_value
;
1141 if (EQ (clause
, Qlambda
))
1143 /* We can't return values to code which signalled an error, but we
1144 can continue code which has signalled a quit. */
1145 if (EQ (sig
, Qquit
))
1148 error ("Returning a value from an error is no longer supported");
1154 struct handler
*h
= handlerlist
;
1155 handlerlist
= allhandlers
;
1156 unwind_to_catch (h
->tag
, Fcons (clause
, Fcons (sig
, data
)));
1160 handlerlist
= allhandlers
;
1161 /* If no handler is present now, try to run the debugger,
1162 and if that fails, throw to top level. */
1163 find_handler_clause (Qerror
, conditions
, sig
, data
, &debugger_value
);
1164 Fthrow (Qtop_level
, Qt
);
1167 /* Return nonzero iff LIST is a non-nil atom or
1168 a list containing one of CONDITIONS. */
1171 wants_debugger (list
, conditions
)
1172 Lisp_Object list
, conditions
;
1179 while (CONSP (conditions
))
1181 Lisp_Object
this, tail
;
1182 this = XCONS (conditions
)->car
;
1183 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1184 if (EQ (XCONS (tail
)->car
, this))
1186 conditions
= XCONS (conditions
)->cdr
;
1191 /* Value of Qlambda means we have called debugger and user has continued.
1192 Store value returned from debugger into *DEBUGGER_VALUE_PTR. */
1195 find_handler_clause (handlers
, conditions
, sig
, data
, debugger_value_ptr
)
1196 Lisp_Object handlers
, conditions
, sig
, data
;
1197 Lisp_Object
*debugger_value_ptr
;
1199 register Lisp_Object h
;
1200 register Lisp_Object tem
;
1201 register Lisp_Object tem1
;
1203 if (EQ (handlers
, Qt
)) /* t is used by handlers for all conditions, set up by C code. */
1205 if (EQ (handlers
, Qerror
)) /* error is used similarly, but means display a backtrace too */
1207 if (wants_debugger (Vstack_trace_on_error
, conditions
))
1208 internal_with_output_to_temp_buffer ("*Backtrace*", Fbacktrace
, Qnil
);
1209 if ((EQ (sig
, Qquit
)
1211 : wants_debugger (Vdebug_on_error
, conditions
))
1212 && when_entered_debugger
< num_nonmacro_input_chars
)
1214 int count
= specpdl_ptr
- specpdl
;
1215 specbind (Qdebug_on_error
, Qnil
);
1216 *debugger_value_ptr
=
1217 call_debugger (Fcons (Qerror
,
1218 Fcons (Fcons (sig
, data
),
1220 return unbind_to (count
, Qlambda
);
1224 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1229 tem
= Fmemq (Fcar (tem1
), conditions
);
1236 /* dump an error message; called like printf */
1240 error (m
, a1
, a2
, a3
)
1244 sprintf (buf
, m
, a1
, a2
, a3
);
1247 Fsignal (Qerror
, Fcons (build_string (buf
), Qnil
));
1250 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 1, 0,
1251 "T if FUNCTION makes provisions for interactive calling.\n\
1252 This means it contains a description for how to read arguments to give it.\n\
1253 The value is nil for an invalid function or a symbol with no function\n\
1256 Interactively callable functions include strings and vectors (treated\n\
1257 as keyboard macros), lambda-expressions that contain a top-level call\n\
1258 to `interactive', autoload definitions made by `autoload' with non-nil\n\
1259 fourth argument, and some of the built-in functions of Lisp.\n\
1261 Also, a symbol satisfies `commandp' if its function definition does so.")
1263 Lisp_Object function
;
1265 register Lisp_Object fun
;
1266 register Lisp_Object funcar
;
1267 register Lisp_Object tem
;
1272 fun
= indirect_function (fun
);
1273 if (EQ (fun
, Qunbound
))
1276 /* Emacs primitives are interactive if their DEFUN specifies an
1277 interactive spec. */
1278 if (XTYPE (fun
) == Lisp_Subr
)
1280 if (XSUBR (fun
)->prompt
)
1286 /* Bytecode objects are interactive if they are long enough to
1287 have an element whose index is COMPILED_INTERACTIVE, which is
1288 where the interactive spec is stored. */
1289 else if (XTYPE (fun
) == Lisp_Compiled
)
1290 return (XVECTOR (fun
)->size
> COMPILED_INTERACTIVE
1293 /* Strings and vectors are keyboard macros. */
1294 if (XTYPE (fun
) == Lisp_String
1295 || XTYPE (fun
) == Lisp_Vector
)
1298 /* Lists may represent commands. */
1301 funcar
= Fcar (fun
);
1302 if (XTYPE (funcar
) != Lisp_Symbol
)
1303 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1304 if (EQ (funcar
, Qlambda
))
1305 return Fassq (Qinteractive
, Fcdr (Fcdr (fun
)));
1306 if (EQ (funcar
, Qmocklisp
))
1307 return Qt
; /* All mocklisp functions can be called interactively */
1308 if (EQ (funcar
, Qautoload
))
1309 return Fcar (Fcdr (Fcdr (Fcdr (fun
))));
1315 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1316 "Define FUNCTION to autoload from FILE.\n\
1317 FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\
1318 Third arg DOCSTRING is documentation for the function.\n\
1319 Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\
1320 Fifth arg TYPE indicates the type of the object:\n\
1321 nil or omitted says FUNCTION is a function,\n\
1322 `keymap' says FUNCTION is really a keymap, and\n\
1323 `macro' or t says FUNCTION is really a macro.\n\
1324 Third through fifth args give info about the real definition.\n\
1325 They default to nil.\n\
1326 If FUNCTION is already defined other than as an autoload,\n\
1327 this does nothing and returns nil.")
1328 (function
, file
, docstring
, interactive
, type
)
1329 Lisp_Object function
, file
, docstring
, interactive
, type
;
1332 Lisp_Object args
[4];
1335 CHECK_SYMBOL (function
, 0);
1336 CHECK_STRING (file
, 1);
1338 /* If function is defined and not as an autoload, don't override */
1339 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
1340 && !(XTYPE (XSYMBOL (function
)->function
) == Lisp_Cons
1341 && EQ (XCONS (XSYMBOL (function
)->function
)->car
, Qautoload
)))
1346 args
[1] = docstring
;
1347 args
[2] = interactive
;
1350 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
1351 #else /* NO_ARG_ARRAY */
1352 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
1353 #endif /* not NO_ARG_ARRAY */
1357 un_autoload (oldqueue
)
1358 Lisp_Object oldqueue
;
1360 register Lisp_Object queue
, first
, second
;
1362 /* Queue to unwind is current value of Vautoload_queue.
1363 oldqueue is the shadowed value to leave in Vautoload_queue. */
1364 queue
= Vautoload_queue
;
1365 Vautoload_queue
= oldqueue
;
1366 while (CONSP (queue
))
1368 first
= Fcar (queue
);
1369 second
= Fcdr (first
);
1370 first
= Fcar (first
);
1371 if (EQ (second
, Qnil
))
1374 Ffset (first
, second
);
1375 queue
= Fcdr (queue
);
1380 do_autoload (fundef
, funname
)
1381 Lisp_Object fundef
, funname
;
1383 int count
= specpdl_ptr
- specpdl
;
1384 Lisp_Object fun
, val
, queue
, first
, second
;
1387 CHECK_SYMBOL (funname
, 0);
1389 /* Value saved here is to be restored into Vautoload_queue */
1390 record_unwind_protect (un_autoload
, Vautoload_queue
);
1391 Vautoload_queue
= Qt
;
1392 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
);
1394 /* Save the old autoloads, in case we ever do an unload. */
1395 queue
= Vautoload_queue
;
1396 while (CONSP (queue
))
1398 first
= Fcar (queue
);
1399 second
= Fcdr (first
);
1400 first
= Fcar (first
);
1401 if (!EQ (second
, Qnil
))
1402 Fput(first
, Qautoload
, (Fcdr (second
)));
1403 queue
= Fcdr (queue
);
1406 /* Once loading finishes, don't undo it. */
1407 Vautoload_queue
= Qt
;
1408 unbind_to (count
, Qnil
);
1410 fun
= Findirect_function (fun
);
1412 if (XTYPE (fun
) == Lisp_Cons
1413 && EQ (XCONS (fun
)->car
, Qautoload
))
1414 error ("Autoloading failed to define function %s",
1415 XSYMBOL (funname
)->name
->data
);
1418 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
1419 "Evaluate FORM and return its value.")
1423 Lisp_Object fun
, val
, original_fun
, original_args
;
1425 struct backtrace backtrace
;
1426 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1428 if (XTYPE (form
) == Lisp_Symbol
)
1430 if (EQ (Vmocklisp_arguments
, Qt
))
1431 return Fsymbol_value (form
);
1432 val
= Fsymbol_value (form
);
1435 else if (EQ (val
, Qt
))
1443 if (consing_since_gc
> gc_cons_threshold
)
1446 Fgarbage_collect ();
1450 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1452 if (max_lisp_eval_depth
< 100)
1453 max_lisp_eval_depth
= 100;
1454 if (lisp_eval_depth
> max_lisp_eval_depth
)
1455 error ("Lisp nesting exceeds max-lisp-eval-depth");
1458 original_fun
= Fcar (form
);
1459 original_args
= Fcdr (form
);
1461 backtrace
.next
= backtrace_list
;
1462 backtrace_list
= &backtrace
;
1463 backtrace
.function
= &original_fun
; /* This also protects them from gc */
1464 backtrace
.args
= &original_args
;
1465 backtrace
.nargs
= UNEVALLED
;
1466 backtrace
.evalargs
= 1;
1467 backtrace
.debug_on_exit
= 0;
1469 if (debug_on_next_call
)
1470 do_debug_on_call (Qt
);
1472 /* At this point, only original_fun and original_args
1473 have values that will be used below */
1475 fun
= Findirect_function (original_fun
);
1477 if (XTYPE (fun
) == Lisp_Subr
)
1479 Lisp_Object numargs
;
1480 Lisp_Object argvals
[7];
1481 Lisp_Object args_left
;
1482 register int i
, maxargs
;
1484 args_left
= original_args
;
1485 numargs
= Flength (args_left
);
1487 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
1488 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
1489 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1491 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1493 backtrace
.evalargs
= 0;
1494 val
= (*XSUBR (fun
)->function
) (args_left
);
1498 if (XSUBR (fun
)->max_args
== MANY
)
1500 /* Pass a vector of evaluated arguments */
1502 register int argnum
= 0;
1504 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1506 GCPRO3 (args_left
, fun
, fun
);
1510 while (!NILP (args_left
))
1512 vals
[argnum
++] = Feval (Fcar (args_left
));
1513 args_left
= Fcdr (args_left
);
1514 gcpro3
.nvars
= argnum
;
1517 backtrace
.args
= vals
;
1518 backtrace
.nargs
= XINT (numargs
);
1520 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
1525 GCPRO3 (args_left
, fun
, fun
);
1526 gcpro3
.var
= argvals
;
1529 maxargs
= XSUBR (fun
)->max_args
;
1530 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
1532 argvals
[i
] = Feval (Fcar (args_left
));
1538 backtrace
.args
= argvals
;
1539 backtrace
.nargs
= XINT (numargs
);
1544 val
= (*XSUBR (fun
)->function
) ();
1547 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
1550 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
1553 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1557 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1558 argvals
[2], argvals
[3]);
1561 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1562 argvals
[3], argvals
[4]);
1565 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1566 argvals
[3], argvals
[4], argvals
[5]);
1569 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1570 argvals
[3], argvals
[4], argvals
[5],
1575 /* Someone has created a subr that takes more arguments than
1576 is supported by this code. We need to either rewrite the
1577 subr to use a different argument protocol, or add more
1578 cases to this switch. */
1582 if (XTYPE (fun
) == Lisp_Compiled
)
1583 val
= apply_lambda (fun
, original_args
, 1);
1587 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1588 funcar
= Fcar (fun
);
1589 if (XTYPE (funcar
) != Lisp_Symbol
)
1590 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1591 if (EQ (funcar
, Qautoload
))
1593 do_autoload (fun
, original_fun
);
1596 if (EQ (funcar
, Qmacro
))
1597 val
= Feval (apply1 (Fcdr (fun
), original_args
));
1598 else if (EQ (funcar
, Qlambda
))
1599 val
= apply_lambda (fun
, original_args
, 1);
1600 else if (EQ (funcar
, Qmocklisp
))
1601 val
= ml_apply (fun
, original_args
);
1603 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1606 if (!EQ (Vmocklisp_arguments
, Qt
))
1610 else if (EQ (val
, Qt
))
1614 if (backtrace
.debug_on_exit
)
1615 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
1616 backtrace_list
= backtrace
.next
;
1620 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
1621 "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
1622 Thus, (apply '+ 1 2 '(3 4)) returns 10.")
1627 register int i
, numargs
;
1628 register Lisp_Object spread_arg
;
1629 register Lisp_Object
*funcall_args
;
1631 struct gcpro gcpro1
;
1635 spread_arg
= args
[nargs
- 1];
1636 CHECK_LIST (spread_arg
, nargs
);
1638 numargs
= XINT (Flength (spread_arg
));
1641 return Ffuncall (nargs
- 1, args
);
1642 else if (numargs
== 1)
1644 args
[nargs
- 1] = XCONS (spread_arg
)->car
;
1645 return Ffuncall (nargs
, args
);
1648 numargs
+= nargs
- 2;
1650 fun
= indirect_function (fun
);
1651 if (EQ (fun
, Qunbound
))
1653 /* Let funcall get the error */
1658 if (XTYPE (fun
) == Lisp_Subr
)
1660 if (numargs
< XSUBR (fun
)->min_args
1661 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
1662 goto funcall
; /* Let funcall get the error */
1663 else if (XSUBR (fun
)->max_args
> numargs
)
1665 /* Avoid making funcall cons up a yet another new vector of arguments
1666 by explicitly supplying nil's for optional values */
1667 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
1668 * sizeof (Lisp_Object
));
1669 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
1670 funcall_args
[++i
] = Qnil
;
1671 GCPRO1 (*funcall_args
);
1672 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
1676 /* We add 1 to numargs because funcall_args includes the
1677 function itself as well as its arguments. */
1680 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
1681 * sizeof (Lisp_Object
));
1682 GCPRO1 (*funcall_args
);
1683 gcpro1
.nvars
= 1 + numargs
;
1686 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
1687 /* Spread the last arg we got. Its first element goes in
1688 the slot that it used to occupy, hence this value of I. */
1690 while (!NILP (spread_arg
))
1692 funcall_args
[i
++] = XCONS (spread_arg
)->car
;
1693 spread_arg
= XCONS (spread_arg
)->cdr
;
1696 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
1699 /* Apply fn to arg */
1702 Lisp_Object fn
, arg
;
1704 struct gcpro gcpro1
;
1708 RETURN_UNGCPRO (Ffuncall (1, &fn
));
1712 Lisp_Object args
[2];
1716 RETURN_UNGCPRO (Fapply (2, args
));
1718 #else /* not NO_ARG_ARRAY */
1719 RETURN_UNGCPRO (Fapply (2, &fn
));
1720 #endif /* not NO_ARG_ARRAY */
1723 /* Call function fn on no arguments */
1728 struct gcpro gcpro1
;
1731 RETURN_UNGCPRO (Ffuncall (1, &fn
));
1734 /* Call function fn with argument arg */
1738 Lisp_Object fn
, arg
;
1740 struct gcpro gcpro1
;
1742 Lisp_Object args
[2];
1748 RETURN_UNGCPRO (Ffuncall (2, args
));
1749 #else /* not NO_ARG_ARRAY */
1752 RETURN_UNGCPRO (Ffuncall (2, &fn
));
1753 #endif /* not NO_ARG_ARRAY */
1756 /* Call function fn with arguments arg, arg1 */
1759 call2 (fn
, arg
, arg1
)
1760 Lisp_Object fn
, arg
, arg1
;
1762 struct gcpro gcpro1
;
1764 Lisp_Object args
[3];
1770 RETURN_UNGCPRO (Ffuncall (3, args
));
1771 #else /* not NO_ARG_ARRAY */
1774 RETURN_UNGCPRO (Ffuncall (3, &fn
));
1775 #endif /* not NO_ARG_ARRAY */
1778 /* Call function fn with arguments arg, arg1, arg2 */
1781 call3 (fn
, arg
, arg1
, arg2
)
1782 Lisp_Object fn
, arg
, arg1
, arg2
;
1784 struct gcpro gcpro1
;
1786 Lisp_Object args
[4];
1793 RETURN_UNGCPRO (Ffuncall (4, args
));
1794 #else /* not NO_ARG_ARRAY */
1797 RETURN_UNGCPRO (Ffuncall (4, &fn
));
1798 #endif /* not NO_ARG_ARRAY */
1801 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
1802 "Call first argument as a function, passing remaining arguments to it.\n\
1803 Thus, (funcall 'cons 'x 'y) returns (x . y).")
1810 int numargs
= nargs
- 1;
1811 Lisp_Object lisp_numargs
;
1813 struct backtrace backtrace
;
1814 register Lisp_Object
*internal_args
;
1818 if (consing_since_gc
> gc_cons_threshold
)
1819 Fgarbage_collect ();
1821 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1823 if (max_lisp_eval_depth
< 100)
1824 max_lisp_eval_depth
= 100;
1825 if (lisp_eval_depth
> max_lisp_eval_depth
)
1826 error ("Lisp nesting exceeds max-lisp-eval-depth");
1829 backtrace
.next
= backtrace_list
;
1830 backtrace_list
= &backtrace
;
1831 backtrace
.function
= &args
[0];
1832 backtrace
.args
= &args
[1];
1833 backtrace
.nargs
= nargs
- 1;
1834 backtrace
.evalargs
= 0;
1835 backtrace
.debug_on_exit
= 0;
1837 if (debug_on_next_call
)
1838 do_debug_on_call (Qlambda
);
1844 fun
= Findirect_function (fun
);
1846 if (XTYPE (fun
) == Lisp_Subr
)
1848 if (numargs
< XSUBR (fun
)->min_args
1849 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
1851 XFASTINT (lisp_numargs
) = numargs
;
1852 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (lisp_numargs
, Qnil
)));
1855 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1856 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1858 if (XSUBR (fun
)->max_args
== MANY
)
1860 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
1864 if (XSUBR (fun
)->max_args
> numargs
)
1866 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
1867 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
1868 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
1869 internal_args
[i
] = Qnil
;
1872 internal_args
= args
+ 1;
1873 switch (XSUBR (fun
)->max_args
)
1876 val
= (*XSUBR (fun
)->function
) ();
1879 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
1882 val
= (*XSUBR (fun
)->function
) (internal_args
[0],
1886 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
1890 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
1895 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
1896 internal_args
[2], internal_args
[3],
1900 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
1901 internal_args
[2], internal_args
[3],
1902 internal_args
[4], internal_args
[5]);
1905 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
1906 internal_args
[2], internal_args
[3],
1907 internal_args
[4], internal_args
[5],
1913 /* If a subr takes more than 6 arguments without using MANY
1914 or UNEVALLED, we need to extend this function to support it.
1915 Until this is done, there is no way to call the function. */
1919 if (XTYPE (fun
) == Lisp_Compiled
)
1920 val
= funcall_lambda (fun
, numargs
, args
+ 1);
1924 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1925 funcar
= Fcar (fun
);
1926 if (XTYPE (funcar
) != Lisp_Symbol
)
1927 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1928 if (EQ (funcar
, Qlambda
))
1929 val
= funcall_lambda (fun
, numargs
, args
+ 1);
1930 else if (EQ (funcar
, Qmocklisp
))
1931 val
= ml_apply (fun
, Flist (numargs
, args
+ 1));
1932 else if (EQ (funcar
, Qautoload
))
1934 do_autoload (fun
, args
[0]);
1938 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1942 if (backtrace
.debug_on_exit
)
1943 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
1944 backtrace_list
= backtrace
.next
;
1949 apply_lambda (fun
, args
, eval_flag
)
1950 Lisp_Object fun
, args
;
1953 Lisp_Object args_left
;
1954 Lisp_Object numargs
;
1955 register Lisp_Object
*arg_vector
;
1956 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1958 register Lisp_Object tem
;
1960 numargs
= Flength (args
);
1961 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1964 GCPRO3 (*arg_vector
, args_left
, fun
);
1967 for (i
= 0; i
< XINT (numargs
);)
1969 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
1970 if (eval_flag
) tem
= Feval (tem
);
1971 arg_vector
[i
++] = tem
;
1979 backtrace_list
->args
= arg_vector
;
1980 backtrace_list
->nargs
= i
;
1982 backtrace_list
->evalargs
= 0;
1983 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
1985 /* Do the debug-on-exit now, while arg_vector still exists. */
1986 if (backtrace_list
->debug_on_exit
)
1987 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
1988 /* Don't do it again when we return to eval. */
1989 backtrace_list
->debug_on_exit
= 0;
1993 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
1994 and return the result of evaluation.
1995 FUN must be either a lambda-expression or a compiled-code object. */
1998 funcall_lambda (fun
, nargs
, arg_vector
)
2001 register Lisp_Object
*arg_vector
;
2003 Lisp_Object val
, tem
;
2004 register Lisp_Object syms_left
;
2005 Lisp_Object numargs
;
2006 register Lisp_Object next
;
2007 int count
= specpdl_ptr
- specpdl
;
2009 int optional
= 0, rest
= 0;
2011 specbind (Qmocklisp_arguments
, Qt
); /* t means NOT mocklisp! */
2013 XFASTINT (numargs
) = nargs
;
2015 if (XTYPE (fun
) == Lisp_Cons
)
2016 syms_left
= Fcar (Fcdr (fun
));
2017 else if (XTYPE (fun
) == Lisp_Compiled
)
2018 syms_left
= XVECTOR (fun
)->contents
[COMPILED_ARGLIST
];
2022 for (; !NILP (syms_left
); syms_left
= Fcdr (syms_left
))
2025 next
= Fcar (syms_left
);
2026 while (XTYPE (next
) != Lisp_Symbol
)
2027 next
= Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2028 if (EQ (next
, Qand_rest
))
2030 else if (EQ (next
, Qand_optional
))
2034 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
2039 tem
= arg_vector
[i
++];
2040 specbind (next
, tem
);
2043 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2045 specbind (next
, Qnil
);
2049 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2051 if (XTYPE (fun
) == Lisp_Cons
)
2052 val
= Fprogn (Fcdr (Fcdr (fun
)));
2054 val
= Fbyte_code (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
],
2055 XVECTOR (fun
)->contents
[COMPILED_CONSTANTS
],
2056 XVECTOR (fun
)->contents
[COMPILED_STACK_DEPTH
]);
2057 return unbind_to (count
, val
);
2063 register int count
= specpdl_ptr
- specpdl
;
2064 if (specpdl_size
>= max_specpdl_size
)
2066 if (max_specpdl_size
< 400)
2067 max_specpdl_size
= 400;
2068 if (specpdl_size
>= max_specpdl_size
)
2070 if (!NILP (Vdebug_on_error
))
2071 /* Leave room for some specpdl in the debugger. */
2072 max_specpdl_size
= specpdl_size
+ 100;
2074 Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil
));
2078 if (specpdl_size
> max_specpdl_size
)
2079 specpdl_size
= max_specpdl_size
;
2080 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
2081 specpdl_ptr
= specpdl
+ count
;
2085 specbind (symbol
, value
)
2086 Lisp_Object symbol
, value
;
2088 extern void store_symval_forwarding (); /* in eval.c */
2091 CHECK_SYMBOL (symbol
, 0);
2093 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2095 specpdl_ptr
->symbol
= symbol
;
2096 specpdl_ptr
->func
= 0;
2097 ovalue
= XSYMBOL (symbol
)->value
;
2098 specpdl_ptr
->old_value
= EQ (ovalue
, Qunbound
) ? Qunbound
: Fsymbol_value (symbol
);
2100 if (XTYPE (ovalue
) == Lisp_Buffer_Objfwd
)
2101 store_symval_forwarding (symbol
, ovalue
, value
);
2103 Fset (symbol
, value
);
2107 record_unwind_protect (function
, arg
)
2108 Lisp_Object (*function
)();
2111 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2113 specpdl_ptr
->func
= function
;
2114 specpdl_ptr
->symbol
= Qnil
;
2115 specpdl_ptr
->old_value
= arg
;
2120 unbind_to (count
, value
)
2124 int quitf
= !NILP (Vquit_flag
);
2125 struct gcpro gcpro1
;
2131 while (specpdl_ptr
!= specpdl
+ count
)
2134 if (specpdl_ptr
->func
!= 0)
2135 (*specpdl_ptr
->func
) (specpdl_ptr
->old_value
);
2136 /* Note that a "binding" of nil is really an unwind protect,
2137 so in that case the "old value" is a list of forms to evaluate. */
2138 else if (NILP (specpdl_ptr
->symbol
))
2139 Fprogn (specpdl_ptr
->old_value
);
2141 Fset (specpdl_ptr
->symbol
, specpdl_ptr
->old_value
);
2143 if (NILP (Vquit_flag
) && quitf
) Vquit_flag
= Qt
;
2152 /* Get the value of symbol's global binding, even if that binding
2153 is not now dynamically visible. */
2156 top_level_value (symbol
)
2159 register struct specbinding
*ptr
= specpdl
;
2161 CHECK_SYMBOL (symbol
, 0);
2162 for (; ptr
!= specpdl_ptr
; ptr
++)
2164 if (EQ (ptr
->symbol
, symbol
))
2165 return ptr
->old_value
;
2167 return Fsymbol_value (symbol
);
2171 top_level_set (symbol
, newval
)
2172 Lisp_Object symbol
, newval
;
2174 register struct specbinding
*ptr
= specpdl
;
2176 CHECK_SYMBOL (symbol
, 0);
2177 for (; ptr
!= specpdl_ptr
; ptr
++)
2179 if (EQ (ptr
->symbol
, symbol
))
2181 ptr
->old_value
= newval
;
2185 return Fset (symbol
, newval
);
2190 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
2191 "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\
2192 The debugger is entered when that frame exits, if the flag is non-nil.")
2194 Lisp_Object level
, flag
;
2196 register struct backtrace
*backlist
= backtrace_list
;
2199 CHECK_NUMBER (level
, 0);
2201 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
2203 backlist
= backlist
->next
;
2207 backlist
->debug_on_exit
= !NILP (flag
);
2212 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
2213 "Print a trace of Lisp function calls currently active.\n\
2214 Output stream used is value of `standard-output'.")
2217 register struct backtrace
*backlist
= backtrace_list
;
2221 extern Lisp_Object Vprint_level
;
2222 struct gcpro gcpro1
;
2224 XFASTINT (Vprint_level
) = 3;
2231 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
2232 if (backlist
->nargs
== UNEVALLED
)
2234 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
2238 tem
= *backlist
->function
;
2239 Fprin1 (tem
, Qnil
); /* This can QUIT */
2240 write_string ("(", -1);
2241 if (backlist
->nargs
== MANY
)
2243 for (tail
= *backlist
->args
, i
= 0;
2245 tail
= Fcdr (tail
), i
++)
2247 if (i
) write_string (" ", -1);
2248 Fprin1 (Fcar (tail
), Qnil
);
2253 for (i
= 0; i
< backlist
->nargs
; i
++)
2255 if (i
) write_string (" ", -1);
2256 Fprin1 (backlist
->args
[i
], Qnil
);
2260 write_string (")\n", -1);
2261 backlist
= backlist
->next
;
2264 Vprint_level
= Qnil
;
2269 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, "",
2270 "Return the function and arguments N frames up from current execution point.\n\
2271 If that frame has not evaluated the arguments yet (or is a special form),\n\
2272 the value is (nil FUNCTION ARG-FORMS...).\n\
2273 If that frame has evaluated its arguments and called its function already,\n\
2274 the value is (t FUNCTION ARG-VALUES...).\n\
2275 A &rest arg is represented as the tail of the list ARG-VALUES.\n\
2276 FUNCTION is whatever was supplied as car of evaluated list,\n\
2277 or a lambda expression for macro calls.\n\
2278 If N is more than the number of frames, the value is nil.")
2280 Lisp_Object nframes
;
2282 register struct backtrace
*backlist
= backtrace_list
;
2286 CHECK_NATNUM (nframes
, 0);
2288 /* Find the frame requested. */
2289 for (i
= 0; i
< XFASTINT (nframes
); i
++)
2290 backlist
= backlist
->next
;
2294 if (backlist
->nargs
== UNEVALLED
)
2295 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
2298 if (backlist
->nargs
== MANY
)
2299 tem
= *backlist
->args
;
2301 tem
= Flist (backlist
->nargs
, backlist
->args
);
2303 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
2309 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
2310 "Limit on number of Lisp variable bindings & unwind-protects before error.");
2312 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
2313 "Limit on depth in `eval', `apply' and `funcall' before error.\n\
2314 This limit is to catch infinite recursions for you before they cause\n\
2315 actual stack overflow in C, which would be fatal for Emacs.\n\
2316 You can safely make it considerably larger than its default value,\n\
2317 if that proves inconveniently small.");
2319 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
2320 "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
2321 Typing C-G sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
2324 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
2325 "Non-nil inhibits C-g quitting from happening immediately.\n\
2326 Note that `quit-flag' will still be set by typing C-g,\n\
2327 so a quit will be signalled as soon as `inhibit-quit' is nil.\n\
2328 To prevent this happening, set `quit-flag' to nil\n\
2329 before making `inhibit-quit' nil.");
2330 Vinhibit_quit
= Qnil
;
2332 Qinhibit_quit
= intern ("inhibit-quit");
2333 staticpro (&Qinhibit_quit
);
2335 Qautoload
= intern ("autoload");
2336 staticpro (&Qautoload
);
2338 Qdebug_on_error
= intern ("debug-on-error");
2339 staticpro (&Qdebug_on_error
);
2341 Qmacro
= intern ("macro");
2342 staticpro (&Qmacro
);
2344 /* Note that the process handling also uses Qexit, but we don't want
2345 to staticpro it twice, so we just do it here. */
2346 Qexit
= intern ("exit");
2349 Qinteractive
= intern ("interactive");
2350 staticpro (&Qinteractive
);
2352 Qcommandp
= intern ("commandp");
2353 staticpro (&Qcommandp
);
2355 Qdefun
= intern ("defun");
2356 staticpro (&Qdefun
);
2358 Qand_rest
= intern ("&rest");
2359 staticpro (&Qand_rest
);
2361 Qand_optional
= intern ("&optional");
2362 staticpro (&Qand_optional
);
2364 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
2365 "*Non-nil means automatically display a backtrace buffer\n\
2366 after any error that is handled by the editor command loop.\n\
2367 If the value is a list, an error only means to display a backtrace\n\
2368 if one of its condition symbols appears in the list.");
2369 Vstack_trace_on_error
= Qnil
;
2371 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
2372 "*Non-nil means enter debugger if an error is signaled.\n\
2373 Does not apply to errors handled by `condition-case'.\n\
2374 If the value is a list, an error only means to enter the debugger\n\
2375 if one of its condition symbols appears in the list.\n\
2376 See also variable `debug-on-quit'.");
2377 Vdebug_on_error
= Qnil
;
2379 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
2380 "*Non-nil means enter debugger if quit is signaled (C-G, for example).\n\
2381 Does not apply if quit is handled by a `condition-case'.");
2384 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
2385 "Non-nil means enter debugger before next `eval', `apply' or `funcall'.");
2387 DEFVAR_LISP ("debugger", &Vdebugger
,
2388 "Function to call to invoke debugger.\n\
2389 If due to frame exit, args are `exit' and the value being returned;\n\
2390 this function's value will be returned instead of that.\n\
2391 If due to error, args are `error' and a list of the args to `signal'.\n\
2392 If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
2393 If due to `eval' entry, one arg, t.");
2396 Qmocklisp_arguments
= intern ("mocklisp-arguments");
2397 staticpro (&Qmocklisp_arguments
);
2398 DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments
,
2399 "While in a mocklisp function, the list of its unevaluated args.");
2400 Vmocklisp_arguments
= Qt
;
2402 DEFVAR_LISP ("run-hooks", &Vrun_hooks
,
2403 "Set to the function `run-hooks', if that function has been defined.\n\
2404 Otherwise, nil (in a bare Emacs without preloaded Lisp code).");
2407 staticpro (&Vautoload_queue
);
2408 Vautoload_queue
= Qnil
;
2419 defsubr (&Sfunction
);
2421 defsubr (&Sdefmacro
);
2423 defsubr (&Sdefconst
);
2424 defsubr (&Suser_variable_p
);
2428 defsubr (&Smacroexpand
);
2431 defsubr (&Sunwind_protect
);
2432 defsubr (&Scondition_case
);
2434 defsubr (&Sinteractive_p
);
2435 defsubr (&Scommandp
);
2436 defsubr (&Sautoload
);
2439 defsubr (&Sfuncall
);
2440 defsubr (&Sbacktrace_debug
);
2441 defsubr (&Sbacktrace
);
2442 defsubr (&Sbacktrace_frame
);