1 /* Evaluator for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1987 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. */
35 /* This definition is duplicated in alloc.c and keyboard.c */
36 /* Putting it in lisp.h makes cc bomb out! */
40 struct backtrace
*next
;
41 Lisp_Object
*function
;
42 Lisp_Object
*args
; /* Points to vector of args. */
43 int nargs
; /* length of vector */
44 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
46 /* Nonzero means call value of debugger when done with this operation. */
50 struct backtrace
*backtrace_list
;
56 struct catchtag
*next
;
59 struct backtrace
*backlist
;
60 struct handler
*handlerlist
;
63 int poll_suppress_count
;
66 struct catchtag
*catchlist
;
68 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
69 Lisp_Object Qinhibit_quit
, Vinhibit_quit
, Vquit_flag
;
70 Lisp_Object Qmocklisp_arguments
, Vmocklisp_arguments
, Qmocklisp
;
71 Lisp_Object Qand_rest
, Qand_optional
;
72 Lisp_Object Qdebug_on_error
;
74 Lisp_Object Vrun_hooks
;
76 /* Non-nil means record all fset's and provide's, to be undone
77 if the file being autoloaded is not fully loaded.
78 They are recorded by being consed onto the front of Vautoload_queue:
79 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */
81 Lisp_Object Vautoload_queue
;
83 /* Current number of specbindings allocated in specpdl. */
86 /* Pointer to beginning of specpdl. */
87 struct specbinding
*specpdl
;
89 /* Pointer to first unused element in specpdl. */
90 struct specbinding
*specpdl_ptr
;
92 /* Maximum size allowed for specpdl allocation */
95 /* Depth in Lisp evaluations and function calls. */
98 /* Maximum allowed depth in Lisp evaluations and function calls. */
99 int max_lisp_eval_depth
;
101 /* Nonzero means enter debugger before next function call */
102 int debug_on_next_call
;
104 /* Nonzero means display a backtrace if an error
105 is handled by the command loop's error handler. */
106 int stack_trace_on_error
;
108 /* Nonzero means enter debugger if an error
109 is handled by the command loop's error handler. */
112 /* Nonzero means enter debugger if a quit signal
113 is handled by the command loop's error handler. */
116 /* Nonzero means we are trying to enter the debugger.
117 This is to prevent recursive attempts. */
118 int entering_debugger
;
120 Lisp_Object Vdebugger
;
122 void specbind (), record_unwind_protect ();
124 Lisp_Object
funcall_lambda ();
125 extern Lisp_Object
ml_apply (); /* Apply a mocklisp function to unevaluated argument list */
130 specpdl
= (struct specbinding
*) malloc (specpdl_size
* sizeof (struct specbinding
));
131 max_specpdl_size
= 600;
132 max_lisp_eval_depth
= 200;
137 specpdl_ptr
= specpdl
;
142 debug_on_next_call
= 0;
144 entering_debugger
= 0;
151 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
152 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
153 if (specpdl_size
+ 40 > max_specpdl_size
)
154 max_specpdl_size
= specpdl_size
+ 40;
155 debug_on_next_call
= 0;
156 entering_debugger
= 1;
157 return apply1 (Vdebugger
, arg
);
160 do_debug_on_call (code
)
163 debug_on_next_call
= 0;
164 backtrace_list
->debug_on_exit
= 1;
165 call_debugger (Fcons (code
, Qnil
));
168 /* NOTE!!! Every function that can call EVAL must protect its args
169 and temporaries from garbage collection while it needs them.
170 The definition of `For' shows what you have to do. */
172 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
173 "Eval args until one of them yields non-nil, then return that value.\n\
174 The remaining args are not evalled at all.\n\
175 If all args return nil, return nil.")
179 register Lisp_Object val
;
180 Lisp_Object args_left
;
191 val
= Feval (Fcar (args_left
));
194 args_left
= Fcdr (args_left
);
196 while (!NULL(args_left
));
202 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
203 "Eval args until one of them yields nil, then return nil.\n\
204 The remaining args are not evalled at all.\n\
205 If no arg yields nil, return the last arg's value.")
209 register Lisp_Object val
;
210 Lisp_Object args_left
;
221 val
= Feval (Fcar (args_left
));
224 args_left
= Fcdr (args_left
);
226 while (!NULL(args_left
));
232 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
233 "(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...\n\
234 Returns the value of THEN or the value of the last of the ELSE's.\n\
235 THEN must be one expression, but ELSE... can be zero or more expressions.\n\
236 If COND yields nil, and there are no ELSE's, the value is nil.")
240 register Lisp_Object cond
;
244 cond
= Feval (Fcar (args
));
248 return Feval (Fcar (Fcdr (args
)));
249 return Fprogn (Fcdr (Fcdr (args
)));
252 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
253 "(cond CLAUSES...): try each clause until one succeeds.\n\
254 Each clause looks like (CONDITION BODY...). CONDITION is evaluated\n\
255 and, if the value is non-nil, this clause succeeds:\n\
256 then the expressions in BODY are evaluated and the last one's\n\
257 value is the value of the cond-form.\n\
258 If no clause succeeds, cond returns nil.\n\
259 If a clause has one element, as in (CONDITION),\n\
260 CONDITION's value if non-nil is returned from the cond-form.")
264 register Lisp_Object clause
, val
;
271 clause
= Fcar (args
);
272 val
= Feval (Fcar (clause
));
275 if (!EQ (XCONS (clause
)->cdr
, Qnil
))
276 val
= Fprogn (XCONS (clause
)->cdr
);
279 args
= XCONS (args
)->cdr
;
286 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
287 "(progn BODY...): eval BODY forms sequentially and return value of last one.")
291 register Lisp_Object val
, tem
;
292 Lisp_Object args_left
;
295 /* In Mocklisp code, symbols at the front of the progn arglist
296 are to be bound to zero. */
297 if (!EQ (Vmocklisp_arguments
, Qt
))
299 val
= make_number (0);
300 while (!NULL (args
) && (tem
= Fcar (args
), XTYPE (tem
) == Lisp_Symbol
))
303 specbind (tem
, val
), args
= Fcdr (args
);
315 val
= Feval (Fcar (args_left
));
316 args_left
= Fcdr (args_left
);
318 while (!NULL(args_left
));
324 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
325 "(prog1 FIRST BODY...): eval FIRST and BODY sequentially; value from FIRST.\n\
326 The value of FIRST is saved during the evaluation of the remaining args,\n\
327 whose values are discarded.")
332 register Lisp_Object args_left
;
333 struct gcpro gcpro1
, gcpro2
;
334 register int argnum
= 0;
346 val
= Feval (Fcar (args_left
));
348 Feval (Fcar (args_left
));
349 args_left
= Fcdr (args_left
);
351 while (!NULL(args_left
));
357 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
358 "(prog1 X Y BODY...): eval X, Y and BODY sequentially; value from Y.\n\
359 The value of Y is saved during the evaluation of the remaining args,\n\
360 whose values are discarded.")
365 register Lisp_Object args_left
;
366 struct gcpro gcpro1
, gcpro2
;
367 register int argnum
= -1;
381 val
= Feval (Fcar (args_left
));
383 Feval (Fcar (args_left
));
384 args_left
= Fcdr (args_left
);
386 while (!NULL(args_left
));
392 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
393 "(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.\n\
394 The SYMs are not evaluated. Thus (setq x y) sets x to the value of y.\n\
395 Each SYM is set before the next VAL is computed.")
399 register Lisp_Object args_left
;
400 register Lisp_Object val
, sym
;
411 val
= Feval (Fcar (Fcdr (args_left
)));
412 sym
= Fcar (args_left
);
414 args_left
= Fcdr (Fcdr (args_left
));
416 while (!NULL(args_left
));
422 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
423 "Return the argument, without evaluating it. `(quote x)' yields `x'.")
430 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
431 "Like `quote', but preferred for objects which are functions.\n\
432 In byte compilation, `function' causes its argument to be compiled.\n\
433 `quote' cannot do that.")
440 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
441 "Return t if function in which this appears was called interactively.\n\
442 This means that the function was called with call-interactively (which\n\
443 includes being called as the binding of a key)\n\
444 and input is currently coming from the keyboard (not in keyboard macro).")
447 register struct backtrace
*btp
;
448 register Lisp_Object fun
;
453 /* Unless the object was compiled, skip the frame of interactive-p itself
454 (if interpreted) or the frame of byte-code (if called from
455 compiled function). */
456 btp
= backtrace_list
;
457 if (XTYPE (*btp
->function
) != Lisp_Compiled
)
460 && (btp
->nargs
== UNEVALLED
|| EQ (*btp
->function
, Qbytecode
)))
463 /* btp now points at the frame of the innermost function
464 that DOES eval its args.
465 If it is a built-in function (such as load or eval-region)
467 fun
= *btp
->function
;
468 while (XTYPE (fun
) == Lisp_Symbol
)
471 fun
= Fsymbol_function (fun
);
473 if (XTYPE (fun
) == Lisp_Subr
)
475 /* btp points to the frame of a Lisp function that called interactive-p.
476 Return t if that function was called interactively. */
477 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
482 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
483 "(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.\n\
484 The definition is (lambda ARGLIST [DOCSTRING] BODY...).\n\
485 See also the function `interactive'.")
489 register Lisp_Object fn_name
;
490 register Lisp_Object defn
;
492 fn_name
= Fcar (args
);
493 defn
= Fcons (Qlambda
, Fcdr (args
));
494 if (!NULL (Vpurify_flag
))
495 defn
= Fpurecopy (defn
);
496 Ffset (fn_name
, defn
);
500 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
501 "(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.\n\
502 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).\n\
503 When the macro is called, as in (NAME ARGS...),\n\
504 the function (lambda ARGLIST BODY...) is applied to\n\
505 the list ARGS... as it appears in the expression,\n\
506 and the result should be a form to be evaluated instead of the original.")
510 register Lisp_Object fn_name
;
511 register Lisp_Object defn
;
513 fn_name
= Fcar (args
);
514 defn
= Fcons (Qmacro
, Fcons (Qlambda
, Fcdr (args
)));
515 if (!NULL (Vpurify_flag
))
516 defn
= Fpurecopy (defn
);
517 Ffset (fn_name
, defn
);
521 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
522 "(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.\n\
523 You are not required to define a variable in order to use it,\n\
524 but the definition can supply documentation and an initial value\n\
525 in a way that tags can recognize.\n\n\
526 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.\n\
527 If SYMBOL is buffer-local, its default value is initialized in this way.\n\
528 INITVALUE and DOCSTRING are optional.\n\
529 If DOCSTRING starts with *, this variable is identified as a user option.\n\
530 This means that M-x set-variable and M-x edit-options recognize it.\n\
531 If INITVALUE is missing, SYMBOL's value is not set.")
535 register Lisp_Object sym
, tem
;
541 tem
= Fdefault_boundp (sym
);
543 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
545 tem
= Fcar (Fcdr (Fcdr (args
)));
548 if (!NULL (Vpurify_flag
))
549 tem
= Fpurecopy (tem
);
550 Fput (sym
, Qvariable_documentation
, tem
);
555 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
556 "(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant variable.\n\
557 The intent is that programs do not change this value, but users may.\n\
558 Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\
559 If SYMBOL is buffer-local, its default value is initialized in this way.\n\
560 DOCSTRING is optional.\n\
561 If DOCSTRING starts with *, this variable is identified as a user option.\n\
562 This means that M-x set-variable and M-x edit-options recognize it.\n\n\
563 Note: do not use `defconst' for user options in libraries that are not\n\
564 normally loaded, since it is useful for users to be able to specify\n\
565 their own values for such variables before loading the library.\n\
566 Since `defconst' unconditionally assigns the variable,\n\
567 it would override the user's choice.")
571 register Lisp_Object sym
, tem
;
574 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
575 tem
= Fcar (Fcdr (Fcdr (args
)));
578 if (!NULL (Vpurify_flag
))
579 tem
= Fpurecopy (tem
);
580 Fput (sym
, Qvariable_documentation
, tem
);
585 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
586 "Returns t if VARIABLE is intended to be set and modified by users.\n\
587 \(The alternative is a variable used internally in a Lisp program.)\n\
588 Determined by whether the first character of the documentation\n\
589 for the variable is \"*\"")
591 Lisp_Object variable
;
593 Lisp_Object documentation
;
595 documentation
= Fget (variable
, Qvariable_documentation
);
596 if (XTYPE (documentation
) == Lisp_Int
&& XINT (documentation
) < 0)
598 if ((XTYPE (documentation
) == Lisp_String
) &&
599 ((unsigned char) XSTRING (documentation
)->data
[0] == '*'))
604 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
605 "(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
606 The value of the last form in BODY is returned.\n\
607 Each element of VARLIST is a symbol (which is bound to nil)\n\
608 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
609 Each VALUEFORM can refer to the symbols already bound by this VARLIST.")
613 Lisp_Object varlist
, val
, elt
;
614 int count
= specpdl_ptr
- specpdl
;
615 struct gcpro gcpro1
, gcpro2
, gcpro3
;
617 GCPRO3 (args
, elt
, varlist
);
619 varlist
= Fcar (args
);
620 while (!NULL (varlist
))
623 elt
= Fcar (varlist
);
624 if (XTYPE (elt
) == Lisp_Symbol
)
625 specbind (elt
, Qnil
);
628 val
= Feval (Fcar (Fcdr (elt
)));
629 specbind (Fcar (elt
), val
);
631 varlist
= Fcdr (varlist
);
634 val
= Fprogn (Fcdr (args
));
635 return unbind_to (count
, val
);
638 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
639 "(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
640 The value of the last form in BODY is returned.\n\
641 Each element of VARLIST is a symbol (which is bound to nil)\n\
642 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
643 All the VALUEFORMs are evalled before any symbols are bound.")
647 Lisp_Object
*temps
, tem
;
648 register Lisp_Object elt
, varlist
;
649 int count
= specpdl_ptr
- specpdl
;
651 struct gcpro gcpro1
, gcpro2
;
653 varlist
= Fcar (args
);
655 /* Make space to hold the values to give the bound variables */
656 elt
= Flength (varlist
);
657 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
659 /* Compute the values and store them in `temps' */
661 GCPRO2 (args
, *temps
);
664 for (argnum
= 0; !NULL (varlist
); varlist
= Fcdr (varlist
))
667 elt
= Fcar (varlist
);
668 if (XTYPE (elt
) == Lisp_Symbol
)
669 temps
[argnum
++] = Qnil
;
671 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
672 gcpro2
.nvars
= argnum
;
676 varlist
= Fcar (args
);
677 for (argnum
= 0; !NULL (varlist
); varlist
= Fcdr (varlist
))
679 elt
= Fcar (varlist
);
680 tem
= temps
[argnum
++];
681 if (XTYPE (elt
) == Lisp_Symbol
)
684 specbind (Fcar (elt
), tem
);
687 elt
= Fprogn (Fcdr (args
));
688 return unbind_to (count
, elt
);
691 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
692 "(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.\n\
693 The order of execution is thus TEST, BODY, TEST, BODY and so on\n\
694 until TEST returns nil.")
698 Lisp_Object test
, body
, tem
;
699 struct gcpro gcpro1
, gcpro2
;
705 while (tem
= Feval (test
), !NULL (tem
))
715 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
716 "Return result of expanding macros at top level of FORM.\n\
717 If FORM is not a macro call, it is returned unchanged.\n\
718 Otherwise, the macro is expanded and the expansion is considered\n\
719 in place of FORM. When a non-macro-call results, it is returned.\n\n\
720 The second optional arg ENVIRONMENT species an environment of macro\n\
721 definitions to shadow the loaded ones for use in file byte-compilation.")
723 register Lisp_Object form
;
726 register Lisp_Object expander
, sym
, def
, tem
;
730 /* Come back here each time we expand a macro call,
731 in case it expands into another macro call. */
732 if (XTYPE (form
) != Lisp_Cons
)
734 sym
= XCONS (form
)->car
;
735 /* Detect ((macro lambda ...) ...) */
736 if (XTYPE (sym
) == Lisp_Cons
737 && EQ (XCONS (sym
)->car
, Qmacro
))
739 expander
= XCONS (sym
)->cdr
;
742 if (XTYPE (sym
) != Lisp_Symbol
)
744 /* Trace symbols aliases to other symbols
745 until we get a symbol that is not an alias. */
749 tem
= Fassq (sym
, env
);
752 def
= XSYMBOL (sym
)->function
;
753 if (XTYPE (def
) == Lisp_Symbol
&& !EQ (def
, Qunbound
))
760 #if 0 /* This is turned off because it caused an element (foo . bar)
761 to have the effect of defining foo as an alias for the macro bar.
762 That is inconsistent; bar should be a function to expand foo. */
763 if (XTYPE (tem
) == Lisp_Cons
764 && XTYPE (XCONS (tem
)->cdr
) == Lisp_Symbol
)
765 sym
= XCONS (tem
)->cdr
;
771 /* Right now TEM is the result from SYM in ENV,
772 and if TEM is nil then DEF is SYM's function definition. */
775 /* SYM is not mentioned in ENV.
776 Look at its function definition. */
777 if (EQ (def
, Qunbound
)
778 || XTYPE (def
) != Lisp_Cons
)
779 /* Not defined or definition not suitable */
781 if (EQ (XCONS (def
)->car
, Qautoload
))
783 /* Autoloading function: will it be a macro when loaded? */
784 tem
= Fcar (Fnthcdr (make_number (4), def
));
787 /* Yes, load it and try again. */
788 do_autoload (def
, sym
);
791 else if (!EQ (XCONS (def
)->car
, Qmacro
))
793 else expander
= XCONS (def
)->cdr
;
797 expander
= XCONS (tem
)->cdr
;
802 form
= apply1 (expander
, XCONS (form
)->cdr
);
807 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
808 "(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.\n\
809 TAG is evalled to get the tag to use. Then the BODY is executed.\n\
810 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.\n\
811 If no throw happens, `catch' returns the value of the last BODY form.\n\
812 If a throw happens, it specifies the value to return from `catch'.")
816 register Lisp_Object tag
;
820 tag
= Feval (Fcar (args
));
822 return internal_catch (tag
, Fprogn
, Fcdr (args
));
825 /* Set up a catch, then call C function FUNC on argument ARG.
826 FUNC should return a Lisp_Object.
827 This is how catches are done from within C code. */
830 internal_catch (tag
, func
, arg
)
832 Lisp_Object (*func
) ();
835 /* This structure is made part of the chain `catchlist'. */
838 /* Fill in the components of c, and put it on the list. */
842 c
.backlist
= backtrace_list
;
843 c
.handlerlist
= handlerlist
;
844 c
.lisp_eval_depth
= lisp_eval_depth
;
845 c
.pdlcount
= specpdl_ptr
- specpdl
;
846 c
.poll_suppress_count
= poll_suppress_count
;
851 if (! _setjmp (c
.jmp
))
852 c
.val
= (*func
) (arg
);
854 /* Throw works by a longjmp that comes right here. */
859 /* Discard from the catchlist all catch tags back through CATCH.
860 Before each catch is discarded, unbind all special bindings
861 made within that catch. Also, when discarding a catch that
862 corresponds to a condition handler, discard that handler.
864 At the end, restore some static info saved in CATCH.
866 This is used for correct unwinding in Fthrow and Fsignal,
867 before doing the longjmp that actually destroys the stack frames
868 in which these handlers and catches reside. */
872 struct catchtag
*catch;
874 register int last_time
;
878 last_time
= catchlist
== catch;
879 unbind_to (catchlist
->pdlcount
, Qnil
);
880 handlerlist
= catchlist
->handlerlist
;
881 catchlist
= catchlist
->next
;
885 gcprolist
= catch->gcpro
;
886 backtrace_list
= catch->backlist
;
887 lisp_eval_depth
= catch->lisp_eval_depth
;
890 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
891 "(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.\n\
892 Both TAG and VALUE are evalled.")
894 register Lisp_Object tag
, val
;
896 register struct catchtag
*c
;
901 for (c
= catchlist
; c
; c
= c
->next
)
903 if (EQ (c
->tag
, tag
))
905 /* Restore the polling-suppression count. */
906 if (c
->poll_suppress_count
> poll_suppress_count
)
908 while (c
->poll_suppress_count
< poll_suppress_count
)
912 _longjmp (c
->jmp
, 1);
915 tag
= Fsignal (Qno_catch
, Fcons (tag
, Fcons (val
, Qnil
)));
920 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
921 "Do BODYFORM, protecting with UNWINDFORMS.\n\
922 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).\n\
923 If BODYFORM completes normally, its value is returned\n\
924 after executing the UNWINDFORMS.\n\
925 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.")
930 int count
= specpdl_ptr
- specpdl
;
932 record_unwind_protect (0, Fcdr (args
));
933 val
= Feval (Fcar (args
));
934 return unbind_to (count
, val
);
937 /* Chain of condition handlers currently in effect.
938 The elements of this chain are contained in the stack frames
939 of Fcondition_case and internal_condition_case.
940 When an error is signaled (by calling Fsignal, below),
941 this chain is searched for an element that applies. */
943 struct handler
*handlerlist
;
945 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
946 "Regain control when an error is signaled.\n\
947 Usage looks like (condition-case VAR BODYFORM HANDLERS...).\n\
948 executes BODYFORM and returns its value if no error happens.\n\
949 Each element of HANDLERS looks like (CONDITION-NAME BODY...)\n\
950 where the BODY is made of Lisp expressions.\n\n\
951 A handler is applicable to an error\n\
952 if CONDITION-NAME is one of the error's condition names.\n\
953 If an error happens, the first applicable handler is run.\n\
955 When a handler handles an error,\n\
956 control returns to the condition-case and the handler BODY... is executed\n\
957 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\
958 VAR may be nil; then you do not get access to the signal information.\n\
960 The value of the last BODY form is returned from the condition-case.\n\
961 See also the function `signal' for more info.")
968 register Lisp_Object tem
;
971 CHECK_SYMBOL (tem
, 0);
975 c
.backlist
= backtrace_list
;
976 c
.handlerlist
= handlerlist
;
977 c
.lisp_eval_depth
= lisp_eval_depth
;
978 c
.pdlcount
= specpdl_ptr
- specpdl
;
979 c
.poll_suppress_count
= poll_suppress_count
;
984 specbind (h
.var
, Fcdr (c
.val
));
985 val
= Fprogn (Fcdr (Fcar (c
.val
)));
986 unbind_to (c
.pdlcount
, Qnil
);
992 h
.handler
= Fcdr (Fcdr (args
));
994 for (val
= h
.handler
; ! NULL (val
); val
= Fcdr (val
))
998 (!CONSP (tem
) || (XTYPE (XCONS (tem
)->car
) != Lisp_Symbol
)))
999 error ("Invalid condition handler", tem
);
1002 h
.next
= handlerlist
;
1003 h
.poll_suppress_count
= poll_suppress_count
;
1007 val
= Feval (Fcar (Fcdr (args
)));
1009 handlerlist
= h
.next
;
1014 internal_condition_case (bfun
, handlers
, hfun
)
1015 Lisp_Object (*bfun
) ();
1016 Lisp_Object handlers
;
1017 Lisp_Object (*hfun
) ();
1025 c
.backlist
= backtrace_list
;
1026 c
.handlerlist
= handlerlist
;
1027 c
.lisp_eval_depth
= lisp_eval_depth
;
1028 c
.pdlcount
= specpdl_ptr
- specpdl
;
1029 c
.poll_suppress_count
= poll_suppress_count
;
1030 c
.gcpro
= gcprolist
;
1031 if (_setjmp (c
.jmp
))
1033 return (*hfun
) (Fcdr (c
.val
));
1037 h
.handler
= handlers
;
1039 h
.poll_suppress_count
= poll_suppress_count
;
1040 h
.next
= handlerlist
;
1046 handlerlist
= h
.next
;
1050 static Lisp_Object
find_handler_clause ();
1052 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1053 "Signal an error. Args are SIGNAL-NAME, and associated DATA.\n\
1054 This function does not return.\n\n\
1055 A signal name is a symbol with an `error-conditions' property\n\
1056 that is a list of condition names.\n\
1057 A handler for any of those names will get to handle this signal.\n\
1058 The symbol `error' should normally be one of them.\n\
1060 DATA should be a list. Its elements are printed as part of the error message.\n\
1061 If the signal is handled, DATA is made available to the handler.\n\
1062 See also the function `condition-case'.")
1064 Lisp_Object sig
, data
;
1066 register struct handler
*allhandlers
= handlerlist
;
1067 Lisp_Object conditions
;
1068 extern int gc_in_progress
;
1069 extern int waiting_for_input
;
1070 Lisp_Object debugger_value
;
1072 quit_error_check ();
1074 if (gc_in_progress
|| waiting_for_input
)
1077 TOTALLY_UNBLOCK_INPUT
;
1079 conditions
= Fget (sig
, Qerror_conditions
);
1081 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1083 register Lisp_Object clause
;
1084 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1085 sig
, data
, &debugger_value
);
1087 #if 0 /* Most callers are not prepared to handle gc if this returns.
1088 So, since this feature is not very useful, take it out. */
1089 /* If have called debugger and user wants to continue,
1091 if (EQ (clause
, Qlambda
))
1092 return debugger_value
;
1094 if (EQ (clause
, Qlambda
))
1095 error ("Returning a value from an error is no longer supported");
1100 struct handler
*h
= handlerlist
;
1101 /* Restore the polling-suppression count. */
1102 if (h
->poll_suppress_count
> poll_suppress_count
)
1104 while (h
->poll_suppress_count
< poll_suppress_count
)
1106 handlerlist
= allhandlers
;
1107 unbind_catch (h
->tag
);
1108 h
->tag
->val
= Fcons (clause
, Fcons (sig
, data
));
1109 _longjmp (h
->tag
->jmp
, 1);
1113 handlerlist
= allhandlers
;
1114 /* If no handler is present now, try to run the debugger,
1115 and if that fails, throw to top level. */
1116 find_handler_clause (Qerror
, conditions
, sig
, data
, &debugger_value
);
1117 Fthrow (Qtop_level
, Qt
);
1120 /* Value of Qlambda means we have called debugger and
1121 user has continued. Store value returned fromdebugger
1122 into *debugger_value_ptr */
1125 find_handler_clause (handlers
, conditions
, sig
, data
, debugger_value_ptr
)
1126 Lisp_Object handlers
, conditions
, sig
, data
;
1127 Lisp_Object
*debugger_value_ptr
;
1129 register Lisp_Object h
;
1130 register Lisp_Object tem
;
1131 register Lisp_Object tem1
;
1133 if (EQ (handlers
, Qt
)) /* t is used by handlers for all conditions, set up by C code. */
1135 if (EQ (handlers
, Qerror
)) /* error is used similarly, but means display a backtrace too */
1137 if (stack_trace_on_error
)
1138 internal_with_output_to_temp_buffer ("*Backtrace*", Fbacktrace
, Qnil
);
1139 if (!entering_debugger
1140 && EQ (sig
, Qquit
) ? debug_on_quit
: debug_on_error
)
1142 int count
= specpdl_ptr
- specpdl
;
1143 specbind (Qdebug_on_error
, Qnil
);
1144 *debugger_value_ptr
=
1145 call_debugger (Fcons (Qerror
,
1146 Fcons (Fcons (sig
, data
),
1148 return unbind_to (count
, Qlambda
);
1152 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1157 tem
= Fmemq (Fcar (tem1
), conditions
);
1164 /* dump an error message; called like printf */
1168 error (m
, a1
, a2
, a3
)
1172 sprintf (buf
, m
, a1
, a2
, a3
);
1175 Fsignal (Qerror
, Fcons (build_string (buf
), Qnil
));
1178 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 1, 0,
1179 "T if FUNCTION makes provisions for interactive calling.\n\
1180 This means it contains a description for how to read arguments to give it.\n\
1181 The value is nil for an invalid function or a symbol with no function\n\
1184 Interactively callable functions include strings and vectors (treated\n\
1185 as keyboard macros), lambda-expressions that contain a top-level call\n\
1186 to `interactive', autoload definitions made by `autoload' with non-nil\n\
1187 fourth argument, and some of the built-in functions of Lisp.\n\
1189 Also, a symbol satisfies `commandp' if its function definition does so.")
1191 Lisp_Object function
;
1193 register Lisp_Object fun
;
1194 register Lisp_Object funcar
;
1195 register Lisp_Object tem
;
1200 /* Dereference symbols, but avoid infinte loops. Eech. */
1201 while (XTYPE (fun
) == Lisp_Symbol
)
1203 if (++i
> 10) return Qnil
;
1204 tem
= Ffboundp (fun
);
1205 if (NULL (tem
)) return Qnil
;
1206 fun
= Fsymbol_function (fun
);
1209 /* Emacs primitives are interactive if their DEFUN specifies an
1210 interactive spec. */
1211 if (XTYPE (fun
) == Lisp_Subr
)
1213 if (XSUBR (fun
)->prompt
)
1219 /* Bytecode objects are interactive if they are long enough to
1220 have an element whose index is COMPILED_INTERACTIVE, which is
1221 where the interactive spec is stored. */
1222 else if (XTYPE (fun
) == Lisp_Compiled
)
1223 return (XVECTOR (fun
)->size
> COMPILED_INTERACTIVE
1226 /* Strings and vectors are keyboard macros. */
1227 if (XTYPE (fun
) == Lisp_String
1228 || XTYPE (fun
) == Lisp_Vector
)
1231 /* Lists may represent commands. */
1234 funcar
= Fcar (fun
);
1235 if (XTYPE (funcar
) != Lisp_Symbol
)
1236 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1237 if (EQ (funcar
, Qlambda
))
1238 return Fassq (Qinteractive
, Fcdr (Fcdr (fun
)));
1239 if (EQ (funcar
, Qmocklisp
))
1240 return Qt
; /* All mocklisp functions can be called interactively */
1241 if (EQ (funcar
, Qautoload
))
1242 return Fcar (Fcdr (Fcdr (Fcdr (fun
))));
1248 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1249 "Define FUNCTION to autoload from FILE.\n\
1250 FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\
1251 Third arg DOCSTRING is documentation for the function.\n\
1252 Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\
1253 Fifth arg MACRO if non-nil says the function is really a macro.\n\
1254 Third through fifth args give info about the real definition.\n\
1255 They default to nil.\n\
1256 If FUNCTION is already defined other than as an autoload,\n\
1257 this does nothing and returns nil.")
1258 (function
, file
, docstring
, interactive
, macro
)
1259 Lisp_Object function
, file
, docstring
, interactive
, macro
;
1262 Lisp_Object args
[4];
1265 CHECK_SYMBOL (function
, 0);
1266 CHECK_STRING (file
, 1);
1268 /* If function is defined and not as an autoload, don't override */
1269 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
1270 && !(XTYPE (XSYMBOL (function
)->function
) == Lisp_Cons
1271 && EQ (XCONS (XSYMBOL (function
)->function
)->car
, Qautoload
)))
1276 args
[1] = docstring
;
1277 args
[2] = interactive
;
1280 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
1281 #else /* NO_ARG_ARRAY */
1282 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
1283 #endif /* not NO_ARG_ARRAY */
1287 un_autoload (oldqueue
)
1288 Lisp_Object oldqueue
;
1290 register Lisp_Object queue
, first
, second
;
1292 /* Queue to unwind is current value of Vautoload_queue.
1293 oldqueue is the shadowed value to leave in Vautoload_queue. */
1294 queue
= Vautoload_queue
;
1295 Vautoload_queue
= oldqueue
;
1296 while (CONSP (queue
))
1298 first
= Fcar (queue
);
1299 second
= Fcdr (first
);
1300 first
= Fcar (first
);
1301 if (EQ (second
, Qnil
))
1304 Ffset (first
, second
);
1305 queue
= Fcdr (queue
);
1310 do_autoload (fundef
, funname
)
1311 Lisp_Object fundef
, funname
;
1313 int count
= specpdl_ptr
- specpdl
;
1314 Lisp_Object fun
, val
;
1317 CHECK_SYMBOL (funname
, 0);
1319 /* Value saved here is to be restored into Vautoload_queue */
1320 record_unwind_protect (un_autoload
, Vautoload_queue
);
1321 Vautoload_queue
= Qt
;
1322 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
);
1323 /* Once loading finishes, don't undo it. */
1324 Vautoload_queue
= Qt
;
1325 unbind_to (count
, Qnil
);
1327 while (XTYPE (fun
) == Lisp_Symbol
)
1330 val
= XSYMBOL (fun
)->function
;
1331 if (EQ (val
, Qunbound
))
1332 Fsymbol_function (fun
); /* Get the right kind of error! */
1335 if (XTYPE (fun
) == Lisp_Cons
1336 && EQ (XCONS (fun
)->car
, Qautoload
))
1337 error ("Autoloading failed to define function %s",
1338 XSYMBOL (funname
)->name
->data
);
1341 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
1342 "Evaluate FORM and return its value.")
1346 Lisp_Object fun
, val
, original_fun
, original_args
;
1348 struct backtrace backtrace
;
1349 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1351 if (XTYPE (form
) == Lisp_Symbol
)
1353 if (EQ (Vmocklisp_arguments
, Qt
))
1354 return Fsymbol_value (form
);
1355 val
= Fsymbol_value (form
);
1358 else if (EQ (val
, Qt
))
1366 if (consing_since_gc
> gc_cons_threshold
)
1369 Fgarbage_collect ();
1373 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1375 if (max_lisp_eval_depth
< 100)
1376 max_lisp_eval_depth
= 100;
1377 if (lisp_eval_depth
> max_lisp_eval_depth
)
1378 error ("Lisp nesting exceeds max-lisp-eval-depth");
1381 original_fun
= Fcar (form
);
1382 original_args
= Fcdr (form
);
1384 backtrace
.next
= backtrace_list
;
1385 backtrace_list
= &backtrace
;
1386 backtrace
.function
= &original_fun
; /* This also protects them from gc */
1387 backtrace
.args
= &original_args
;
1388 backtrace
.nargs
= UNEVALLED
;
1389 backtrace
.evalargs
= 1;
1390 backtrace
.debug_on_exit
= 0;
1392 if (debug_on_next_call
)
1393 do_debug_on_call (Qt
);
1395 /* At this point, only original_fun and original_args
1396 have values that will be used below */
1399 while (XTYPE (fun
) == Lisp_Symbol
)
1402 val
= XSYMBOL (fun
)->function
;
1403 if (EQ (val
, Qunbound
))
1404 Fsymbol_function (fun
); /* Get the right kind of error! */
1408 if (XTYPE (fun
) == Lisp_Subr
)
1410 Lisp_Object numargs
;
1411 Lisp_Object argvals
[7];
1412 Lisp_Object args_left
;
1413 register int i
, maxargs
;
1415 args_left
= original_args
;
1416 numargs
= Flength (args_left
);
1418 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
1419 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
1420 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1422 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1424 backtrace
.evalargs
= 0;
1425 val
= (*XSUBR (fun
)->function
) (args_left
);
1429 if (XSUBR (fun
)->max_args
== MANY
)
1431 /* Pass a vector of evaluated arguments */
1433 register int argnum
= 0;
1435 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1437 GCPRO3 (args_left
, fun
, fun
);
1441 while (!NULL (args_left
))
1443 vals
[argnum
++] = Feval (Fcar (args_left
));
1444 args_left
= Fcdr (args_left
);
1445 gcpro3
.nvars
= argnum
;
1448 backtrace
.args
= vals
;
1449 backtrace
.nargs
= XINT (numargs
);
1451 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
1456 GCPRO3 (args_left
, fun
, fun
);
1457 gcpro3
.var
= argvals
;
1460 maxargs
= XSUBR (fun
)->max_args
;
1461 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
1463 argvals
[i
] = Feval (Fcar (args_left
));
1469 backtrace
.args
= argvals
;
1470 backtrace
.nargs
= XINT (numargs
);
1475 val
= (*XSUBR (fun
)->function
) ();
1478 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
1481 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
1484 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1488 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1489 argvals
[2], argvals
[3]);
1492 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1493 argvals
[3], argvals
[4]);
1496 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1497 argvals
[3], argvals
[4], argvals
[5]);
1501 error ("Ffuncall doesn't handle that number of arguments.");
1505 if (XTYPE (fun
) == Lisp_Compiled
)
1506 val
= apply_lambda (fun
, original_args
, 1);
1510 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1511 funcar
= Fcar (fun
);
1512 if (XTYPE (funcar
) != Lisp_Symbol
)
1513 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1514 if (EQ (funcar
, Qautoload
))
1516 do_autoload (fun
, original_fun
);
1519 if (EQ (funcar
, Qmacro
))
1520 val
= Feval (apply1 (Fcdr (fun
), original_args
));
1521 else if (EQ (funcar
, Qlambda
))
1522 val
= apply_lambda (fun
, original_args
, 1);
1523 else if (EQ (funcar
, Qmocklisp
))
1524 val
= ml_apply (fun
, original_args
);
1526 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1529 if (!EQ (Vmocklisp_arguments
, Qt
))
1533 else if (EQ (val
, Qt
))
1537 if (backtrace
.debug_on_exit
)
1538 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
1539 backtrace_list
= backtrace
.next
;
1543 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
1544 "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
1545 Thus, (apply '+ 1 2 '(3 4)) returns 10.")
1550 register int i
, numargs
;
1551 register Lisp_Object spread_arg
;
1552 register Lisp_Object
*funcall_args
;
1554 struct gcpro gcpro1
;
1558 spread_arg
= args
[nargs
- 1];
1559 CHECK_LIST (spread_arg
, nargs
);
1561 numargs
= XINT (Flength (spread_arg
));
1564 return Ffuncall (nargs
- 1, args
);
1565 else if (numargs
== 1)
1567 args
[nargs
- 1] = XCONS (spread_arg
)->car
;
1568 return Ffuncall (nargs
, args
);
1571 numargs
+= nargs
- 2;
1573 while (XTYPE (fun
) == Lisp_Symbol
)
1576 fun
= XSYMBOL (fun
)->function
;
1577 if (EQ (fun
, Qunbound
))
1579 /* Let funcall get the error */
1585 if (XTYPE (fun
) == Lisp_Subr
)
1587 if (numargs
< XSUBR (fun
)->min_args
1588 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
1589 goto funcall
; /* Let funcall get the error */
1590 else if (XSUBR (fun
)->max_args
> numargs
)
1592 /* Avoid making funcall cons up a yet another new vector of arguments
1593 by explicitly supplying nil's for optional values */
1594 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
1595 * sizeof (Lisp_Object
));
1596 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
1597 funcall_args
[++i
] = Qnil
;
1598 GCPRO1 (*funcall_args
);
1599 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
1603 /* We add 1 to numargs because funcall_args includes the
1604 function itself as well as its arguments. */
1607 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
1608 * sizeof (Lisp_Object
));
1609 GCPRO1 (*funcall_args
);
1610 gcpro1
.nvars
= 1 + numargs
;
1613 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
1614 /* Spread the last arg we got. Its first element goes in
1615 the slot that it used to occupy, hence this value of I. */
1617 while (!NULL (spread_arg
))
1619 funcall_args
[i
++] = XCONS (spread_arg
)->car
;
1620 spread_arg
= XCONS (spread_arg
)->cdr
;
1623 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
1626 /* Apply fn to arg */
1629 Lisp_Object fn
, arg
;
1631 struct gcpro gcpro1
;
1635 RETURN_UNGCPRO (Ffuncall (1, &fn
));
1639 Lisp_Object args
[2];
1643 RETURN_UNGCPRO (Fapply (2, args
));
1645 #else /* not NO_ARG_ARRAY */
1646 RETURN_UNGCPRO (Fapply (2, &fn
));
1647 #endif /* not NO_ARG_ARRAY */
1650 /* Call function fn on no arguments */
1655 struct gcpro gcpro1
;
1658 RETURN_UNGCPRO (Ffuncall (1, &fn
));
1661 /* Call function fn with argument arg */
1665 Lisp_Object fn
, arg
;
1667 struct gcpro gcpro1
;
1669 Lisp_Object args
[2];
1675 RETURN_UNGCPRO (Ffuncall (2, args
));
1676 #else /* not NO_ARG_ARRAY */
1679 RETURN_UNGCPRO (Ffuncall (2, &fn
));
1680 #endif /* not NO_ARG_ARRAY */
1683 /* Call function fn with arguments arg, arg1 */
1686 call2 (fn
, arg
, arg1
)
1687 Lisp_Object fn
, arg
, arg1
;
1689 struct gcpro gcpro1
;
1691 Lisp_Object args
[3];
1697 RETURN_UNGCPRO (Ffuncall (3, args
));
1698 #else /* not NO_ARG_ARRAY */
1701 RETURN_UNGCPRO (Ffuncall (3, &fn
));
1702 #endif /* not NO_ARG_ARRAY */
1705 /* Call function fn with arguments arg, arg1, arg2 */
1708 call3 (fn
, arg
, arg1
, arg2
)
1709 Lisp_Object fn
, arg
, arg1
, arg2
;
1711 struct gcpro gcpro1
;
1713 Lisp_Object args
[4];
1720 RETURN_UNGCPRO (Ffuncall (4, args
));
1721 #else /* not NO_ARG_ARRAY */
1724 RETURN_UNGCPRO (Ffuncall (4, &fn
));
1725 #endif /* not NO_ARG_ARRAY */
1728 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
1729 "Call first argument as a function, passing remaining arguments to it.\n\
1730 Thus, (funcall 'cons 'x 'y) returns (x . y).")
1737 int numargs
= nargs
- 1;
1738 Lisp_Object lisp_numargs
;
1740 struct backtrace backtrace
;
1741 register Lisp_Object
*internal_args
;
1745 if (consing_since_gc
> gc_cons_threshold
)
1746 Fgarbage_collect ();
1748 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1750 if (max_lisp_eval_depth
< 100)
1751 max_lisp_eval_depth
= 100;
1752 if (lisp_eval_depth
> max_lisp_eval_depth
)
1753 error ("Lisp nesting exceeds max-lisp-eval-depth");
1756 backtrace
.next
= backtrace_list
;
1757 backtrace_list
= &backtrace
;
1758 backtrace
.function
= &args
[0];
1759 backtrace
.args
= &args
[1];
1760 backtrace
.nargs
= nargs
- 1;
1761 backtrace
.evalargs
= 0;
1762 backtrace
.debug_on_exit
= 0;
1764 if (debug_on_next_call
)
1765 do_debug_on_call (Qlambda
);
1770 while (XTYPE (fun
) == Lisp_Symbol
)
1773 val
= XSYMBOL (fun
)->function
;
1774 if (EQ (val
, Qunbound
))
1775 Fsymbol_function (fun
); /* Get the right kind of error! */
1779 if (XTYPE (fun
) == Lisp_Subr
)
1781 if (numargs
< XSUBR (fun
)->min_args
1782 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
1784 XFASTINT (lisp_numargs
) = numargs
;
1785 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (lisp_numargs
, Qnil
)));
1788 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1789 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1791 if (XSUBR (fun
)->max_args
== MANY
)
1793 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
1797 if (XSUBR (fun
)->max_args
> numargs
)
1799 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
1800 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
1801 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
1802 internal_args
[i
] = Qnil
;
1805 internal_args
= args
+ 1;
1806 switch (XSUBR (fun
)->max_args
)
1809 val
= (*XSUBR (fun
)->function
) ();
1812 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
1815 val
= (*XSUBR (fun
)->function
) (internal_args
[0],
1819 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
1823 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
1828 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
1829 internal_args
[2], internal_args
[3],
1833 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
1834 internal_args
[2], internal_args
[3],
1835 internal_args
[4], internal_args
[5]);
1839 error ("funcall: this number of args not handled.");
1842 if (XTYPE (fun
) == Lisp_Compiled
)
1843 val
= funcall_lambda (fun
, numargs
, args
+ 1);
1847 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1848 funcar
= Fcar (fun
);
1849 if (XTYPE (funcar
) != Lisp_Symbol
)
1850 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1851 if (EQ (funcar
, Qlambda
))
1852 val
= funcall_lambda (fun
, numargs
, args
+ 1);
1853 else if (EQ (funcar
, Qmocklisp
))
1854 val
= ml_apply (fun
, Flist (numargs
, args
+ 1));
1855 else if (EQ (funcar
, Qautoload
))
1857 do_autoload (fun
, args
[0]);
1861 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1865 if (backtrace
.debug_on_exit
)
1866 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
1867 backtrace_list
= backtrace
.next
;
1872 apply_lambda (fun
, args
, eval_flag
)
1873 Lisp_Object fun
, args
;
1876 Lisp_Object args_left
;
1877 Lisp_Object numargs
;
1878 register Lisp_Object
*arg_vector
;
1879 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1881 register Lisp_Object tem
;
1883 numargs
= Flength (args
);
1884 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1887 GCPRO3 (*arg_vector
, args_left
, fun
);
1890 for (i
= 0; i
< XINT (numargs
);)
1892 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
1893 if (eval_flag
) tem
= Feval (tem
);
1894 arg_vector
[i
++] = tem
;
1902 backtrace_list
->args
= arg_vector
;
1903 backtrace_list
->nargs
= i
;
1905 backtrace_list
->evalargs
= 0;
1906 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
1908 /* Do the debug-on-exit now, while arg_vector still exists. */
1909 if (backtrace_list
->debug_on_exit
)
1910 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
1911 /* Don't do it again when we return to eval. */
1912 backtrace_list
->debug_on_exit
= 0;
1916 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
1917 and return the result of evaluation.
1918 FUN must be either a lambda-expression or a compiled-code object. */
1921 funcall_lambda (fun
, nargs
, arg_vector
)
1924 register Lisp_Object
*arg_vector
;
1926 Lisp_Object val
, tem
;
1927 register Lisp_Object syms_left
;
1928 Lisp_Object numargs
;
1929 register Lisp_Object next
;
1930 int count
= specpdl_ptr
- specpdl
;
1932 int optional
= 0, rest
= 0;
1934 specbind (Qmocklisp_arguments
, Qt
); /* t means NOT mocklisp! */
1936 XFASTINT (numargs
) = nargs
;
1938 if (XTYPE (fun
) == Lisp_Cons
)
1939 syms_left
= Fcar (Fcdr (fun
));
1940 else if (XTYPE (fun
) == Lisp_Compiled
)
1941 syms_left
= XVECTOR (fun
)->contents
[COMPILED_ARGLIST
];
1945 for (; !NULL (syms_left
); syms_left
= Fcdr (syms_left
))
1948 next
= Fcar (syms_left
);
1949 if (EQ (next
, Qand_rest
))
1951 else if (EQ (next
, Qand_optional
))
1955 specbind (Fcar (syms_left
), Flist (nargs
- i
, &arg_vector
[i
]));
1960 tem
= arg_vector
[i
++];
1961 specbind (next
, tem
);
1964 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1966 specbind (next
, Qnil
);
1970 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1972 if (XTYPE (fun
) == Lisp_Cons
)
1973 val
= Fprogn (Fcdr (Fcdr (fun
)));
1975 val
= Fbyte_code (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
],
1976 XVECTOR (fun
)->contents
[COMPILED_CONSTANTS
],
1977 XVECTOR (fun
)->contents
[COMPILED_STACK_DEPTH
]);
1978 return unbind_to (count
, val
);
1984 register int count
= specpdl_ptr
- specpdl
;
1985 if (specpdl_size
>= max_specpdl_size
)
1987 if (max_specpdl_size
< 400)
1988 max_specpdl_size
= 400;
1989 if (specpdl_size
>= max_specpdl_size
)
1992 Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil
));
1993 max_specpdl_size
*= 2;
1997 if (specpdl_size
> max_specpdl_size
)
1998 specpdl_size
= max_specpdl_size
;
1999 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
2000 specpdl_ptr
= specpdl
+ count
;
2004 specbind (symbol
, value
)
2005 Lisp_Object symbol
, value
;
2007 extern void store_symval_forwarding (); /* in eval.c */
2010 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2012 specpdl_ptr
->symbol
= symbol
;
2013 specpdl_ptr
->func
= 0;
2014 ovalue
= XSYMBOL (symbol
)->value
;
2015 specpdl_ptr
->old_value
= EQ (ovalue
, Qunbound
) ? Qunbound
: Fsymbol_value (symbol
);
2017 if (XTYPE (ovalue
) == Lisp_Buffer_Objfwd
)
2018 store_symval_forwarding (symbol
, ovalue
, value
);
2020 Fset (symbol
, value
);
2024 record_unwind_protect (function
, arg
)
2025 Lisp_Object (*function
)();
2028 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2030 specpdl_ptr
->func
= function
;
2031 specpdl_ptr
->symbol
= Qnil
;
2032 specpdl_ptr
->old_value
= arg
;
2037 unbind_to (count
, value
)
2041 int quitf
= !NULL (Vquit_flag
);
2042 struct gcpro gcpro1
;
2048 while (specpdl_ptr
!= specpdl
+ count
)
2051 if (specpdl_ptr
->func
!= 0)
2052 (*specpdl_ptr
->func
) (specpdl_ptr
->old_value
);
2053 /* Note that a "binding" of nil is really an unwind protect,
2054 so in that case the "old value" is a list of forms to evaluate. */
2055 else if (NULL (specpdl_ptr
->symbol
))
2056 Fprogn (specpdl_ptr
->old_value
);
2058 Fset (specpdl_ptr
->symbol
, specpdl_ptr
->old_value
);
2060 if (NULL (Vquit_flag
) && quitf
) Vquit_flag
= Qt
;
2069 /* Get the value of symbol's global binding, even if that binding
2070 is not now dynamically visible. */
2073 top_level_value (symbol
)
2076 register struct specbinding
*ptr
= specpdl
;
2078 CHECK_SYMBOL (symbol
, 0);
2079 for (; ptr
!= specpdl_ptr
; ptr
++)
2081 if (EQ (ptr
->symbol
, symbol
))
2082 return ptr
->old_value
;
2084 return Fsymbol_value (symbol
);
2088 top_level_set (symbol
, newval
)
2089 Lisp_Object symbol
, newval
;
2091 register struct specbinding
*ptr
= specpdl
;
2093 CHECK_SYMBOL (symbol
, 0);
2094 for (; ptr
!= specpdl_ptr
; ptr
++)
2096 if (EQ (ptr
->symbol
, symbol
))
2098 ptr
->old_value
= newval
;
2102 return Fset (symbol
, newval
);
2107 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
2108 "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\
2109 The debugger is entered when that frame exits, if the flag is non-nil.")
2111 Lisp_Object level
, flag
;
2113 register struct backtrace
*backlist
= backtrace_list
;
2116 CHECK_NUMBER (level
, 0);
2118 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
2120 backlist
= backlist
->next
;
2124 backlist
->debug_on_exit
= !NULL (flag
);
2129 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
2130 "Print a trace of Lisp function calls currently active.\n\
2131 Output stream used is value of `standard-output'.")
2134 register struct backtrace
*backlist
= backtrace_list
;
2138 extern Lisp_Object Vprint_level
;
2139 struct gcpro gcpro1
;
2141 entering_debugger
= 0;
2143 XFASTINT (Vprint_level
) = 3;
2150 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
2151 if (backlist
->nargs
== UNEVALLED
)
2153 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
2157 tem
= *backlist
->function
;
2158 Fprin1 (tem
, Qnil
); /* This can QUIT */
2159 write_string ("(", -1);
2160 if (backlist
->nargs
== MANY
)
2162 for (tail
= *backlist
->args
, i
= 0;
2164 tail
= Fcdr (tail
), i
++)
2166 if (i
) write_string (" ", -1);
2167 Fprin1 (Fcar (tail
), Qnil
);
2172 for (i
= 0; i
< backlist
->nargs
; i
++)
2174 if (i
) write_string (" ", -1);
2175 Fprin1 (backlist
->args
[i
], Qnil
);
2179 write_string (")\n", -1);
2180 backlist
= backlist
->next
;
2183 Vprint_level
= Qnil
;
2188 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, "",
2189 "Return the function and arguments N frames up from current execution point.\n\
2190 If that frame has not evaluated the arguments yet (or is a special form),\n\
2191 the value is (nil FUNCTION ARG-FORMS...).\n\
2192 If that frame has evaluated its arguments and called its function already,\n\
2193 the value is (t FUNCTION ARG-VALUES...).\n\
2194 A &rest arg is represented as the tail of the list ARG-VALUES.\n\
2195 FUNCTION is whatever was supplied as car of evaluated list,\n\
2196 or a lambda expression for macro calls.\n\
2197 If N is more than the number of frames, the value is nil.")
2199 Lisp_Object nframes
;
2201 register struct backtrace
*backlist
= backtrace_list
;
2205 CHECK_NATNUM (nframes
, 0);
2207 /* Find the frame requested. */
2208 for (i
= 0; i
< XFASTINT (nframes
); i
++)
2209 backlist
= backlist
->next
;
2213 if (backlist
->nargs
== UNEVALLED
)
2214 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
2217 if (backlist
->nargs
== MANY
)
2218 tem
= *backlist
->args
;
2220 tem
= Flist (backlist
->nargs
, backlist
->args
);
2222 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
2228 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
2229 "Limit on number of Lisp variable bindings & unwind-protects before error.");
2231 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
2232 "Limit on depth in `eval', `apply' and `funcall' before error.\n\
2233 This limit is to catch infinite recursions for you before they cause\n\
2234 actual stack overflow in C, which would be fatal for Emacs.\n\
2235 You can safely make it considerably larger than its default value,\n\
2236 if that proves inconveniently small.");
2238 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
2239 "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
2240 Typing C-G sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
2243 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
2244 "Non-nil inhibits C-g quitting from happening immediately.\n\
2245 Note that `quit-flag' will still be set by typing C-g,\n\
2246 so a quit will be signalled as soon as `inhibit-quit' is nil.\n\
2247 To prevent this happening, set `quit-flag' to nil\n\
2248 before making `inhibit-quit' nil.");
2249 Vinhibit_quit
= Qnil
;
2251 Qinhibit_quit
= intern ("inhibit-quit");
2252 staticpro (&Qinhibit_quit
);
2254 Qautoload
= intern ("autoload");
2255 staticpro (&Qautoload
);
2257 Qdebug_on_error
= intern ("debug-on-error");
2258 staticpro (&Qdebug_on_error
);
2260 Qmacro
= intern ("macro");
2261 staticpro (&Qmacro
);
2263 /* Note that the process handling also uses Qexit, but we don't want
2264 to staticpro it twice, so we just do it here. */
2265 Qexit
= intern ("exit");
2268 Qinteractive
= intern ("interactive");
2269 staticpro (&Qinteractive
);
2271 Qcommandp
= intern ("commandp");
2272 staticpro (&Qcommandp
);
2274 Qdefun
= intern ("defun");
2275 staticpro (&Qdefun
);
2277 Qand_rest
= intern ("&rest");
2278 staticpro (&Qand_rest
);
2280 Qand_optional
= intern ("&optional");
2281 staticpro (&Qand_optional
);
2283 DEFVAR_BOOL ("stack-trace-on-error", &stack_trace_on_error
,
2284 "*Non-nil means automatically display a backtrace buffer\n\
2285 after any error that is handled by the editor command loop.");
2286 stack_trace_on_error
= 0;
2288 DEFVAR_BOOL ("debug-on-error", &debug_on_error
,
2289 "*Non-nil means enter debugger if an error is signaled.\n\
2290 Does not apply to errors handled by `condition-case'.\n\
2291 See also variable `debug-on-quit'.");
2294 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
2295 "*Non-nil means enter debugger if quit is signaled (C-G, for example).\n\
2296 Does not apply if quit is handled by a `condition-case'.");
2299 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
2300 "Non-nil means enter debugger before next `eval', `apply' or `funcall'.");
2302 DEFVAR_LISP ("debugger", &Vdebugger
,
2303 "Function to call to invoke debugger.\n\
2304 If due to frame exit, args are `exit' and the value being returned;\n\
2305 this function's value will be returned instead of that.\n\
2306 If due to error, args are `error' and a list of the args to `signal'.\n\
2307 If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
2308 If due to `eval' entry, one arg, t.");
2311 Qmocklisp_arguments
= intern ("mocklisp-arguments");
2312 staticpro (&Qmocklisp_arguments
);
2313 DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments
,
2314 "While in a mocklisp function, the list of its unevaluated args.");
2315 Vmocklisp_arguments
= Qt
;
2317 DEFVAR_LISP ("run-hooks", &Vrun_hooks
,
2318 "Set to the function `run-hooks', if that function has been defined.\n\
2319 Otherwise, nil (in a bare Emacs without preloaded Lisp code).");
2322 staticpro (&Vautoload_queue
);
2323 Vautoload_queue
= Qnil
;
2334 defsubr (&Sfunction
);
2336 defsubr (&Sdefmacro
);
2338 defsubr (&Sdefconst
);
2339 defsubr (&Suser_variable_p
);
2343 defsubr (&Smacroexpand
);
2346 defsubr (&Sunwind_protect
);
2347 defsubr (&Scondition_case
);
2349 defsubr (&Sinteractive_p
);
2350 defsubr (&Scommandp
);
2351 defsubr (&Sautoload
);
2354 defsubr (&Sfuncall
);
2355 defsubr (&Sbacktrace_debug
);
2356 defsubr (&Sbacktrace
);
2357 defsubr (&Sbacktrace_frame
);