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
46 list of unevalled args */
48 /* Nonzero means call value of debugger when done with this operation. */
52 struct backtrace
*backtrace_list
;
58 struct catchtag
*next
;
61 struct backtrace
*backlist
;
62 struct handler
*handlerlist
;
65 int poll_suppress_count
;
68 struct catchtag
*catchlist
;
70 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
71 Lisp_Object Qinhibit_quit
, Vinhibit_quit
, Vquit_flag
;
72 Lisp_Object Qmocklisp_arguments
, Vmocklisp_arguments
, Qmocklisp
;
73 Lisp_Object Qand_rest
, Qand_optional
;
74 Lisp_Object Qdebug_on_error
;
76 Lisp_Object Vrun_hooks
;
78 /* Non-nil means record all fset's and provide's, to be undone
79 if the file being autoloaded is not fully loaded.
80 They are recorded by being consed onto the front of Vautoload_queue:
81 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */
83 Lisp_Object Vautoload_queue
;
85 /* Current number of specbindings allocated in specpdl. */
88 /* Pointer to beginning of specpdl. */
89 struct specbinding
*specpdl
;
91 /* Pointer to first unused element in specpdl. */
92 struct specbinding
*specpdl_ptr
;
94 /* Maximum size allowed for specpdl allocation */
97 /* Depth in Lisp evaluations and function calls. */
100 /* Maximum allowed depth in Lisp evaluations and function calls. */
101 int max_lisp_eval_depth
;
103 /* Nonzero means enter debugger before next function call */
104 int debug_on_next_call
;
106 /* List of conditions (non-nil atom means all) which cause a backtrace
107 if an error is handled by the command loop's error handler. */
108 Lisp_Object Vstack_trace_on_error
;
110 /* List of conditions (non-nil atom means all) which enter the debugger
111 if an error is handled by the command loop's error handler. */
112 Lisp_Object Vdebug_on_error
;
114 /* Nonzero means enter debugger if a quit signal
115 is handled by the command loop's error handler. */
118 /* Nonzero means we are trying to enter the debugger.
119 This is to prevent recursive attempts. */
120 int entering_debugger
;
122 Lisp_Object Vdebugger
;
124 void specbind (), record_unwind_protect ();
126 Lisp_Object
funcall_lambda ();
127 extern Lisp_Object
ml_apply (); /* Apply a mocklisp function to unevaluated argument list */
132 specpdl
= (struct specbinding
*) malloc (specpdl_size
* sizeof (struct specbinding
));
133 max_specpdl_size
= 600;
134 max_lisp_eval_depth
= 200;
139 specpdl_ptr
= specpdl
;
144 debug_on_next_call
= 0;
146 entering_debugger
= 0;
153 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
154 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
155 if (specpdl_size
+ 40 > max_specpdl_size
)
156 max_specpdl_size
= specpdl_size
+ 40;
157 debug_on_next_call
= 0;
158 entering_debugger
= 1;
159 return apply1 (Vdebugger
, arg
);
162 do_debug_on_call (code
)
165 debug_on_next_call
= 0;
166 backtrace_list
->debug_on_exit
= 1;
167 call_debugger (Fcons (code
, Qnil
));
170 /* NOTE!!! Every function that can call EVAL must protect its args
171 and temporaries from garbage collection while it needs them.
172 The definition of `For' shows what you have to do. */
174 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
175 "Eval args until one of them yields non-nil, then return that value.\n\
176 The remaining args are not evalled at all.\n\
177 If all args return nil, return nil.")
181 register Lisp_Object val
;
182 Lisp_Object args_left
;
193 val
= Feval (Fcar (args_left
));
196 args_left
= Fcdr (args_left
);
198 while (!NILP(args_left
));
204 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
205 "Eval args until one of them yields nil, then return nil.\n\
206 The remaining args are not evalled at all.\n\
207 If no arg yields nil, return the last arg's value.")
211 register Lisp_Object val
;
212 Lisp_Object args_left
;
223 val
= Feval (Fcar (args_left
));
226 args_left
= Fcdr (args_left
);
228 while (!NILP(args_left
));
234 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
235 "(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...\n\
236 Returns the value of THEN or the value of the last of the ELSE's.\n\
237 THEN must be one expression, but ELSE... can be zero or more expressions.\n\
238 If COND yields nil, and there are no ELSE's, the value is nil.")
242 register Lisp_Object cond
;
246 cond
= Feval (Fcar (args
));
250 return Feval (Fcar (Fcdr (args
)));
251 return Fprogn (Fcdr (Fcdr (args
)));
254 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
255 "(cond CLAUSES...): try each clause until one succeeds.\n\
256 Each clause looks like (CONDITION BODY...). CONDITION is evaluated\n\
257 and, if the value is non-nil, this clause succeeds:\n\
258 then the expressions in BODY are evaluated and the last one's\n\
259 value is the value of the cond-form.\n\
260 If no clause succeeds, cond returns nil.\n\
261 If a clause has one element, as in (CONDITION),\n\
262 CONDITION's value if non-nil is returned from the cond-form.")
266 register Lisp_Object clause
, val
;
273 clause
= Fcar (args
);
274 val
= Feval (Fcar (clause
));
277 if (!EQ (XCONS (clause
)->cdr
, Qnil
))
278 val
= Fprogn (XCONS (clause
)->cdr
);
281 args
= XCONS (args
)->cdr
;
288 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
289 "(progn BODY...): eval BODY forms sequentially and return value of last one.")
293 register Lisp_Object val
, tem
;
294 Lisp_Object args_left
;
297 /* In Mocklisp code, symbols at the front of the progn arglist
298 are to be bound to zero. */
299 if (!EQ (Vmocklisp_arguments
, Qt
))
301 val
= make_number (0);
302 while (!NILP (args
) && (tem
= Fcar (args
), XTYPE (tem
) == Lisp_Symbol
))
305 specbind (tem
, val
), args
= Fcdr (args
);
317 val
= Feval (Fcar (args_left
));
318 args_left
= Fcdr (args_left
);
320 while (!NILP(args_left
));
326 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
327 "(prog1 FIRST BODY...): eval FIRST and BODY sequentially; value from FIRST.\n\
328 The value of FIRST is saved during the evaluation of the remaining args,\n\
329 whose values are discarded.")
334 register Lisp_Object args_left
;
335 struct gcpro gcpro1
, gcpro2
;
336 register int argnum
= 0;
348 val
= Feval (Fcar (args_left
));
350 Feval (Fcar (args_left
));
351 args_left
= Fcdr (args_left
);
353 while (!NILP(args_left
));
359 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
360 "(prog1 X Y BODY...): eval X, Y and BODY sequentially; value from Y.\n\
361 The value of Y is saved during the evaluation of the remaining args,\n\
362 whose values are discarded.")
367 register Lisp_Object args_left
;
368 struct gcpro gcpro1
, gcpro2
;
369 register int argnum
= -1;
383 val
= Feval (Fcar (args_left
));
385 Feval (Fcar (args_left
));
386 args_left
= Fcdr (args_left
);
388 while (!NILP(args_left
));
394 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
395 "(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.\n\
396 The SYMs are not evaluated. Thus (setq x y) sets x to the value of y.\n\
397 Each SYM is set before the next VAL is computed.")
401 register Lisp_Object args_left
;
402 register Lisp_Object val
, sym
;
413 val
= Feval (Fcar (Fcdr (args_left
)));
414 sym
= Fcar (args_left
);
416 args_left
= Fcdr (Fcdr (args_left
));
418 while (!NILP(args_left
));
424 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
425 "Return the argument, without evaluating it. `(quote x)' yields `x'.")
432 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
433 "Like `quote', but preferred for objects which are functions.\n\
434 In byte compilation, `function' causes its argument to be compiled.\n\
435 `quote' cannot do that.")
442 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
443 "Return t if function in which this appears was called interactively.\n\
444 This means that the function was called with call-interactively (which\n\
445 includes being called as the binding of a key)\n\
446 and input is currently coming from the keyboard (not in keyboard macro).")
449 register struct backtrace
*btp
;
450 register Lisp_Object fun
;
455 btp
= backtrace_list
;
457 /* If this isn't a byte-compiled function, there may be a frame at
458 the top for Finteractive_p itself. If so, skip it. */
459 fun
= Findirect_function (*btp
->function
);
460 if (XTYPE (fun
) == Lisp_Subr
461 && (struct Lisp_Subr
*) XPNTR (fun
) == &Sinteractive_p
)
464 /* If we're running an Emacs 18-style byte-compiled function, there
465 may be a frame for Fbytecode. Now, given the strictest
466 definition, this function isn't really being called
467 interactively, but because that's the way Emacs 18 always builds
468 byte-compiled functions, we'll accept it for now. */
469 if (EQ (*btp
->function
, Qbytecode
))
472 /* If this isn't a byte-compiled function, then we may now be
473 looking at several frames for special forms. Skip past them. */
475 btp
->nargs
== UNEVALLED
)
478 /* btp now points at the frame of the innermost function that isn't
479 a special form, ignoring frames for Finteractive_p and/or
480 Fbytecode at the top. If this frame is for a built-in function
481 (such as load or eval-region) return nil. */
482 fun
= Findirect_function (*btp
->function
);
483 if (XTYPE (fun
) == Lisp_Subr
)
485 /* btp points to the frame of a Lisp function that called interactive-p.
486 Return t if that function was called interactively. */
487 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
492 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
493 "(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.\n\
494 The definition is (lambda ARGLIST [DOCSTRING] BODY...).\n\
495 See also the function `interactive'.")
499 register Lisp_Object fn_name
;
500 register Lisp_Object defn
;
502 fn_name
= Fcar (args
);
503 defn
= Fcons (Qlambda
, Fcdr (args
));
504 if (!NILP (Vpurify_flag
))
505 defn
= Fpurecopy (defn
);
506 Ffset (fn_name
, defn
);
510 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
511 "(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.\n\
512 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).\n\
513 When the macro is called, as in (NAME ARGS...),\n\
514 the function (lambda ARGLIST BODY...) is applied to\n\
515 the list ARGS... as it appears in the expression,\n\
516 and the result should be a form to be evaluated instead of the original.")
520 register Lisp_Object fn_name
;
521 register Lisp_Object defn
;
523 fn_name
= Fcar (args
);
524 defn
= Fcons (Qmacro
, Fcons (Qlambda
, Fcdr (args
)));
525 if (!NILP (Vpurify_flag
))
526 defn
= Fpurecopy (defn
);
527 Ffset (fn_name
, defn
);
531 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
532 "(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.\n\
533 You are not required to define a variable in order to use it,\n\
534 but the definition can supply documentation and an initial value\n\
535 in a way that tags can recognize.\n\n\
536 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.\n\
537 If SYMBOL is buffer-local, its default value is what is set;\n\
538 buffer-local values are not affected.\n\
539 INITVALUE and DOCSTRING are optional.\n\
540 If DOCSTRING starts with *, this variable is identified as a user option.\n\
541 This means that M-x set-variable and M-x edit-options recognize it.\n\
542 If INITVALUE is missing, SYMBOL's value is not set.")
546 register Lisp_Object sym
, tem
;
552 tem
= Fdefault_boundp (sym
);
554 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
556 tem
= Fcar (Fcdr (Fcdr (args
)));
559 if (!NILP (Vpurify_flag
))
560 tem
= Fpurecopy (tem
);
561 Fput (sym
, Qvariable_documentation
, tem
);
566 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
567 "(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant variable.\n\
568 The intent is that programs do not change this value, but users may.\n\
569 Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\
570 If SYMBOL is buffer-local, its default value is what is set;\n\
571 buffer-local values are not affected.\n\
572 DOCSTRING is optional.\n\
573 If DOCSTRING starts with *, this variable is identified as a user option.\n\
574 This means that M-x set-variable and M-x edit-options recognize it.\n\n\
575 Note: do not use `defconst' for user options in libraries that are not\n\
576 normally loaded, since it is useful for users to be able to specify\n\
577 their own values for such variables before loading the library.\n\
578 Since `defconst' unconditionally assigns the variable,\n\
579 it would override the user's choice.")
583 register Lisp_Object sym
, tem
;
586 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
587 tem
= Fcar (Fcdr (Fcdr (args
)));
590 if (!NILP (Vpurify_flag
))
591 tem
= Fpurecopy (tem
);
592 Fput (sym
, Qvariable_documentation
, tem
);
597 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
598 "Returns t if VARIABLE is intended to be set and modified by users.\n\
599 \(The alternative is a variable used internally in a Lisp program.)\n\
600 Determined by whether the first character of the documentation\n\
601 for the variable is \"*\"")
603 Lisp_Object variable
;
605 Lisp_Object documentation
;
607 documentation
= Fget (variable
, Qvariable_documentation
);
608 if (XTYPE (documentation
) == Lisp_Int
&& XINT (documentation
) < 0)
610 if ((XTYPE (documentation
) == Lisp_String
) &&
611 ((unsigned char) XSTRING (documentation
)->data
[0] == '*'))
616 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
617 "(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
618 The value of the last form in BODY is returned.\n\
619 Each element of VARLIST is a symbol (which is bound to nil)\n\
620 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
621 Each VALUEFORM can refer to the symbols already bound by this VARLIST.")
625 Lisp_Object varlist
, val
, elt
;
626 int count
= specpdl_ptr
- specpdl
;
627 struct gcpro gcpro1
, gcpro2
, gcpro3
;
629 GCPRO3 (args
, elt
, varlist
);
631 varlist
= Fcar (args
);
632 while (!NILP (varlist
))
635 elt
= Fcar (varlist
);
636 if (XTYPE (elt
) == Lisp_Symbol
)
637 specbind (elt
, Qnil
);
638 else if (! NILP (Fcdr (Fcdr (elt
))))
640 Fcons (build_string ("`let' bindings can have only one value-form"),
644 val
= Feval (Fcar (Fcdr (elt
)));
645 specbind (Fcar (elt
), val
);
647 varlist
= Fcdr (varlist
);
650 val
= Fprogn (Fcdr (args
));
651 return unbind_to (count
, val
);
654 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
655 "(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
656 The value of the last form in BODY is returned.\n\
657 Each element of VARLIST is a symbol (which is bound to nil)\n\
658 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
659 All the VALUEFORMs are evalled before any symbols are bound.")
663 Lisp_Object
*temps
, tem
;
664 register Lisp_Object elt
, varlist
;
665 int count
= specpdl_ptr
- specpdl
;
667 struct gcpro gcpro1
, gcpro2
;
669 varlist
= Fcar (args
);
671 /* Make space to hold the values to give the bound variables */
672 elt
= Flength (varlist
);
673 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
675 /* Compute the values and store them in `temps' */
677 GCPRO2 (args
, *temps
);
680 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
683 elt
= Fcar (varlist
);
684 if (XTYPE (elt
) == Lisp_Symbol
)
685 temps
[argnum
++] = Qnil
;
686 else if (! NILP (Fcdr (Fcdr (elt
))))
688 Fcons (build_string ("`let' bindings can have only one value-form"),
691 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
692 gcpro2
.nvars
= argnum
;
696 varlist
= Fcar (args
);
697 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
699 elt
= Fcar (varlist
);
700 tem
= temps
[argnum
++];
701 if (XTYPE (elt
) == Lisp_Symbol
)
704 specbind (Fcar (elt
), tem
);
707 elt
= Fprogn (Fcdr (args
));
708 return unbind_to (count
, elt
);
711 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
712 "(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.\n\
713 The order of execution is thus TEST, BODY, TEST, BODY and so on\n\
714 until TEST returns nil.")
718 Lisp_Object test
, body
, tem
;
719 struct gcpro gcpro1
, gcpro2
;
725 while (tem
= Feval (test
), !NILP (tem
))
735 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
736 "Return result of expanding macros at top level of FORM.\n\
737 If FORM is not a macro call, it is returned unchanged.\n\
738 Otherwise, the macro is expanded and the expansion is considered\n\
739 in place of FORM. When a non-macro-call results, it is returned.\n\n\
740 The second optional arg ENVIRONMENT species an environment of macro\n\
741 definitions to shadow the loaded ones for use in file byte-compilation.")
743 register Lisp_Object form
;
746 /* With cleanups from Hallvard Furuseth. */
747 register Lisp_Object expander
, sym
, def
, tem
;
751 /* Come back here each time we expand a macro call,
752 in case it expands into another macro call. */
753 if (XTYPE (form
) != Lisp_Cons
)
755 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
756 def
= sym
= XCONS (form
)->car
;
758 /* Trace symbols aliases to other symbols
759 until we get a symbol that is not an alias. */
760 while (XTYPE (def
) == Lisp_Symbol
)
764 tem
= Fassq (sym
, env
);
767 def
= XSYMBOL (sym
)->function
;
768 if (!EQ (def
, Qunbound
))
773 /* Right now TEM is the result from SYM in ENV,
774 and if TEM is nil then DEF is SYM's function definition. */
777 /* SYM is not mentioned in ENV.
778 Look at its function definition. */
779 if (EQ (def
, Qunbound
)
780 || XTYPE (def
) != Lisp_Cons
)
781 /* Not defined or definition not suitable */
783 if (EQ (XCONS (def
)->car
, Qautoload
))
785 /* Autoloading function: will it be a macro when loaded? */
786 tem
= Fcar (Fnthcdr (make_number (4), def
));
789 /* Yes, load it and try again. */
790 do_autoload (def
, sym
);
793 else if (!EQ (XCONS (def
)->car
, Qmacro
))
795 else expander
= XCONS (def
)->cdr
;
799 expander
= XCONS (tem
)->cdr
;
803 form
= apply1 (expander
, XCONS (form
)->cdr
);
808 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
809 "(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.\n\
810 TAG is evalled to get the tag to use. Then the BODY is executed.\n\
811 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.\n\
812 If no throw happens, `catch' returns the value of the last BODY form.\n\
813 If a throw happens, it specifies the value to return from `catch'.")
817 register Lisp_Object tag
;
821 tag
= Feval (Fcar (args
));
823 return internal_catch (tag
, Fprogn
, Fcdr (args
));
826 /* Set up a catch, then call C function FUNC on argument ARG.
827 FUNC should return a Lisp_Object.
828 This is how catches are done from within C code. */
831 internal_catch (tag
, func
, arg
)
833 Lisp_Object (*func
) ();
836 /* This structure is made part of the chain `catchlist'. */
839 /* Fill in the components of c, and put it on the list. */
843 c
.backlist
= backtrace_list
;
844 c
.handlerlist
= handlerlist
;
845 c
.lisp_eval_depth
= lisp_eval_depth
;
846 c
.pdlcount
= specpdl_ptr
- specpdl
;
847 c
.poll_suppress_count
= poll_suppress_count
;
852 if (! _setjmp (c
.jmp
))
853 c
.val
= (*func
) (arg
);
855 /* Throw works by a longjmp that comes right here. */
860 /* Discard from the catchlist all catch tags back through CATCH.
861 Before each catch is discarded, unbind all special bindings
862 made within that catch. Also, when discarding a catch that
863 corresponds to a condition handler, discard that handler.
865 At the end, restore some static info saved in CATCH.
867 This is used for correct unwinding in Fthrow and Fsignal,
868 before doing the longjmp that actually destroys the stack frames
869 in which these handlers and catches reside. */
873 struct catchtag
*catch;
875 register int last_time
;
879 last_time
= catchlist
== catch;
880 unbind_to (catchlist
->pdlcount
, Qnil
);
881 handlerlist
= catchlist
->handlerlist
;
882 catchlist
= catchlist
->next
;
886 gcprolist
= catch->gcpro
;
887 backtrace_list
= catch->backlist
;
888 lisp_eval_depth
= catch->lisp_eval_depth
;
891 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
892 "(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.\n\
893 Both TAG and VALUE are evalled.")
895 register Lisp_Object tag
, val
;
897 register struct catchtag
*c
;
902 for (c
= catchlist
; c
; c
= c
->next
)
904 if (EQ (c
->tag
, tag
))
906 /* Restore the polling-suppression count. */
907 if (c
->poll_suppress_count
> poll_suppress_count
)
909 while (c
->poll_suppress_count
< poll_suppress_count
)
913 _longjmp (c
->jmp
, 1);
916 tag
= Fsignal (Qno_catch
, Fcons (tag
, Fcons (val
, Qnil
)));
921 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
922 "Do BODYFORM, protecting with UNWINDFORMS.\n\
923 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).\n\
924 If BODYFORM completes normally, its value is returned\n\
925 after executing the UNWINDFORMS.\n\
926 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.")
931 int count
= specpdl_ptr
- specpdl
;
933 record_unwind_protect (0, Fcdr (args
));
934 val
= Feval (Fcar (args
));
935 return unbind_to (count
, val
);
938 /* Chain of condition handlers currently in effect.
939 The elements of this chain are contained in the stack frames
940 of Fcondition_case and internal_condition_case.
941 When an error is signaled (by calling Fsignal, below),
942 this chain is searched for an element that applies. */
944 struct handler
*handlerlist
;
946 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
947 "Regain control when an error is signaled.\n\
948 Usage looks like (condition-case VAR BODYFORM HANDLERS...).\n\
949 executes BODYFORM and returns its value if no error happens.\n\
950 Each element of HANDLERS looks like (CONDITION-NAME BODY...)\n\
951 where the BODY is made of Lisp expressions.\n\n\
952 A handler is applicable to an error\n\
953 if CONDITION-NAME is one of the error's condition names.\n\
954 If an error happens, the first applicable handler is run.\n\
956 When a handler handles an error,\n\
957 control returns to the condition-case and the handler BODY... is executed\n\
958 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\
959 VAR may be nil; then you do not get access to the signal information.\n\
961 The value of the last BODY form is returned from the condition-case.\n\
962 See also the function `signal' for more info.")
969 register Lisp_Object tem
;
972 CHECK_SYMBOL (tem
, 0);
976 c
.backlist
= backtrace_list
;
977 c
.handlerlist
= handlerlist
;
978 c
.lisp_eval_depth
= lisp_eval_depth
;
979 c
.pdlcount
= specpdl_ptr
- specpdl
;
980 c
.poll_suppress_count
= poll_suppress_count
;
985 specbind (h
.var
, Fcdr (c
.val
));
986 val
= Fprogn (Fcdr (Fcar (c
.val
)));
987 unbind_to (c
.pdlcount
, Qnil
);
993 h
.handler
= Fcdr (Fcdr (args
));
995 for (val
= h
.handler
; ! NILP (val
); val
= Fcdr (val
))
999 (!CONSP (tem
) || (XTYPE (XCONS (tem
)->car
) != Lisp_Symbol
)))
1000 error ("Invalid condition handler", tem
);
1003 h
.next
= handlerlist
;
1004 h
.poll_suppress_count
= poll_suppress_count
;
1008 val
= Feval (Fcar (Fcdr (args
)));
1010 handlerlist
= h
.next
;
1015 internal_condition_case (bfun
, handlers
, hfun
)
1016 Lisp_Object (*bfun
) ();
1017 Lisp_Object handlers
;
1018 Lisp_Object (*hfun
) ();
1026 c
.backlist
= backtrace_list
;
1027 c
.handlerlist
= handlerlist
;
1028 c
.lisp_eval_depth
= lisp_eval_depth
;
1029 c
.pdlcount
= specpdl_ptr
- specpdl
;
1030 c
.poll_suppress_count
= poll_suppress_count
;
1031 c
.gcpro
= gcprolist
;
1032 if (_setjmp (c
.jmp
))
1034 return (*hfun
) (Fcdr (c
.val
));
1038 h
.handler
= handlers
;
1040 h
.poll_suppress_count
= poll_suppress_count
;
1041 h
.next
= handlerlist
;
1047 handlerlist
= h
.next
;
1051 static Lisp_Object
find_handler_clause ();
1053 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1054 "Signal an error. Args are SIGNAL-NAME, and associated DATA.\n\
1055 This function does not return.\n\n\
1056 A signal name is a symbol with an `error-conditions' property\n\
1057 that is a list of condition names.\n\
1058 A handler for any of those names will get to handle this signal.\n\
1059 The symbol `error' should normally be one of them.\n\
1061 DATA should be a list. Its elements are printed as part of the error message.\n\
1062 If the signal is handled, DATA is made available to the handler.\n\
1063 See also the function `condition-case'.")
1065 Lisp_Object sig
, data
;
1067 register struct handler
*allhandlers
= handlerlist
;
1068 Lisp_Object conditions
;
1069 extern int gc_in_progress
;
1070 extern int waiting_for_input
;
1071 Lisp_Object debugger_value
;
1073 quit_error_check ();
1075 if (gc_in_progress
|| waiting_for_input
)
1078 #ifdef HAVE_X_WINDOWS
1079 TOTALLY_UNBLOCK_INPUT
;
1082 conditions
= Fget (sig
, Qerror_conditions
);
1084 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1086 register Lisp_Object clause
;
1087 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1088 sig
, data
, &debugger_value
);
1090 #if 0 /* Most callers are not prepared to handle gc if this returns.
1091 So, since this feature is not very useful, take it out. */
1092 /* If have called debugger and user wants to continue,
1094 if (EQ (clause
, Qlambda
))
1095 return debugger_value
;
1097 if (EQ (clause
, Qlambda
))
1098 error ("Returning a value from an error is no longer supported");
1103 struct handler
*h
= handlerlist
;
1104 /* Restore the polling-suppression count. */
1105 if (h
->poll_suppress_count
> poll_suppress_count
)
1107 while (h
->poll_suppress_count
< poll_suppress_count
)
1109 handlerlist
= allhandlers
;
1110 unbind_catch (h
->tag
);
1111 h
->tag
->val
= Fcons (clause
, Fcons (sig
, data
));
1112 _longjmp (h
->tag
->jmp
, 1);
1116 handlerlist
= allhandlers
;
1117 /* If no handler is present now, try to run the debugger,
1118 and if that fails, throw to top level. */
1119 find_handler_clause (Qerror
, conditions
, sig
, data
, &debugger_value
);
1120 Fthrow (Qtop_level
, Qt
);
1123 /* Return nonzero iff LIST is a non-nil atom or
1124 a list containing one of CONDITIONS. */
1127 wants_debugger (list
, conditions
)
1128 Lisp_Object list
, conditions
;
1130 static int looking
= 0;
1134 /* We got an error while looking in LIST. */
1145 while (!NILP (conditions
))
1148 tem
= Fmemq (XCONS (conditions
)->car
, list
);
1154 conditions
= XCONS (conditions
)->cdr
;
1158 /* Value of Qlambda means we have called debugger and user has continued.
1159 Store value returned from debugger into *DEBUGGER_VALUE_PTR. */
1162 find_handler_clause (handlers
, conditions
, sig
, data
, debugger_value_ptr
)
1163 Lisp_Object handlers
, conditions
, sig
, data
;
1164 Lisp_Object
*debugger_value_ptr
;
1166 register Lisp_Object h
;
1167 register Lisp_Object tem
;
1168 register Lisp_Object tem1
;
1170 if (EQ (handlers
, Qt
)) /* t is used by handlers for all conditions, set up by C code. */
1172 if (EQ (handlers
, Qerror
)) /* error is used similarly, but means display a backtrace too */
1174 if (wants_debugger (Vstack_trace_on_error
, conditions
))
1175 internal_with_output_to_temp_buffer ("*Backtrace*", Fbacktrace
, Qnil
);
1176 if (!entering_debugger
1177 && ((EQ (sig
, Qquit
) && debug_on_quit
)
1178 || wants_debugger (Vdebug_on_error
, conditions
)))
1180 int count
= specpdl_ptr
- specpdl
;
1181 specbind (Qdebug_on_error
, Qnil
);
1182 *debugger_value_ptr
=
1183 call_debugger (Fcons (Qerror
,
1184 Fcons (Fcons (sig
, data
),
1186 return unbind_to (count
, Qlambda
);
1190 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1195 tem
= Fmemq (Fcar (tem1
), conditions
);
1202 /* dump an error message; called like printf */
1206 error (m
, a1
, a2
, a3
)
1210 sprintf (buf
, m
, a1
, a2
, a3
);
1213 Fsignal (Qerror
, Fcons (build_string (buf
), Qnil
));
1216 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 1, 0,
1217 "T if FUNCTION makes provisions for interactive calling.\n\
1218 This means it contains a description for how to read arguments to give it.\n\
1219 The value is nil for an invalid function or a symbol with no function\n\
1222 Interactively callable functions include strings and vectors (treated\n\
1223 as keyboard macros), lambda-expressions that contain a top-level call\n\
1224 to `interactive', autoload definitions made by `autoload' with non-nil\n\
1225 fourth argument, and some of the built-in functions of Lisp.\n\
1227 Also, a symbol satisfies `commandp' if its function definition does so.")
1229 Lisp_Object function
;
1231 register Lisp_Object fun
;
1232 register Lisp_Object funcar
;
1233 register Lisp_Object tem
;
1238 fun
= indirect_function (fun
);
1239 if (EQ (fun
, Qunbound
))
1242 /* Emacs primitives are interactive if their DEFUN specifies an
1243 interactive spec. */
1244 if (XTYPE (fun
) == Lisp_Subr
)
1246 if (XSUBR (fun
)->prompt
)
1252 /* Bytecode objects are interactive if they are long enough to
1253 have an element whose index is COMPILED_INTERACTIVE, which is
1254 where the interactive spec is stored. */
1255 else if (XTYPE (fun
) == Lisp_Compiled
)
1256 return (XVECTOR (fun
)->size
> COMPILED_INTERACTIVE
1259 /* Strings and vectors are keyboard macros. */
1260 if (XTYPE (fun
) == Lisp_String
1261 || XTYPE (fun
) == Lisp_Vector
)
1264 /* Lists may represent commands. */
1267 funcar
= Fcar (fun
);
1268 if (XTYPE (funcar
) != Lisp_Symbol
)
1269 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1270 if (EQ (funcar
, Qlambda
))
1271 return Fassq (Qinteractive
, Fcdr (Fcdr (fun
)));
1272 if (EQ (funcar
, Qmocklisp
))
1273 return Qt
; /* All mocklisp functions can be called interactively */
1274 if (EQ (funcar
, Qautoload
))
1275 return Fcar (Fcdr (Fcdr (Fcdr (fun
))));
1281 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1282 "Define FUNCTION to autoload from FILE.\n\
1283 FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\
1284 Third arg DOCSTRING is documentation for the function.\n\
1285 Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\
1286 Fifth arg MACRO if non-nil says the function is really a macro.\n\
1287 Third through fifth args give info about the real definition.\n\
1288 They default to nil.\n\
1289 If FUNCTION is already defined other than as an autoload,\n\
1290 this does nothing and returns nil.")
1291 (function
, file
, docstring
, interactive
, macro
)
1292 Lisp_Object function
, file
, docstring
, interactive
, macro
;
1295 Lisp_Object args
[4];
1298 CHECK_SYMBOL (function
, 0);
1299 CHECK_STRING (file
, 1);
1301 /* If function is defined and not as an autoload, don't override */
1302 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
1303 && !(XTYPE (XSYMBOL (function
)->function
) == Lisp_Cons
1304 && EQ (XCONS (XSYMBOL (function
)->function
)->car
, Qautoload
)))
1309 args
[1] = docstring
;
1310 args
[2] = interactive
;
1313 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
1314 #else /* NO_ARG_ARRAY */
1315 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
1316 #endif /* not NO_ARG_ARRAY */
1320 un_autoload (oldqueue
)
1321 Lisp_Object oldqueue
;
1323 register Lisp_Object queue
, first
, second
;
1325 /* Queue to unwind is current value of Vautoload_queue.
1326 oldqueue is the shadowed value to leave in Vautoload_queue. */
1327 queue
= Vautoload_queue
;
1328 Vautoload_queue
= oldqueue
;
1329 while (CONSP (queue
))
1331 first
= Fcar (queue
);
1332 second
= Fcdr (first
);
1333 first
= Fcar (first
);
1334 if (EQ (second
, Qnil
))
1337 Ffset (first
, second
);
1338 queue
= Fcdr (queue
);
1343 do_autoload (fundef
, funname
)
1344 Lisp_Object fundef
, funname
;
1346 int count
= specpdl_ptr
- specpdl
;
1347 Lisp_Object fun
, val
;
1350 CHECK_SYMBOL (funname
, 0);
1352 /* Value saved here is to be restored into Vautoload_queue */
1353 record_unwind_protect (un_autoload
, Vautoload_queue
);
1354 Vautoload_queue
= Qt
;
1355 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
);
1356 /* Once loading finishes, don't undo it. */
1357 Vautoload_queue
= Qt
;
1358 unbind_to (count
, Qnil
);
1360 fun
= Findirect_function (fun
);
1362 if (XTYPE (fun
) == Lisp_Cons
1363 && EQ (XCONS (fun
)->car
, Qautoload
))
1364 error ("Autoloading failed to define function %s",
1365 XSYMBOL (funname
)->name
->data
);
1368 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
1369 "Evaluate FORM and return its value.")
1373 Lisp_Object fun
, val
, original_fun
, original_args
;
1375 struct backtrace backtrace
;
1376 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1378 if (XTYPE (form
) == Lisp_Symbol
)
1380 if (EQ (Vmocklisp_arguments
, Qt
))
1381 return Fsymbol_value (form
);
1382 val
= Fsymbol_value (form
);
1385 else if (EQ (val
, Qt
))
1393 if (consing_since_gc
> gc_cons_threshold
)
1396 Fgarbage_collect ();
1400 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1402 if (max_lisp_eval_depth
< 100)
1403 max_lisp_eval_depth
= 100;
1404 if (lisp_eval_depth
> max_lisp_eval_depth
)
1405 error ("Lisp nesting exceeds max-lisp-eval-depth");
1408 original_fun
= Fcar (form
);
1409 original_args
= Fcdr (form
);
1411 backtrace
.next
= backtrace_list
;
1412 backtrace_list
= &backtrace
;
1413 backtrace
.function
= &original_fun
; /* This also protects them from gc */
1414 backtrace
.args
= &original_args
;
1415 backtrace
.nargs
= UNEVALLED
;
1416 backtrace
.evalargs
= 1;
1417 backtrace
.debug_on_exit
= 0;
1419 if (debug_on_next_call
)
1420 do_debug_on_call (Qt
);
1422 /* At this point, only original_fun and original_args
1423 have values that will be used below */
1425 fun
= Findirect_function (original_fun
);
1427 if (XTYPE (fun
) == Lisp_Subr
)
1429 Lisp_Object numargs
;
1430 Lisp_Object argvals
[7];
1431 Lisp_Object args_left
;
1432 register int i
, maxargs
;
1434 args_left
= original_args
;
1435 numargs
= Flength (args_left
);
1437 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
1438 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
1439 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1441 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1443 backtrace
.evalargs
= 0;
1444 val
= (*XSUBR (fun
)->function
) (args_left
);
1448 if (XSUBR (fun
)->max_args
== MANY
)
1450 /* Pass a vector of evaluated arguments */
1452 register int argnum
= 0;
1454 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1456 GCPRO3 (args_left
, fun
, fun
);
1460 while (!NILP (args_left
))
1462 vals
[argnum
++] = Feval (Fcar (args_left
));
1463 args_left
= Fcdr (args_left
);
1464 gcpro3
.nvars
= argnum
;
1467 backtrace
.args
= vals
;
1468 backtrace
.nargs
= XINT (numargs
);
1470 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
1475 GCPRO3 (args_left
, fun
, fun
);
1476 gcpro3
.var
= argvals
;
1479 maxargs
= XSUBR (fun
)->max_args
;
1480 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
1482 argvals
[i
] = Feval (Fcar (args_left
));
1488 backtrace
.args
= argvals
;
1489 backtrace
.nargs
= XINT (numargs
);
1494 val
= (*XSUBR (fun
)->function
) ();
1497 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
1500 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
1503 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1507 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1508 argvals
[2], argvals
[3]);
1511 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1512 argvals
[3], argvals
[4]);
1515 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1516 argvals
[3], argvals
[4], argvals
[5]);
1520 /* Someone has created a subr that takes more arguments than
1521 is supported by this code. We need to either rewrite the
1522 subr to use a different argument protocol, or add more
1523 cases to this switch. */
1527 if (XTYPE (fun
) == Lisp_Compiled
)
1528 val
= apply_lambda (fun
, original_args
, 1);
1532 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1533 funcar
= Fcar (fun
);
1534 if (XTYPE (funcar
) != Lisp_Symbol
)
1535 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1536 if (EQ (funcar
, Qautoload
))
1538 do_autoload (fun
, original_fun
);
1541 if (EQ (funcar
, Qmacro
))
1542 val
= Feval (apply1 (Fcdr (fun
), original_args
));
1543 else if (EQ (funcar
, Qlambda
))
1544 val
= apply_lambda (fun
, original_args
, 1);
1545 else if (EQ (funcar
, Qmocklisp
))
1546 val
= ml_apply (fun
, original_args
);
1548 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1551 if (!EQ (Vmocklisp_arguments
, Qt
))
1555 else if (EQ (val
, Qt
))
1559 if (backtrace
.debug_on_exit
)
1560 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
1561 backtrace_list
= backtrace
.next
;
1565 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
1566 "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
1567 Thus, (apply '+ 1 2 '(3 4)) returns 10.")
1572 register int i
, numargs
;
1573 register Lisp_Object spread_arg
;
1574 register Lisp_Object
*funcall_args
;
1576 struct gcpro gcpro1
;
1580 spread_arg
= args
[nargs
- 1];
1581 CHECK_LIST (spread_arg
, nargs
);
1583 numargs
= XINT (Flength (spread_arg
));
1586 return Ffuncall (nargs
- 1, args
);
1587 else if (numargs
== 1)
1589 args
[nargs
- 1] = XCONS (spread_arg
)->car
;
1590 return Ffuncall (nargs
, args
);
1593 numargs
+= nargs
- 2;
1595 fun
= indirect_function (fun
);
1596 if (EQ (fun
, Qunbound
))
1598 /* Let funcall get the error */
1603 if (XTYPE (fun
) == Lisp_Subr
)
1605 if (numargs
< XSUBR (fun
)->min_args
1606 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
1607 goto funcall
; /* Let funcall get the error */
1608 else if (XSUBR (fun
)->max_args
> numargs
)
1610 /* Avoid making funcall cons up a yet another new vector of arguments
1611 by explicitly supplying nil's for optional values */
1612 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
1613 * sizeof (Lisp_Object
));
1614 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
1615 funcall_args
[++i
] = Qnil
;
1616 GCPRO1 (*funcall_args
);
1617 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
1621 /* We add 1 to numargs because funcall_args includes the
1622 function itself as well as its arguments. */
1625 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
1626 * sizeof (Lisp_Object
));
1627 GCPRO1 (*funcall_args
);
1628 gcpro1
.nvars
= 1 + numargs
;
1631 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
1632 /* Spread the last arg we got. Its first element goes in
1633 the slot that it used to occupy, hence this value of I. */
1635 while (!NILP (spread_arg
))
1637 funcall_args
[i
++] = XCONS (spread_arg
)->car
;
1638 spread_arg
= XCONS (spread_arg
)->cdr
;
1641 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
1644 /* Apply fn to arg */
1647 Lisp_Object fn
, arg
;
1649 struct gcpro gcpro1
;
1653 RETURN_UNGCPRO (Ffuncall (1, &fn
));
1657 Lisp_Object args
[2];
1661 RETURN_UNGCPRO (Fapply (2, args
));
1663 #else /* not NO_ARG_ARRAY */
1664 RETURN_UNGCPRO (Fapply (2, &fn
));
1665 #endif /* not NO_ARG_ARRAY */
1668 /* Call function fn on no arguments */
1673 struct gcpro gcpro1
;
1676 RETURN_UNGCPRO (Ffuncall (1, &fn
));
1679 /* Call function fn with argument arg */
1683 Lisp_Object fn
, arg
;
1685 struct gcpro gcpro1
;
1687 Lisp_Object args
[2];
1693 RETURN_UNGCPRO (Ffuncall (2, args
));
1694 #else /* not NO_ARG_ARRAY */
1697 RETURN_UNGCPRO (Ffuncall (2, &fn
));
1698 #endif /* not NO_ARG_ARRAY */
1701 /* Call function fn with arguments arg, arg1 */
1704 call2 (fn
, arg
, arg1
)
1705 Lisp_Object fn
, arg
, arg1
;
1707 struct gcpro gcpro1
;
1709 Lisp_Object args
[3];
1715 RETURN_UNGCPRO (Ffuncall (3, args
));
1716 #else /* not NO_ARG_ARRAY */
1719 RETURN_UNGCPRO (Ffuncall (3, &fn
));
1720 #endif /* not NO_ARG_ARRAY */
1723 /* Call function fn with arguments arg, arg1, arg2 */
1726 call3 (fn
, arg
, arg1
, arg2
)
1727 Lisp_Object fn
, arg
, arg1
, arg2
;
1729 struct gcpro gcpro1
;
1731 Lisp_Object args
[4];
1738 RETURN_UNGCPRO (Ffuncall (4, args
));
1739 #else /* not NO_ARG_ARRAY */
1742 RETURN_UNGCPRO (Ffuncall (4, &fn
));
1743 #endif /* not NO_ARG_ARRAY */
1746 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
1747 "Call first argument as a function, passing remaining arguments to it.\n\
1748 Thus, (funcall 'cons 'x 'y) returns (x . y).")
1755 int numargs
= nargs
- 1;
1756 Lisp_Object lisp_numargs
;
1758 struct backtrace backtrace
;
1759 register Lisp_Object
*internal_args
;
1763 if (consing_since_gc
> gc_cons_threshold
)
1764 Fgarbage_collect ();
1766 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1768 if (max_lisp_eval_depth
< 100)
1769 max_lisp_eval_depth
= 100;
1770 if (lisp_eval_depth
> max_lisp_eval_depth
)
1771 error ("Lisp nesting exceeds max-lisp-eval-depth");
1774 backtrace
.next
= backtrace_list
;
1775 backtrace_list
= &backtrace
;
1776 backtrace
.function
= &args
[0];
1777 backtrace
.args
= &args
[1];
1778 backtrace
.nargs
= nargs
- 1;
1779 backtrace
.evalargs
= 0;
1780 backtrace
.debug_on_exit
= 0;
1782 if (debug_on_next_call
)
1783 do_debug_on_call (Qlambda
);
1789 fun
= Findirect_function (fun
);
1791 if (XTYPE (fun
) == Lisp_Subr
)
1793 if (numargs
< XSUBR (fun
)->min_args
1794 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
1796 XFASTINT (lisp_numargs
) = numargs
;
1797 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (lisp_numargs
, Qnil
)));
1800 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1801 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1803 if (XSUBR (fun
)->max_args
== MANY
)
1805 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
1809 if (XSUBR (fun
)->max_args
> numargs
)
1811 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
1812 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
1813 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
1814 internal_args
[i
] = Qnil
;
1817 internal_args
= args
+ 1;
1818 switch (XSUBR (fun
)->max_args
)
1821 val
= (*XSUBR (fun
)->function
) ();
1824 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
1827 val
= (*XSUBR (fun
)->function
) (internal_args
[0],
1831 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
1835 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
1840 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
1841 internal_args
[2], internal_args
[3],
1845 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
1846 internal_args
[2], internal_args
[3],
1847 internal_args
[4], internal_args
[5]);
1852 /* If a subr takes more than 6 arguments without using MANY
1853 or UNEVALLED, we need to extend this function to support it.
1854 Until this is done, there is no way to call the function. */
1858 if (XTYPE (fun
) == Lisp_Compiled
)
1859 val
= funcall_lambda (fun
, numargs
, args
+ 1);
1863 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1864 funcar
= Fcar (fun
);
1865 if (XTYPE (funcar
) != Lisp_Symbol
)
1866 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1867 if (EQ (funcar
, Qlambda
))
1868 val
= funcall_lambda (fun
, numargs
, args
+ 1);
1869 else if (EQ (funcar
, Qmocklisp
))
1870 val
= ml_apply (fun
, Flist (numargs
, args
+ 1));
1871 else if (EQ (funcar
, Qautoload
))
1873 do_autoload (fun
, args
[0]);
1877 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1881 if (backtrace
.debug_on_exit
)
1882 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
1883 backtrace_list
= backtrace
.next
;
1888 apply_lambda (fun
, args
, eval_flag
)
1889 Lisp_Object fun
, args
;
1892 Lisp_Object args_left
;
1893 Lisp_Object numargs
;
1894 register Lisp_Object
*arg_vector
;
1895 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1897 register Lisp_Object tem
;
1899 numargs
= Flength (args
);
1900 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1903 GCPRO3 (*arg_vector
, args_left
, fun
);
1906 for (i
= 0; i
< XINT (numargs
);)
1908 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
1909 if (eval_flag
) tem
= Feval (tem
);
1910 arg_vector
[i
++] = tem
;
1918 backtrace_list
->args
= arg_vector
;
1919 backtrace_list
->nargs
= i
;
1921 backtrace_list
->evalargs
= 0;
1922 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
1924 /* Do the debug-on-exit now, while arg_vector still exists. */
1925 if (backtrace_list
->debug_on_exit
)
1926 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
1927 /* Don't do it again when we return to eval. */
1928 backtrace_list
->debug_on_exit
= 0;
1932 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
1933 and return the result of evaluation.
1934 FUN must be either a lambda-expression or a compiled-code object. */
1937 funcall_lambda (fun
, nargs
, arg_vector
)
1940 register Lisp_Object
*arg_vector
;
1942 Lisp_Object val
, tem
;
1943 register Lisp_Object syms_left
;
1944 Lisp_Object numargs
;
1945 register Lisp_Object next
;
1946 int count
= specpdl_ptr
- specpdl
;
1948 int optional
= 0, rest
= 0;
1950 specbind (Qmocklisp_arguments
, Qt
); /* t means NOT mocklisp! */
1952 XFASTINT (numargs
) = nargs
;
1954 if (XTYPE (fun
) == Lisp_Cons
)
1955 syms_left
= Fcar (Fcdr (fun
));
1956 else if (XTYPE (fun
) == Lisp_Compiled
)
1957 syms_left
= XVECTOR (fun
)->contents
[COMPILED_ARGLIST
];
1961 for (; !NILP (syms_left
); syms_left
= Fcdr (syms_left
))
1964 next
= Fcar (syms_left
);
1965 while (XTYPE (next
) != Lisp_Symbol
)
1966 next
= Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1967 if (EQ (next
, Qand_rest
))
1969 else if (EQ (next
, Qand_optional
))
1973 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
1978 tem
= arg_vector
[i
++];
1979 specbind (next
, tem
);
1982 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1984 specbind (next
, Qnil
);
1988 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1990 if (XTYPE (fun
) == Lisp_Cons
)
1991 val
= Fprogn (Fcdr (Fcdr (fun
)));
1993 val
= Fbyte_code (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
],
1994 XVECTOR (fun
)->contents
[COMPILED_CONSTANTS
],
1995 XVECTOR (fun
)->contents
[COMPILED_STACK_DEPTH
]);
1996 return unbind_to (count
, val
);
2002 register int count
= specpdl_ptr
- specpdl
;
2003 if (specpdl_size
>= max_specpdl_size
)
2005 if (max_specpdl_size
< 400)
2006 max_specpdl_size
= 400;
2007 if (specpdl_size
>= max_specpdl_size
)
2010 Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil
));
2011 max_specpdl_size
*= 2;
2015 if (specpdl_size
> max_specpdl_size
)
2016 specpdl_size
= max_specpdl_size
;
2017 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
2018 specpdl_ptr
= specpdl
+ count
;
2022 specbind (symbol
, value
)
2023 Lisp_Object symbol
, value
;
2025 extern void store_symval_forwarding (); /* in eval.c */
2028 CHECK_SYMBOL (symbol
, 0);
2030 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2032 specpdl_ptr
->symbol
= symbol
;
2033 specpdl_ptr
->func
= 0;
2034 ovalue
= XSYMBOL (symbol
)->value
;
2035 specpdl_ptr
->old_value
= EQ (ovalue
, Qunbound
) ? Qunbound
: Fsymbol_value (symbol
);
2037 if (XTYPE (ovalue
) == Lisp_Buffer_Objfwd
)
2038 store_symval_forwarding (symbol
, ovalue
, value
);
2040 Fset (symbol
, value
);
2044 record_unwind_protect (function
, arg
)
2045 Lisp_Object (*function
)();
2048 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2050 specpdl_ptr
->func
= function
;
2051 specpdl_ptr
->symbol
= Qnil
;
2052 specpdl_ptr
->old_value
= arg
;
2057 unbind_to (count
, value
)
2061 int quitf
= !NILP (Vquit_flag
);
2062 struct gcpro gcpro1
;
2068 while (specpdl_ptr
!= specpdl
+ count
)
2071 if (specpdl_ptr
->func
!= 0)
2072 (*specpdl_ptr
->func
) (specpdl_ptr
->old_value
);
2073 /* Note that a "binding" of nil is really an unwind protect,
2074 so in that case the "old value" is a list of forms to evaluate. */
2075 else if (NILP (specpdl_ptr
->symbol
))
2076 Fprogn (specpdl_ptr
->old_value
);
2078 Fset (specpdl_ptr
->symbol
, specpdl_ptr
->old_value
);
2080 if (NILP (Vquit_flag
) && quitf
) Vquit_flag
= Qt
;
2089 /* Get the value of symbol's global binding, even if that binding
2090 is not now dynamically visible. */
2093 top_level_value (symbol
)
2096 register struct specbinding
*ptr
= specpdl
;
2098 CHECK_SYMBOL (symbol
, 0);
2099 for (; ptr
!= specpdl_ptr
; ptr
++)
2101 if (EQ (ptr
->symbol
, symbol
))
2102 return ptr
->old_value
;
2104 return Fsymbol_value (symbol
);
2108 top_level_set (symbol
, newval
)
2109 Lisp_Object symbol
, newval
;
2111 register struct specbinding
*ptr
= specpdl
;
2113 CHECK_SYMBOL (symbol
, 0);
2114 for (; ptr
!= specpdl_ptr
; ptr
++)
2116 if (EQ (ptr
->symbol
, symbol
))
2118 ptr
->old_value
= newval
;
2122 return Fset (symbol
, newval
);
2127 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
2128 "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\
2129 The debugger is entered when that frame exits, if the flag is non-nil.")
2131 Lisp_Object level
, flag
;
2133 register struct backtrace
*backlist
= backtrace_list
;
2136 CHECK_NUMBER (level
, 0);
2138 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
2140 backlist
= backlist
->next
;
2144 backlist
->debug_on_exit
= !NILP (flag
);
2149 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
2150 "Print a trace of Lisp function calls currently active.\n\
2151 Output stream used is value of `standard-output'.")
2154 register struct backtrace
*backlist
= backtrace_list
;
2158 extern Lisp_Object Vprint_level
;
2159 struct gcpro gcpro1
;
2161 entering_debugger
= 0;
2163 XFASTINT (Vprint_level
) = 3;
2170 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
2171 if (backlist
->nargs
== UNEVALLED
)
2173 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
2177 tem
= *backlist
->function
;
2178 Fprin1 (tem
, Qnil
); /* This can QUIT */
2179 write_string ("(", -1);
2180 if (backlist
->nargs
== MANY
)
2182 for (tail
= *backlist
->args
, i
= 0;
2184 tail
= Fcdr (tail
), i
++)
2186 if (i
) write_string (" ", -1);
2187 Fprin1 (Fcar (tail
), Qnil
);
2192 for (i
= 0; i
< backlist
->nargs
; i
++)
2194 if (i
) write_string (" ", -1);
2195 Fprin1 (backlist
->args
[i
], Qnil
);
2199 write_string (")\n", -1);
2200 backlist
= backlist
->next
;
2203 Vprint_level
= Qnil
;
2208 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, "",
2209 "Return the function and arguments N frames up from current execution point.\n\
2210 If that frame has not evaluated the arguments yet (or is a special form),\n\
2211 the value is (nil FUNCTION ARG-FORMS...).\n\
2212 If that frame has evaluated its arguments and called its function already,\n\
2213 the value is (t FUNCTION ARG-VALUES...).\n\
2214 A &rest arg is represented as the tail of the list ARG-VALUES.\n\
2215 FUNCTION is whatever was supplied as car of evaluated list,\n\
2216 or a lambda expression for macro calls.\n\
2217 If N is more than the number of frames, the value is nil.")
2219 Lisp_Object nframes
;
2221 register struct backtrace
*backlist
= backtrace_list
;
2225 CHECK_NATNUM (nframes
, 0);
2227 /* Find the frame requested. */
2228 for (i
= 0; i
< XFASTINT (nframes
); i
++)
2229 backlist
= backlist
->next
;
2233 if (backlist
->nargs
== UNEVALLED
)
2234 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
2237 if (backlist
->nargs
== MANY
)
2238 tem
= *backlist
->args
;
2240 tem
= Flist (backlist
->nargs
, backlist
->args
);
2242 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
2248 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
2249 "Limit on number of Lisp variable bindings & unwind-protects before error.");
2251 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
2252 "Limit on depth in `eval', `apply' and `funcall' before error.\n\
2253 This limit is to catch infinite recursions for you before they cause\n\
2254 actual stack overflow in C, which would be fatal for Emacs.\n\
2255 You can safely make it considerably larger than its default value,\n\
2256 if that proves inconveniently small.");
2258 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
2259 "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
2260 Typing C-G sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
2263 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
2264 "Non-nil inhibits C-g quitting from happening immediately.\n\
2265 Note that `quit-flag' will still be set by typing C-g,\n\
2266 so a quit will be signalled as soon as `inhibit-quit' is nil.\n\
2267 To prevent this happening, set `quit-flag' to nil\n\
2268 before making `inhibit-quit' nil.");
2269 Vinhibit_quit
= Qnil
;
2271 Qinhibit_quit
= intern ("inhibit-quit");
2272 staticpro (&Qinhibit_quit
);
2274 Qautoload
= intern ("autoload");
2275 staticpro (&Qautoload
);
2277 Qdebug_on_error
= intern ("debug-on-error");
2278 staticpro (&Qdebug_on_error
);
2280 Qmacro
= intern ("macro");
2281 staticpro (&Qmacro
);
2283 /* Note that the process handling also uses Qexit, but we don't want
2284 to staticpro it twice, so we just do it here. */
2285 Qexit
= intern ("exit");
2288 Qinteractive
= intern ("interactive");
2289 staticpro (&Qinteractive
);
2291 Qcommandp
= intern ("commandp");
2292 staticpro (&Qcommandp
);
2294 Qdefun
= intern ("defun");
2295 staticpro (&Qdefun
);
2297 Qand_rest
= intern ("&rest");
2298 staticpro (&Qand_rest
);
2300 Qand_optional
= intern ("&optional");
2301 staticpro (&Qand_optional
);
2303 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
2304 "*Non-nil means automatically display a backtrace buffer\n\
2305 after any error that is handled by the editor command loop.\n\
2306 If the value is a list, an error only means to display a backtrace\n\
2307 if one of its condition symbols appears in the list.");
2308 Vstack_trace_on_error
= Qnil
;
2310 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
2311 "*Non-nil means enter debugger if an error is signaled.\n\
2312 Does not apply to errors handled by `condition-case'.\n\
2313 If the value is a list, an error only means to enter the debugger\n\
2314 if one of its condition symbols appears in the list.\n\
2315 See also variable `debug-on-quit'.");
2316 Vdebug_on_error
= Qnil
;
2318 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
2319 "*Non-nil means enter debugger if quit is signaled (C-G, for example).\n\
2320 Does not apply if quit is handled by a `condition-case'.\n\
2321 A non-nil value is equivalent to a `debug-on-error' value containing `quit'.");
2324 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
2325 "Non-nil means enter debugger before next `eval', `apply' or `funcall'.");
2327 DEFVAR_LISP ("debugger", &Vdebugger
,
2328 "Function to call to invoke debugger.\n\
2329 If due to frame exit, args are `exit' and the value being returned;\n\
2330 this function's value will be returned instead of that.\n\
2331 If due to error, args are `error' and a list of the args to `signal'.\n\
2332 If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
2333 If due to `eval' entry, one arg, t.");
2336 Qmocklisp_arguments
= intern ("mocklisp-arguments");
2337 staticpro (&Qmocklisp_arguments
);
2338 DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments
,
2339 "While in a mocklisp function, the list of its unevaluated args.");
2340 Vmocklisp_arguments
= Qt
;
2342 DEFVAR_LISP ("run-hooks", &Vrun_hooks
,
2343 "Set to the function `run-hooks', if that function has been defined.\n\
2344 Otherwise, nil (in a bare Emacs without preloaded Lisp code).");
2347 staticpro (&Vautoload_queue
);
2348 Vautoload_queue
= Qnil
;
2359 defsubr (&Sfunction
);
2361 defsubr (&Sdefmacro
);
2363 defsubr (&Sdefconst
);
2364 defsubr (&Suser_variable_p
);
2368 defsubr (&Smacroexpand
);
2371 defsubr (&Sunwind_protect
);
2372 defsubr (&Scondition_case
);
2374 defsubr (&Sinteractive_p
);
2375 defsubr (&Scommandp
);
2376 defsubr (&Sautoload
);
2379 defsubr (&Sfuncall
);
2380 defsubr (&Sbacktrace_debug
);
2381 defsubr (&Sbacktrace
);
2382 defsubr (&Sbacktrace_frame
);