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 Lisp_Object Vrun_hooks
;
95 /* Non-nil means record all fset's and provide's, to be undone
96 if the file being autoloaded is not fully loaded.
97 They are recorded by being consed onto the front of Vautoload_queue:
98 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */
100 Lisp_Object Vautoload_queue
;
102 /* Current number of specbindings allocated in specpdl. */
105 /* Pointer to beginning of specpdl. */
106 struct specbinding
*specpdl
;
108 /* Pointer to first unused element in specpdl. */
109 struct specbinding
*specpdl_ptr
;
111 /* Maximum size allowed for specpdl allocation */
112 int max_specpdl_size
;
114 /* Depth in Lisp evaluations and function calls. */
117 /* Maximum allowed depth in Lisp evaluations and function calls. */
118 int max_lisp_eval_depth
;
120 /* Nonzero means enter debugger before next function call */
121 int debug_on_next_call
;
123 /* List of conditions (non-nil atom means all) which cause a backtrace
124 if an error is handled by the command loop's error handler. */
125 Lisp_Object Vstack_trace_on_error
;
127 /* List of conditions (non-nil atom means all) which enter the debugger
128 if an error is handled by the command loop's error handler. */
129 Lisp_Object Vdebug_on_error
;
131 /* List of conditions and regexps specifying error messages which
132 do not enter the debugger even if Vdebug_on_errors says they should. */
133 Lisp_Object Vdebug_ignored_errors
;
135 /* Nonzero means enter debugger if a quit signal
136 is handled by the command loop's error handler. */
139 /* The value of num_nonmacro_input_chars as of the last time we
140 started to enter the debugger. If we decide to enter the debugger
141 again when this is still equal to num_nonmacro_input_chars, then we
142 know that the debugger itself has an error, and we should just
143 signal the error instead of entering an infinite loop of debugger
145 int when_entered_debugger
;
147 Lisp_Object Vdebugger
;
149 void specbind (), record_unwind_protect ();
151 Lisp_Object
run_hook_with_args ();
153 Lisp_Object
funcall_lambda ();
154 extern Lisp_Object
ml_apply (); /* Apply a mocklisp function to unevaluated argument list */
159 specpdl
= (struct specbinding
*) xmalloc (specpdl_size
* sizeof (struct specbinding
));
160 specpdl_ptr
= specpdl
;
161 max_specpdl_size
= 600;
162 max_lisp_eval_depth
= 200;
169 specpdl_ptr
= specpdl
;
174 debug_on_next_call
= 0;
176 /* This is less than the initial value of num_nonmacro_input_chars. */
177 when_entered_debugger
= -1;
184 if (lisp_eval_depth
+ 20 > max_lisp_eval_depth
)
185 max_lisp_eval_depth
= lisp_eval_depth
+ 20;
186 if (specpdl_size
+ 40 > max_specpdl_size
)
187 max_specpdl_size
= specpdl_size
+ 40;
188 debug_on_next_call
= 0;
189 when_entered_debugger
= num_nonmacro_input_chars
;
190 return apply1 (Vdebugger
, arg
);
193 do_debug_on_call (code
)
196 debug_on_next_call
= 0;
197 backtrace_list
->debug_on_exit
= 1;
198 call_debugger (Fcons (code
, Qnil
));
201 /* NOTE!!! Every function that can call EVAL must protect its args
202 and temporaries from garbage collection while it needs them.
203 The definition of `For' shows what you have to do. */
205 DEFUN ("or", For
, Sor
, 0, UNEVALLED
, 0,
206 "Eval args until one of them yields non-nil, then return that value.\n\
207 The remaining args are not evalled at all.\n\
208 If all args return nil, return nil.")
212 register Lisp_Object val
;
213 Lisp_Object args_left
;
224 val
= Feval (Fcar (args_left
));
227 args_left
= Fcdr (args_left
);
229 while (!NILP(args_left
));
235 DEFUN ("and", Fand
, Sand
, 0, UNEVALLED
, 0,
236 "Eval args until one of them yields nil, then return nil.\n\
237 The remaining args are not evalled at all.\n\
238 If no arg yields nil, return the last arg's value.")
242 register Lisp_Object val
;
243 Lisp_Object args_left
;
254 val
= Feval (Fcar (args_left
));
257 args_left
= Fcdr (args_left
);
259 while (!NILP(args_left
));
265 DEFUN ("if", Fif
, Sif
, 2, UNEVALLED
, 0,
266 "(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...\n\
267 Returns the value of THEN or the value of the last of the ELSE's.\n\
268 THEN must be one expression, but ELSE... can be zero or more expressions.\n\
269 If COND yields nil, and there are no ELSE's, the value is nil.")
273 register Lisp_Object cond
;
277 cond
= Feval (Fcar (args
));
281 return Feval (Fcar (Fcdr (args
)));
282 return Fprogn (Fcdr (Fcdr (args
)));
285 DEFUN ("cond", Fcond
, Scond
, 0, UNEVALLED
, 0,
286 "(cond CLAUSES...): try each clause until one succeeds.\n\
287 Each clause looks like (CONDITION BODY...). CONDITION is evaluated\n\
288 and, if the value is non-nil, this clause succeeds:\n\
289 then the expressions in BODY are evaluated and the last one's\n\
290 value is the value of the cond-form.\n\
291 If no clause succeeds, cond returns nil.\n\
292 If a clause has one element, as in (CONDITION),\n\
293 CONDITION's value if non-nil is returned from the cond-form.")
297 register Lisp_Object clause
, val
;
304 clause
= Fcar (args
);
305 val
= Feval (Fcar (clause
));
308 if (!EQ (XCONS (clause
)->cdr
, Qnil
))
309 val
= Fprogn (XCONS (clause
)->cdr
);
312 args
= XCONS (args
)->cdr
;
319 DEFUN ("progn", Fprogn
, Sprogn
, 0, UNEVALLED
, 0,
320 "(progn BODY...): eval BODY forms sequentially and return value of last one.")
324 register Lisp_Object val
, tem
;
325 Lisp_Object args_left
;
328 /* In Mocklisp code, symbols at the front of the progn arglist
329 are to be bound to zero. */
330 if (!EQ (Vmocklisp_arguments
, Qt
))
332 val
= make_number (0);
333 while (!NILP (args
) && (tem
= Fcar (args
), SYMBOLP (tem
)))
336 specbind (tem
, val
), args
= Fcdr (args
);
348 val
= Feval (Fcar (args_left
));
349 args_left
= Fcdr (args_left
);
351 while (!NILP(args_left
));
357 DEFUN ("prog1", Fprog1
, Sprog1
, 1, UNEVALLED
, 0,
358 "(prog1 FIRST BODY...): eval FIRST and BODY sequentially; value from FIRST.\n\
359 The value of FIRST is saved during the evaluation of the remaining args,\n\
360 whose values are discarded.")
365 register Lisp_Object args_left
;
366 struct gcpro gcpro1
, gcpro2
;
367 register int argnum
= 0;
379 val
= Feval (Fcar (args_left
));
381 Feval (Fcar (args_left
));
382 args_left
= Fcdr (args_left
);
384 while (!NILP(args_left
));
390 DEFUN ("prog2", Fprog2
, Sprog2
, 2, UNEVALLED
, 0,
391 "(prog2 X Y BODY...): eval X, Y and BODY sequentially; value from Y.\n\
392 The value of Y is saved during the evaluation of the remaining args,\n\
393 whose values are discarded.")
398 register Lisp_Object args_left
;
399 struct gcpro gcpro1
, gcpro2
;
400 register int argnum
= -1;
414 val
= Feval (Fcar (args_left
));
416 Feval (Fcar (args_left
));
417 args_left
= Fcdr (args_left
);
419 while (!NILP (args_left
));
425 DEFUN ("setq", Fsetq
, Ssetq
, 0, UNEVALLED
, 0,
426 "(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.\n\
427 The symbols SYM are variables; they are literal (not evaluated).\n\
428 The values VAL are expressions; they are evaluated.\n\
429 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.\n\
430 The second VAL is not computed until after the first SYM is set, and so on;\n\
431 each VAL can use the new value of variables set earlier in the `setq'.\n\
432 The return value of the `setq' form is the value of the last VAL.")
436 register Lisp_Object args_left
;
437 register Lisp_Object val
, sym
;
448 val
= Feval (Fcar (Fcdr (args_left
)));
449 sym
= Fcar (args_left
);
451 args_left
= Fcdr (Fcdr (args_left
));
453 while (!NILP(args_left
));
459 DEFUN ("quote", Fquote
, Squote
, 1, UNEVALLED
, 0,
460 "Return the argument, without evaluating it. `(quote x)' yields `x'.")
467 DEFUN ("function", Ffunction
, Sfunction
, 1, UNEVALLED
, 0,
468 "Like `quote', but preferred for objects which are functions.\n\
469 In byte compilation, `function' causes its argument to be compiled.\n\
470 `quote' cannot do that.")
477 DEFUN ("interactive-p", Finteractive_p
, Sinteractive_p
, 0, 0, 0,
478 "Return t if function in which this appears was called interactively.\n\
479 This means that the function was called with call-interactively (which\n\
480 includes being called as the binding of a key)\n\
481 and input is currently coming from the keyboard (not in keyboard macro).")
484 register struct backtrace
*btp
;
485 register Lisp_Object fun
;
490 btp
= backtrace_list
;
492 /* If this isn't a byte-compiled function, there may be a frame at
493 the top for Finteractive_p itself. If so, skip it. */
494 fun
= Findirect_function (*btp
->function
);
495 if (SUBRP (fun
) && XSUBR (fun
) == &Sinteractive_p
)
498 /* If we're running an Emacs 18-style byte-compiled function, there
499 may be a frame for Fbytecode. Now, given the strictest
500 definition, this function isn't really being called
501 interactively, but because that's the way Emacs 18 always builds
502 byte-compiled functions, we'll accept it for now. */
503 if (EQ (*btp
->function
, Qbytecode
))
506 /* If this isn't a byte-compiled function, then we may now be
507 looking at several frames for special forms. Skip past them. */
509 btp
->nargs
== UNEVALLED
)
512 /* btp now points at the frame of the innermost function that isn't
513 a special form, ignoring frames for Finteractive_p and/or
514 Fbytecode at the top. If this frame is for a built-in function
515 (such as load or eval-region) return nil. */
516 fun
= Findirect_function (*btp
->function
);
519 /* btp points to the frame of a Lisp function that called interactive-p.
520 Return t if that function was called interactively. */
521 if (btp
&& btp
->next
&& EQ (*btp
->next
->function
, Qcall_interactively
))
526 DEFUN ("defun", Fdefun
, Sdefun
, 2, UNEVALLED
, 0,
527 "(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.\n\
528 The definition is (lambda ARGLIST [DOCSTRING] BODY...).\n\
529 See also the function `interactive'.")
533 register Lisp_Object fn_name
;
534 register Lisp_Object defn
;
536 fn_name
= Fcar (args
);
537 defn
= Fcons (Qlambda
, Fcdr (args
));
538 if (!NILP (Vpurify_flag
))
539 defn
= Fpurecopy (defn
);
540 Ffset (fn_name
, defn
);
541 LOADHIST_ATTACH (fn_name
);
545 DEFUN ("defmacro", Fdefmacro
, Sdefmacro
, 2, UNEVALLED
, 0,
546 "(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.\n\
547 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).\n\
548 When the macro is called, as in (NAME ARGS...),\n\
549 the function (lambda ARGLIST BODY...) is applied to\n\
550 the list ARGS... as it appears in the expression,\n\
551 and the result should be a form to be evaluated instead of the original.")
555 register Lisp_Object fn_name
;
556 register Lisp_Object defn
;
558 fn_name
= Fcar (args
);
559 defn
= Fcons (Qmacro
, Fcons (Qlambda
, Fcdr (args
)));
560 if (!NILP (Vpurify_flag
))
561 defn
= Fpurecopy (defn
);
562 Ffset (fn_name
, defn
);
563 LOADHIST_ATTACH (fn_name
);
567 DEFUN ("defvar", Fdefvar
, Sdefvar
, 1, UNEVALLED
, 0,
568 "(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.\n\
569 You are not required to define a variable in order to use it,\n\
570 but the definition can supply documentation and an initial value\n\
571 in a way that tags can recognize.\n\n\
572 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.\n\
573 If SYMBOL is buffer-local, its default value is what is set;\n\
574 buffer-local values are not affected.\n\
575 INITVALUE and DOCSTRING are optional.\n\
576 If DOCSTRING starts with *, this variable is identified as a user option.\n\
577 This means that M-x set-variable and M-x edit-options recognize it.\n\
578 If INITVALUE is missing, SYMBOL's value is not set.")
582 register Lisp_Object sym
, tem
, tail
;
586 if (!NILP (Fcdr (Fcdr (tail
))))
587 error ("too many arguments");
591 tem
= Fdefault_boundp (sym
);
593 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
595 tail
= Fcdr (Fcdr (args
));
596 if (!NILP (Fcar (tail
)))
599 if (!NILP (Vpurify_flag
))
600 tem
= Fpurecopy (tem
);
601 Fput (sym
, Qvariable_documentation
, tem
);
603 LOADHIST_ATTACH (sym
);
607 DEFUN ("defconst", Fdefconst
, Sdefconst
, 2, UNEVALLED
, 0,
608 "(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant variable.\n\
609 The intent is that programs do not change this value, but users may.\n\
610 Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\
611 If SYMBOL is buffer-local, its default value is what is set;\n\
612 buffer-local values are not affected.\n\
613 DOCSTRING is optional.\n\
614 If DOCSTRING starts with *, this variable is identified as a user option.\n\
615 This means that M-x set-variable and M-x edit-options recognize it.\n\n\
616 Note: do not use `defconst' for user options in libraries that are not\n\
617 normally loaded, since it is useful for users to be able to specify\n\
618 their own values for such variables before loading the library.\n\
619 Since `defconst' unconditionally assigns the variable,\n\
620 it would override the user's choice.")
624 register Lisp_Object sym
, tem
;
627 if (!NILP (Fcdr (Fcdr (Fcdr (args
)))))
628 error ("too many arguments");
630 Fset_default (sym
, Feval (Fcar (Fcdr (args
))));
631 tem
= Fcar (Fcdr (Fcdr (args
)));
634 if (!NILP (Vpurify_flag
))
635 tem
= Fpurecopy (tem
);
636 Fput (sym
, Qvariable_documentation
, tem
);
638 LOADHIST_ATTACH (sym
);
642 DEFUN ("user-variable-p", Fuser_variable_p
, Suser_variable_p
, 1, 1, 0,
643 "Returns t if VARIABLE is intended to be set and modified by users.\n\
644 \(The alternative is a variable used internally in a Lisp program.)\n\
645 Determined by whether the first character of the documentation\n\
646 for the variable is `*'.")
648 Lisp_Object variable
;
650 Lisp_Object documentation
;
652 documentation
= Fget (variable
, Qvariable_documentation
);
653 if (INTEGERP (documentation
) && XINT (documentation
) < 0)
655 if (STRINGP (documentation
)
656 && ((unsigned char) XSTRING (documentation
)->data
[0] == '*'))
658 /* If it is (STRING . INTEGER), a negative integer means a user variable. */
659 if (CONSP (documentation
)
660 && STRINGP (XCONS (documentation
)->car
)
661 && INTEGERP (XCONS (documentation
)->cdr
)
662 && XINT (XCONS (documentation
)->cdr
) < 0)
667 DEFUN ("let*", FletX
, SletX
, 1, UNEVALLED
, 0,
668 "(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
669 The value of the last form in BODY is returned.\n\
670 Each element of VARLIST is a symbol (which is bound to nil)\n\
671 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
672 Each VALUEFORM can refer to the symbols already bound by this VARLIST.")
676 Lisp_Object varlist
, val
, elt
;
677 int count
= specpdl_ptr
- specpdl
;
678 struct gcpro gcpro1
, gcpro2
, gcpro3
;
680 GCPRO3 (args
, elt
, varlist
);
682 varlist
= Fcar (args
);
683 while (!NILP (varlist
))
686 elt
= Fcar (varlist
);
688 specbind (elt
, Qnil
);
689 else if (! NILP (Fcdr (Fcdr (elt
))))
691 Fcons (build_string ("`let' bindings can have only one value-form"),
695 val
= Feval (Fcar (Fcdr (elt
)));
696 specbind (Fcar (elt
), val
);
698 varlist
= Fcdr (varlist
);
701 val
= Fprogn (Fcdr (args
));
702 return unbind_to (count
, val
);
705 DEFUN ("let", Flet
, Slet
, 1, UNEVALLED
, 0,
706 "(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
707 The value of the last form in BODY is returned.\n\
708 Each element of VARLIST is a symbol (which is bound to nil)\n\
709 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
710 All the VALUEFORMs are evalled before any symbols are bound.")
714 Lisp_Object
*temps
, tem
;
715 register Lisp_Object elt
, varlist
;
716 int count
= specpdl_ptr
- specpdl
;
718 struct gcpro gcpro1
, gcpro2
;
720 varlist
= Fcar (args
);
722 /* Make space to hold the values to give the bound variables */
723 elt
= Flength (varlist
);
724 temps
= (Lisp_Object
*) alloca (XFASTINT (elt
) * sizeof (Lisp_Object
));
726 /* Compute the values and store them in `temps' */
728 GCPRO2 (args
, *temps
);
731 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
734 elt
= Fcar (varlist
);
736 temps
[argnum
++] = Qnil
;
737 else if (! NILP (Fcdr (Fcdr (elt
))))
739 Fcons (build_string ("`let' bindings can have only one value-form"),
742 temps
[argnum
++] = Feval (Fcar (Fcdr (elt
)));
743 gcpro2
.nvars
= argnum
;
747 varlist
= Fcar (args
);
748 for (argnum
= 0; !NILP (varlist
); varlist
= Fcdr (varlist
))
750 elt
= Fcar (varlist
);
751 tem
= temps
[argnum
++];
755 specbind (Fcar (elt
), tem
);
758 elt
= Fprogn (Fcdr (args
));
759 return unbind_to (count
, elt
);
762 DEFUN ("while", Fwhile
, Swhile
, 1, UNEVALLED
, 0,
763 "(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.\n\
764 The order of execution is thus TEST, BODY, TEST, BODY and so on\n\
765 until TEST returns nil.")
769 Lisp_Object test
, body
, tem
;
770 struct gcpro gcpro1
, gcpro2
;
776 while (tem
= Feval (test
),
777 (!EQ (Vmocklisp_arguments
, Qt
) ? XINT (tem
) : !NILP (tem
)))
787 DEFUN ("macroexpand", Fmacroexpand
, Smacroexpand
, 1, 2, 0,
788 "Return result of expanding macros at top level of FORM.\n\
789 If FORM is not a macro call, it is returned unchanged.\n\
790 Otherwise, the macro is expanded and the expansion is considered\n\
791 in place of FORM. When a non-macro-call results, it is returned.\n\n\
792 The second optional arg ENVIRONMENT species an environment of macro\n\
793 definitions to shadow the loaded ones for use in file byte-compilation.")
795 register Lisp_Object form
;
796 Lisp_Object environment
;
798 /* With cleanups from Hallvard Furuseth. */
799 register Lisp_Object expander
, sym
, def
, tem
;
803 /* Come back here each time we expand a macro call,
804 in case it expands into another macro call. */
807 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
808 def
= sym
= XCONS (form
)->car
;
810 /* Trace symbols aliases to other symbols
811 until we get a symbol that is not an alias. */
812 while (SYMBOLP (def
))
816 tem
= Fassq (sym
, environment
);
819 def
= XSYMBOL (sym
)->function
;
820 if (!EQ (def
, Qunbound
))
825 /* Right now TEM is the result from SYM in ENVIRONMENT,
826 and if TEM is nil then DEF is SYM's function definition. */
829 /* SYM is not mentioned in ENVIRONMENT.
830 Look at its function definition. */
831 if (EQ (def
, Qunbound
) || !CONSP (def
))
832 /* Not defined or definition not suitable */
834 if (EQ (XCONS (def
)->car
, Qautoload
))
836 /* Autoloading function: will it be a macro when loaded? */
837 tem
= Fnth (make_number (4), def
);
838 if (EQ (tem
, Qt
) || EQ (tem
, Qmacro
))
839 /* Yes, load it and try again. */
843 do_autoload (def
, sym
);
850 else if (!EQ (XCONS (def
)->car
, Qmacro
))
852 else expander
= XCONS (def
)->cdr
;
856 expander
= XCONS (tem
)->cdr
;
860 form
= apply1 (expander
, XCONS (form
)->cdr
);
865 DEFUN ("catch", Fcatch
, Scatch
, 1, UNEVALLED
, 0,
866 "(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.\n\
867 TAG is evalled to get the tag to use. Then the BODY is executed.\n\
868 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.\n\
869 If no throw happens, `catch' returns the value of the last BODY form.\n\
870 If a throw happens, it specifies the value to return from `catch'.")
874 register Lisp_Object tag
;
878 tag
= Feval (Fcar (args
));
880 return internal_catch (tag
, Fprogn
, Fcdr (args
));
883 /* Set up a catch, then call C function FUNC on argument ARG.
884 FUNC should return a Lisp_Object.
885 This is how catches are done from within C code. */
888 internal_catch (tag
, func
, arg
)
890 Lisp_Object (*func
) ();
893 /* This structure is made part of the chain `catchlist'. */
896 /* Fill in the components of c, and put it on the list. */
900 c
.backlist
= backtrace_list
;
901 c
.handlerlist
= handlerlist
;
902 c
.lisp_eval_depth
= lisp_eval_depth
;
903 c
.pdlcount
= specpdl_ptr
- specpdl
;
904 c
.poll_suppress_count
= poll_suppress_count
;
909 if (! _setjmp (c
.jmp
))
910 c
.val
= (*func
) (arg
);
912 /* Throw works by a longjmp that comes right here. */
917 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
918 jump to that CATCH, returning VALUE as the value of that catch.
920 This is the guts Fthrow and Fsignal; they differ only in the way
921 they choose the catch tag to throw to. A catch tag for a
922 condition-case form has a TAG of Qnil.
924 Before each catch is discarded, unbind all special bindings and
925 execute all unwind-protect clauses made above that catch. Unwind
926 the handler stack as we go, so that the proper handlers are in
927 effect for each unwind-protect clause we run. At the end, restore
928 some static info saved in CATCH, and longjmp to the location
931 This is used for correct unwinding in Fthrow and Fsignal. */
934 unwind_to_catch (catch, value
)
935 struct catchtag
*catch;
938 register int last_time
;
940 /* Save the value in the tag. */
943 /* Restore the polling-suppression count. */
944 set_poll_suppress_count (catch->poll_suppress_count
);
948 last_time
= catchlist
== catch;
950 /* Unwind the specpdl stack, and then restore the proper set of
952 unbind_to (catchlist
->pdlcount
, Qnil
);
953 handlerlist
= catchlist
->handlerlist
;
954 catchlist
= catchlist
->next
;
958 gcprolist
= catch->gcpro
;
959 backtrace_list
= catch->backlist
;
960 lisp_eval_depth
= catch->lisp_eval_depth
;
962 _longjmp (catch->jmp
, 1);
965 DEFUN ("throw", Fthrow
, Sthrow
, 2, 2, 0,
966 "(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.\n\
967 Both TAG and VALUE are evalled.")
969 register Lisp_Object tag
, value
;
971 register struct catchtag
*c
;
976 for (c
= catchlist
; c
; c
= c
->next
)
978 if (EQ (c
->tag
, tag
))
979 unwind_to_catch (c
, value
);
981 tag
= Fsignal (Qno_catch
, Fcons (tag
, Fcons (value
, Qnil
)));
986 DEFUN ("unwind-protect", Funwind_protect
, Sunwind_protect
, 1, UNEVALLED
, 0,
987 "Do BODYFORM, protecting with UNWINDFORMS.\n\
988 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).\n\
989 If BODYFORM completes normally, its value is returned\n\
990 after executing the UNWINDFORMS.\n\
991 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.")
996 int count
= specpdl_ptr
- specpdl
;
998 record_unwind_protect (0, Fcdr (args
));
999 val
= Feval (Fcar (args
));
1000 return unbind_to (count
, val
);
1003 /* Chain of condition handlers currently in effect.
1004 The elements of this chain are contained in the stack frames
1005 of Fcondition_case and internal_condition_case.
1006 When an error is signaled (by calling Fsignal, below),
1007 this chain is searched for an element that applies. */
1009 struct handler
*handlerlist
;
1011 DEFUN ("condition-case", Fcondition_case
, Scondition_case
, 2, UNEVALLED
, 0,
1012 "Regain control when an error is signaled.\n\
1013 Usage looks like (condition-case VAR BODYFORM HANDLERS...).\n\
1014 executes BODYFORM and returns its value if no error happens.\n\
1015 Each element of HANDLERS looks like (CONDITION-NAME BODY...)\n\
1016 where the BODY is made of Lisp expressions.\n\n\
1017 A handler is applicable to an error\n\
1018 if CONDITION-NAME is one of the error's condition names.\n\
1019 If an error happens, the first applicable handler is run.\n\
1021 The car of a handler may be a list of condition names\n\
1022 instead of a single condition name.\n\
1024 When a handler handles an error,\n\
1025 control returns to the condition-case and the handler BODY... is executed\n\
1026 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\
1027 VAR may be nil; then you do not get access to the signal information.\n\
1029 The value of the last BODY form is returned from the condition-case.\n\
1030 See also the function `signal' for more info.")
1037 register Lisp_Object var
, bodyform
, handlers
;
1040 bodyform
= Fcar (Fcdr (args
));
1041 handlers
= Fcdr (Fcdr (args
));
1042 CHECK_SYMBOL (var
, 0);
1044 for (val
= handlers
; ! NILP (val
); val
= Fcdr (val
))
1050 && (SYMBOLP (XCONS (tem
)->car
)
1051 || CONSP (XCONS (tem
)->car
)))))
1052 error ("Invalid condition handler", tem
);
1057 c
.backlist
= backtrace_list
;
1058 c
.handlerlist
= handlerlist
;
1059 c
.lisp_eval_depth
= lisp_eval_depth
;
1060 c
.pdlcount
= specpdl_ptr
- specpdl
;
1061 c
.poll_suppress_count
= poll_suppress_count
;
1062 c
.gcpro
= gcprolist
;
1063 if (_setjmp (c
.jmp
))
1066 specbind (h
.var
, c
.val
);
1067 val
= Fprogn (Fcdr (h
.chosen_clause
));
1069 /* Note that this just undoes the binding of h.var; whoever
1070 longjumped to us unwound the stack to c.pdlcount before
1072 unbind_to (c
.pdlcount
, Qnil
);
1079 h
.handler
= handlers
;
1080 h
.next
= handlerlist
;
1084 val
= Feval (bodyform
);
1086 handlerlist
= h
.next
;
1090 /* Call the function BFUN with no arguments, catching errors within it
1091 according to HANDLERS. If there is an error, call HFUN with
1092 one argument which is the data that describes the error:
1095 HANDLERS can be a list of conditions to catch.
1096 If HANDLERS is Qt, catch all errors.
1097 If HANDLERS is Qerror, catch all errors
1098 but allow the debugger to run if that is enabled. */
1101 internal_condition_case (bfun
, handlers
, hfun
)
1102 Lisp_Object (*bfun
) ();
1103 Lisp_Object handlers
;
1104 Lisp_Object (*hfun
) ();
1110 /* Since Fsignal resets this to 0, it had better be 0 now
1111 or else we have a potential bug. */
1112 if (interrupt_input_blocked
!= 0)
1117 c
.backlist
= backtrace_list
;
1118 c
.handlerlist
= handlerlist
;
1119 c
.lisp_eval_depth
= lisp_eval_depth
;
1120 c
.pdlcount
= specpdl_ptr
- specpdl
;
1121 c
.poll_suppress_count
= poll_suppress_count
;
1122 c
.gcpro
= gcprolist
;
1123 if (_setjmp (c
.jmp
))
1125 return (*hfun
) (c
.val
);
1129 h
.handler
= handlers
;
1131 h
.next
= handlerlist
;
1137 handlerlist
= h
.next
;
1141 /* Like internal_condition_case but call HFUN with ARG as its argument. */
1144 internal_condition_case_1 (bfun
, arg
, handlers
, hfun
)
1145 Lisp_Object (*bfun
) ();
1147 Lisp_Object handlers
;
1148 Lisp_Object (*hfun
) ();
1156 c
.backlist
= backtrace_list
;
1157 c
.handlerlist
= handlerlist
;
1158 c
.lisp_eval_depth
= lisp_eval_depth
;
1159 c
.pdlcount
= specpdl_ptr
- specpdl
;
1160 c
.poll_suppress_count
= poll_suppress_count
;
1161 c
.gcpro
= gcprolist
;
1162 if (_setjmp (c
.jmp
))
1164 return (*hfun
) (c
.val
);
1168 h
.handler
= handlers
;
1170 h
.next
= handlerlist
;
1174 val
= (*bfun
) (arg
);
1176 handlerlist
= h
.next
;
1180 static Lisp_Object
find_handler_clause ();
1182 DEFUN ("signal", Fsignal
, Ssignal
, 2, 2, 0,
1183 "Signal an error. Args are ERROR-SYMBOL and associated DATA.\n\
1184 This function does not return.\n\n\
1185 An error symbol is a symbol with an `error-conditions' property\n\
1186 that is a list of condition names.\n\
1187 A handler for any of those names will get to handle this signal.\n\
1188 The symbol `error' should normally be one of them.\n\
1190 DATA should be a list. Its elements are printed as part of the error message.\n\
1191 If the signal is handled, DATA is made available to the handler.\n\
1192 See also the function `condition-case'.")
1193 (error_symbol
, data
)
1194 Lisp_Object error_symbol
, data
;
1196 register struct handler
*allhandlers
= handlerlist
;
1197 Lisp_Object conditions
;
1198 extern int gc_in_progress
;
1199 extern int waiting_for_input
;
1200 Lisp_Object debugger_value
;
1202 quit_error_check ();
1204 if (gc_in_progress
|| waiting_for_input
)
1207 #ifdef HAVE_WINDOW_SYSTEM
1208 TOTALLY_UNBLOCK_INPUT
;
1211 conditions
= Fget (error_symbol
, Qerror_conditions
);
1213 for (; handlerlist
; handlerlist
= handlerlist
->next
)
1215 register Lisp_Object clause
;
1216 clause
= find_handler_clause (handlerlist
->handler
, conditions
,
1217 error_symbol
, data
, &debugger_value
);
1219 #if 0 /* Most callers are not prepared to handle gc if this returns.
1220 So, since this feature is not very useful, take it out. */
1221 /* If have called debugger and user wants to continue,
1223 if (EQ (clause
, Qlambda
))
1224 return debugger_value
;
1226 if (EQ (clause
, Qlambda
))
1228 /* We can't return values to code which signaled an error, but we
1229 can continue code which has signaled a quit. */
1230 if (EQ (error_symbol
, Qquit
))
1233 error ("Cannot return from the debugger in an error");
1239 Lisp_Object unwind_data
;
1240 struct handler
*h
= handlerlist
;
1242 handlerlist
= allhandlers
;
1243 if (EQ (data
, memory_signal_data
))
1244 unwind_data
= memory_signal_data
;
1246 unwind_data
= Fcons (error_symbol
, data
);
1247 h
->chosen_clause
= clause
;
1248 unwind_to_catch (h
->tag
, unwind_data
);
1252 handlerlist
= allhandlers
;
1253 /* If no handler is present now, try to run the debugger,
1254 and if that fails, throw to top level. */
1255 find_handler_clause (Qerror
, conditions
, error_symbol
, data
, &debugger_value
);
1256 Fthrow (Qtop_level
, Qt
);
1259 /* Return nonzero iff LIST is a non-nil atom or
1260 a list containing one of CONDITIONS. */
1263 wants_debugger (list
, conditions
)
1264 Lisp_Object list
, conditions
;
1271 while (CONSP (conditions
))
1273 Lisp_Object
this, tail
;
1274 this = XCONS (conditions
)->car
;
1275 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1276 if (EQ (XCONS (tail
)->car
, this))
1278 conditions
= XCONS (conditions
)->cdr
;
1283 /* Return 1 if an error with condition-symbols CONDITIONS,
1284 and described by SIGNAL-DATA, should skip the debugger
1285 according to debugger-ignore-errors. */
1288 skip_debugger (conditions
, data
)
1289 Lisp_Object conditions
, data
;
1292 int first_string
= 1;
1293 Lisp_Object error_message
;
1295 for (tail
= Vdebug_ignored_errors
; CONSP (tail
);
1296 tail
= XCONS (tail
)->cdr
)
1298 if (STRINGP (XCONS (tail
)->car
))
1302 error_message
= Ferror_message_string (data
);
1305 if (fast_string_match (XCONS (tail
)->car
, error_message
) >= 0)
1310 Lisp_Object contail
;
1312 for (contail
= conditions
; CONSP (contail
);
1313 contail
= XCONS (contail
)->cdr
)
1314 if (EQ (XCONS (tail
)->car
, XCONS (contail
)->car
))
1322 /* Value of Qlambda means we have called debugger and user has continued.
1323 Store value returned from debugger into *DEBUGGER_VALUE_PTR. */
1326 find_handler_clause (handlers
, conditions
, sig
, data
, debugger_value_ptr
)
1327 Lisp_Object handlers
, conditions
, sig
, data
;
1328 Lisp_Object
*debugger_value_ptr
;
1330 register Lisp_Object h
;
1331 register Lisp_Object tem
;
1333 if (EQ (handlers
, Qt
)) /* t is used by handlers for all conditions, set up by C code. */
1335 if (EQ (handlers
, Qerror
)) /* error is used similarly, but means display a backtrace too */
1337 if (wants_debugger (Vstack_trace_on_error
, conditions
))
1338 internal_with_output_to_temp_buffer ("*Backtrace*", Fbacktrace
, Qnil
);
1339 if ((EQ (sig
, Qquit
)
1341 : wants_debugger (Vdebug_on_error
, conditions
))
1342 && ! skip_debugger (conditions
, Fcons (sig
, data
))
1343 && when_entered_debugger
< num_nonmacro_input_chars
)
1345 int count
= specpdl_ptr
- specpdl
;
1346 specbind (Qdebug_on_error
, Qnil
);
1348 = call_debugger (Fcons (Qerror
,
1349 Fcons (Fcons (sig
, data
),
1351 return unbind_to (count
, Qlambda
);
1355 for (h
= handlers
; CONSP (h
); h
= Fcdr (h
))
1357 Lisp_Object handler
, condit
;
1360 if (!CONSP (handler
))
1362 condit
= Fcar (handler
);
1363 /* Handle a single condition name in handler HANDLER. */
1364 if (SYMBOLP (condit
))
1366 tem
= Fmemq (Fcar (handler
), conditions
);
1370 /* Handle a list of condition names in handler HANDLER. */
1371 else if (CONSP (condit
))
1373 while (CONSP (condit
))
1375 tem
= Fmemq (Fcar (condit
), conditions
);
1378 condit
= XCONS (condit
)->cdr
;
1385 /* dump an error message; called like printf */
1389 error (m
, a1
, a2
, a3
)
1409 int used
= doprnt (buf
, size
, m
, m
+ mlen
, 3, args
);
1414 buffer
= (char *) xrealloc (buffer
, size
);
1417 buffer
= (char *) xmalloc (size
);
1422 string
= build_string (buf
);
1426 Fsignal (Qerror
, Fcons (string
, Qnil
));
1429 DEFUN ("commandp", Fcommandp
, Scommandp
, 1, 1, 0,
1430 "T if FUNCTION makes provisions for interactive calling.\n\
1431 This means it contains a description for how to read arguments to give it.\n\
1432 The value is nil for an invalid function or a symbol with no function\n\
1435 Interactively callable functions include strings and vectors (treated\n\
1436 as keyboard macros), lambda-expressions that contain a top-level call\n\
1437 to `interactive', autoload definitions made by `autoload' with non-nil\n\
1438 fourth argument, and some of the built-in functions of Lisp.\n\
1440 Also, a symbol satisfies `commandp' if its function definition does so.")
1442 Lisp_Object function
;
1444 register Lisp_Object fun
;
1445 register Lisp_Object funcar
;
1446 register Lisp_Object tem
;
1451 fun
= indirect_function (fun
);
1452 if (EQ (fun
, Qunbound
))
1455 /* Emacs primitives are interactive if their DEFUN specifies an
1456 interactive spec. */
1459 if (XSUBR (fun
)->prompt
)
1465 /* Bytecode objects are interactive if they are long enough to
1466 have an element whose index is COMPILED_INTERACTIVE, which is
1467 where the interactive spec is stored. */
1468 else if (COMPILEDP (fun
))
1469 return ((XVECTOR (fun
)->size
& PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
1472 /* Strings and vectors are keyboard macros. */
1473 if (STRINGP (fun
) || VECTORP (fun
))
1476 /* Lists may represent commands. */
1479 funcar
= Fcar (fun
);
1480 if (!SYMBOLP (funcar
))
1481 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1482 if (EQ (funcar
, Qlambda
))
1483 return Fassq (Qinteractive
, Fcdr (Fcdr (fun
)));
1484 if (EQ (funcar
, Qmocklisp
))
1485 return Qt
; /* All mocklisp functions can be called interactively */
1486 if (EQ (funcar
, Qautoload
))
1487 return Fcar (Fcdr (Fcdr (Fcdr (fun
))));
1493 DEFUN ("autoload", Fautoload
, Sautoload
, 2, 5, 0,
1494 "Define FUNCTION to autoload from FILE.\n\
1495 FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\
1496 Third arg DOCSTRING is documentation for the function.\n\
1497 Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\
1498 Fifth arg TYPE indicates the type of the object:\n\
1499 nil or omitted says FUNCTION is a function,\n\
1500 `keymap' says FUNCTION is really a keymap, and\n\
1501 `macro' or t says FUNCTION is really a macro.\n\
1502 Third through fifth args give info about the real definition.\n\
1503 They default to nil.\n\
1504 If FUNCTION is already defined other than as an autoload,\n\
1505 this does nothing and returns nil.")
1506 (function
, file
, docstring
, interactive
, type
)
1507 Lisp_Object function
, file
, docstring
, interactive
, type
;
1510 Lisp_Object args
[4];
1513 CHECK_SYMBOL (function
, 0);
1514 CHECK_STRING (file
, 1);
1516 /* If function is defined and not as an autoload, don't override */
1517 if (!EQ (XSYMBOL (function
)->function
, Qunbound
)
1518 && !(CONSP (XSYMBOL (function
)->function
)
1519 && EQ (XCONS (XSYMBOL (function
)->function
)->car
, Qautoload
)))
1524 args
[1] = docstring
;
1525 args
[2] = interactive
;
1528 return Ffset (function
, Fcons (Qautoload
, Flist (4, &args
[0])));
1529 #else /* NO_ARG_ARRAY */
1530 return Ffset (function
, Fcons (Qautoload
, Flist (4, &file
)));
1531 #endif /* not NO_ARG_ARRAY */
1535 un_autoload (oldqueue
)
1536 Lisp_Object oldqueue
;
1538 register Lisp_Object queue
, first
, second
;
1540 /* Queue to unwind is current value of Vautoload_queue.
1541 oldqueue is the shadowed value to leave in Vautoload_queue. */
1542 queue
= Vautoload_queue
;
1543 Vautoload_queue
= oldqueue
;
1544 while (CONSP (queue
))
1546 first
= Fcar (queue
);
1547 second
= Fcdr (first
);
1548 first
= Fcar (first
);
1549 if (EQ (second
, Qnil
))
1552 Ffset (first
, second
);
1553 queue
= Fcdr (queue
);
1558 /* Load an autoloaded function.
1559 FUNNAME is the symbol which is the function's name.
1560 FUNDEF is the autoload definition (a list). */
1562 do_autoload (fundef
, funname
)
1563 Lisp_Object fundef
, funname
;
1565 int count
= specpdl_ptr
- specpdl
;
1566 Lisp_Object fun
, val
, queue
, first
, second
;
1567 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1570 CHECK_SYMBOL (funname
, 0);
1571 GCPRO3 (fun
, funname
, fundef
);
1573 /* Value saved here is to be restored into Vautoload_queue */
1574 record_unwind_protect (un_autoload
, Vautoload_queue
);
1575 Vautoload_queue
= Qt
;
1576 Fload (Fcar (Fcdr (fundef
)), Qnil
, noninteractive
? Qt
: Qnil
, Qnil
);
1578 /* Save the old autoloads, in case we ever do an unload. */
1579 queue
= Vautoload_queue
;
1580 while (CONSP (queue
))
1582 first
= Fcar (queue
);
1583 second
= Fcdr (first
);
1584 first
= Fcar (first
);
1586 /* Note: This test is subtle. The cdr of an autoload-queue entry
1587 may be an atom if the autoload entry was generated by a defalias
1590 Fput (first
, Qautoload
, (Fcdr (second
)));
1592 queue
= Fcdr (queue
);
1595 /* Once loading finishes, don't undo it. */
1596 Vautoload_queue
= Qt
;
1597 unbind_to (count
, Qnil
);
1599 fun
= Findirect_function (fun
);
1601 if (!NILP (Fequal (fun
, fundef
)))
1602 error ("Autoloading failed to define function %s",
1603 XSYMBOL (funname
)->name
->data
);
1607 DEFUN ("eval", Feval
, Seval
, 1, 1, 0,
1608 "Evaluate FORM and return its value.")
1612 Lisp_Object fun
, val
, original_fun
, original_args
;
1614 struct backtrace backtrace
;
1615 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1619 if (EQ (Vmocklisp_arguments
, Qt
))
1620 return Fsymbol_value (form
);
1621 val
= Fsymbol_value (form
);
1623 XSETFASTINT (val
, 0);
1624 else if (EQ (val
, Qt
))
1625 XSETFASTINT (val
, 1);
1632 if (consing_since_gc
> gc_cons_threshold
)
1635 Fgarbage_collect ();
1639 if (++lisp_eval_depth
> max_lisp_eval_depth
)
1641 if (max_lisp_eval_depth
< 100)
1642 max_lisp_eval_depth
= 100;
1643 if (lisp_eval_depth
> max_lisp_eval_depth
)
1644 error ("Lisp nesting exceeds max-lisp-eval-depth");
1647 original_fun
= Fcar (form
);
1648 original_args
= Fcdr (form
);
1650 backtrace
.next
= backtrace_list
;
1651 backtrace_list
= &backtrace
;
1652 backtrace
.function
= &original_fun
; /* This also protects them from gc */
1653 backtrace
.args
= &original_args
;
1654 backtrace
.nargs
= UNEVALLED
;
1655 backtrace
.evalargs
= 1;
1656 backtrace
.debug_on_exit
= 0;
1658 if (debug_on_next_call
)
1659 do_debug_on_call (Qt
);
1661 /* At this point, only original_fun and original_args
1662 have values that will be used below */
1664 fun
= Findirect_function (original_fun
);
1668 Lisp_Object numargs
;
1669 Lisp_Object argvals
[7];
1670 Lisp_Object args_left
;
1671 register int i
, maxargs
;
1673 args_left
= original_args
;
1674 numargs
= Flength (args_left
);
1676 if (XINT (numargs
) < XSUBR (fun
)->min_args
||
1677 (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< XINT (numargs
)))
1678 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
1680 if (XSUBR (fun
)->max_args
== UNEVALLED
)
1682 backtrace
.evalargs
= 0;
1683 val
= (*XSUBR (fun
)->function
) (args_left
);
1687 if (XSUBR (fun
)->max_args
== MANY
)
1689 /* Pass a vector of evaluated arguments */
1691 register int argnum
= 0;
1693 vals
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
1695 GCPRO3 (args_left
, fun
, fun
);
1699 while (!NILP (args_left
))
1701 vals
[argnum
++] = Feval (Fcar (args_left
));
1702 args_left
= Fcdr (args_left
);
1703 gcpro3
.nvars
= argnum
;
1706 backtrace
.args
= vals
;
1707 backtrace
.nargs
= XINT (numargs
);
1709 val
= (*XSUBR (fun
)->function
) (XINT (numargs
), vals
);
1714 GCPRO3 (args_left
, fun
, fun
);
1715 gcpro3
.var
= argvals
;
1718 maxargs
= XSUBR (fun
)->max_args
;
1719 for (i
= 0; i
< maxargs
; args_left
= Fcdr (args_left
))
1721 argvals
[i
] = Feval (Fcar (args_left
));
1727 backtrace
.args
= argvals
;
1728 backtrace
.nargs
= XINT (numargs
);
1733 val
= (*XSUBR (fun
)->function
) ();
1736 val
= (*XSUBR (fun
)->function
) (argvals
[0]);
1739 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1]);
1742 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1746 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1],
1747 argvals
[2], argvals
[3]);
1750 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1751 argvals
[3], argvals
[4]);
1754 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1755 argvals
[3], argvals
[4], argvals
[5]);
1758 val
= (*XSUBR (fun
)->function
) (argvals
[0], argvals
[1], argvals
[2],
1759 argvals
[3], argvals
[4], argvals
[5],
1764 /* Someone has created a subr that takes more arguments than
1765 is supported by this code. We need to either rewrite the
1766 subr to use a different argument protocol, or add more
1767 cases to this switch. */
1771 if (COMPILEDP (fun
))
1772 val
= apply_lambda (fun
, original_args
, 1);
1776 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1777 funcar
= Fcar (fun
);
1778 if (!SYMBOLP (funcar
))
1779 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1780 if (EQ (funcar
, Qautoload
))
1782 do_autoload (fun
, original_fun
);
1785 if (EQ (funcar
, Qmacro
))
1786 val
= Feval (apply1 (Fcdr (fun
), original_args
));
1787 else if (EQ (funcar
, Qlambda
))
1788 val
= apply_lambda (fun
, original_args
, 1);
1789 else if (EQ (funcar
, Qmocklisp
))
1790 val
= ml_apply (fun
, original_args
);
1792 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
1795 if (!EQ (Vmocklisp_arguments
, Qt
))
1798 XSETFASTINT (val
, 0);
1799 else if (EQ (val
, Qt
))
1800 XSETFASTINT (val
, 1);
1803 if (backtrace
.debug_on_exit
)
1804 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
1805 backtrace_list
= backtrace
.next
;
1809 DEFUN ("apply", Fapply
, Sapply
, 2, MANY
, 0,
1810 "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
1811 Then return the value FUNCTION returns.\n\
1812 Thus, (apply '+ 1 2 '(3 4)) returns 10.")
1817 register int i
, numargs
;
1818 register Lisp_Object spread_arg
;
1819 register Lisp_Object
*funcall_args
;
1821 struct gcpro gcpro1
;
1825 spread_arg
= args
[nargs
- 1];
1826 CHECK_LIST (spread_arg
, nargs
);
1828 numargs
= XINT (Flength (spread_arg
));
1831 return Ffuncall (nargs
- 1, args
);
1832 else if (numargs
== 1)
1834 args
[nargs
- 1] = XCONS (spread_arg
)->car
;
1835 return Ffuncall (nargs
, args
);
1838 numargs
+= nargs
- 2;
1840 fun
= indirect_function (fun
);
1841 if (EQ (fun
, Qunbound
))
1843 /* Let funcall get the error */
1850 if (numargs
< XSUBR (fun
)->min_args
1851 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
1852 goto funcall
; /* Let funcall get the error */
1853 else if (XSUBR (fun
)->max_args
> numargs
)
1855 /* Avoid making funcall cons up a yet another new vector of arguments
1856 by explicitly supplying nil's for optional values */
1857 funcall_args
= (Lisp_Object
*) alloca ((1 + XSUBR (fun
)->max_args
)
1858 * sizeof (Lisp_Object
));
1859 for (i
= numargs
; i
< XSUBR (fun
)->max_args
;)
1860 funcall_args
[++i
] = Qnil
;
1861 GCPRO1 (*funcall_args
);
1862 gcpro1
.nvars
= 1 + XSUBR (fun
)->max_args
;
1866 /* We add 1 to numargs because funcall_args includes the
1867 function itself as well as its arguments. */
1870 funcall_args
= (Lisp_Object
*) alloca ((1 + numargs
)
1871 * sizeof (Lisp_Object
));
1872 GCPRO1 (*funcall_args
);
1873 gcpro1
.nvars
= 1 + numargs
;
1876 bcopy (args
, funcall_args
, nargs
* sizeof (Lisp_Object
));
1877 /* Spread the last arg we got. Its first element goes in
1878 the slot that it used to occupy, hence this value of I. */
1880 while (!NILP (spread_arg
))
1882 funcall_args
[i
++] = XCONS (spread_arg
)->car
;
1883 spread_arg
= XCONS (spread_arg
)->cdr
;
1886 RETURN_UNGCPRO (Ffuncall (gcpro1
.nvars
, funcall_args
));
1889 /* Run hook variables in various ways. */
1891 enum run_hooks_condition
{to_completion
, until_success
, until_failure
};
1893 DEFUN ("run-hooks", Frun_hooks
, Srun_hooks
, 1, MANY
, 0,
1894 "Run each hook in HOOKS. Major mode functions use this.\n\
1895 Each argument should be a symbol, a hook variable.\n\
1896 These symbols are processed in the order specified.\n\
1897 If a hook symbol has a non-nil value, that value may be a function\n\
1898 or a list of functions to be called to run the hook.\n\
1899 If the value is a function, it is called with no arguments.\n\
1900 If it is a list, the elements are called, in order, with no arguments.\n\
1902 To make a hook variable buffer-local, use `make-local-hook',\n\
1903 not `make-local-variable'.")
1908 Lisp_Object hook
[1];
1911 for (i
= 0; i
< nargs
; i
++)
1914 run_hook_with_args (1, hook
, to_completion
);
1920 DEFUN ("run-hook-with-args",
1921 Frun_hook_with_args
, Srun_hook_with_args
, 1, MANY
, 0,
1922 "Run HOOK with the specified arguments ARGS.\n\
1923 HOOK should be a symbol, a hook variable. If HOOK has a non-nil\n\
1924 value, that value may be a function or a list of functions to be\n\
1925 called to run the hook. If the value is a function, it is called with\n\
1926 the given arguments and its return value is returned. If it is a list\n\
1927 of functions, those functions are called, in order,\n\
1928 with the given arguments ARGS.\n\
1929 It is best not to depend on the value return by `run-hook-with-args',\n\
1930 as that may change.\n\
1932 To make a hook variable buffer-local, use `make-local-hook',\n\
1933 not `make-local-variable'.")
1938 return run_hook_with_args (nargs
, args
, to_completion
);
1941 DEFUN ("run-hook-with-args-until-success",
1942 Frun_hook_with_args_until_success
, Srun_hook_with_args_until_success
,
1944 "Run HOOK with the specified arguments ARGS.\n\
1945 HOOK should be a symbol, a hook variable. Its value should\n\
1946 be a list of functions. We call those functions, one by one,\n\
1947 passing arguments ARGS to each of them, until one of them\n\
1948 returns a non-nil value. Then we return that value.\n\
1949 If all the functions return nil, we return nil.\n\
1951 To make a hook variable buffer-local, use `make-local-hook',\n\
1952 not `make-local-variable'.")
1957 return run_hook_with_args (nargs
, args
, until_success
);
1960 DEFUN ("run-hook-with-args-until-failure",
1961 Frun_hook_with_args_until_failure
, Srun_hook_with_args_until_failure
,
1963 "Run HOOK with the specified arguments ARGS.\n\
1964 HOOK should be a symbol, a hook variable. Its value should\n\
1965 be a list of functions. We call those functions, one by one,\n\
1966 passing arguments ARGS to each of them, until one of them\n\
1967 returns nil. Then we return nil.\n\
1968 If all the functions return non-nil, we return non-nil.\n\
1970 To make a hook variable buffer-local, use `make-local-hook',\n\
1971 not `make-local-variable'.")
1976 return run_hook_with_args (nargs
, args
, until_failure
);
1979 /* ARGS[0] should be a hook symbol.
1980 Call each of the functions in the hook value, passing each of them
1981 as arguments all the rest of ARGS (all NARGS - 1 elements).
1982 COND specifies a condition to test after each call
1983 to decide whether to stop.
1984 The caller (or its caller, etc) must gcpro all of ARGS,
1985 except that it isn't necessary to gcpro ARGS[0]. */
1988 run_hook_with_args (nargs
, args
, cond
)
1991 enum run_hooks_condition cond
;
1993 Lisp_Object sym
, val
, ret
;
1994 struct gcpro gcpro1
, gcpro2
;
1996 /* If we are dying or still initializing,
1997 don't do anything--it would probably crash if we tried. */
1998 if (NILP (Vrun_hooks
))
2002 val
= find_symbol_value (sym
);
2003 ret
= (cond
== until_failure
? Qt
: Qnil
);
2005 if (EQ (val
, Qunbound
) || NILP (val
))
2007 else if (!CONSP (val
) || EQ (XCONS (val
)->car
, Qlambda
))
2010 return Ffuncall (nargs
, args
);
2017 CONSP (val
) && ((cond
== to_completion
)
2018 || (cond
== until_success
? NILP (ret
)
2020 val
= XCONS (val
)->cdr
)
2022 if (EQ (XCONS (val
)->car
, Qt
))
2024 /* t indicates this hook has a local binding;
2025 it means to run the global binding too. */
2026 Lisp_Object globals
;
2028 for (globals
= Fdefault_value (sym
);
2029 CONSP (globals
) && ((cond
== to_completion
)
2030 || (cond
== until_success
? NILP (ret
)
2032 globals
= XCONS (globals
)->cdr
)
2034 args
[0] = XCONS (globals
)->car
;
2035 /* In a global value, t should not occur. If it does, we
2036 must ignore it to avoid an endless loop. */
2037 if (!EQ (args
[0], Qt
))
2038 ret
= Ffuncall (nargs
, args
);
2043 args
[0] = XCONS (val
)->car
;
2044 ret
= Ffuncall (nargs
, args
);
2053 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2054 present value of that symbol.
2055 Call each element of FUNLIST,
2056 passing each of them the rest of ARGS.
2057 The caller (or its caller, etc) must gcpro all of ARGS,
2058 except that it isn't necessary to gcpro ARGS[0]. */
2061 run_hook_list_with_args (funlist
, nargs
, args
)
2062 Lisp_Object funlist
;
2068 struct gcpro gcpro1
, gcpro2
;
2073 for (val
= funlist
; CONSP (val
); val
= XCONS (val
)->cdr
)
2075 if (EQ (XCONS (val
)->car
, Qt
))
2077 /* t indicates this hook has a local binding;
2078 it means to run the global binding too. */
2079 Lisp_Object globals
;
2081 for (globals
= Fdefault_value (sym
);
2083 globals
= XCONS (globals
)->cdr
)
2085 args
[0] = XCONS (globals
)->car
;
2086 /* In a global value, t should not occur. If it does, we
2087 must ignore it to avoid an endless loop. */
2088 if (!EQ (args
[0], Qt
))
2089 Ffuncall (nargs
, args
);
2094 args
[0] = XCONS (val
)->car
;
2095 Ffuncall (nargs
, args
);
2102 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2. */
2105 run_hook_with_args_2 (hook
, arg1
, arg2
)
2106 Lisp_Object hook
, arg1
, arg2
;
2108 Lisp_Object temp
[3];
2113 Frun_hook_with_args (3, temp
);
2116 /* Apply fn to arg */
2119 Lisp_Object fn
, arg
;
2121 struct gcpro gcpro1
;
2125 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2129 Lisp_Object args
[2];
2133 RETURN_UNGCPRO (Fapply (2, args
));
2135 #else /* not NO_ARG_ARRAY */
2136 RETURN_UNGCPRO (Fapply (2, &fn
));
2137 #endif /* not NO_ARG_ARRAY */
2140 /* Call function fn on no arguments */
2145 struct gcpro gcpro1
;
2148 RETURN_UNGCPRO (Ffuncall (1, &fn
));
2151 /* Call function fn with 1 argument arg1 */
2155 Lisp_Object fn
, arg1
;
2157 struct gcpro gcpro1
;
2159 Lisp_Object args
[2];
2165 RETURN_UNGCPRO (Ffuncall (2, args
));
2166 #else /* not NO_ARG_ARRAY */
2169 RETURN_UNGCPRO (Ffuncall (2, &fn
));
2170 #endif /* not NO_ARG_ARRAY */
2173 /* Call function fn with 2 arguments arg1, arg2 */
2176 call2 (fn
, arg1
, arg2
)
2177 Lisp_Object fn
, arg1
, arg2
;
2179 struct gcpro gcpro1
;
2181 Lisp_Object args
[3];
2187 RETURN_UNGCPRO (Ffuncall (3, args
));
2188 #else /* not NO_ARG_ARRAY */
2191 RETURN_UNGCPRO (Ffuncall (3, &fn
));
2192 #endif /* not NO_ARG_ARRAY */
2195 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2198 call3 (fn
, arg1
, arg2
, arg3
)
2199 Lisp_Object fn
, arg1
, arg2
, arg3
;
2201 struct gcpro gcpro1
;
2203 Lisp_Object args
[4];
2210 RETURN_UNGCPRO (Ffuncall (4, args
));
2211 #else /* not NO_ARG_ARRAY */
2214 RETURN_UNGCPRO (Ffuncall (4, &fn
));
2215 #endif /* not NO_ARG_ARRAY */
2218 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2221 call4 (fn
, arg1
, arg2
, arg3
, arg4
)
2222 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
;
2224 struct gcpro gcpro1
;
2226 Lisp_Object args
[5];
2234 RETURN_UNGCPRO (Ffuncall (5, args
));
2235 #else /* not NO_ARG_ARRAY */
2238 RETURN_UNGCPRO (Ffuncall (5, &fn
));
2239 #endif /* not NO_ARG_ARRAY */
2242 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2245 call5 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
)
2246 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
;
2248 struct gcpro gcpro1
;
2250 Lisp_Object args
[6];
2259 RETURN_UNGCPRO (Ffuncall (6, args
));
2260 #else /* not NO_ARG_ARRAY */
2263 RETURN_UNGCPRO (Ffuncall (6, &fn
));
2264 #endif /* not NO_ARG_ARRAY */
2267 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2270 call6 (fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
)
2271 Lisp_Object fn
, arg1
, arg2
, arg3
, arg4
, arg5
, arg6
;
2273 struct gcpro gcpro1
;
2275 Lisp_Object args
[7];
2285 RETURN_UNGCPRO (Ffuncall (7, args
));
2286 #else /* not NO_ARG_ARRAY */
2289 RETURN_UNGCPRO (Ffuncall (7, &fn
));
2290 #endif /* not NO_ARG_ARRAY */
2293 DEFUN ("funcall", Ffuncall
, Sfuncall
, 1, MANY
, 0,
2294 "Call first argument as a function, passing remaining arguments to it.\n\
2295 Return the value that function returns.\n\
2296 Thus, (funcall 'cons 'x 'y) returns (x . y).")
2303 int numargs
= nargs
- 1;
2304 Lisp_Object lisp_numargs
;
2306 struct backtrace backtrace
;
2307 register Lisp_Object
*internal_args
;
2311 if (consing_since_gc
> gc_cons_threshold
)
2312 Fgarbage_collect ();
2314 if (++lisp_eval_depth
> max_lisp_eval_depth
)
2316 if (max_lisp_eval_depth
< 100)
2317 max_lisp_eval_depth
= 100;
2318 if (lisp_eval_depth
> max_lisp_eval_depth
)
2319 error ("Lisp nesting exceeds max-lisp-eval-depth");
2322 backtrace
.next
= backtrace_list
;
2323 backtrace_list
= &backtrace
;
2324 backtrace
.function
= &args
[0];
2325 backtrace
.args
= &args
[1];
2326 backtrace
.nargs
= nargs
- 1;
2327 backtrace
.evalargs
= 0;
2328 backtrace
.debug_on_exit
= 0;
2330 if (debug_on_next_call
)
2331 do_debug_on_call (Qlambda
);
2337 fun
= Findirect_function (fun
);
2341 if (numargs
< XSUBR (fun
)->min_args
2342 || (XSUBR (fun
)->max_args
>= 0 && XSUBR (fun
)->max_args
< numargs
))
2344 XSETFASTINT (lisp_numargs
, numargs
);
2345 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (lisp_numargs
, Qnil
)));
2348 if (XSUBR (fun
)->max_args
== UNEVALLED
)
2349 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2351 if (XSUBR (fun
)->max_args
== MANY
)
2353 val
= (*XSUBR (fun
)->function
) (numargs
, args
+ 1);
2357 if (XSUBR (fun
)->max_args
> numargs
)
2359 internal_args
= (Lisp_Object
*) alloca (XSUBR (fun
)->max_args
* sizeof (Lisp_Object
));
2360 bcopy (args
+ 1, internal_args
, numargs
* sizeof (Lisp_Object
));
2361 for (i
= numargs
; i
< XSUBR (fun
)->max_args
; i
++)
2362 internal_args
[i
] = Qnil
;
2365 internal_args
= args
+ 1;
2366 switch (XSUBR (fun
)->max_args
)
2369 val
= (*XSUBR (fun
)->function
) ();
2372 val
= (*XSUBR (fun
)->function
) (internal_args
[0]);
2375 val
= (*XSUBR (fun
)->function
) (internal_args
[0],
2379 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2383 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2388 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2389 internal_args
[2], internal_args
[3],
2393 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2394 internal_args
[2], internal_args
[3],
2395 internal_args
[4], internal_args
[5]);
2398 val
= (*XSUBR (fun
)->function
) (internal_args
[0], internal_args
[1],
2399 internal_args
[2], internal_args
[3],
2400 internal_args
[4], internal_args
[5],
2406 /* If a subr takes more than 6 arguments without using MANY
2407 or UNEVALLED, we need to extend this function to support it.
2408 Until this is done, there is no way to call the function. */
2412 if (COMPILEDP (fun
))
2413 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2417 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2418 funcar
= Fcar (fun
);
2419 if (!SYMBOLP (funcar
))
2420 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2421 if (EQ (funcar
, Qlambda
))
2422 val
= funcall_lambda (fun
, numargs
, args
+ 1);
2423 else if (EQ (funcar
, Qmocklisp
))
2424 val
= ml_apply (fun
, Flist (numargs
, args
+ 1));
2425 else if (EQ (funcar
, Qautoload
))
2427 do_autoload (fun
, args
[0]);
2431 return Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2435 if (backtrace
.debug_on_exit
)
2436 val
= call_debugger (Fcons (Qexit
, Fcons (val
, Qnil
)));
2437 backtrace_list
= backtrace
.next
;
2442 apply_lambda (fun
, args
, eval_flag
)
2443 Lisp_Object fun
, args
;
2446 Lisp_Object args_left
;
2447 Lisp_Object numargs
;
2448 register Lisp_Object
*arg_vector
;
2449 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2451 register Lisp_Object tem
;
2453 numargs
= Flength (args
);
2454 arg_vector
= (Lisp_Object
*) alloca (XINT (numargs
) * sizeof (Lisp_Object
));
2457 GCPRO3 (*arg_vector
, args_left
, fun
);
2460 for (i
= 0; i
< XINT (numargs
);)
2462 tem
= Fcar (args_left
), args_left
= Fcdr (args_left
);
2463 if (eval_flag
) tem
= Feval (tem
);
2464 arg_vector
[i
++] = tem
;
2472 backtrace_list
->args
= arg_vector
;
2473 backtrace_list
->nargs
= i
;
2475 backtrace_list
->evalargs
= 0;
2476 tem
= funcall_lambda (fun
, XINT (numargs
), arg_vector
);
2478 /* Do the debug-on-exit now, while arg_vector still exists. */
2479 if (backtrace_list
->debug_on_exit
)
2480 tem
= call_debugger (Fcons (Qexit
, Fcons (tem
, Qnil
)));
2481 /* Don't do it again when we return to eval. */
2482 backtrace_list
->debug_on_exit
= 0;
2486 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
2487 and return the result of evaluation.
2488 FUN must be either a lambda-expression or a compiled-code object. */
2491 funcall_lambda (fun
, nargs
, arg_vector
)
2494 register Lisp_Object
*arg_vector
;
2496 Lisp_Object val
, tem
;
2497 register Lisp_Object syms_left
;
2498 Lisp_Object numargs
;
2499 register Lisp_Object next
;
2500 int count
= specpdl_ptr
- specpdl
;
2502 int optional
= 0, rest
= 0;
2504 specbind (Qmocklisp_arguments
, Qt
); /* t means NOT mocklisp! */
2506 XSETFASTINT (numargs
, nargs
);
2509 syms_left
= Fcar (Fcdr (fun
));
2510 else if (COMPILEDP (fun
))
2511 syms_left
= XVECTOR (fun
)->contents
[COMPILED_ARGLIST
];
2515 for (; !NILP (syms_left
); syms_left
= Fcdr (syms_left
))
2518 next
= Fcar (syms_left
);
2519 while (!SYMBOLP (next
))
2520 next
= Fsignal (Qinvalid_function
, Fcons (fun
, Qnil
));
2521 if (EQ (next
, Qand_rest
))
2523 else if (EQ (next
, Qand_optional
))
2527 specbind (next
, Flist (nargs
- i
, &arg_vector
[i
]));
2532 tem
= arg_vector
[i
++];
2533 specbind (next
, tem
);
2536 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2538 specbind (next
, Qnil
);
2542 return Fsignal (Qwrong_number_of_arguments
, Fcons (fun
, Fcons (numargs
, Qnil
)));
2545 val
= Fprogn (Fcdr (Fcdr (fun
)));
2548 /* If we have not actually read the bytecode string
2549 and constants vector yet, fetch them from the file. */
2550 if (CONSP (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
]))
2551 Ffetch_bytecode (fun
);
2552 val
= Fbyte_code (XVECTOR (fun
)->contents
[COMPILED_BYTECODE
],
2553 XVECTOR (fun
)->contents
[COMPILED_CONSTANTS
],
2554 XVECTOR (fun
)->contents
[COMPILED_STACK_DEPTH
]);
2556 return unbind_to (count
, val
);
2559 DEFUN ("fetch-bytecode", Ffetch_bytecode
, Sfetch_bytecode
,
2561 "If byte-compiled OBJECT is lazy-loaded, fetch it now.")
2567 if (COMPILEDP (object
)
2568 && CONSP (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]))
2570 tem
= read_doc_string (XVECTOR (object
)->contents
[COMPILED_BYTECODE
]);
2572 error ("invalid byte code");
2573 XVECTOR (object
)->contents
[COMPILED_BYTECODE
] = XCONS (tem
)->car
;
2574 XVECTOR (object
)->contents
[COMPILED_CONSTANTS
] = XCONS (tem
)->cdr
;
2582 register int count
= specpdl_ptr
- specpdl
;
2583 if (specpdl_size
>= max_specpdl_size
)
2585 if (max_specpdl_size
< 400)
2586 max_specpdl_size
= 400;
2587 if (specpdl_size
>= max_specpdl_size
)
2589 if (!NILP (Vdebug_on_error
))
2590 /* Leave room for some specpdl in the debugger. */
2591 max_specpdl_size
= specpdl_size
+ 100;
2593 Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil
));
2597 if (specpdl_size
> max_specpdl_size
)
2598 specpdl_size
= max_specpdl_size
;
2599 specpdl
= (struct specbinding
*) xrealloc (specpdl
, specpdl_size
* sizeof (struct specbinding
));
2600 specpdl_ptr
= specpdl
+ count
;
2604 specbind (symbol
, value
)
2605 Lisp_Object symbol
, value
;
2609 CHECK_SYMBOL (symbol
, 0);
2611 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2613 specpdl_ptr
->symbol
= symbol
;
2614 specpdl_ptr
->func
= 0;
2615 specpdl_ptr
->old_value
= ovalue
= find_symbol_value (symbol
);
2617 if (BUFFER_OBJFWDP (ovalue
) || KBOARD_OBJFWDP (ovalue
))
2618 store_symval_forwarding (symbol
, ovalue
, value
);
2620 Fset (symbol
, value
);
2624 record_unwind_protect (function
, arg
)
2625 Lisp_Object (*function
)();
2628 if (specpdl_ptr
== specpdl
+ specpdl_size
)
2630 specpdl_ptr
->func
= function
;
2631 specpdl_ptr
->symbol
= Qnil
;
2632 specpdl_ptr
->old_value
= arg
;
2637 unbind_to (count
, value
)
2641 int quitf
= !NILP (Vquit_flag
);
2642 struct gcpro gcpro1
;
2648 while (specpdl_ptr
!= specpdl
+ count
)
2651 if (specpdl_ptr
->func
!= 0)
2652 (*specpdl_ptr
->func
) (specpdl_ptr
->old_value
);
2653 /* Note that a "binding" of nil is really an unwind protect,
2654 so in that case the "old value" is a list of forms to evaluate. */
2655 else if (NILP (specpdl_ptr
->symbol
))
2656 Fprogn (specpdl_ptr
->old_value
);
2658 Fset (specpdl_ptr
->symbol
, specpdl_ptr
->old_value
);
2660 if (NILP (Vquit_flag
) && quitf
) Vquit_flag
= Qt
;
2669 /* Get the value of symbol's global binding, even if that binding
2670 is not now dynamically visible. */
2673 top_level_value (symbol
)
2676 register struct specbinding
*ptr
= specpdl
;
2678 CHECK_SYMBOL (symbol
, 0);
2679 for (; ptr
!= specpdl_ptr
; ptr
++)
2681 if (EQ (ptr
->symbol
, symbol
))
2682 return ptr
->old_value
;
2684 return Fsymbol_value (symbol
);
2688 top_level_set (symbol
, newval
)
2689 Lisp_Object symbol
, newval
;
2691 register struct specbinding
*ptr
= specpdl
;
2693 CHECK_SYMBOL (symbol
, 0);
2694 for (; ptr
!= specpdl_ptr
; ptr
++)
2696 if (EQ (ptr
->symbol
, symbol
))
2698 ptr
->old_value
= newval
;
2702 return Fset (symbol
, newval
);
2707 DEFUN ("backtrace-debug", Fbacktrace_debug
, Sbacktrace_debug
, 2, 2, 0,
2708 "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\
2709 The debugger is entered when that frame exits, if the flag is non-nil.")
2711 Lisp_Object level
, flag
;
2713 register struct backtrace
*backlist
= backtrace_list
;
2716 CHECK_NUMBER (level
, 0);
2718 for (i
= 0; backlist
&& i
< XINT (level
); i
++)
2720 backlist
= backlist
->next
;
2724 backlist
->debug_on_exit
= !NILP (flag
);
2729 DEFUN ("backtrace", Fbacktrace
, Sbacktrace
, 0, 0, "",
2730 "Print a trace of Lisp function calls currently active.\n\
2731 Output stream used is value of `standard-output'.")
2734 register struct backtrace
*backlist
= backtrace_list
;
2738 extern Lisp_Object Vprint_level
;
2739 struct gcpro gcpro1
;
2741 XSETFASTINT (Vprint_level
, 3);
2748 write_string (backlist
->debug_on_exit
? "* " : " ", 2);
2749 if (backlist
->nargs
== UNEVALLED
)
2751 Fprin1 (Fcons (*backlist
->function
, *backlist
->args
), Qnil
);
2752 write_string ("\n", -1);
2756 tem
= *backlist
->function
;
2757 Fprin1 (tem
, Qnil
); /* This can QUIT */
2758 write_string ("(", -1);
2759 if (backlist
->nargs
== MANY
)
2761 for (tail
= *backlist
->args
, i
= 0;
2763 tail
= Fcdr (tail
), i
++)
2765 if (i
) write_string (" ", -1);
2766 Fprin1 (Fcar (tail
), Qnil
);
2771 for (i
= 0; i
< backlist
->nargs
; i
++)
2773 if (i
) write_string (" ", -1);
2774 Fprin1 (backlist
->args
[i
], Qnil
);
2777 write_string (")\n", -1);
2779 backlist
= backlist
->next
;
2782 Vprint_level
= Qnil
;
2787 DEFUN ("backtrace-frame", Fbacktrace_frame
, Sbacktrace_frame
, 1, 1, "",
2788 "Return the function and arguments NFRAMES up from current execution point.\n\
2789 If that frame has not evaluated the arguments yet (or is a special form),\n\
2790 the value is (nil FUNCTION ARG-FORMS...).\n\
2791 If that frame has evaluated its arguments and called its function already,\n\
2792 the value is (t FUNCTION ARG-VALUES...).\n\
2793 A &rest arg is represented as the tail of the list ARG-VALUES.\n\
2794 FUNCTION is whatever was supplied as car of evaluated list,\n\
2795 or a lambda expression for macro calls.\n\
2796 If NFRAMES is more than the number of frames, the value is nil.")
2798 Lisp_Object nframes
;
2800 register struct backtrace
*backlist
= backtrace_list
;
2804 CHECK_NATNUM (nframes
, 0);
2806 /* Find the frame requested. */
2807 for (i
= 0; backlist
&& i
< XFASTINT (nframes
); i
++)
2808 backlist
= backlist
->next
;
2812 if (backlist
->nargs
== UNEVALLED
)
2813 return Fcons (Qnil
, Fcons (*backlist
->function
, *backlist
->args
));
2816 if (backlist
->nargs
== MANY
)
2817 tem
= *backlist
->args
;
2819 tem
= Flist (backlist
->nargs
, backlist
->args
);
2821 return Fcons (Qt
, Fcons (*backlist
->function
, tem
));
2827 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size
,
2828 "Limit on number of Lisp variable bindings & unwind-protects before error.");
2830 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth
,
2831 "Limit on depth in `eval', `apply' and `funcall' before error.\n\
2832 This limit is to catch infinite recursions for you before they cause\n\
2833 actual stack overflow in C, which would be fatal for Emacs.\n\
2834 You can safely make it considerably larger than its default value,\n\
2835 if that proves inconveniently small.");
2837 DEFVAR_LISP ("quit-flag", &Vquit_flag
,
2838 "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
2839 Typing C-g sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
2842 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit
,
2843 "Non-nil inhibits C-g quitting from happening immediately.\n\
2844 Note that `quit-flag' will still be set by typing C-g,\n\
2845 so a quit will be signaled as soon as `inhibit-quit' is nil.\n\
2846 To prevent this happening, set `quit-flag' to nil\n\
2847 before making `inhibit-quit' nil.");
2848 Vinhibit_quit
= Qnil
;
2850 Qinhibit_quit
= intern ("inhibit-quit");
2851 staticpro (&Qinhibit_quit
);
2853 Qautoload
= intern ("autoload");
2854 staticpro (&Qautoload
);
2856 Qdebug_on_error
= intern ("debug-on-error");
2857 staticpro (&Qdebug_on_error
);
2859 Qmacro
= intern ("macro");
2860 staticpro (&Qmacro
);
2862 /* Note that the process handling also uses Qexit, but we don't want
2863 to staticpro it twice, so we just do it here. */
2864 Qexit
= intern ("exit");
2867 Qinteractive
= intern ("interactive");
2868 staticpro (&Qinteractive
);
2870 Qcommandp
= intern ("commandp");
2871 staticpro (&Qcommandp
);
2873 Qdefun
= intern ("defun");
2874 staticpro (&Qdefun
);
2876 Qand_rest
= intern ("&rest");
2877 staticpro (&Qand_rest
);
2879 Qand_optional
= intern ("&optional");
2880 staticpro (&Qand_optional
);
2882 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error
,
2883 "*Non-nil means automatically display a backtrace buffer\n\
2884 after any error that is handled by the editor command loop.\n\
2885 If the value is a list, an error only means to display a backtrace\n\
2886 if one of its condition symbols appears in the list.");
2887 Vstack_trace_on_error
= Qnil
;
2889 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error
,
2890 "*Non-nil means enter debugger if an error is signaled.\n\
2891 Does not apply to errors handled by `condition-case'.\n\
2892 If the value is a list, an error only means to enter the debugger\n\
2893 if one of its condition symbols appears in the list.\n\
2894 See also variable `debug-on-quit'.");
2895 Vdebug_on_error
= Qnil
;
2897 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors
,
2898 "*List of errors for which the debugger should not be called.\n\
2899 Each element may be a condition-name or a regexp that matches error messages.\n\
2900 If any element applies to a given error, that error skips the debugger\n\
2901 and just returns to top level.\n\
2902 This overrides the variable `debug-on-error'.\n\
2903 It does not apply to errors handled by `condition-case'.");
2904 Vdebug_ignored_errors
= Qnil
;
2906 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit
,
2907 "*Non-nil means enter debugger if quit is signaled (C-g, for example).\n\
2908 Does not apply if quit is handled by a `condition-case'.");
2911 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call
,
2912 "Non-nil means enter debugger before next `eval', `apply' or `funcall'.");
2914 DEFVAR_LISP ("debugger", &Vdebugger
,
2915 "Function to call to invoke debugger.\n\
2916 If due to frame exit, args are `exit' and the value being returned;\n\
2917 this function's value will be returned instead of that.\n\
2918 If due to error, args are `error' and a list of the args to `signal'.\n\
2919 If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
2920 If due to `eval' entry, one arg, t.");
2923 Qmocklisp_arguments
= intern ("mocklisp-arguments");
2924 staticpro (&Qmocklisp_arguments
);
2925 DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments
,
2926 "While in a mocklisp function, the list of its unevaluated args.");
2927 Vmocklisp_arguments
= Qt
;
2929 DEFVAR_LISP ("run-hooks", &Vrun_hooks
,
2930 "Set to the function `run-hooks', if that function has been defined.\n\
2931 Otherwise, nil (in a bare Emacs without preloaded Lisp code).");
2933 staticpro (&Vautoload_queue
);
2934 Vautoload_queue
= Qnil
;
2945 defsubr (&Sfunction
);
2947 defsubr (&Sdefmacro
);
2949 defsubr (&Sdefconst
);
2950 defsubr (&Suser_variable_p
);
2954 defsubr (&Smacroexpand
);
2957 defsubr (&Sunwind_protect
);
2958 defsubr (&Scondition_case
);
2960 defsubr (&Sinteractive_p
);
2961 defsubr (&Scommandp
);
2962 defsubr (&Sautoload
);
2965 defsubr (&Sfuncall
);
2966 defsubr (&Srun_hooks
);
2967 defsubr (&Srun_hook_with_args
);
2968 defsubr (&Srun_hook_with_args_until_success
);
2969 defsubr (&Srun_hook_with_args_until_failure
);
2970 defsubr (&Sfetch_bytecode
);
2971 defsubr (&Sbacktrace_debug
);
2972 defsubr (&Sbacktrace
);
2973 defsubr (&Sbacktrace_frame
);