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. */
36 /* This definition is duplicated in alloc.c and keyboard.c */
37 /* Putting it in lisp.h makes cc bomb out! */
41 struct backtrace
*next
;
42 Lisp_Object
*function
;
43 Lisp_Object
*args
; /* Points to vector of args. */
44 int nargs
; /* length of vector */
45 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
47 /* Nonzero means call value of debugger when done with this operation. */
51 struct backtrace
*backtrace_list
;
57 struct catchtag
*next
;
60 struct backtrace
*backlist
;
61 struct handler
*handlerlist
;
64 int poll_suppress_count
;
67 struct catchtag
*catchlist
;
69 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
70 Lisp_Object Qinhibit_quit
, Vinhibit_quit
, Vquit_flag
;
71 Lisp_Object Qmocklisp_arguments
, Vmocklisp_arguments
, Qmocklisp
;
72 Lisp_Object Qand_rest
, Qand_optional
;
73 Lisp_Object Qdebug_on_error
;
75 Lisp_Object Vrun_hooks
;
77 /* Non-nil means record all fset's and provide's, to be undone
78 if the file being autoloaded is not fully loaded.
79 They are recorded by being consed onto the front of Vautoload_queue:
80 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */
82 Lisp_Object Vautoload_queue
;
84 /* Current number of specbindings allocated in specpdl. */
87 /* Pointer to beginning of specpdl. */
88 struct specbinding
*specpdl
;
90 /* Pointer to first unused element in specpdl. */
91 struct specbinding
*specpdl_ptr
;
93 /* Maximum size allowed for specpdl allocation */
96 /* Depth in Lisp evaluations and function calls. */
99 /* Maximum allowed depth in Lisp evaluations and function calls. */
100 int max_lisp_eval_depth
;
102 /* Nonzero means enter debugger before next function call */
103 int debug_on_next_call
;
105 /* List of conditions (non-nil atom means all) which cause a backtrace
106 if an error is handled by the command loop's error handler. */
107 Lisp_Object Vstack_trace_on_error
;
109 /* List of conditions (non-nil atom means all) which enter the debugger
110 if an error is handled by the command loop's error handler. */
111 Lisp_Object Vdebug_on_error
;
113 /* Nonzero means enter debugger if a quit signal
114 is handled by the command loop's error handler. */
117 /* Nonzero means we are trying to enter the debugger.
118 This is to prevent recursive attempts. */
119 int entering_debugger
;
121 Lisp_Object Vdebugger
;
123 void specbind (), record_unwind_protect ();
125 Lisp_Object
funcall_lambda ();
126 extern Lisp_Object
ml_apply (); /* Apply a mocklisp function to unevaluated argument list */
131 specpdl
= (struct specbinding
*) malloc (specpdl_size
* sizeof (struct specbinding
));
132 max_specpdl_size
= 600;
133 max_lisp_eval_depth
= 200;
138 specpdl_ptr
= specpdl
;
143 debug_on_next_call
= 0;
145 entering_debugger
= 0;
152 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
153 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
154 if (specpdl_size
+ 40 > max_specpdl_size
)
155 max_specpdl_size
= specpdl_size
+ 40;
156 debug_on_next_call
= 0;
157 entering_debugger
= 1;
158 return apply1 (Vdebugger
, arg
);
161 do_debug_on_call (code
)
164 debug_on_next_call
= 0;
165 backtrace_list
->debug_on_exit
= 1;
166 call_debugger (Fcons (code
, Qnil
));
169 /* NOTE!!! Every function that can call EVAL must protect its args
170 and temporaries from garbage collection while it needs them.
171 The definition of `For' shows what you have to do. */
173 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
174 "Eval args until one of them yields non-nil, then return that value.\n\
175 The remaining args are not evalled at all.\n\
176 If all args return nil, return nil.")
180 register Lisp_Object val
;
181 Lisp_Object args_left
;
192 val
= Feval (Fcar (args_left
));
195 args_left
= Fcdr (args_left
);
197 while (!NILP(args_left
));
203 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
204 "Eval args until one of them yields nil, then return nil.\n\
205 The remaining args are not evalled at all.\n\
206 If no arg yields nil, return the last arg's value.")
210 register Lisp_Object val
;
211 Lisp_Object args_left
;
222 val
= Feval (Fcar (args_left
));
225 args_left
= Fcdr (args_left
);
227 while (!NILP(args_left
));
233 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
234 "(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...\n\
235 Returns the value of THEN or the value of the last of the ELSE's.\n\
236 THEN must be one expression, but ELSE... can be zero or more expressions.\n\
237 If COND yields nil, and there are no ELSE's, the value is nil.")
241 register Lisp_Object cond
;
245 cond
= Feval (Fcar (args
));
249 return Feval (Fcar (Fcdr (args
)));
250 return Fprogn (Fcdr (Fcdr (args
)));
253 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
254 "(cond CLAUSES...): try each clause until one succeeds.\n\
255 Each clause looks like (CONDITION BODY...). CONDITION is evaluated\n\
256 and, if the value is non-nil, this clause succeeds:\n\
257 then the expressions in BODY are evaluated and the last one's\n\
258 value is the value of the cond-form.\n\
259 If no clause succeeds, cond returns nil.\n\
260 If a clause has one element, as in (CONDITION),\n\
261 CONDITION's value if non-nil is returned from the cond-form.")
265 register Lisp_Object clause
, val
;
272 clause
= Fcar (args
);
273 val
= Feval (Fcar (clause
));
276 if (!EQ (XCONS (clause
)->cdr
, Qnil
))
277 val
= Fprogn (XCONS (clause
)->cdr
);
280 args
= XCONS (args
)->cdr
;
287 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
288 "(progn BODY...): eval BODY forms sequentially and return value of last one.")
292 register Lisp_Object val
, tem
;
293 Lisp_Object args_left
;
296 /* In Mocklisp code, symbols at the front of the progn arglist
297 are to be bound to zero. */
298 if (!EQ (Vmocklisp_arguments
, Qt
))
300 val
= make_number (0);
301 while (!NILP (args
) && (tem
= Fcar (args
), XTYPE (tem
) == Lisp_Symbol
))
304 specbind (tem
, val
), args
= Fcdr (args
);
316 val
= Feval (Fcar (args_left
));
317 args_left
= Fcdr (args_left
);
319 while (!NILP(args_left
));
325 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
326 "(prog1 FIRST BODY...): eval FIRST and BODY sequentially; value from FIRST.\n\
327 The value of FIRST is saved during the evaluation of the remaining args,\n\
328 whose values are discarded.")
333 register Lisp_Object args_left
;
334 struct gcpro gcpro1
, gcpro2
;
335 register int argnum
= 0;
347 val
= Feval (Fcar (args_left
));
349 Feval (Fcar (args_left
));
350 args_left
= Fcdr (args_left
);
352 while (!NILP(args_left
));
358 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
359 "(prog1 X Y BODY...): eval X, Y and BODY sequentially; value from Y.\n\
360 The value of Y is saved during the evaluation of the remaining args,\n\
361 whose values are discarded.")
366 register Lisp_Object args_left
;
367 struct gcpro gcpro1
, gcpro2
;
368 register int argnum
= -1;
382 val
= Feval (Fcar (args_left
));
384 Feval (Fcar (args_left
));
385 args_left
= Fcdr (args_left
);
387 while (!NILP(args_left
));
393 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
394 "(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.\n\
395 The SYMs are not evaluated. Thus (setq x y) sets x to the value of y.\n\
396 Each SYM is set before the next VAL is computed.")
400 register Lisp_Object args_left
;
401 register Lisp_Object val
, sym
;
412 val
= Feval (Fcar (Fcdr (args_left
)));
413 sym
= Fcar (args_left
);
415 args_left
= Fcdr (Fcdr (args_left
));
417 while (!NILP(args_left
));
423 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
424 "Return the argument, without evaluating it. `(quote x)' yields `x'.")
431 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
432 "Like `quote', but preferred for objects which are functions.\n\
433 In byte compilation, `function' causes its argument to be compiled.\n\
434 `quote' cannot do that.")
441 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
442 "Return t if function in which this appears was called interactively.\n\
443 This means that the function was called with call-interactively (which\n\
444 includes being called as the binding of a key)\n\
445 and input is currently coming from the keyboard (not in keyboard macro).")
448 register struct backtrace
*btp
;
449 register Lisp_Object fun
;
454 /* Unless the object was compiled, skip the frame of interactive-p itself
455 (if interpreted) or the frame of byte-code (if called from
456 compiled function). */
457 btp
= backtrace_list
;
458 if (XTYPE (*btp
->function
) != Lisp_Compiled
)
461 && (btp
->nargs
== UNEVALLED
|| EQ (*btp
->function
, Qbytecode
)))
464 /* btp now points at the frame of the innermost function
465 that DOES eval its args.
466 If it is a built-in function (such as load or eval-region)
468 fun
= Findirect_function (*btp
->function
);
469 if (XTYPE (fun
) == Lisp_Subr
)
471 /* btp points to the frame of a Lisp function that called interactive-p.
472 Return t if that function was called interactively. */
473 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
478 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
479 "(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.\n\
480 The definition is (lambda ARGLIST [DOCSTRING] BODY...).\n\
481 See also the function `interactive'.")
485 register Lisp_Object fn_name
;
486 register Lisp_Object defn
;
488 fn_name
= Fcar (args
);
489 defn
= Fcons (Qlambda
, Fcdr (args
));
490 if (!NILP (Vpurify_flag
))
491 defn
= Fpurecopy (defn
);
492 Ffset (fn_name
, defn
);
496 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
497 "(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.\n\
498 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).\n\
499 When the macro is called, as in (NAME ARGS...),\n\
500 the function (lambda ARGLIST BODY...) is applied to\n\
501 the list ARGS... as it appears in the expression,\n\
502 and the result should be a form to be evaluated instead of the original.")
506 register Lisp_Object fn_name
;
507 register Lisp_Object defn
;
509 fn_name
= Fcar (args
);
510 defn
= Fcons (Qmacro
, Fcons (Qlambda
, Fcdr (args
)));
511 if (!NILP (Vpurify_flag
))
512 defn
= Fpurecopy (defn
);
513 Ffset (fn_name
, defn
);
517 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
518 "(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.\n\
519 You are not required to define a variable in order to use it,\n\
520 but the definition can supply documentation and an initial value\n\
521 in a way that tags can recognize.\n\n\
522 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.\n\
523 If SYMBOL is buffer-local, its default value is what is set;\n\
524 buffer-local values are not affected.\n\
525 INITVALUE and DOCSTRING are optional.\n\
526 If DOCSTRING starts with *, this variable is identified as a user option.\n\
527 This means that M-x set-variable and M-x edit-options recognize it.\n\
528 If INITVALUE is missing, SYMBOL's value is not set.")
532 register Lisp_Object sym
, tem
;
538 tem
= Fdefault_boundp (sym
);
540 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
542 tem
= Fcar (Fcdr (Fcdr (args
)));
545 if (!NILP (Vpurify_flag
))
546 tem
= Fpurecopy (tem
);
547 Fput (sym
, Qvariable_documentation
, tem
);
552 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
553 "(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant variable.\n\
554 The intent is that programs do not change this value, but users may.\n\
555 Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\
556 If SYMBOL is buffer-local, its default value is what is set;\n\
557 buffer-local values are not affected.\n\
558 DOCSTRING is optional.\n\
559 If DOCSTRING starts with *, this variable is identified as a user option.\n\
560 This means that M-x set-variable and M-x edit-options recognize it.\n\n\
561 Note: do not use `defconst' for user options in libraries that are not\n\
562 normally loaded, since it is useful for users to be able to specify\n\
563 their own values for such variables before loading the library.\n\
564 Since `defconst' unconditionally assigns the variable,\n\
565 it would override the user's choice.")
569 register Lisp_Object sym
, tem
;
572 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
573 tem
= Fcar (Fcdr (Fcdr (args
)));
576 if (!NILP (Vpurify_flag
))
577 tem
= Fpurecopy (tem
);
578 Fput (sym
, Qvariable_documentation
, tem
);
583 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
584 "Returns t if VARIABLE is intended to be set and modified by users.\n\
585 \(The alternative is a variable used internally in a Lisp program.)\n\
586 Determined by whether the first character of the documentation\n\
587 for the variable is \"*\"")
589 Lisp_Object variable
;
591 Lisp_Object documentation
;
593 documentation
= Fget (variable
, Qvariable_documentation
);
594 if (XTYPE (documentation
) == Lisp_Int
&& XINT (documentation
) < 0)
596 if ((XTYPE (documentation
) == Lisp_String
) &&
597 ((unsigned char) XSTRING (documentation
)->data
[0] == '*'))
602 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
603 "(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
604 The value of the last form in BODY is returned.\n\
605 Each element of VARLIST is a symbol (which is bound to nil)\n\
606 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
607 Each VALUEFORM can refer to the symbols already bound by this VARLIST.")
611 Lisp_Object varlist
, val
, elt
;
612 int count
= specpdl_ptr
- specpdl
;
613 struct gcpro gcpro1
, gcpro2
, gcpro3
;
615 GCPRO3 (args
, elt
, varlist
);
617 varlist
= Fcar (args
);
618 while (!NILP (varlist
))
621 elt
= Fcar (varlist
);
622 if (XTYPE (elt
) == Lisp_Symbol
)
623 specbind (elt
, Qnil
);
624 else if (! NILP (Fcdr (Fcdr (elt
))))
626 Fcons (build_string ("`let' bindings can have only one value-form"),
630 val
= Feval (Fcar (Fcdr (elt
)));
631 specbind (Fcar (elt
), val
);
633 varlist
= Fcdr (varlist
);
636 val
= Fprogn (Fcdr (args
));
637 return unbind_to (count
, val
);
640 DEFUN ("let", Flet
, Slet
, 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 All the VALUEFORMs are evalled before any symbols are bound.")
649 Lisp_Object
*temps
, tem
;
650 register Lisp_Object elt
, varlist
;
651 int count
= specpdl_ptr
- specpdl
;
653 struct gcpro gcpro1
, gcpro2
;
655 varlist
= Fcar (args
);
657 /* Make space to hold the values to give the bound variables */
658 elt
= Flength (varlist
);
659 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
661 /* Compute the values and store them in `temps' */
663 GCPRO2 (args
, *temps
);
666 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
669 elt
= Fcar (varlist
);
670 if (XTYPE (elt
) == Lisp_Symbol
)
671 temps
[argnum
++] = Qnil
;
672 else if (! NILP (Fcdr (Fcdr (elt
))))
674 Fcons (build_string ("`let' bindings can have only one value-form"),
677 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
678 gcpro2
.nvars
= argnum
;
682 varlist
= Fcar (args
);
683 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
685 elt
= Fcar (varlist
);
686 tem
= temps
[argnum
++];
687 if (XTYPE (elt
) == Lisp_Symbol
)
690 specbind (Fcar (elt
), tem
);
693 elt
= Fprogn (Fcdr (args
));
694 return unbind_to (count
, elt
);
697 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
698 "(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.\n\
699 The order of execution is thus TEST, BODY, TEST, BODY and so on\n\
700 until TEST returns nil.")
704 Lisp_Object test
, body
, tem
;
705 struct gcpro gcpro1
, gcpro2
;
711 while (tem
= Feval (test
), !NILP (tem
))
721 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
722 "Return result of expanding macros at top level of FORM.\n\
723 If FORM is not a macro call, it is returned unchanged.\n\
724 Otherwise, the macro is expanded and the expansion is considered\n\
725 in place of FORM. When a non-macro-call results, it is returned.\n\n\
726 The second optional arg ENVIRONMENT species an environment of macro\n\
727 definitions to shadow the loaded ones for use in file byte-compilation.")
729 register Lisp_Object form
;
732 register Lisp_Object expander
, sym
, def
, tem
;
736 /* Come back here each time we expand a macro call,
737 in case it expands into another macro call. */
738 if (XTYPE (form
) != Lisp_Cons
)
740 sym
= XCONS (form
)->car
;
741 /* Detect ((macro lambda ...) ...) */
742 if (XTYPE (sym
) == Lisp_Cons
743 && EQ (XCONS (sym
)->car
, Qmacro
))
745 expander
= XCONS (sym
)->cdr
;
748 if (XTYPE (sym
) != Lisp_Symbol
)
750 /* Trace symbols aliases to other symbols
751 until we get a symbol that is not an alias. */
755 tem
= Fassq (sym
, env
);
758 def
= XSYMBOL (sym
)->function
;
759 if (XTYPE (def
) == Lisp_Symbol
&& !EQ (def
, Qunbound
))
766 #if 0 /* This is turned off because it caused an element (foo . bar)
767 to have the effect of defining foo as an alias for the macro bar.
768 That is inconsistent; bar should be a function to expand foo. */
769 if (XTYPE (tem
) == Lisp_Cons
770 && XTYPE (XCONS (tem
)->cdr
) == Lisp_Symbol
)
771 sym
= XCONS (tem
)->cdr
;
777 /* Right now TEM is the result from SYM in ENV,
778 and if TEM is nil then DEF is SYM's function definition. */
781 /* SYM is not mentioned in ENV.
782 Look at its function definition. */
783 if (EQ (def
, Qunbound
)
784 || XTYPE (def
) != Lisp_Cons
)
785 /* Not defined or definition not suitable */
787 if (EQ (XCONS (def
)->car
, Qautoload
))
789 /* Autoloading function: will it be a macro when loaded? */
790 tem
= Fcar (Fnthcdr (make_number (4), def
));
793 /* Yes, load it and try again. */
794 do_autoload (def
, sym
);
797 else if (!EQ (XCONS (def
)->car
, Qmacro
))
799 else expander
= XCONS (def
)->cdr
;
803 expander
= XCONS (tem
)->cdr
;
808 form
= apply1 (expander
, XCONS (form
)->cdr
);
813 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
814 "(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.\n\
815 TAG is evalled to get the tag to use. Then the BODY is executed.\n\
816 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.\n\
817 If no throw happens, `catch' returns the value of the last BODY form.\n\
818 If a throw happens, it specifies the value to return from `catch'.")
822 register Lisp_Object tag
;
826 tag
= Feval (Fcar (args
));
828 return internal_catch (tag
, Fprogn
, Fcdr (args
));
831 /* Set up a catch, then call C function FUNC on argument ARG.
832 FUNC should return a Lisp_Object.
833 This is how catches are done from within C code. */
836 internal_catch (tag
, func
, arg
)
838 Lisp_Object (*func
) ();
841 /* This structure is made part of the chain `catchlist'. */
844 /* Fill in the components of c, and put it on the list. */
848 c
.backlist
= backtrace_list
;
849 c
.handlerlist
= handlerlist
;
850 c
.lisp_eval_depth
= lisp_eval_depth
;
851 c
.pdlcount
= specpdl_ptr
- specpdl
;
852 c
.poll_suppress_count
= poll_suppress_count
;
857 if (! _setjmp (c
.jmp
))
858 c
.val
= (*func
) (arg
);
860 /* Throw works by a longjmp that comes right here. */
865 /* Discard from the catchlist all catch tags back through CATCH.
866 Before each catch is discarded, unbind all special bindings
867 made within that catch. Also, when discarding a catch that
868 corresponds to a condition handler, discard that handler.
870 At the end, restore some static info saved in CATCH.
872 This is used for correct unwinding in Fthrow and Fsignal,
873 before doing the longjmp that actually destroys the stack frames
874 in which these handlers and catches reside. */
878 struct catchtag
*catch;
880 register int last_time
;
884 last_time
= catchlist
== catch;
885 unbind_to (catchlist
->pdlcount
, Qnil
);
886 handlerlist
= catchlist
->handlerlist
;
887 catchlist
= catchlist
->next
;
891 gcprolist
= catch->gcpro
;
892 backtrace_list
= catch->backlist
;
893 lisp_eval_depth
= catch->lisp_eval_depth
;
896 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
897 "(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.\n\
898 Both TAG and VALUE are evalled.")
900 register Lisp_Object tag
, val
;
902 register struct catchtag
*c
;
907 for (c
= catchlist
; c
; c
= c
->next
)
909 if (EQ (c
->tag
, tag
))
911 /* Restore the polling-suppression count. */
912 if (c
->poll_suppress_count
> poll_suppress_count
)
914 while (c
->poll_suppress_count
< poll_suppress_count
)
918 _longjmp (c
->jmp
, 1);
921 tag
= Fsignal (Qno_catch
, Fcons (tag
, Fcons (val
, Qnil
)));
926 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
927 "Do BODYFORM, protecting with UNWINDFORMS.\n\
928 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).\n\
929 If BODYFORM completes normally, its value is returned\n\
930 after executing the UNWINDFORMS.\n\
931 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.")
936 int count
= specpdl_ptr
- specpdl
;
938 record_unwind_protect (0, Fcdr (args
));
939 val
= Feval (Fcar (args
));
940 return unbind_to (count
, val
);
943 /* Chain of condition handlers currently in effect.
944 The elements of this chain are contained in the stack frames
945 of Fcondition_case and internal_condition_case.
946 When an error is signaled (by calling Fsignal, below),
947 this chain is searched for an element that applies. */
949 struct handler
*handlerlist
;
951 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
952 "Regain control when an error is signaled.\n\
953 Usage looks like (condition-case VAR BODYFORM HANDLERS...).\n\
954 executes BODYFORM and returns its value if no error happens.\n\
955 Each element of HANDLERS looks like (CONDITION-NAME BODY...)\n\
956 where the BODY is made of Lisp expressions.\n\n\
957 A handler is applicable to an error\n\
958 if CONDITION-NAME is one of the error's condition names.\n\
959 If an error happens, the first applicable handler is run.\n\
961 When a handler handles an error,\n\
962 control returns to the condition-case and the handler BODY... is executed\n\
963 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\
964 VAR may be nil; then you do not get access to the signal information.\n\
966 The value of the last BODY form is returned from the condition-case.\n\
967 See also the function `signal' for more info.")
974 register Lisp_Object tem
;
977 CHECK_SYMBOL (tem
, 0);
981 c
.backlist
= backtrace_list
;
982 c
.handlerlist
= handlerlist
;
983 c
.lisp_eval_depth
= lisp_eval_depth
;
984 c
.pdlcount
= specpdl_ptr
- specpdl
;
985 c
.poll_suppress_count
= poll_suppress_count
;
990 specbind (h
.var
, Fcdr (c
.val
));
991 val
= Fprogn (Fcdr (Fcar (c
.val
)));
992 unbind_to (c
.pdlcount
, Qnil
);
998 h
.handler
= Fcdr (Fcdr (args
));
1000 for (val
= h
.handler
; ! NILP (val
); val
= Fcdr (val
))
1003 if ((!NILP (tem
)) &&
1004 (!CONSP (tem
) || (XTYPE (XCONS (tem
)->car
) != Lisp_Symbol
)))
1005 error ("Invalid condition handler", tem
);
1008 h
.next
= handlerlist
;
1009 h
.poll_suppress_count
= poll_suppress_count
;
1013 val
= Feval (Fcar (Fcdr (args
)));
1015 handlerlist
= h
.next
;
1020 internal_condition_case (bfun
, handlers
, hfun
)
1021 Lisp_Object (*bfun
) ();
1022 Lisp_Object handlers
;
1023 Lisp_Object (*hfun
) ();
1031 c
.backlist
= backtrace_list
;
1032 c
.handlerlist
= handlerlist
;
1033 c
.lisp_eval_depth
= lisp_eval_depth
;
1034 c
.pdlcount
= specpdl_ptr
- specpdl
;
1035 c
.poll_suppress_count
= poll_suppress_count
;
1036 c
.gcpro
= gcprolist
;
1037 if (_setjmp (c
.jmp
))
1039 return (*hfun
) (Fcdr (c
.val
));
1043 h
.handler
= handlers
;
1045 h
.poll_suppress_count
= poll_suppress_count
;
1046 h
.next
= handlerlist
;
1052 handlerlist
= h
.next
;
1056 static Lisp_Object
find_handler_clause ();
1058 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1059 "Signal an error. Args are SIGNAL-NAME, and associated DATA.\n\
1060 This function does not return.\n\n\
1061 A signal name is a symbol with an `error-conditions' property\n\
1062 that is a list of condition names.\n\
1063 A handler for any of those names will get to handle this signal.\n\
1064 The symbol `error' should normally be one of them.\n\
1066 DATA should be a list. Its elements are printed as part of the error message.\n\
1067 If the signal is handled, DATA is made available to the handler.\n\
1068 See also the function `condition-case'.")
1070 Lisp_Object sig
, data
;
1072 register struct handler
*allhandlers
= handlerlist
;
1073 Lisp_Object conditions
;
1074 extern int gc_in_progress
;
1075 extern int waiting_for_input
;
1076 Lisp_Object debugger_value
;
1078 quit_error_check ();
1080 if (gc_in_progress
|| waiting_for_input
)
1083 TOTALLY_UNBLOCK_INPUT
;
1085 conditions
= Fget (sig
, Qerror_conditions
);
1087 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1089 register Lisp_Object clause
;
1090 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1091 sig
, data
, &debugger_value
);
1093 #if 0 /* Most callers are not prepared to handle gc if this returns.
1094 So, since this feature is not very useful, take it out. */
1095 /* If have called debugger and user wants to continue,
1097 if (EQ (clause
, Qlambda
))
1098 return debugger_value
;
1100 if (EQ (clause
, Qlambda
))
1101 error ("Returning a value from an error is no longer supported");
1106 struct handler
*h
= handlerlist
;
1107 /* Restore the polling-suppression count. */
1108 if (h
->poll_suppress_count
> poll_suppress_count
)
1110 while (h
->poll_suppress_count
< poll_suppress_count
)
1112 handlerlist
= allhandlers
;
1113 unbind_catch (h
->tag
);
1114 h
->tag
->val
= Fcons (clause
, Fcons (sig
, data
));
1115 _longjmp (h
->tag
->jmp
, 1);
1119 handlerlist
= allhandlers
;
1120 /* If no handler is present now, try to run the debugger,
1121 and if that fails, throw to top level. */
1122 find_handler_clause (Qerror
, conditions
, sig
, data
, &debugger_value
);
1123 Fthrow (Qtop_level
, Qt
);
1126 /* Return nonzero iff LIST is a non-nil atom or
1127 a list containing one of CONDITIONS. */
1130 wants_debugger (list
, conditions
)
1131 Lisp_Object list
, conditions
;
1133 static int looking
= 0;
1137 /* We got an error while looking in LIST. */
1148 while (!NILP (conditions
))
1151 tem
= Fmemq (XCONS (conditions
)->car
, list
);
1157 conditions
= XCONS (conditions
)->cdr
;
1161 /* Value of Qlambda means we have called debugger and user has continued.
1162 Store value returned from debugger into *DEBUGGER_VALUE_PTR. */
1165 find_handler_clause (handlers
, conditions
, sig
, data
, debugger_value_ptr
)
1166 Lisp_Object handlers
, conditions
, sig
, data
;
1167 Lisp_Object
*debugger_value_ptr
;
1169 register Lisp_Object h
;
1170 register Lisp_Object tem
;
1171 register Lisp_Object tem1
;
1173 if (EQ (handlers
, Qt
)) /* t is used by handlers for all conditions, set up by C code. */
1175 if (EQ (handlers
, Qerror
)) /* error is used similarly, but means display a backtrace too */
1177 if (wants_debugger (Vstack_trace_on_error
, conditions
))
1178 internal_with_output_to_temp_buffer ("*Backtrace*", Fbacktrace
, Qnil
);
1179 if (!entering_debugger
1180 && ((EQ (sig
, Qquit
) && debug_on_quit
)
1181 || wants_debugger (Vdebug_on_error
, conditions
)))
1183 int count
= specpdl_ptr
- specpdl
;
1184 specbind (Qdebug_on_error
, Qnil
);
1185 *debugger_value_ptr
=
1186 call_debugger (Fcons (Qerror
,
1187 Fcons (Fcons (sig
, data
),
1189 return unbind_to (count
, Qlambda
);
1193 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1198 tem
= Fmemq (Fcar (tem1
), conditions
);
1205 /* dump an error message; called like printf */
1209 error (m
, a1
, a2
, a3
)
1213 sprintf (buf
, m
, a1
, a2
, a3
);
1216 Fsignal (Qerror
, Fcons (build_string (buf
), Qnil
));
1219 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 1, 0,
1220 "T if FUNCTION makes provisions for interactive calling.\n\
1221 This means it contains a description for how to read arguments to give it.\n\
1222 The value is nil for an invalid function or a symbol with no function\n\
1225 Interactively callable functions include strings and vectors (treated\n\
1226 as keyboard macros), lambda-expressions that contain a top-level call\n\
1227 to `interactive', autoload definitions made by `autoload' with non-nil\n\
1228 fourth argument, and some of the built-in functions of Lisp.\n\
1230 Also, a symbol satisfies `commandp' if its function definition does so.")
1232 Lisp_Object function
;
1234 register Lisp_Object fun
;
1235 register Lisp_Object funcar
;
1236 register Lisp_Object tem
;
1241 fun
= indirect_function (fun
);
1242 if (EQ (fun
, Qunbound
))
1245 /* Emacs primitives are interactive if their DEFUN specifies an
1246 interactive spec. */
1247 if (XTYPE (fun
) == Lisp_Subr
)
1249 if (XSUBR (fun
)->prompt
)
1255 /* Bytecode objects are interactive if they are long enough to
1256 have an element whose index is COMPILED_INTERACTIVE, which is
1257 where the interactive spec is stored. */
1258 else if (XTYPE (fun
) == Lisp_Compiled
)
1259 return (XVECTOR (fun
)->size
> COMPILED_INTERACTIVE
1262 /* Strings and vectors are keyboard macros. */
1263 if (XTYPE (fun
) == Lisp_String
1264 || XTYPE (fun
) == Lisp_Vector
)
1267 /* Lists may represent commands. */
1270 funcar
= Fcar (fun
);
1271 if (XTYPE (funcar
) != Lisp_Symbol
)
1272 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1273 if (EQ (funcar
, Qlambda
))
1274 return Fassq (Qinteractive
, Fcdr (Fcdr (fun
)));
1275 if (EQ (funcar
, Qmocklisp
))
1276 return Qt
; /* All mocklisp functions can be called interactively */
1277 if (EQ (funcar
, Qautoload
))
1278 return Fcar (Fcdr (Fcdr (Fcdr (fun
))));
1284 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1285 "Define FUNCTION to autoload from FILE.\n\
1286 FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\
1287 Third arg DOCSTRING is documentation for the function.\n\
1288 Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\
1289 Fifth arg MACRO if non-nil says the function is really a macro.\n\
1290 Third through fifth args give info about the real definition.\n\
1291 They default to nil.\n\
1292 If FUNCTION is already defined other than as an autoload,\n\
1293 this does nothing and returns nil.")
1294 (function
, file
, docstring
, interactive
, macro
)
1295 Lisp_Object function
, file
, docstring
, interactive
, macro
;
1298 Lisp_Object args
[4];
1301 CHECK_SYMBOL (function
, 0);
1302 CHECK_STRING (file
, 1);
1304 /* If function is defined and not as an autoload, don't override */
1305 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
1306 && !(XTYPE (XSYMBOL (function
)->function
) == Lisp_Cons
1307 && EQ (XCONS (XSYMBOL (function
)->function
)->car
, Qautoload
)))
1312 args
[1] = docstring
;
1313 args
[2] = interactive
;
1316 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
1317 #else /* NO_ARG_ARRAY */
1318 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
1319 #endif /* not NO_ARG_ARRAY */
1323 un_autoload (oldqueue
)
1324 Lisp_Object oldqueue
;
1326 register Lisp_Object queue
, first
, second
;
1328 /* Queue to unwind is current value of Vautoload_queue.
1329 oldqueue is the shadowed value to leave in Vautoload_queue. */
1330 queue
= Vautoload_queue
;
1331 Vautoload_queue
= oldqueue
;
1332 while (CONSP (queue
))
1334 first
= Fcar (queue
);
1335 second
= Fcdr (first
);
1336 first
= Fcar (first
);
1337 if (EQ (second
, Qnil
))
1340 Ffset (first
, second
);
1341 queue
= Fcdr (queue
);
1346 do_autoload (fundef
, funname
)
1347 Lisp_Object fundef
, funname
;
1349 int count
= specpdl_ptr
- specpdl
;
1350 Lisp_Object fun
, val
;
1353 CHECK_SYMBOL (funname
, 0);
1355 /* Value saved here is to be restored into Vautoload_queue */
1356 record_unwind_protect (un_autoload
, Vautoload_queue
);
1357 Vautoload_queue
= Qt
;
1358 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
);
1359 /* Once loading finishes, don't undo it. */
1360 Vautoload_queue
= Qt
;
1361 unbind_to (count
, Qnil
);
1363 fun
= Findirect_function (fun
);
1365 if (XTYPE (fun
) == Lisp_Cons
1366 && EQ (XCONS (fun
)->car
, Qautoload
))
1367 error ("Autoloading failed to define function %s",
1368 XSYMBOL (funname
)->name
->data
);
1371 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
1372 "Evaluate FORM and return its value.")
1376 Lisp_Object fun
, val
, original_fun
, original_args
;
1378 struct backtrace backtrace
;
1379 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1381 if (XTYPE (form
) == Lisp_Symbol
)
1383 if (EQ (Vmocklisp_arguments
, Qt
))
1384 return Fsymbol_value (form
);
1385 val
= Fsymbol_value (form
);
1388 else if (EQ (val
, Qt
))
1396 if (consing_since_gc
> gc_cons_threshold
)
1399 Fgarbage_collect ();
1403 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1405 if (max_lisp_eval_depth
< 100)
1406 max_lisp_eval_depth
= 100;
1407 if (lisp_eval_depth
> max_lisp_eval_depth
)
1408 error ("Lisp nesting exceeds max-lisp-eval-depth");
1411 original_fun
= Fcar (form
);
1412 original_args
= Fcdr (form
);
1414 backtrace
.next
= backtrace_list
;
1415 backtrace_list
= &backtrace
;
1416 backtrace
.function
= &original_fun
; /* This also protects them from gc */
1417 backtrace
.args
= &original_args
;
1418 backtrace
.nargs
= UNEVALLED
;
1419 backtrace
.evalargs
= 1;
1420 backtrace
.debug_on_exit
= 0;
1422 if (debug_on_next_call
)
1423 do_debug_on_call (Qt
);
1425 /* At this point, only original_fun and original_args
1426 have values that will be used below */
1428 fun
= Findirect_function (original_fun
);
1430 if (XTYPE (fun
) == Lisp_Subr
)
1432 Lisp_Object numargs
;
1433 Lisp_Object argvals
[7];
1434 Lisp_Object args_left
;
1435 register int i
, maxargs
;
1437 args_left
= original_args
;
1438 numargs
= Flength (args_left
);
1440 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
1441 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
1442 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1444 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1446 backtrace
.evalargs
= 0;
1447 val
= (*XSUBR (fun
)->function
) (args_left
);
1451 if (XSUBR (fun
)->max_args
== MANY
)
1453 /* Pass a vector of evaluated arguments */
1455 register int argnum
= 0;
1457 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1459 GCPRO3 (args_left
, fun
, fun
);
1463 while (!NILP (args_left
))
1465 vals
[argnum
++] = Feval (Fcar (args_left
));
1466 args_left
= Fcdr (args_left
);
1467 gcpro3
.nvars
= argnum
;
1470 backtrace
.args
= vals
;
1471 backtrace
.nargs
= XINT (numargs
);
1473 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
1478 GCPRO3 (args_left
, fun
, fun
);
1479 gcpro3
.var
= argvals
;
1482 maxargs
= XSUBR (fun
)->max_args
;
1483 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
1485 argvals
[i
] = Feval (Fcar (args_left
));
1491 backtrace
.args
= argvals
;
1492 backtrace
.nargs
= XINT (numargs
);
1497 val
= (*XSUBR (fun
)->function
) ();
1500 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
1503 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
1506 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1510 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1511 argvals
[2], argvals
[3]);
1514 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1515 argvals
[3], argvals
[4]);
1518 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1519 argvals
[3], argvals
[4], argvals
[5]);
1523 /* Someone has created a subr that takes more arguments than
1524 is supported by this code. We need to either rewrite the
1525 subr to use a different argument protocol, or add more
1526 cases to this switch. */
1530 if (XTYPE (fun
) == Lisp_Compiled
)
1531 val
= apply_lambda (fun
, original_args
, 1);
1535 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1536 funcar
= Fcar (fun
);
1537 if (XTYPE (funcar
) != Lisp_Symbol
)
1538 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1539 if (EQ (funcar
, Qautoload
))
1541 do_autoload (fun
, original_fun
);
1544 if (EQ (funcar
, Qmacro
))
1545 val
= Feval (apply1 (Fcdr (fun
), original_args
));
1546 else if (EQ (funcar
, Qlambda
))
1547 val
= apply_lambda (fun
, original_args
, 1);
1548 else if (EQ (funcar
, Qmocklisp
))
1549 val
= ml_apply (fun
, original_args
);
1551 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1554 if (!EQ (Vmocklisp_arguments
, Qt
))
1558 else if (EQ (val
, Qt
))
1562 if (backtrace
.debug_on_exit
)
1563 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
1564 backtrace_list
= backtrace
.next
;
1568 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
1569 "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
1570 Thus, (apply '+ 1 2 '(3 4)) returns 10.")
1575 register int i
, numargs
;
1576 register Lisp_Object spread_arg
;
1577 register Lisp_Object
*funcall_args
;
1579 struct gcpro gcpro1
;
1583 spread_arg
= args
[nargs
- 1];
1584 CHECK_LIST (spread_arg
, nargs
);
1586 numargs
= XINT (Flength (spread_arg
));
1589 return Ffuncall (nargs
- 1, args
);
1590 else if (numargs
== 1)
1592 args
[nargs
- 1] = XCONS (spread_arg
)->car
;
1593 return Ffuncall (nargs
, args
);
1596 numargs
+= nargs
- 2;
1598 fun
= indirect_function (fun
);
1599 if (EQ (fun
, Qunbound
))
1601 /* Let funcall get the error */
1606 if (XTYPE (fun
) == Lisp_Subr
)
1608 if (numargs
< XSUBR (fun
)->min_args
1609 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
1610 goto funcall
; /* Let funcall get the error */
1611 else if (XSUBR (fun
)->max_args
> numargs
)
1613 /* Avoid making funcall cons up a yet another new vector of arguments
1614 by explicitly supplying nil's for optional values */
1615 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
1616 * sizeof (Lisp_Object
));
1617 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
1618 funcall_args
[++i
] = Qnil
;
1619 GCPRO1 (*funcall_args
);
1620 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
1624 /* We add 1 to numargs because funcall_args includes the
1625 function itself as well as its arguments. */
1628 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
1629 * sizeof (Lisp_Object
));
1630 GCPRO1 (*funcall_args
);
1631 gcpro1
.nvars
= 1 + numargs
;
1634 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
1635 /* Spread the last arg we got. Its first element goes in
1636 the slot that it used to occupy, hence this value of I. */
1638 while (!NILP (spread_arg
))
1640 funcall_args
[i
++] = XCONS (spread_arg
)->car
;
1641 spread_arg
= XCONS (spread_arg
)->cdr
;
1644 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
1647 /* Apply fn to arg */
1650 Lisp_Object fn
, arg
;
1652 struct gcpro gcpro1
;
1656 RETURN_UNGCPRO (Ffuncall (1, &fn
));
1660 Lisp_Object args
[2];
1664 RETURN_UNGCPRO (Fapply (2, args
));
1666 #else /* not NO_ARG_ARRAY */
1667 RETURN_UNGCPRO (Fapply (2, &fn
));
1668 #endif /* not NO_ARG_ARRAY */
1671 /* Call function fn on no arguments */
1676 struct gcpro gcpro1
;
1679 RETURN_UNGCPRO (Ffuncall (1, &fn
));
1682 /* Call function fn with argument arg */
1686 Lisp_Object fn
, arg
;
1688 struct gcpro gcpro1
;
1690 Lisp_Object args
[2];
1696 RETURN_UNGCPRO (Ffuncall (2, args
));
1697 #else /* not NO_ARG_ARRAY */
1700 RETURN_UNGCPRO (Ffuncall (2, &fn
));
1701 #endif /* not NO_ARG_ARRAY */
1704 /* Call function fn with arguments arg, arg1 */
1707 call2 (fn
, arg
, arg1
)
1708 Lisp_Object fn
, arg
, arg1
;
1710 struct gcpro gcpro1
;
1712 Lisp_Object args
[3];
1718 RETURN_UNGCPRO (Ffuncall (3, args
));
1719 #else /* not NO_ARG_ARRAY */
1722 RETURN_UNGCPRO (Ffuncall (3, &fn
));
1723 #endif /* not NO_ARG_ARRAY */
1726 /* Call function fn with arguments arg, arg1, arg2 */
1729 call3 (fn
, arg
, arg1
, arg2
)
1730 Lisp_Object fn
, arg
, arg1
, arg2
;
1732 struct gcpro gcpro1
;
1734 Lisp_Object args
[4];
1741 RETURN_UNGCPRO (Ffuncall (4, args
));
1742 #else /* not NO_ARG_ARRAY */
1745 RETURN_UNGCPRO (Ffuncall (4, &fn
));
1746 #endif /* not NO_ARG_ARRAY */
1749 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
1750 "Call first argument as a function, passing remaining arguments to it.\n\
1751 Thus, (funcall 'cons 'x 'y) returns (x . y).")
1758 int numargs
= nargs
- 1;
1759 Lisp_Object lisp_numargs
;
1761 struct backtrace backtrace
;
1762 register Lisp_Object
*internal_args
;
1766 if (consing_since_gc
> gc_cons_threshold
)
1767 Fgarbage_collect ();
1769 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1771 if (max_lisp_eval_depth
< 100)
1772 max_lisp_eval_depth
= 100;
1773 if (lisp_eval_depth
> max_lisp_eval_depth
)
1774 error ("Lisp nesting exceeds max-lisp-eval-depth");
1777 backtrace
.next
= backtrace_list
;
1778 backtrace_list
= &backtrace
;
1779 backtrace
.function
= &args
[0];
1780 backtrace
.args
= &args
[1];
1781 backtrace
.nargs
= nargs
- 1;
1782 backtrace
.evalargs
= 0;
1783 backtrace
.debug_on_exit
= 0;
1785 if (debug_on_next_call
)
1786 do_debug_on_call (Qlambda
);
1792 fun
= Findirect_function (fun
);
1794 if (XTYPE (fun
) == Lisp_Subr
)
1796 if (numargs
< XSUBR (fun
)->min_args
1797 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
1799 XFASTINT (lisp_numargs
) = numargs
;
1800 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (lisp_numargs
, Qnil
)));
1803 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1804 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1806 if (XSUBR (fun
)->max_args
== MANY
)
1808 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
1812 if (XSUBR (fun
)->max_args
> numargs
)
1814 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
1815 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
1816 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
1817 internal_args
[i
] = Qnil
;
1820 internal_args
= args
+ 1;
1821 switch (XSUBR (fun
)->max_args
)
1824 val
= (*XSUBR (fun
)->function
) ();
1827 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
1830 val
= (*XSUBR (fun
)->function
) (internal_args
[0],
1834 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
1838 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
1843 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
1844 internal_args
[2], internal_args
[3],
1848 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
1849 internal_args
[2], internal_args
[3],
1850 internal_args
[4], internal_args
[5]);
1855 /* If a subr takes more than 6 arguments without using MANY
1856 or UNEVALLED, we need to extend this function to support it.
1857 Until this is done, there is no way to call the function. */
1861 if (XTYPE (fun
) == Lisp_Compiled
)
1862 val
= funcall_lambda (fun
, numargs
, args
+ 1);
1866 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1867 funcar
= Fcar (fun
);
1868 if (XTYPE (funcar
) != Lisp_Symbol
)
1869 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1870 if (EQ (funcar
, Qlambda
))
1871 val
= funcall_lambda (fun
, numargs
, args
+ 1);
1872 else if (EQ (funcar
, Qmocklisp
))
1873 val
= ml_apply (fun
, Flist (numargs
, args
+ 1));
1874 else if (EQ (funcar
, Qautoload
))
1876 do_autoload (fun
, args
[0]);
1880 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1884 if (backtrace
.debug_on_exit
)
1885 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
1886 backtrace_list
= backtrace
.next
;
1891 apply_lambda (fun
, args
, eval_flag
)
1892 Lisp_Object fun
, args
;
1895 Lisp_Object args_left
;
1896 Lisp_Object numargs
;
1897 register Lisp_Object
*arg_vector
;
1898 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1900 register Lisp_Object tem
;
1902 numargs
= Flength (args
);
1903 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1906 GCPRO3 (*arg_vector
, args_left
, fun
);
1909 for (i
= 0; i
< XINT (numargs
);)
1911 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
1912 if (eval_flag
) tem
= Feval (tem
);
1913 arg_vector
[i
++] = tem
;
1921 backtrace_list
->args
= arg_vector
;
1922 backtrace_list
->nargs
= i
;
1924 backtrace_list
->evalargs
= 0;
1925 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
1927 /* Do the debug-on-exit now, while arg_vector still exists. */
1928 if (backtrace_list
->debug_on_exit
)
1929 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
1930 /* Don't do it again when we return to eval. */
1931 backtrace_list
->debug_on_exit
= 0;
1935 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
1936 and return the result of evaluation.
1937 FUN must be either a lambda-expression or a compiled-code object. */
1940 funcall_lambda (fun
, nargs
, arg_vector
)
1943 register Lisp_Object
*arg_vector
;
1945 Lisp_Object val
, tem
;
1946 register Lisp_Object syms_left
;
1947 Lisp_Object numargs
;
1948 register Lisp_Object next
;
1949 int count
= specpdl_ptr
- specpdl
;
1951 int optional
= 0, rest
= 0;
1953 specbind (Qmocklisp_arguments
, Qt
); /* t means NOT mocklisp! */
1955 XFASTINT (numargs
) = nargs
;
1957 if (XTYPE (fun
) == Lisp_Cons
)
1958 syms_left
= Fcar (Fcdr (fun
));
1959 else if (XTYPE (fun
) == Lisp_Compiled
)
1960 syms_left
= XVECTOR (fun
)->contents
[COMPILED_ARGLIST
];
1964 for (; !NILP (syms_left
); syms_left
= Fcdr (syms_left
))
1967 next
= Fcar (syms_left
);
1968 while (XTYPE (next
) != Lisp_Symbol
)
1969 next
= Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1970 if (EQ (next
, Qand_rest
))
1972 else if (EQ (next
, Qand_optional
))
1976 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
1981 tem
= arg_vector
[i
++];
1982 specbind (next
, tem
);
1985 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1987 specbind (next
, Qnil
);
1991 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1993 if (XTYPE (fun
) == Lisp_Cons
)
1994 val
= Fprogn (Fcdr (Fcdr (fun
)));
1996 val
= Fbyte_code (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
],
1997 XVECTOR (fun
)->contents
[COMPILED_CONSTANTS
],
1998 XVECTOR (fun
)->contents
[COMPILED_STACK_DEPTH
]);
1999 return unbind_to (count
, val
);
2005 register int count
= specpdl_ptr
- specpdl
;
2006 if (specpdl_size
>= max_specpdl_size
)
2008 if (max_specpdl_size
< 400)
2009 max_specpdl_size
= 400;
2010 if (specpdl_size
>= max_specpdl_size
)
2013 Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil
));
2014 max_specpdl_size
*= 2;
2018 if (specpdl_size
> max_specpdl_size
)
2019 specpdl_size
= max_specpdl_size
;
2020 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
2021 specpdl_ptr
= specpdl
+ count
;
2025 specbind (symbol
, value
)
2026 Lisp_Object symbol
, value
;
2028 extern void store_symval_forwarding (); /* in eval.c */
2031 CHECK_SYMBOL (symbol
, 0);
2033 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2035 specpdl_ptr
->symbol
= symbol
;
2036 specpdl_ptr
->func
= 0;
2037 ovalue
= XSYMBOL (symbol
)->value
;
2038 specpdl_ptr
->old_value
= EQ (ovalue
, Qunbound
) ? Qunbound
: Fsymbol_value (symbol
);
2040 if (XTYPE (ovalue
) == Lisp_Buffer_Objfwd
)
2041 store_symval_forwarding (symbol
, ovalue
, value
);
2043 Fset (symbol
, value
);
2047 record_unwind_protect (function
, arg
)
2048 Lisp_Object (*function
)();
2051 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2053 specpdl_ptr
->func
= function
;
2054 specpdl_ptr
->symbol
= Qnil
;
2055 specpdl_ptr
->old_value
= arg
;
2060 unbind_to (count
, value
)
2064 int quitf
= !NILP (Vquit_flag
);
2065 struct gcpro gcpro1
;
2071 while (specpdl_ptr
!= specpdl
+ count
)
2074 if (specpdl_ptr
->func
!= 0)
2075 (*specpdl_ptr
->func
) (specpdl_ptr
->old_value
);
2076 /* Note that a "binding" of nil is really an unwind protect,
2077 so in that case the "old value" is a list of forms to evaluate. */
2078 else if (NILP (specpdl_ptr
->symbol
))
2079 Fprogn (specpdl_ptr
->old_value
);
2081 Fset (specpdl_ptr
->symbol
, specpdl_ptr
->old_value
);
2083 if (NILP (Vquit_flag
) && quitf
) Vquit_flag
= Qt
;
2092 /* Get the value of symbol's global binding, even if that binding
2093 is not now dynamically visible. */
2096 top_level_value (symbol
)
2099 register struct specbinding
*ptr
= specpdl
;
2101 CHECK_SYMBOL (symbol
, 0);
2102 for (; ptr
!= specpdl_ptr
; ptr
++)
2104 if (EQ (ptr
->symbol
, symbol
))
2105 return ptr
->old_value
;
2107 return Fsymbol_value (symbol
);
2111 top_level_set (symbol
, newval
)
2112 Lisp_Object symbol
, newval
;
2114 register struct specbinding
*ptr
= specpdl
;
2116 CHECK_SYMBOL (symbol
, 0);
2117 for (; ptr
!= specpdl_ptr
; ptr
++)
2119 if (EQ (ptr
->symbol
, symbol
))
2121 ptr
->old_value
= newval
;
2125 return Fset (symbol
, newval
);
2130 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
2131 "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\
2132 The debugger is entered when that frame exits, if the flag is non-nil.")
2134 Lisp_Object level
, flag
;
2136 register struct backtrace
*backlist
= backtrace_list
;
2139 CHECK_NUMBER (level
, 0);
2141 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
2143 backlist
= backlist
->next
;
2147 backlist
->debug_on_exit
= !NILP (flag
);
2152 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
2153 "Print a trace of Lisp function calls currently active.\n\
2154 Output stream used is value of `standard-output'.")
2157 register struct backtrace
*backlist
= backtrace_list
;
2161 extern Lisp_Object Vprint_level
;
2162 struct gcpro gcpro1
;
2164 entering_debugger
= 0;
2166 XFASTINT (Vprint_level
) = 3;
2173 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
2174 if (backlist
->nargs
== UNEVALLED
)
2176 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
2180 tem
= *backlist
->function
;
2181 Fprin1 (tem
, Qnil
); /* This can QUIT */
2182 write_string ("(", -1);
2183 if (backlist
->nargs
== MANY
)
2185 for (tail
= *backlist
->args
, i
= 0;
2187 tail
= Fcdr (tail
), i
++)
2189 if (i
) write_string (" ", -1);
2190 Fprin1 (Fcar (tail
), Qnil
);
2195 for (i
= 0; i
< backlist
->nargs
; i
++)
2197 if (i
) write_string (" ", -1);
2198 Fprin1 (backlist
->args
[i
], Qnil
);
2202 write_string (")\n", -1);
2203 backlist
= backlist
->next
;
2206 Vprint_level
= Qnil
;
2211 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, "",
2212 "Return the function and arguments N frames up from current execution point.\n\
2213 If that frame has not evaluated the arguments yet (or is a special form),\n\
2214 the value is (nil FUNCTION ARG-FORMS...).\n\
2215 If that frame has evaluated its arguments and called its function already,\n\
2216 the value is (t FUNCTION ARG-VALUES...).\n\
2217 A &rest arg is represented as the tail of the list ARG-VALUES.\n\
2218 FUNCTION is whatever was supplied as car of evaluated list,\n\
2219 or a lambda expression for macro calls.\n\
2220 If N is more than the number of frames, the value is nil.")
2222 Lisp_Object nframes
;
2224 register struct backtrace
*backlist
= backtrace_list
;
2228 CHECK_NATNUM (nframes
, 0);
2230 /* Find the frame requested. */
2231 for (i
= 0; i
< XFASTINT (nframes
); i
++)
2232 backlist
= backlist
->next
;
2236 if (backlist
->nargs
== UNEVALLED
)
2237 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
2240 if (backlist
->nargs
== MANY
)
2241 tem
= *backlist
->args
;
2243 tem
= Flist (backlist
->nargs
, backlist
->args
);
2245 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
2251 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
2252 "Limit on number of Lisp variable bindings & unwind-protects before error.");
2254 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
2255 "Limit on depth in `eval', `apply' and `funcall' before error.\n\
2256 This limit is to catch infinite recursions for you before they cause\n\
2257 actual stack overflow in C, which would be fatal for Emacs.\n\
2258 You can safely make it considerably larger than its default value,\n\
2259 if that proves inconveniently small.");
2261 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
2262 "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
2263 Typing C-G sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
2266 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
2267 "Non-nil inhibits C-g quitting from happening immediately.\n\
2268 Note that `quit-flag' will still be set by typing C-g,\n\
2269 so a quit will be signalled as soon as `inhibit-quit' is nil.\n\
2270 To prevent this happening, set `quit-flag' to nil\n\
2271 before making `inhibit-quit' nil.");
2272 Vinhibit_quit
= Qnil
;
2274 Qinhibit_quit
= intern ("inhibit-quit");
2275 staticpro (&Qinhibit_quit
);
2277 Qautoload
= intern ("autoload");
2278 staticpro (&Qautoload
);
2280 Qdebug_on_error
= intern ("debug-on-error");
2281 staticpro (&Qdebug_on_error
);
2283 Qmacro
= intern ("macro");
2284 staticpro (&Qmacro
);
2286 /* Note that the process handling also uses Qexit, but we don't want
2287 to staticpro it twice, so we just do it here. */
2288 Qexit
= intern ("exit");
2291 Qinteractive
= intern ("interactive");
2292 staticpro (&Qinteractive
);
2294 Qcommandp
= intern ("commandp");
2295 staticpro (&Qcommandp
);
2297 Qdefun
= intern ("defun");
2298 staticpro (&Qdefun
);
2300 Qand_rest
= intern ("&rest");
2301 staticpro (&Qand_rest
);
2303 Qand_optional
= intern ("&optional");
2304 staticpro (&Qand_optional
);
2306 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
2307 "*Non-nil means automatically display a backtrace buffer\n\
2308 after any error that is handled by the editor command loop.\n\
2309 If the value is a list, an error only means to display a backtrace\n\
2310 if one of its condition symbols appears in the list.");
2311 Vstack_trace_on_error
= Qnil
;
2313 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
2314 "*Non-nil means enter debugger if an error is signaled.\n\
2315 Does not apply to errors handled by `condition-case'.\n\
2316 If the value is a list, an error only means to enter the debugger\n\
2317 if one of its condition symbols appears in the list.\n\
2318 See also variable `debug-on-quit'.");
2319 Vdebug_on_error
= Qnil
;
2321 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
2322 "*Non-nil means enter debugger if quit is signaled (C-G, for example).\n\
2323 Does not apply if quit is handled by a `condition-case'.
2324 A non-nil value is equivalent to a `debug-on-error' value containing 'quit.");
2327 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
2328 "Non-nil means enter debugger before next `eval', `apply' or `funcall'.");
2330 DEFVAR_LISP ("debugger", &Vdebugger
,
2331 "Function to call to invoke debugger.\n\
2332 If due to frame exit, args are `exit' and the value being returned;\n\
2333 this function's value will be returned instead of that.\n\
2334 If due to error, args are `error' and a list of the args to `signal'.\n\
2335 If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
2336 If due to `eval' entry, one arg, t.");
2339 Qmocklisp_arguments
= intern ("mocklisp-arguments");
2340 staticpro (&Qmocklisp_arguments
);
2341 DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments
,
2342 "While in a mocklisp function, the list of its unevaluated args.");
2343 Vmocklisp_arguments
= Qt
;
2345 DEFVAR_LISP ("run-hooks", &Vrun_hooks
,
2346 "Set to the function `run-hooks', if that function has been defined.\n\
2347 Otherwise, nil (in a bare Emacs without preloaded Lisp code).");
2350 staticpro (&Vautoload_queue
);
2351 Vautoload_queue
= Qnil
;
2362 defsubr (&Sfunction
);
2364 defsubr (&Sdefmacro
);
2366 defsubr (&Sdefconst
);
2367 defsubr (&Suser_variable_p
);
2371 defsubr (&Smacroexpand
);
2374 defsubr (&Sunwind_protect
);
2375 defsubr (&Scondition_case
);
2377 defsubr (&Sinteractive_p
);
2378 defsubr (&Scommandp
);
2379 defsubr (&Sautoload
);
2382 defsubr (&Sfuncall
);
2383 defsubr (&Sbacktrace_debug
);
2384 defsubr (&Sbacktrace
);
2385 defsubr (&Sbacktrace_frame
);