1 /* Evaluator for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
24 #include "blockinput.h"
35 /* This definition is duplicated in alloc.c and keyboard.c */
36 /* Putting it in lisp.h makes cc bomb out! */
40 struct backtrace
*next
;
41 Lisp_Object
*function
;
42 Lisp_Object
*args
; /* Points to vector of args. */
43 int nargs
; /* Length of vector.
44 If nargs is UNEVALLED, args points to slot holding
45 list of unevalled args */
47 /* Nonzero means call value of debugger when done with this operation. */
51 struct backtrace
*backtrace_list
;
53 /* This structure helps implement the `catch' and `throw' control
54 structure. A struct catchtag contains all the information needed
55 to restore the state of the interpreter after a non-local jump.
57 Handlers for error conditions (represented by `struct handler'
58 structures) just point to a catch tag to do the cleanup required
61 catchtag structures are chained together in the C calling stack;
62 the `next' member points to the next outer catchtag.
64 A call like (throw TAG VAL) searches for a catchtag whose `tag'
65 member is TAG, and then unbinds to it. The `val' member is used to
66 hold VAL while the stack is unwound; `val' is returned as the value
69 All the other members are concerned with restoring the interpreter
75 struct catchtag
*next
;
78 struct backtrace
*backlist
;
79 struct handler
*handlerlist
;
82 int poll_suppress_count
;
85 struct catchtag
*catchlist
;
87 Lisp_Object Qautoload
, Qmacro
, Qexit
, Qinteractive
, Qcommandp
, Qdefun
;
88 Lisp_Object Qinhibit_quit
, Vinhibit_quit
, Vquit_flag
;
89 Lisp_Object Qmocklisp_arguments
, Vmocklisp_arguments
, Qmocklisp
;
90 Lisp_Object Qand_rest
, Qand_optional
;
91 Lisp_Object Qdebug_on_error
;
93 /* This holds either the symbol `run-hooks' or nil.
94 It is nil at an early stage of startup, and when Emacs
96 Lisp_Object Vrun_hooks
;
98 /* Non-nil means record all fset's and provide's, to be undone
99 if the file being autoloaded is not fully loaded.
100 They are recorded by being consed onto the front of Vautoload_queue:
101 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */
103 Lisp_Object Vautoload_queue
;
105 /* Current number of specbindings allocated in specpdl. */
108 /* Pointer to beginning of specpdl. */
109 struct specbinding
*specpdl
;
111 /* Pointer to first unused element in specpdl. */
112 struct specbinding
*specpdl_ptr
;
114 /* Maximum size allowed for specpdl allocation */
115 int max_specpdl_size
;
117 /* Depth in Lisp evaluations and function calls. */
120 /* Maximum allowed depth in Lisp evaluations and function calls. */
121 int max_lisp_eval_depth
;
123 /* Nonzero means enter debugger before next function call */
124 int debug_on_next_call
;
126 /* List of conditions (non-nil atom means all) which cause a backtrace
127 if an error is handled by the command loop's error handler. */
128 Lisp_Object Vstack_trace_on_error
;
130 /* List of conditions (non-nil atom means all) which enter the debugger
131 if an error is handled by the command loop's error handler. */
132 Lisp_Object Vdebug_on_error
;
134 /* List of conditions and regexps specifying error messages which
135 do not enter the debugger even if Vdebug_on_errors says they should. */
136 Lisp_Object Vdebug_ignored_errors
;
138 /* Non-nil means call the debugger even if the error will be handled. */
139 Lisp_Object Vdebug_on_signal
;
141 /* Hook for edebug to use. */
142 Lisp_Object Vsignal_hook_function
;
144 /* Nonzero means enter debugger if a quit signal
145 is handled by the command loop's error handler. */
148 /* The value of num_nonmacro_input_chars as of the last time we
149 started to enter the debugger. If we decide to enter the debugger
150 again when this is still equal to num_nonmacro_input_chars, then we
151 know that the debugger itself has an error, and we should just
152 signal the error instead of entering an infinite loop of debugger
154 int when_entered_debugger
;
156 Lisp_Object Vdebugger
;
158 void specbind (), record_unwind_protect ();
160 Lisp_Object
run_hook_with_args ();
162 Lisp_Object
funcall_lambda ();
163 extern Lisp_Object
ml_apply (); /* Apply a mocklisp function to unevaluated argument list */
168 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
169 specpdl_ptr
= specpdl
;
170 max_specpdl_size
= 600;
171 max_lisp_eval_depth
= 300;
178 specpdl_ptr
= specpdl
;
183 debug_on_next_call
= 0;
185 /* This is less than the initial value of num_nonmacro_input_chars. */
186 when_entered_debugger
= -1;
193 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
194 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
195 if (specpdl_size
+ 40 > max_specpdl_size
)
196 max_specpdl_size
= specpdl_size
+ 40;
197 debug_on_next_call
= 0;
198 when_entered_debugger
= num_nonmacro_input_chars
;
199 return apply1 (Vdebugger
, arg
);
202 do_debug_on_call (code
)
205 debug_on_next_call
= 0;
206 backtrace_list
->debug_on_exit
= 1;
207 call_debugger (Fcons (code
, Qnil
));
210 /* NOTE!!! Every function that can call EVAL must protect its args
211 and temporaries from garbage collection while it needs them.
212 The definition of `For' shows what you have to do. */
214 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
215 "Eval args until one of them yields non-nil, then return that value.\n\
216 The remaining args are not evalled at all.\n\
217 If all args return nil, return nil.")
221 register Lisp_Object val
;
222 Lisp_Object args_left
;
233 val
= Feval (Fcar (args_left
));
236 args_left
= Fcdr (args_left
);
238 while (!NILP(args_left
));
244 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
245 "Eval args until one of them yields nil, then return nil.\n\
246 The remaining args are not evalled at all.\n\
247 If no arg yields nil, return the last arg's value.")
251 register Lisp_Object val
;
252 Lisp_Object args_left
;
263 val
= Feval (Fcar (args_left
));
266 args_left
= Fcdr (args_left
);
268 while (!NILP(args_left
));
274 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
275 "(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...\n\
276 Returns the value of THEN or the value of the last of the ELSE's.\n\
277 THEN must be one expression, but ELSE... can be zero or more expressions.\n\
278 If COND yields nil, and there are no ELSE's, the value is nil.")
282 register Lisp_Object cond
;
286 cond
= Feval (Fcar (args
));
290 return Feval (Fcar (Fcdr (args
)));
291 return Fprogn (Fcdr (Fcdr (args
)));
294 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
295 "(cond CLAUSES...): try each clause until one succeeds.\n\
296 Each clause looks like (CONDITION BODY...). CONDITION is evaluated\n\
297 and, if the value is non-nil, this clause succeeds:\n\
298 then the expressions in BODY are evaluated and the last one's\n\
299 value is the value of the cond-form.\n\
300 If no clause succeeds, cond returns nil.\n\
301 If a clause has one element, as in (CONDITION),\n\
302 CONDITION's value if non-nil is returned from the cond-form.")
306 register Lisp_Object clause
, val
;
313 clause
= Fcar (args
);
314 val
= Feval (Fcar (clause
));
317 if (!EQ (XCONS (clause
)->cdr
, Qnil
))
318 val
= Fprogn (XCONS (clause
)->cdr
);
321 args
= XCONS (args
)->cdr
;
328 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
329 "(progn BODY...): eval BODY forms sequentially and return value of last one.")
333 register Lisp_Object val
, tem
;
334 Lisp_Object args_left
;
337 /* In Mocklisp code, symbols at the front of the progn arglist
338 are to be bound to zero. */
339 if (!EQ (Vmocklisp_arguments
, Qt
))
341 val
= make_number (0);
342 while (!NILP (args
) && (tem
= Fcar (args
), SYMBOLP (tem
)))
345 specbind (tem
, val
), args
= Fcdr (args
);
357 val
= Feval (Fcar (args_left
));
358 args_left
= Fcdr (args_left
);
360 while (!NILP(args_left
));
366 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
367 "(prog1 FIRST BODY...): eval FIRST and BODY sequentially; value from FIRST.\n\
368 The value of FIRST is saved during the evaluation of the remaining args,\n\
369 whose values are discarded.")
374 register Lisp_Object args_left
;
375 struct gcpro gcpro1
, gcpro2
;
376 register int argnum
= 0;
388 val
= Feval (Fcar (args_left
));
390 Feval (Fcar (args_left
));
391 args_left
= Fcdr (args_left
);
393 while (!NILP(args_left
));
399 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
400 "(prog2 X Y BODY...): eval X, Y and BODY sequentially; value from Y.\n\
401 The value of Y is saved during the evaluation of the remaining args,\n\
402 whose values are discarded.")
407 register Lisp_Object args_left
;
408 struct gcpro gcpro1
, gcpro2
;
409 register int argnum
= -1;
423 val
= Feval (Fcar (args_left
));
425 Feval (Fcar (args_left
));
426 args_left
= Fcdr (args_left
);
428 while (!NILP (args_left
));
434 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
435 "(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.\n\
436 The symbols SYM are variables; they are literal (not evaluated).\n\
437 The values VAL are expressions; they are evaluated.\n\
438 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.\n\
439 The second VAL is not computed until after the first SYM is set, and so on;\n\
440 each VAL can use the new value of variables set earlier in the `setq'.\n\
441 The return value of the `setq' form is the value of the last VAL.")
445 register Lisp_Object args_left
;
446 register Lisp_Object val
, sym
;
457 val
= Feval (Fcar (Fcdr (args_left
)));
458 sym
= Fcar (args_left
);
460 args_left
= Fcdr (Fcdr (args_left
));
462 while (!NILP(args_left
));
468 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
469 "Return the argument, without evaluating it. `(quote x)' yields `x'.")
476 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
477 "Like `quote', but preferred for objects which are functions.\n\
478 In byte compilation, `function' causes its argument to be compiled.\n\
479 `quote' cannot do that.")
486 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
487 "Return t if function in which this appears was called interactively.\n\
488 This means that the function was called with call-interactively (which\n\
489 includes being called as the binding of a key)\n\
490 and input is currently coming from the keyboard (not in keyboard macro).")
493 register struct backtrace
*btp
;
494 register Lisp_Object fun
;
499 btp
= backtrace_list
;
501 /* If this isn't a byte-compiled function, there may be a frame at
502 the top for Finteractive_p itself. If so, skip it. */
503 fun
= Findirect_function (*btp
->function
);
504 if (SUBRP (fun
) && XSUBR (fun
) == &Sinteractive_p
)
507 /* If we're running an Emacs 18-style byte-compiled function, there
508 may be a frame for Fbytecode. Now, given the strictest
509 definition, this function isn't really being called
510 interactively, but because that's the way Emacs 18 always builds
511 byte-compiled functions, we'll accept it for now. */
512 if (EQ (*btp
->function
, Qbytecode
))
515 /* If this isn't a byte-compiled function, then we may now be
516 looking at several frames for special forms. Skip past them. */
518 btp
->nargs
== UNEVALLED
)
521 /* btp now points at the frame of the innermost function that isn't
522 a special form, ignoring frames for Finteractive_p and/or
523 Fbytecode at the top. If this frame is for a built-in function
524 (such as load or eval-region) return nil. */
525 fun
= Findirect_function (*btp
->function
);
528 /* btp points to the frame of a Lisp function that called interactive-p.
529 Return t if that function was called interactively. */
530 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
535 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
536 "(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.\n\
537 The definition is (lambda ARGLIST [DOCSTRING] BODY...).\n\
538 See also the function `interactive'.")
542 register Lisp_Object fn_name
;
543 register Lisp_Object defn
;
545 fn_name
= Fcar (args
);
546 defn
= Fcons (Qlambda
, Fcdr (args
));
547 if (!NILP (Vpurify_flag
))
548 defn
= Fpurecopy (defn
);
549 Ffset (fn_name
, defn
);
550 LOADHIST_ATTACH (fn_name
);
554 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
555 "(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.\n\
556 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).\n\
557 When the macro is called, as in (NAME ARGS...),\n\
558 the function (lambda ARGLIST BODY...) is applied to\n\
559 the list ARGS... as it appears in the expression,\n\
560 and the result should be a form to be evaluated instead of the original.")
564 register Lisp_Object fn_name
;
565 register Lisp_Object defn
;
567 fn_name
= Fcar (args
);
568 defn
= Fcons (Qmacro
, Fcons (Qlambda
, Fcdr (args
)));
569 if (!NILP (Vpurify_flag
))
570 defn
= Fpurecopy (defn
);
571 Ffset (fn_name
, defn
);
572 LOADHIST_ATTACH (fn_name
);
576 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
577 "(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.\n\
578 You are not required to define a variable in order to use it,\n\
579 but the definition can supply documentation and an initial value\n\
580 in a way that tags can recognize.\n\n\
581 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.\n\
582 If SYMBOL is buffer-local, its default value is what is set;\n\
583 buffer-local values are not affected.\n\
584 INITVALUE and DOCSTRING are optional.\n\
585 If DOCSTRING starts with *, this variable is identified as a user option.\n\
586 This means that M-x set-variable and M-x edit-options recognize it.\n\
587 If INITVALUE is missing, SYMBOL's value is not set.")
591 register Lisp_Object sym
, tem
, tail
;
595 if (!NILP (Fcdr (Fcdr (tail
))))
596 error ("too many arguments");
600 tem
= Fdefault_boundp (sym
);
602 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
604 tail
= Fcdr (Fcdr (args
));
605 if (!NILP (Fcar (tail
)))
608 if (!NILP (Vpurify_flag
))
609 tem
= Fpurecopy (tem
);
610 Fput (sym
, Qvariable_documentation
, tem
);
612 LOADHIST_ATTACH (sym
);
616 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
617 "(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant variable.\n\
618 The intent is that programs do not change this value, but users may.\n\
619 Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\
620 If SYMBOL is buffer-local, its default value is what is set;\n\
621 buffer-local values are not affected.\n\
622 DOCSTRING is optional.\n\
623 If DOCSTRING starts with *, this variable is identified as a user option.\n\
624 This means that M-x set-variable and M-x edit-options recognize it.\n\n\
625 Note: do not use `defconst' for user options in libraries that are not\n\
626 normally loaded, since it is useful for users to be able to specify\n\
627 their own values for such variables before loading the library.\n\
628 Since `defconst' unconditionally assigns the variable,\n\
629 it would override the user's choice.")
633 register Lisp_Object sym
, tem
;
636 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
637 error ("too many arguments");
639 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
640 tem
= Fcar (Fcdr (Fcdr (args
)));
643 if (!NILP (Vpurify_flag
))
644 tem
= Fpurecopy (tem
);
645 Fput (sym
, Qvariable_documentation
, tem
);
647 LOADHIST_ATTACH (sym
);
651 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
652 "Returns t if VARIABLE is intended to be set and modified by users.\n\
653 \(The alternative is a variable used internally in a Lisp program.)\n\
654 Determined by whether the first character of the documentation\n\
655 for the variable is `*'.")
657 Lisp_Object variable
;
659 Lisp_Object documentation
;
661 if (!SYMBOLP (variable
))
664 documentation
= Fget (variable
, Qvariable_documentation
);
665 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
667 if (STRINGP (documentation
)
668 && ((unsigned char) XSTRING (documentation
)->data
[0] == '*'))
670 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
671 if (CONSP (documentation
)
672 && STRINGP (XCONS (documentation
)->car
)
673 && INTEGERP (XCONS (documentation
)->cdr
)
674 && XINT (XCONS (documentation
)->cdr
) < 0)
679 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
680 "(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
681 The value of the last form in BODY is returned.\n\
682 Each element of VARLIST is a symbol (which is bound to nil)\n\
683 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
684 Each VALUEFORM can refer to the symbols already bound by this VARLIST.")
688 Lisp_Object varlist
, val
, elt
;
689 int count
= specpdl_ptr
- specpdl
;
690 struct gcpro gcpro1
, gcpro2
, gcpro3
;
692 GCPRO3 (args
, elt
, varlist
);
694 varlist
= Fcar (args
);
695 while (!NILP (varlist
))
698 elt
= Fcar (varlist
);
700 specbind (elt
, Qnil
);
701 else if (! NILP (Fcdr (Fcdr (elt
))))
703 Fcons (build_string ("`let' bindings can have only one value-form"),
707 val
= Feval (Fcar (Fcdr (elt
)));
708 specbind (Fcar (elt
), val
);
710 varlist
= Fcdr (varlist
);
713 val
= Fprogn (Fcdr (args
));
714 return unbind_to (count
, val
);
717 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
718 "(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
719 The value of the last form in BODY is returned.\n\
720 Each element of VARLIST is a symbol (which is bound to nil)\n\
721 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
722 All the VALUEFORMs are evalled before any symbols are bound.")
726 Lisp_Object
*temps
, tem
;
727 register Lisp_Object elt
, varlist
;
728 int count
= specpdl_ptr
- specpdl
;
730 struct gcpro gcpro1
, gcpro2
;
732 varlist
= Fcar (args
);
734 /* Make space to hold the values to give the bound variables */
735 elt
= Flength (varlist
);
736 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
738 /* Compute the values and store them in `temps' */
740 GCPRO2 (args
, *temps
);
743 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
746 elt
= Fcar (varlist
);
748 temps
[argnum
++] = Qnil
;
749 else if (! NILP (Fcdr (Fcdr (elt
))))
751 Fcons (build_string ("`let' bindings can have only one value-form"),
754 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
755 gcpro2
.nvars
= argnum
;
759 varlist
= Fcar (args
);
760 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
762 elt
= Fcar (varlist
);
763 tem
= temps
[argnum
++];
767 specbind (Fcar (elt
), tem
);
770 elt
= Fprogn (Fcdr (args
));
771 return unbind_to (count
, elt
);
774 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
775 "(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.\n\
776 The order of execution is thus TEST, BODY, TEST, BODY and so on\n\
777 until TEST returns nil.")
781 Lisp_Object test
, body
, tem
;
782 struct gcpro gcpro1
, gcpro2
;
788 while (tem
= Feval (test
),
789 (!EQ (Vmocklisp_arguments
, Qt
) ? XINT (tem
) : !NILP (tem
)))
799 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
800 "Return result of expanding macros at top level of FORM.\n\
801 If FORM is not a macro call, it is returned unchanged.\n\
802 Otherwise, the macro is expanded and the expansion is considered\n\
803 in place of FORM. When a non-macro-call results, it is returned.\n\n\
804 The second optional arg ENVIRONMENT species an environment of macro\n\
805 definitions to shadow the loaded ones for use in file byte-compilation.")
808 Lisp_Object environment
;
810 /* With cleanups from Hallvard Furuseth. */
811 register Lisp_Object expander
, sym
, def
, tem
;
815 /* Come back here each time we expand a macro call,
816 in case it expands into another macro call. */
819 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
820 def
= sym
= XCONS (form
)->car
;
822 /* Trace symbols aliases to other symbols
823 until we get a symbol that is not an alias. */
824 while (SYMBOLP (def
))
828 tem
= Fassq (sym
, environment
);
831 def
= XSYMBOL (sym
)->function
;
832 if (!EQ (def
, Qunbound
))
837 /* Right now TEM is the result from SYM in ENVIRONMENT,
838 and if TEM is nil then DEF is SYM's function definition. */
841 /* SYM is not mentioned in ENVIRONMENT.
842 Look at its function definition. */
843 if (EQ (def
, Qunbound
) || !CONSP (def
))
844 /* Not defined or definition not suitable */
846 if (EQ (XCONS (def
)->car
, Qautoload
))
848 /* Autoloading function: will it be a macro when loaded? */
849 tem
= Fnth (make_number (4), def
);
850 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
851 /* Yes, load it and try again. */
855 do_autoload (def
, sym
);
862 else if (!EQ (XCONS (def
)->car
, Qmacro
))
864 else expander
= XCONS (def
)->cdr
;
868 expander
= XCONS (tem
)->cdr
;
872 form
= apply1 (expander
, XCONS (form
)->cdr
);
877 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
878 "(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.\n\
879 TAG is evalled to get the tag to use. Then the BODY is executed.\n\
880 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.\n\
881 If no throw happens, `catch' returns the value of the last BODY form.\n\
882 If a throw happens, it specifies the value to return from `catch'.")
886 register Lisp_Object tag
;
890 tag
= Feval (Fcar (args
));
892 return internal_catch (tag
, Fprogn
, Fcdr (args
));
895 /* Set up a catch, then call C function FUNC on argument ARG.
896 FUNC should return a Lisp_Object.
897 This is how catches are done from within C code. */
900 internal_catch (tag
, func
, arg
)
902 Lisp_Object (*func
) ();
905 /* This structure is made part of the chain `catchlist'. */
908 /* Fill in the components of c, and put it on the list. */
912 c
.backlist
= backtrace_list
;
913 c
.handlerlist
= handlerlist
;
914 c
.lisp_eval_depth
= lisp_eval_depth
;
915 c
.pdlcount
= specpdl_ptr
- specpdl
;
916 c
.poll_suppress_count
= poll_suppress_count
;
921 if (! _setjmp (c
.jmp
))
922 c
.val
= (*func
) (arg
);
924 /* Throw works by a longjmp that comes right here. */
929 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
930 jump to that CATCH, returning VALUE as the value of that catch.
932 This is the guts Fthrow and Fsignal; they differ only in the way
933 they choose the catch tag to throw to. A catch tag for a
934 condition-case form has a TAG of Qnil.
936 Before each catch is discarded, unbind all special bindings and
937 execute all unwind-protect clauses made above that catch. Unwind
938 the handler stack as we go, so that the proper handlers are in
939 effect for each unwind-protect clause we run. At the end, restore
940 some static info saved in CATCH, and longjmp to the location
943 This is used for correct unwinding in Fthrow and Fsignal. */
946 unwind_to_catch (catch, value
)
947 struct catchtag
*catch;
950 register int last_time
;
952 /* Save the value in the tag. */
955 /* Restore the polling-suppression count. */
956 set_poll_suppress_count (catch->poll_suppress_count
);
960 last_time
= catchlist
== catch;
962 /* Unwind the specpdl stack, and then restore the proper set of
964 unbind_to (catchlist
->pdlcount
, Qnil
);
965 handlerlist
= catchlist
->handlerlist
;
966 catchlist
= catchlist
->next
;
970 gcprolist
= catch->gcpro
;
971 backtrace_list
= catch->backlist
;
972 lisp_eval_depth
= catch->lisp_eval_depth
;
974 _longjmp (catch->jmp
, 1);
977 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
978 "(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.\n\
979 Both TAG and VALUE are evalled.")
981 register Lisp_Object tag
, value
;
983 register struct catchtag
*c
;
988 for (c
= catchlist
; c
; c
= c
->next
)
990 if (EQ (c
->tag
, tag
))
991 unwind_to_catch (c
, value
);
993 tag
= Fsignal (Qno_catch
, Fcons (tag
, Fcons (value
, Qnil
)));
998 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
999 "Do BODYFORM, protecting with UNWINDFORMS.\n\
1000 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).\n\
1001 If BODYFORM completes normally, its value is returned\n\
1002 after executing the UNWINDFORMS.\n\
1003 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.")
1008 int count
= specpdl_ptr
- specpdl
;
1010 record_unwind_protect (0, Fcdr (args
));
1011 val
= Feval (Fcar (args
));
1012 return unbind_to (count
, val
);
1015 /* Chain of condition handlers currently in effect.
1016 The elements of this chain are contained in the stack frames
1017 of Fcondition_case and internal_condition_case.
1018 When an error is signaled (by calling Fsignal, below),
1019 this chain is searched for an element that applies. */
1021 struct handler
*handlerlist
;
1023 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1024 "Regain control when an error is signaled.\n\
1025 Usage looks like (condition-case VAR BODYFORM HANDLERS...).\n\
1026 executes BODYFORM and returns its value if no error happens.\n\
1027 Each element of HANDLERS looks like (CONDITION-NAME BODY...)\n\
1028 where the BODY is made of Lisp expressions.\n\n\
1029 A handler is applicable to an error\n\
1030 if CONDITION-NAME is one of the error's condition names.\n\
1031 If an error happens, the first applicable handler is run.\n\
1033 The car of a handler may be a list of condition names\n\
1034 instead of a single condition name.\n\
1036 When a handler handles an error,\n\
1037 control returns to the condition-case and the handler BODY... is executed\n\
1038 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\
1039 VAR may be nil; then you do not get access to the signal information.\n\
1041 The value of the last BODY form is returned from the condition-case.\n\
1042 See also the function `signal' for more info.")
1049 register Lisp_Object var
, bodyform
, handlers
;
1052 bodyform
= Fcar (Fcdr (args
));
1053 handlers
= Fcdr (Fcdr (args
));
1054 CHECK_SYMBOL (var
, 0);
1056 for (val
= handlers
; ! NILP (val
); val
= Fcdr (val
))
1062 && (SYMBOLP (XCONS (tem
)->car
)
1063 || CONSP (XCONS (tem
)->car
)))))
1064 error ("Invalid condition handler", tem
);
1069 c
.backlist
= backtrace_list
;
1070 c
.handlerlist
= handlerlist
;
1071 c
.lisp_eval_depth
= lisp_eval_depth
;
1072 c
.pdlcount
= specpdl_ptr
- specpdl
;
1073 c
.poll_suppress_count
= poll_suppress_count
;
1074 c
.gcpro
= gcprolist
;
1075 if (_setjmp (c
.jmp
))
1078 specbind (h
.var
, c
.val
);
1079 val
= Fprogn (Fcdr (h
.chosen_clause
));
1081 /* Note that this just undoes the binding of h.var; whoever
1082 longjumped to us unwound the stack to c.pdlcount before
1084 unbind_to (c
.pdlcount
, Qnil
);
1091 h
.handler
= handlers
;
1092 h
.next
= handlerlist
;
1096 val
= Feval (bodyform
);
1098 handlerlist
= h
.next
;
1102 /* Call the function BFUN with no arguments, catching errors within it
1103 according to HANDLERS. If there is an error, call HFUN with
1104 one argument which is the data that describes the error:
1107 HANDLERS can be a list of conditions to catch.
1108 If HANDLERS is Qt, catch all errors.
1109 If HANDLERS is Qerror, catch all errors
1110 but allow the debugger to run if that is enabled. */
1113 internal_condition_case (bfun
, handlers
, hfun
)
1114 Lisp_Object (*bfun
) ();
1115 Lisp_Object handlers
;
1116 Lisp_Object (*hfun
) ();
1122 /* Since Fsignal resets this to 0, it had better be 0 now
1123 or else we have a potential bug. */
1124 if (interrupt_input_blocked
!= 0)
1129 c
.backlist
= backtrace_list
;
1130 c
.handlerlist
= handlerlist
;
1131 c
.lisp_eval_depth
= lisp_eval_depth
;
1132 c
.pdlcount
= specpdl_ptr
- specpdl
;
1133 c
.poll_suppress_count
= poll_suppress_count
;
1134 c
.gcpro
= gcprolist
;
1135 if (_setjmp (c
.jmp
))
1137 return (*hfun
) (c
.val
);
1141 h
.handler
= handlers
;
1143 h
.next
= handlerlist
;
1149 handlerlist
= h
.next
;
1153 /* Like internal_condition_case but call HFUN with ARG as its argument. */
1156 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1157 Lisp_Object (*bfun
) ();
1159 Lisp_Object handlers
;
1160 Lisp_Object (*hfun
) ();
1168 c
.backlist
= backtrace_list
;
1169 c
.handlerlist
= handlerlist
;
1170 c
.lisp_eval_depth
= lisp_eval_depth
;
1171 c
.pdlcount
= specpdl_ptr
- specpdl
;
1172 c
.poll_suppress_count
= poll_suppress_count
;
1173 c
.gcpro
= gcprolist
;
1174 if (_setjmp (c
.jmp
))
1176 return (*hfun
) (c
.val
);
1180 h
.handler
= handlers
;
1182 h
.next
= handlerlist
;
1186 val
= (*bfun
) (arg
);
1188 handlerlist
= h
.next
;
1192 static Lisp_Object
find_handler_clause ();
1194 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1195 "Signal an error. Args are ERROR-SYMBOL and associated DATA.\n\
1196 This function does not return.\n\n\
1197 An error symbol is a symbol with an `error-conditions' property\n\
1198 that is a list of condition names.\n\
1199 A handler for any of those names will get to handle this signal.\n\
1200 The symbol `error' should normally be one of them.\n\
1202 DATA should be a list. Its elements are printed as part of the error message.\n\
1203 If the signal is handled, DATA is made available to the handler.\n\
1204 See also the function `condition-case'.")
1205 (error_symbol
, data
)
1206 Lisp_Object error_symbol
, data
;
1208 register struct handler
*allhandlers
= handlerlist
;
1209 Lisp_Object conditions
;
1210 extern int gc_in_progress
;
1211 extern int waiting_for_input
;
1212 Lisp_Object debugger_value
;
1215 quit_error_check ();
1217 if (gc_in_progress
|| waiting_for_input
)
1220 #ifdef HAVE_WINDOW_SYSTEM
1221 TOTALLY_UNBLOCK_INPUT
;
1224 /* This hook is used by edebug. */
1225 if (! NILP (Vsignal_hook_function
))
1226 Ffuncall (Vsignal_hook_function
, error_symbol
, data
);
1228 conditions
= Fget (error_symbol
, Qerror_conditions
);
1230 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1232 register Lisp_Object clause
;
1233 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1234 error_symbol
, data
, &debugger_value
);
1236 #if 0 /* Most callers are not prepared to handle gc if this returns.
1237 So, since this feature is not very useful, take it out. */
1238 /* If have called debugger and user wants to continue,
1240 if (EQ (clause
, Qlambda
))
1241 return debugger_value
;
1243 if (EQ (clause
, Qlambda
))
1245 /* We can't return values to code which signaled an error, but we
1246 can continue code which has signaled a quit. */
1247 if (EQ (error_symbol
, Qquit
))
1250 error ("Cannot return from the debugger in an error");
1256 Lisp_Object unwind_data
;
1257 struct handler
*h
= handlerlist
;
1259 handlerlist
= allhandlers
;
1260 if (EQ (data
, memory_signal_data
))
1261 unwind_data
= memory_signal_data
;
1263 unwind_data
= Fcons (error_symbol
, data
);
1264 h
->chosen_clause
= clause
;
1265 unwind_to_catch (h
->tag
, unwind_data
);
1269 handlerlist
= allhandlers
;
1270 /* If no handler is present now, try to run the debugger,
1271 and if that fails, throw to top level. */
1272 find_handler_clause (Qerror
, conditions
, error_symbol
, data
, &debugger_value
);
1274 Fthrow (Qtop_level
, Qt
);
1276 if (! EQ (data
, memory_signal_data
))
1277 data
= Fcons (error_symbol
, data
);
1279 string
= Ferror_message_string (data
);
1280 fatal (XSTRING (string
)->data
, 0, 0);
1283 /* Return nonzero iff LIST is a non-nil atom or
1284 a list containing one of CONDITIONS. */
1287 wants_debugger (list
, conditions
)
1288 Lisp_Object list
, conditions
;
1295 while (CONSP (conditions
))
1297 Lisp_Object
this, tail
;
1298 this = XCONS (conditions
)->car
;
1299 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1300 if (EQ (XCONS (tail
)->car
, this))
1302 conditions
= XCONS (conditions
)->cdr
;
1307 /* Return 1 if an error with condition-symbols CONDITIONS,
1308 and described by SIGNAL-DATA, should skip the debugger
1309 according to debugger-ignore-errors. */
1312 skip_debugger (conditions
, data
)
1313 Lisp_Object conditions
, data
;
1316 int first_string
= 1;
1317 Lisp_Object error_message
;
1319 for (tail
= Vdebug_ignored_errors
; CONSP (tail
);
1320 tail
= XCONS (tail
)->cdr
)
1322 if (STRINGP (XCONS (tail
)->car
))
1326 error_message
= Ferror_message_string (data
);
1329 if (fast_string_match (XCONS (tail
)->car
, error_message
) >= 0)
1334 Lisp_Object contail
;
1336 for (contail
= conditions
; CONSP (contail
);
1337 contail
= XCONS (contail
)->cdr
)
1338 if (EQ (XCONS (tail
)->car
, XCONS (contail
)->car
))
1346 /* Value of Qlambda means we have called debugger and user has continued.
1347 Store value returned from debugger into *DEBUGGER_VALUE_PTR. */
1350 find_handler_clause (handlers
, conditions
, sig
, data
, debugger_value_ptr
)
1351 Lisp_Object handlers
, conditions
, sig
, data
;
1352 Lisp_Object
*debugger_value_ptr
;
1354 register Lisp_Object h
;
1355 register Lisp_Object tem
;
1357 if (EQ (handlers
, Qt
)) /* t is used by handlers for all conditions, set up by C code. */
1359 /* error is used similarly, but means print an error message
1360 and run the debugger if that is enabled. */
1361 if (EQ (handlers
, Qerror
)
1362 || !NILP (Vdebug_on_signal
)) /* This says call debugger even if
1363 there is a handler. */
1365 int count
= specpdl_ptr
- specpdl
;
1366 int debugger_called
= 0;
1368 if (wants_debugger (Vstack_trace_on_error
, conditions
))
1369 internal_with_output_to_temp_buffer ("*Backtrace*", Fbacktrace
, Qnil
);
1370 if ((EQ (sig
, Qquit
)
1372 : wants_debugger (Vdebug_on_error
, conditions
))
1373 && ! skip_debugger (conditions
, Fcons (sig
, data
))
1374 && when_entered_debugger
< num_nonmacro_input_chars
)
1376 specbind (Qdebug_on_error
, Qnil
);
1378 = call_debugger (Fcons (Qerror
,
1379 Fcons (Fcons (sig
, data
),
1381 debugger_called
= 1;
1383 /* If there is no handler, return saying whether we ran the debugger. */
1384 if (EQ (handlers
, Qerror
))
1386 if (debugger_called
)
1387 return unbind_to (count
, Qlambda
);
1391 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1393 Lisp_Object handler
, condit
;
1396 if (!CONSP (handler
))
1398 condit
= Fcar (handler
);
1399 /* Handle a single condition name in handler HANDLER. */
1400 if (SYMBOLP (condit
))
1402 tem
= Fmemq (Fcar (handler
), conditions
);
1406 /* Handle a list of condition names in handler HANDLER. */
1407 else if (CONSP (condit
))
1409 while (CONSP (condit
))
1411 tem
= Fmemq (Fcar (condit
), conditions
);
1414 condit
= XCONS (condit
)->cdr
;
1421 /* dump an error message; called like printf */
1425 error (m
, a1
, a2
, a3
)
1445 int used
= doprnt (buf
, size
, m
, m
+ mlen
, 3, args
);
1450 buffer
= (char *) xrealloc (buffer
, size
);
1453 buffer
= (char *) xmalloc (size
);
1458 string
= build_string (buf
);
1462 Fsignal (Qerror
, Fcons (string
, Qnil
));
1465 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 1, 0,
1466 "T if FUNCTION makes provisions for interactive calling.\n\
1467 This means it contains a description for how to read arguments to give it.\n\
1468 The value is nil for an invalid function or a symbol with no function\n\
1471 Interactively callable functions include strings and vectors (treated\n\
1472 as keyboard macros), lambda-expressions that contain a top-level call\n\
1473 to `interactive', autoload definitions made by `autoload' with non-nil\n\
1474 fourth argument, and some of the built-in functions of Lisp.\n\
1476 Also, a symbol satisfies `commandp' if its function definition does so.")
1478 Lisp_Object function
;
1480 register Lisp_Object fun
;
1481 register Lisp_Object funcar
;
1482 register Lisp_Object tem
;
1487 fun
= indirect_function (fun
);
1488 if (EQ (fun
, Qunbound
))
1491 /* Emacs primitives are interactive if their DEFUN specifies an
1492 interactive spec. */
1495 if (XSUBR (fun
)->prompt
)
1501 /* Bytecode objects are interactive if they are long enough to
1502 have an element whose index is COMPILED_INTERACTIVE, which is
1503 where the interactive spec is stored. */
1504 else if (COMPILEDP (fun
))
1505 return ((XVECTOR (fun
)->size
& PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
1508 /* Strings and vectors are keyboard macros. */
1509 if (STRINGP (fun
) || VECTORP (fun
))
1512 /* Lists may represent commands. */
1515 funcar
= Fcar (fun
);
1516 if (!SYMBOLP (funcar
))
1517 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1518 if (EQ (funcar
, Qlambda
))
1519 return Fassq (Qinteractive
, Fcdr (Fcdr (fun
)));
1520 if (EQ (funcar
, Qmocklisp
))
1521 return Qt
; /* All mocklisp functions can be called interactively */
1522 if (EQ (funcar
, Qautoload
))
1523 return Fcar (Fcdr (Fcdr (Fcdr (fun
))));
1529 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1530 "Define FUNCTION to autoload from FILE.\n\
1531 FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\
1532 Third arg DOCSTRING is documentation for the function.\n\
1533 Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\
1534 Fifth arg TYPE indicates the type of the object:\n\
1535 nil or omitted says FUNCTION is a function,\n\
1536 `keymap' says FUNCTION is really a keymap, and\n\
1537 `macro' or t says FUNCTION is really a macro.\n\
1538 Third through fifth args give info about the real definition.\n\
1539 They default to nil.\n\
1540 If FUNCTION is already defined other than as an autoload,\n\
1541 this does nothing and returns nil.")
1542 (function
, file
, docstring
, interactive
, type
)
1543 Lisp_Object function
, file
, docstring
, interactive
, type
;
1546 Lisp_Object args
[4];
1549 CHECK_SYMBOL (function
, 0);
1550 CHECK_STRING (file
, 1);
1552 /* If function is defined and not as an autoload, don't override */
1553 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
1554 && !(CONSP (XSYMBOL (function
)->function
)
1555 && EQ (XCONS (XSYMBOL (function
)->function
)->car
, Qautoload
)))
1560 args
[1] = docstring
;
1561 args
[2] = interactive
;
1564 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
1565 #else /* NO_ARG_ARRAY */
1566 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
1567 #endif /* not NO_ARG_ARRAY */
1571 un_autoload (oldqueue
)
1572 Lisp_Object oldqueue
;
1574 register Lisp_Object queue
, first
, second
;
1576 /* Queue to unwind is current value of Vautoload_queue.
1577 oldqueue is the shadowed value to leave in Vautoload_queue. */
1578 queue
= Vautoload_queue
;
1579 Vautoload_queue
= oldqueue
;
1580 while (CONSP (queue
))
1582 first
= Fcar (queue
);
1583 second
= Fcdr (first
);
1584 first
= Fcar (first
);
1585 if (EQ (second
, Qnil
))
1588 Ffset (first
, second
);
1589 queue
= Fcdr (queue
);
1594 /* Load an autoloaded function.
1595 FUNNAME is the symbol which is the function's name.
1596 FUNDEF is the autoload definition (a list). */
1598 do_autoload (fundef
, funname
)
1599 Lisp_Object fundef
, funname
;
1601 int count
= specpdl_ptr
- specpdl
;
1602 Lisp_Object fun
, val
, queue
, first
, second
;
1603 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1606 CHECK_SYMBOL (funname
, 0);
1607 GCPRO3 (fun
, funname
, fundef
);
1609 /* Value saved here is to be restored into Vautoload_queue */
1610 record_unwind_protect (un_autoload
, Vautoload_queue
);
1611 Vautoload_queue
= Qt
;
1612 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
);
1614 /* Save the old autoloads, in case we ever do an unload. */
1615 queue
= Vautoload_queue
;
1616 while (CONSP (queue
))
1618 first
= Fcar (queue
);
1619 second
= Fcdr (first
);
1620 first
= Fcar (first
);
1622 /* Note: This test is subtle. The cdr of an autoload-queue entry
1623 may be an atom if the autoload entry was generated by a defalias
1626 Fput (first
, Qautoload
, (Fcdr (second
)));
1628 queue
= Fcdr (queue
);
1631 /* Once loading finishes, don't undo it. */
1632 Vautoload_queue
= Qt
;
1633 unbind_to (count
, Qnil
);
1635 fun
= Findirect_function (fun
);
1637 if (!NILP (Fequal (fun
, fundef
)))
1638 error ("Autoloading failed to define function %s",
1639 XSYMBOL (funname
)->name
->data
);
1643 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
1644 "Evaluate FORM and return its value.")
1648 Lisp_Object fun
, val
, original_fun
, original_args
;
1650 struct backtrace backtrace
;
1651 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1655 if (EQ (Vmocklisp_arguments
, Qt
))
1656 return Fsymbol_value (form
);
1657 val
= Fsymbol_value (form
);
1659 XSETFASTINT (val
, 0);
1660 else if (EQ (val
, Qt
))
1661 XSETFASTINT (val
, 1);
1668 if (consing_since_gc
> gc_cons_threshold
)
1671 Fgarbage_collect ();
1675 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1677 if (max_lisp_eval_depth
< 100)
1678 max_lisp_eval_depth
= 100;
1679 if (lisp_eval_depth
> max_lisp_eval_depth
)
1680 error ("Lisp nesting exceeds max-lisp-eval-depth");
1683 original_fun
= Fcar (form
);
1684 original_args
= Fcdr (form
);
1686 backtrace
.next
= backtrace_list
;
1687 backtrace_list
= &backtrace
;
1688 backtrace
.function
= &original_fun
; /* This also protects them from gc */
1689 backtrace
.args
= &original_args
;
1690 backtrace
.nargs
= UNEVALLED
;
1691 backtrace
.evalargs
= 1;
1692 backtrace
.debug_on_exit
= 0;
1694 if (debug_on_next_call
)
1695 do_debug_on_call (Qt
);
1697 /* At this point, only original_fun and original_args
1698 have values that will be used below */
1700 fun
= Findirect_function (original_fun
);
1704 Lisp_Object numargs
;
1705 Lisp_Object argvals
[7];
1706 Lisp_Object args_left
;
1707 register int i
, maxargs
;
1709 args_left
= original_args
;
1710 numargs
= Flength (args_left
);
1712 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
1713 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
1714 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1716 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1718 backtrace
.evalargs
= 0;
1719 val
= (*XSUBR (fun
)->function
) (args_left
);
1723 if (XSUBR (fun
)->max_args
== MANY
)
1725 /* Pass a vector of evaluated arguments */
1727 register int argnum
= 0;
1729 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1731 GCPRO3 (args_left
, fun
, fun
);
1735 while (!NILP (args_left
))
1737 vals
[argnum
++] = Feval (Fcar (args_left
));
1738 args_left
= Fcdr (args_left
);
1739 gcpro3
.nvars
= argnum
;
1742 backtrace
.args
= vals
;
1743 backtrace
.nargs
= XINT (numargs
);
1745 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
1750 GCPRO3 (args_left
, fun
, fun
);
1751 gcpro3
.var
= argvals
;
1754 maxargs
= XSUBR (fun
)->max_args
;
1755 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
1757 argvals
[i
] = Feval (Fcar (args_left
));
1763 backtrace
.args
= argvals
;
1764 backtrace
.nargs
= XINT (numargs
);
1769 val
= (*XSUBR (fun
)->function
) ();
1772 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
1775 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
1778 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1782 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1783 argvals
[2], argvals
[3]);
1786 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1787 argvals
[3], argvals
[4]);
1790 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1791 argvals
[3], argvals
[4], argvals
[5]);
1794 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1795 argvals
[3], argvals
[4], argvals
[5],
1800 /* Someone has created a subr that takes more arguments than
1801 is supported by this code. We need to either rewrite the
1802 subr to use a different argument protocol, or add more
1803 cases to this switch. */
1807 if (COMPILEDP (fun
))
1808 val
= apply_lambda (fun
, original_args
, 1);
1812 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1813 funcar
= Fcar (fun
);
1814 if (!SYMBOLP (funcar
))
1815 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1816 if (EQ (funcar
, Qautoload
))
1818 do_autoload (fun
, original_fun
);
1821 if (EQ (funcar
, Qmacro
))
1822 val
= Feval (apply1 (Fcdr (fun
), original_args
));
1823 else if (EQ (funcar
, Qlambda
))
1824 val
= apply_lambda (fun
, original_args
, 1);
1825 else if (EQ (funcar
, Qmocklisp
))
1826 val
= ml_apply (fun
, original_args
);
1828 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1831 if (!EQ (Vmocklisp_arguments
, Qt
))
1834 XSETFASTINT (val
, 0);
1835 else if (EQ (val
, Qt
))
1836 XSETFASTINT (val
, 1);
1839 if (backtrace
.debug_on_exit
)
1840 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
1841 backtrace_list
= backtrace
.next
;
1845 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
1846 "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
1847 Then return the value FUNCTION returns.\n\
1848 Thus, (apply '+ 1 2 '(3 4)) returns 10.")
1853 register int i
, numargs
;
1854 register Lisp_Object spread_arg
;
1855 register Lisp_Object
*funcall_args
;
1857 struct gcpro gcpro1
;
1861 spread_arg
= args
[nargs
- 1];
1862 CHECK_LIST (spread_arg
, nargs
);
1864 numargs
= XINT (Flength (spread_arg
));
1867 return Ffuncall (nargs
- 1, args
);
1868 else if (numargs
== 1)
1870 args
[nargs
- 1] = XCONS (spread_arg
)->car
;
1871 return Ffuncall (nargs
, args
);
1874 numargs
+= nargs
- 2;
1876 fun
= indirect_function (fun
);
1877 if (EQ (fun
, Qunbound
))
1879 /* Let funcall get the error */
1886 if (numargs
< XSUBR (fun
)->min_args
1887 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
1888 goto funcall
; /* Let funcall get the error */
1889 else if (XSUBR (fun
)->max_args
> numargs
)
1891 /* Avoid making funcall cons up a yet another new vector of arguments
1892 by explicitly supplying nil's for optional values */
1893 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
1894 * sizeof (Lisp_Object
));
1895 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
1896 funcall_args
[++i
] = Qnil
;
1897 GCPRO1 (*funcall_args
);
1898 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
1902 /* We add 1 to numargs because funcall_args includes the
1903 function itself as well as its arguments. */
1906 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
1907 * sizeof (Lisp_Object
));
1908 GCPRO1 (*funcall_args
);
1909 gcpro1
.nvars
= 1 + numargs
;
1912 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
1913 /* Spread the last arg we got. Its first element goes in
1914 the slot that it used to occupy, hence this value of I. */
1916 while (!NILP (spread_arg
))
1918 funcall_args
[i
++] = XCONS (spread_arg
)->car
;
1919 spread_arg
= XCONS (spread_arg
)->cdr
;
1922 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
1925 /* Run hook variables in various ways. */
1927 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
1929 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 1, MANY
, 0,
1930 "Run each hook in HOOKS. Major mode functions use this.\n\
1931 Each argument should be a symbol, a hook variable.\n\
1932 These symbols are processed in the order specified.\n\
1933 If a hook symbol has a non-nil value, that value may be a function\n\
1934 or a list of functions to be called to run the hook.\n\
1935 If the value is a function, it is called with no arguments.\n\
1936 If it is a list, the elements are called, in order, with no arguments.\n\
1938 To make a hook variable buffer-local, use `make-local-hook',\n\
1939 not `make-local-variable'.")
1944 Lisp_Object hook
[1];
1947 for (i
= 0; i
< nargs
; i
++)
1950 run_hook_with_args (1, hook
, to_completion
);
1956 DEFUN ("run-hook-with-args", Frun_hook_with_args
,
1957 Srun_hook_with_args
, 1, MANY
, 0,
1958 "Run HOOK with the specified arguments ARGS.\n\
1959 HOOK should be a symbol, a hook variable. If HOOK has a non-nil\n\
1960 value, that value may be a function or a list of functions to be\n\
1961 called to run the hook. If the value is a function, it is called with\n\
1962 the given arguments and its return value is returned. If it is a list\n\
1963 of functions, those functions are called, in order,\n\
1964 with the given arguments ARGS.\n\
1965 It is best not to depend on the value return by `run-hook-with-args',\n\
1966 as that may change.\n\
1968 To make a hook variable buffer-local, use `make-local-hook',\n\
1969 not `make-local-variable'.")
1974 return run_hook_with_args (nargs
, args
, to_completion
);
1977 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success
,
1978 Srun_hook_with_args_until_success
, 1, MANY
, 0,
1979 "Run HOOK with the specified arguments ARGS.\n\
1980 HOOK should be a symbol, a hook variable. Its value should\n\
1981 be a list of functions. We call those functions, one by one,\n\
1982 passing arguments ARGS to each of them, until one of them\n\
1983 returns a non-nil value. Then we return that value.\n\
1984 If all the functions return nil, we return nil.\n\
1986 To make a hook variable buffer-local, use `make-local-hook',\n\
1987 not `make-local-variable'.")
1992 return run_hook_with_args (nargs
, args
, until_success
);
1995 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure
,
1996 Srun_hook_with_args_until_failure
, 1, MANY
, 0,
1997 "Run HOOK with the specified arguments ARGS.\n\
1998 HOOK should be a symbol, a hook variable. Its value should\n\
1999 be a list of functions. We call those functions, one by one,\n\
2000 passing arguments ARGS to each of them, until one of them\n\
2001 returns nil. Then we return nil.\n\
2002 If all the functions return non-nil, we return non-nil.\n\
2004 To make a hook variable buffer-local, use `make-local-hook',\n\
2005 not `make-local-variable'.")
2010 return run_hook_with_args (nargs
, args
, until_failure
);
2013 /* ARGS[0] should be a hook symbol.
2014 Call each of the functions in the hook value, passing each of them
2015 as arguments all the rest of ARGS (all NARGS - 1 elements).
2016 COND specifies a condition to test after each call
2017 to decide whether to stop.
2018 The caller (or its caller, etc) must gcpro all of ARGS,
2019 except that it isn't necessary to gcpro ARGS[0]. */
2022 run_hook_with_args (nargs
, args
, cond
)
2025 enum run_hooks_condition cond
;
2027 Lisp_Object sym
, val
, ret
;
2028 struct gcpro gcpro1
, gcpro2
;
2030 /* If we are dying or still initializing,
2031 don't do anything--it would probably crash if we tried. */
2032 if (NILP (Vrun_hooks
))
2036 val
= find_symbol_value (sym
);
2037 ret
= (cond
== until_failure
? Qt
: Qnil
);
2039 if (EQ (val
, Qunbound
) || NILP (val
))
2041 else if (!CONSP (val
) || EQ (XCONS (val
)->car
, Qlambda
))
2044 return Ffuncall (nargs
, args
);
2051 CONSP (val
) && ((cond
== to_completion
)
2052 || (cond
== until_success
? NILP (ret
)
2054 val
= XCONS (val
)->cdr
)
2056 if (EQ (XCONS (val
)->car
, Qt
))
2058 /* t indicates this hook has a local binding;
2059 it means to run the global binding too. */
2060 Lisp_Object globals
;
2062 for (globals
= Fdefault_value (sym
);
2063 CONSP (globals
) && ((cond
== to_completion
)
2064 || (cond
== until_success
? NILP (ret
)
2066 globals
= XCONS (globals
)->cdr
)
2068 args
[0] = XCONS (globals
)->car
;
2069 /* In a global value, t should not occur. If it does, we
2070 must ignore it to avoid an endless loop. */
2071 if (!EQ (args
[0], Qt
))
2072 ret
= Ffuncall (nargs
, args
);
2077 args
[0] = XCONS (val
)->car
;
2078 ret
= Ffuncall (nargs
, args
);
2087 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2088 present value of that symbol.
2089 Call each element of FUNLIST,
2090 passing each of them the rest of ARGS.
2091 The caller (or its caller, etc) must gcpro all of ARGS,
2092 except that it isn't necessary to gcpro ARGS[0]. */
2095 run_hook_list_with_args (funlist
, nargs
, args
)
2096 Lisp_Object funlist
;
2102 struct gcpro gcpro1
, gcpro2
;
2107 for (val
= funlist
; CONSP (val
); val
= XCONS (val
)->cdr
)
2109 if (EQ (XCONS (val
)->car
, Qt
))
2111 /* t indicates this hook has a local binding;
2112 it means to run the global binding too. */
2113 Lisp_Object globals
;
2115 for (globals
= Fdefault_value (sym
);
2117 globals
= XCONS (globals
)->cdr
)
2119 args
[0] = XCONS (globals
)->car
;
2120 /* In a global value, t should not occur. If it does, we
2121 must ignore it to avoid an endless loop. */
2122 if (!EQ (args
[0], Qt
))
2123 Ffuncall (nargs
, args
);
2128 args
[0] = XCONS (val
)->car
;
2129 Ffuncall (nargs
, args
);
2136 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2139 run_hook_with_args_2 (hook
, arg1
, arg2
)
2140 Lisp_Object hook
, arg1
, arg2
;
2142 Lisp_Object temp
[3];
2147 Frun_hook_with_args (3, temp
);
2150 /* Apply fn to arg */
2153 Lisp_Object fn
, arg
;
2155 struct gcpro gcpro1
;
2159 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2163 Lisp_Object args
[2];
2167 RETURN_UNGCPRO (Fapply (2, args
));
2169 #else /* not NO_ARG_ARRAY */
2170 RETURN_UNGCPRO (Fapply (2, &fn
));
2171 #endif /* not NO_ARG_ARRAY */
2174 /* Call function fn on no arguments */
2179 struct gcpro gcpro1
;
2182 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2185 /* Call function fn with 1 argument arg1 */
2189 Lisp_Object fn
, arg1
;
2191 struct gcpro gcpro1
;
2193 Lisp_Object args
[2];
2199 RETURN_UNGCPRO (Ffuncall (2, args
));
2200 #else /* not NO_ARG_ARRAY */
2203 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2204 #endif /* not NO_ARG_ARRAY */
2207 /* Call function fn with 2 arguments arg1, arg2 */
2210 call2 (fn
, arg1
, arg2
)
2211 Lisp_Object fn
, arg1
, arg2
;
2213 struct gcpro gcpro1
;
2215 Lisp_Object args
[3];
2221 RETURN_UNGCPRO (Ffuncall (3, args
));
2222 #else /* not NO_ARG_ARRAY */
2225 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2226 #endif /* not NO_ARG_ARRAY */
2229 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2232 call3 (fn
, arg1
, arg2
, arg3
)
2233 Lisp_Object fn
, arg1
, arg2
, arg3
;
2235 struct gcpro gcpro1
;
2237 Lisp_Object args
[4];
2244 RETURN_UNGCPRO (Ffuncall (4, args
));
2245 #else /* not NO_ARG_ARRAY */
2248 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2249 #endif /* not NO_ARG_ARRAY */
2252 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2255 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2256 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2258 struct gcpro gcpro1
;
2260 Lisp_Object args
[5];
2268 RETURN_UNGCPRO (Ffuncall (5, args
));
2269 #else /* not NO_ARG_ARRAY */
2272 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2273 #endif /* not NO_ARG_ARRAY */
2276 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2279 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2280 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2282 struct gcpro gcpro1
;
2284 Lisp_Object args
[6];
2293 RETURN_UNGCPRO (Ffuncall (6, args
));
2294 #else /* not NO_ARG_ARRAY */
2297 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2298 #endif /* not NO_ARG_ARRAY */
2301 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2304 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2305 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2307 struct gcpro gcpro1
;
2309 Lisp_Object args
[7];
2319 RETURN_UNGCPRO (Ffuncall (7, args
));
2320 #else /* not NO_ARG_ARRAY */
2323 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2324 #endif /* not NO_ARG_ARRAY */
2327 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2328 "Call first argument as a function, passing remaining arguments to it.\n\
2329 Return the value that function returns.\n\
2330 Thus, (funcall 'cons 'x 'y) returns (x . y).")
2337 int numargs
= nargs
- 1;
2338 Lisp_Object lisp_numargs
;
2340 struct backtrace backtrace
;
2341 register Lisp_Object
*internal_args
;
2345 if (consing_since_gc
> gc_cons_threshold
)
2346 Fgarbage_collect ();
2348 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2350 if (max_lisp_eval_depth
< 100)
2351 max_lisp_eval_depth
= 100;
2352 if (lisp_eval_depth
> max_lisp_eval_depth
)
2353 error ("Lisp nesting exceeds max-lisp-eval-depth");
2356 backtrace
.next
= backtrace_list
;
2357 backtrace_list
= &backtrace
;
2358 backtrace
.function
= &args
[0];
2359 backtrace
.args
= &args
[1];
2360 backtrace
.nargs
= nargs
- 1;
2361 backtrace
.evalargs
= 0;
2362 backtrace
.debug_on_exit
= 0;
2364 if (debug_on_next_call
)
2365 do_debug_on_call (Qlambda
);
2371 fun
= Findirect_function (fun
);
2375 if (numargs
< XSUBR (fun
)->min_args
2376 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2378 XSETFASTINT (lisp_numargs
, numargs
);
2379 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (lisp_numargs
, Qnil
)));
2382 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2383 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2385 if (XSUBR (fun
)->max_args
== MANY
)
2387 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
2391 if (XSUBR (fun
)->max_args
> numargs
)
2393 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2394 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
2395 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2396 internal_args
[i
] = Qnil
;
2399 internal_args
= args
+ 1;
2400 switch (XSUBR (fun
)->max_args
)
2403 val
= (*XSUBR (fun
)->function
) ();
2406 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
2409 val
= (*XSUBR (fun
)->function
) (internal_args
[0],
2413 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2417 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2422 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2423 internal_args
[2], internal_args
[3],
2427 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2428 internal_args
[2], internal_args
[3],
2429 internal_args
[4], internal_args
[5]);
2432 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2433 internal_args
[2], internal_args
[3],
2434 internal_args
[4], internal_args
[5],
2440 /* If a subr takes more than 6 arguments without using MANY
2441 or UNEVALLED, we need to extend this function to support it.
2442 Until this is done, there is no way to call the function. */
2446 if (COMPILEDP (fun
))
2447 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2451 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2452 funcar
= Fcar (fun
);
2453 if (!SYMBOLP (funcar
))
2454 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2455 if (EQ (funcar
, Qlambda
))
2456 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2457 else if (EQ (funcar
, Qmocklisp
))
2458 val
= ml_apply (fun
, Flist (numargs
, args
+ 1));
2459 else if (EQ (funcar
, Qautoload
))
2461 do_autoload (fun
, args
[0]);
2465 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2469 if (backtrace
.debug_on_exit
)
2470 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2471 backtrace_list
= backtrace
.next
;
2476 apply_lambda (fun
, args
, eval_flag
)
2477 Lisp_Object fun
, args
;
2480 Lisp_Object args_left
;
2481 Lisp_Object numargs
;
2482 register Lisp_Object
*arg_vector
;
2483 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2485 register Lisp_Object tem
;
2487 numargs
= Flength (args
);
2488 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2491 GCPRO3 (*arg_vector
, args_left
, fun
);
2494 for (i
= 0; i
< XINT (numargs
);)
2496 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2497 if (eval_flag
) tem
= Feval (tem
);
2498 arg_vector
[i
++] = tem
;
2506 backtrace_list
->args
= arg_vector
;
2507 backtrace_list
->nargs
= i
;
2509 backtrace_list
->evalargs
= 0;
2510 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
2512 /* Do the debug-on-exit now, while arg_vector still exists. */
2513 if (backtrace_list
->debug_on_exit
)
2514 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
2515 /* Don't do it again when we return to eval. */
2516 backtrace_list
->debug_on_exit
= 0;
2520 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2521 and return the result of evaluation.
2522 FUN must be either a lambda-expression or a compiled-code object. */
2525 funcall_lambda (fun
, nargs
, arg_vector
)
2528 register Lisp_Object
*arg_vector
;
2530 Lisp_Object val
, tem
;
2531 register Lisp_Object syms_left
;
2532 Lisp_Object numargs
;
2533 register Lisp_Object next
;
2534 int count
= specpdl_ptr
- specpdl
;
2536 int optional
= 0, rest
= 0;
2538 specbind (Qmocklisp_arguments
, Qt
); /* t means NOT mocklisp! */
2540 XSETFASTINT (numargs
, nargs
);
2543 syms_left
= Fcar (Fcdr (fun
));
2544 else if (COMPILEDP (fun
))
2545 syms_left
= XVECTOR (fun
)->contents
[COMPILED_ARGLIST
];
2549 for (; !NILP (syms_left
); syms_left
= Fcdr (syms_left
))
2552 next
= Fcar (syms_left
);
2553 while (!SYMBOLP (next
))
2554 next
= Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2555 if (EQ (next
, Qand_rest
))
2557 else if (EQ (next
, Qand_optional
))
2561 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
2566 tem
= arg_vector
[i
++];
2567 specbind (next
, tem
);
2570 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2572 specbind (next
, Qnil
);
2576 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2579 val
= Fprogn (Fcdr (Fcdr (fun
)));
2582 /* If we have not actually read the bytecode string
2583 and constants vector yet, fetch them from the file. */
2584 if (CONSP (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
]))
2585 Ffetch_bytecode (fun
);
2586 val
= Fbyte_code (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
],
2587 XVECTOR (fun
)->contents
[COMPILED_CONSTANTS
],
2588 XVECTOR (fun
)->contents
[COMPILED_STACK_DEPTH
]);
2590 return unbind_to (count
, val
);
2593 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
2595 "If byte-compiled OBJECT is lazy-loaded, fetch it now.")
2601 if (COMPILEDP (object
)
2602 && CONSP (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]))
2604 tem
= read_doc_string (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]);
2606 error ("invalid byte code");
2607 XVECTOR (object
)->contents
[COMPILED_BYTECODE
] = XCONS (tem
)->car
;
2608 XVECTOR (object
)->contents
[COMPILED_CONSTANTS
] = XCONS (tem
)->cdr
;
2616 register int count
= specpdl_ptr
- specpdl
;
2617 if (specpdl_size
>= max_specpdl_size
)
2619 if (max_specpdl_size
< 400)
2620 max_specpdl_size
= 400;
2621 if (specpdl_size
>= max_specpdl_size
)
2623 if (!NILP (Vdebug_on_error
))
2624 /* Leave room for some specpdl in the debugger. */
2625 max_specpdl_size
= specpdl_size
+ 100;
2627 Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil
));
2631 if (specpdl_size
> max_specpdl_size
)
2632 specpdl_size
= max_specpdl_size
;
2633 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
2634 specpdl_ptr
= specpdl
+ count
;
2638 specbind (symbol
, value
)
2639 Lisp_Object symbol
, value
;
2643 CHECK_SYMBOL (symbol
, 0);
2645 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2647 specpdl_ptr
->symbol
= symbol
;
2648 specpdl_ptr
->func
= 0;
2649 specpdl_ptr
->old_value
= ovalue
= find_symbol_value (symbol
);
2651 if (BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
))
2652 store_symval_forwarding (symbol
, ovalue
, value
);
2654 set_internal (symbol
, value
, 1);
2658 record_unwind_protect (function
, arg
)
2659 Lisp_Object (*function
)();
2662 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2664 specpdl_ptr
->func
= function
;
2665 specpdl_ptr
->symbol
= Qnil
;
2666 specpdl_ptr
->old_value
= arg
;
2671 unbind_to (count
, value
)
2675 int quitf
= !NILP (Vquit_flag
);
2676 struct gcpro gcpro1
;
2682 while (specpdl_ptr
!= specpdl
+ count
)
2685 if (specpdl_ptr
->func
!= 0)
2686 (*specpdl_ptr
->func
) (specpdl_ptr
->old_value
);
2687 /* Note that a "binding" of nil is really an unwind protect,
2688 so in that case the "old value" is a list of forms to evaluate. */
2689 else if (NILP (specpdl_ptr
->symbol
))
2690 Fprogn (specpdl_ptr
->old_value
);
2692 set_internal (specpdl_ptr
->symbol
, specpdl_ptr
->old_value
, 1);
2694 if (NILP (Vquit_flag
) && quitf
) Vquit_flag
= Qt
;
2703 /* Get the value of symbol's global binding, even if that binding
2704 is not now dynamically visible. */
2707 top_level_value (symbol
)
2710 register struct specbinding
*ptr
= specpdl
;
2712 CHECK_SYMBOL (symbol
, 0);
2713 for (; ptr
!= specpdl_ptr
; ptr
++)
2715 if (EQ (ptr
->symbol
, symbol
))
2716 return ptr
->old_value
;
2718 return Fsymbol_value (symbol
);
2722 top_level_set (symbol
, newval
)
2723 Lisp_Object symbol
, newval
;
2725 register struct specbinding
*ptr
= specpdl
;
2727 CHECK_SYMBOL (symbol
, 0);
2728 for (; ptr
!= specpdl_ptr
; ptr
++)
2730 if (EQ (ptr
->symbol
, symbol
))
2732 ptr
->old_value
= newval
;
2736 return Fset (symbol
, newval
);
2741 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
2742 "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\
2743 The debugger is entered when that frame exits, if the flag is non-nil.")
2745 Lisp_Object level
, flag
;
2747 register struct backtrace
*backlist
= backtrace_list
;
2750 CHECK_NUMBER (level
, 0);
2752 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
2754 backlist
= backlist
->next
;
2758 backlist
->debug_on_exit
= !NILP (flag
);
2763 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
2764 "Print a trace of Lisp function calls currently active.\n\
2765 Output stream used is value of `standard-output'.")
2768 register struct backtrace
*backlist
= backtrace_list
;
2772 extern Lisp_Object Vprint_level
;
2773 struct gcpro gcpro1
;
2775 XSETFASTINT (Vprint_level
, 3);
2782 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
2783 if (backlist
->nargs
== UNEVALLED
)
2785 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
2786 write_string ("\n", -1);
2790 tem
= *backlist
->function
;
2791 Fprin1 (tem
, Qnil
); /* This can QUIT */
2792 write_string ("(", -1);
2793 if (backlist
->nargs
== MANY
)
2795 for (tail
= *backlist
->args
, i
= 0;
2797 tail
= Fcdr (tail
), i
++)
2799 if (i
) write_string (" ", -1);
2800 Fprin1 (Fcar (tail
), Qnil
);
2805 for (i
= 0; i
< backlist
->nargs
; i
++)
2807 if (i
) write_string (" ", -1);
2808 Fprin1 (backlist
->args
[i
], Qnil
);
2811 write_string (")\n", -1);
2813 backlist
= backlist
->next
;
2816 Vprint_level
= Qnil
;
2821 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, "",
2822 "Return the function and arguments NFRAMES up from current execution point.\n\
2823 If that frame has not evaluated the arguments yet (or is a special form),\n\
2824 the value is (nil FUNCTION ARG-FORMS...).\n\
2825 If that frame has evaluated its arguments and called its function already,\n\
2826 the value is (t FUNCTION ARG-VALUES...).\n\
2827 A &rest arg is represented as the tail of the list ARG-VALUES.\n\
2828 FUNCTION is whatever was supplied as car of evaluated list,\n\
2829 or a lambda expression for macro calls.\n\
2830 If NFRAMES is more than the number of frames, the value is nil.")
2832 Lisp_Object nframes
;
2834 register struct backtrace
*backlist
= backtrace_list
;
2838 CHECK_NATNUM (nframes
, 0);
2840 /* Find the frame requested. */
2841 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
2842 backlist
= backlist
->next
;
2846 if (backlist
->nargs
== UNEVALLED
)
2847 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
2850 if (backlist
->nargs
== MANY
)
2851 tem
= *backlist
->args
;
2853 tem
= Flist (backlist
->nargs
, backlist
->args
);
2855 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
2861 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
2862 "Limit on number of Lisp variable bindings & unwind-protects before error.");
2864 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
2865 "Limit on depth in `eval', `apply' and `funcall' before error.\n\
2866 This limit is to catch infinite recursions for you before they cause\n\
2867 actual stack overflow in C, which would be fatal for Emacs.\n\
2868 You can safely make it considerably larger than its default value,\n\
2869 if that proves inconveniently small.");
2871 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
2872 "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
2873 Typing C-g sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
2876 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
2877 "Non-nil inhibits C-g quitting from happening immediately.\n\
2878 Note that `quit-flag' will still be set by typing C-g,\n\
2879 so a quit will be signaled as soon as `inhibit-quit' is nil.\n\
2880 To prevent this happening, set `quit-flag' to nil\n\
2881 before making `inhibit-quit' nil.");
2882 Vinhibit_quit
= Qnil
;
2884 Qinhibit_quit
= intern ("inhibit-quit");
2885 staticpro (&Qinhibit_quit
);
2887 Qautoload
= intern ("autoload");
2888 staticpro (&Qautoload
);
2890 Qdebug_on_error
= intern ("debug-on-error");
2891 staticpro (&Qdebug_on_error
);
2893 Qmacro
= intern ("macro");
2894 staticpro (&Qmacro
);
2896 /* Note that the process handling also uses Qexit, but we don't want
2897 to staticpro it twice, so we just do it here. */
2898 Qexit
= intern ("exit");
2901 Qinteractive
= intern ("interactive");
2902 staticpro (&Qinteractive
);
2904 Qcommandp
= intern ("commandp");
2905 staticpro (&Qcommandp
);
2907 Qdefun
= intern ("defun");
2908 staticpro (&Qdefun
);
2910 Qand_rest
= intern ("&rest");
2911 staticpro (&Qand_rest
);
2913 Qand_optional
= intern ("&optional");
2914 staticpro (&Qand_optional
);
2916 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
2917 "*Non-nil means automatically display a backtrace buffer\n\
2918 after any error that is handled by the editor command loop.\n\
2919 If the value is a list, an error only means to display a backtrace\n\
2920 if one of its condition symbols appears in the list.");
2921 Vstack_trace_on_error
= Qnil
;
2923 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
2924 "*Non-nil means enter debugger if an error is signaled.\n\
2925 Does not apply to errors handled by `condition-case'.\n\
2926 If the value is a list, an error only means to enter the debugger\n\
2927 if one of its condition symbols appears in the list.\n\
2928 See also variable `debug-on-quit'.");
2929 Vdebug_on_error
= Qnil
;
2931 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
2932 "*List of errors for which the debugger should not be called.\n\
2933 Each element may be a condition-name or a regexp that matches error messages.\n\
2934 If any element applies to a given error, that error skips the debugger\n\
2935 and just returns to top level.\n\
2936 This overrides the variable `debug-on-error'.\n\
2937 It does not apply to errors handled by `condition-case'.");
2938 Vdebug_ignored_errors
= Qnil
;
2940 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
2941 "*Non-nil means enter debugger if quit is signaled (C-g, for example).\n\
2942 Does not apply if quit is handled by a `condition-case'.");
2945 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
2946 "Non-nil means enter debugger before next `eval', `apply' or `funcall'.");
2948 DEFVAR_LISP ("debugger", &Vdebugger
,
2949 "Function to call to invoke debugger.\n\
2950 If due to frame exit, args are `exit' and the value being returned;\n\
2951 this function's value will be returned instead of that.\n\
2952 If due to error, args are `error' and a list of the args to `signal'.\n\
2953 If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
2954 If due to `eval' entry, one arg, t.");
2957 DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function
,
2958 "If non-nil, this is a function for `signal' to call.\n\
2959 It receives the same arguments that `signal' was given.\n\
2960 The Edebug package uses this to regain control.");
2961 Vsignal_hook_function
= Qnil
;
2963 Qmocklisp_arguments
= intern ("mocklisp-arguments");
2964 staticpro (&Qmocklisp_arguments
);
2965 DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments
,
2966 "While in a mocklisp function, the list of its unevaluated args.");
2967 Vmocklisp_arguments
= Qt
;
2969 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal
,
2970 "*Non-nil means call the debugger regardless of condition handlers.\n\
2971 Note that `debug-on-error', `debug-on-quit' and friends\n\
2972 still determine whether to handle the particular condition.");
2973 Vdebug_on_signal
= Qnil
;
2975 Vrun_hooks
= intern ("run-hooks");
2976 staticpro (&Vrun_hooks
);
2978 staticpro (&Vautoload_queue
);
2979 Vautoload_queue
= Qnil
;
2990 defsubr (&Sfunction
);
2992 defsubr (&Sdefmacro
);
2994 defsubr (&Sdefconst
);
2995 defsubr (&Suser_variable_p
);
2999 defsubr (&Smacroexpand
);
3002 defsubr (&Sunwind_protect
);
3003 defsubr (&Scondition_case
);
3005 defsubr (&Sinteractive_p
);
3006 defsubr (&Scommandp
);
3007 defsubr (&Sautoload
);
3010 defsubr (&Sfuncall
);
3011 defsubr (&Srun_hooks
);
3012 defsubr (&Srun_hook_with_args
);
3013 defsubr (&Srun_hook_with_args_until_success
);
3014 defsubr (&Srun_hook_with_args_until_failure
);
3015 defsubr (&Sfetch_bytecode
);
3016 defsubr (&Sbacktrace_debug
);
3017 defsubr (&Sbacktrace
);
3018 defsubr (&Sbacktrace_frame
);