1 /* Evaluator for XEmacs Lisp interpreter.
2 Copyright (C) 1985-1987, 1992-1994 Free Software Foundation, Inc.
3 Copyright (C) 1995 Sun Microsystems, Inc.
4 Copyright (C) 2000 Ben Wing.
6 This file is part of XEmacs.
8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with XEmacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
23 /* Synched up with: FSF 19.30 (except for Fsignal), Mule 2.0. */
29 #include "backtrace.h"
36 int always_gc; /* Debugging hack */
41 struct backtrace *backtrace_list;
43 /* Note: you must always fill in all of the fields in a backtrace structure
44 before pushing them on the backtrace_list. The profiling code depends
47 #define PUSH_BACKTRACE(bt) do { \
48 (bt).next = backtrace_list; \
49 backtrace_list = &(bt); \
52 #define POP_BACKTRACE(bt) do { \
53 backtrace_list = (bt).next; \
56 /* Macros for calling subrs with an argument list whose length is only
57 known at runtime. See EXFUN and DEFUN for similar hackery. */
60 #define AV_1(av) av[0]
61 #define AV_2(av) AV_1(av), av[1]
62 #define AV_3(av) AV_2(av), av[2]
63 #define AV_4(av) AV_3(av), av[3]
64 #define AV_5(av) AV_4(av), av[4]
65 #define AV_6(av) AV_5(av), av[5]
66 #define AV_7(av) AV_6(av), av[6]
67 #define AV_8(av) AV_7(av), av[7]
69 #define PRIMITIVE_FUNCALL_1(fn, av, ac) \
70 (((Lisp_Object (*)(EXFUN_##ac)) (fn)) (AV_##ac (av)))
72 /* If subrs take more than 8 arguments, more cases need to be added
73 to this switch. (But wait - don't do it - if you really need
74 a SUBR with more than 8 arguments, use max_args == MANY.
75 See the DEFUN macro in lisp.h) */
76 #define PRIMITIVE_FUNCALL(rv, fn, av, ac) do { \
77 void (*PF_fn)(void) = (void (*)(void)) fn; \
78 Lisp_Object *PF_av = (av); \
81 default:rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 0); break; \
82 case 1: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 1); break; \
83 case 2: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 2); break; \
84 case 3: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 3); break; \
85 case 4: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 4); break; \
86 case 5: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 5); break; \
87 case 6: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 6); break; \
88 case 7: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 7); break; \
89 case 8: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 8); break; \
93 #define FUNCALL_SUBR(rv, subr, av, ac) \
94 PRIMITIVE_FUNCALL (rv, subr_function (subr), av, ac);
97 /* This is the list of current catches (and also condition-cases).
98 This is a stack: the most recent catch is at the head of the
99 list. Catches are created by declaring a 'struct catchtag'
100 locally, filling the .TAG field in with the tag, and doing
101 a setjmp() on .JMP. Fthrow() will store the value passed
102 to it in .VAL and longjmp() back to .JMP, back to the function
103 that established the catch. This will always be either
104 internal_catch() (catches established internally or through
105 `catch') or condition_case_1 (condition-cases established
106 internally or through `condition-case').
108 The catchtag also records the current position in the
109 call stack (stored in BACKTRACE_LIST), the current position
110 in the specpdl stack (used for variable bindings and
111 unwind-protects), the value of LISP_EVAL_DEPTH, and the
112 current position in the GCPRO stack. All of these are
113 restored by Fthrow().
116 struct catchtag *catchlist;
118 Lisp_Object Qautoload, Qmacro, Qexit;
119 Lisp_Object Qinteractive, Qcommandp, Qdefun, Qprogn, Qvalues;
120 Lisp_Object Vquit_flag, Vinhibit_quit;
121 Lisp_Object Qand_rest, Qand_optional;
122 Lisp_Object Qdebug_on_error, Qstack_trace_on_error;
123 Lisp_Object Qdebug_on_signal, Qstack_trace_on_signal;
124 Lisp_Object Qdebugger;
125 Lisp_Object Qinhibit_quit;
126 Lisp_Object Qrun_hooks;
128 Lisp_Object Qdisplay_warning;
129 Lisp_Object Vpending_warnings, Vpending_warnings_tail;
132 /* Records whether we want errors to occur. This will be a boolean,
133 nil (errors OK) or t (no errors). If t, an error will cause a
134 throw to Qunbound_suspended_errors_tag.
136 See call_with_suspended_errors(). */
137 Lisp_Object Vcurrent_error_state;
139 /* Current warning class when warnings occur, or nil for no warnings.
140 Only meaningful when Vcurrent_error_state is non-nil.
141 See call_with_suspended_errors(). */
142 Lisp_Object Vcurrent_warning_class;
144 /* Special catch tag used in call_with_suspended_errors(). */
145 Lisp_Object Qunbound_suspended_errors_tag;
147 /* Non-nil means record all fset's and provide's, to be undone
148 if the file being autoloaded is not fully loaded.
149 They are recorded by being consed onto the front of Vautoload_queue:
150 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */
151 Lisp_Object Vautoload_queue;
153 /* Current number of specbindings allocated in specpdl. */
156 /* Pointer to beginning of specpdl. */
157 struct specbinding *specpdl;
159 /* Pointer to first unused element in specpdl. */
160 struct specbinding *specpdl_ptr;
162 /* specpdl_ptr - specpdl */
163 int specpdl_depth_counter;
165 /* Maximum size allowed for specpdl allocation */
166 Fixnum max_specpdl_size;
168 /* Depth in Lisp evaluations and function calls. */
169 static int lisp_eval_depth;
171 /* Maximum allowed depth in Lisp evaluations and function calls. */
172 Fixnum max_lisp_eval_depth;
174 /* Nonzero means enter debugger before next function call */
175 static int debug_on_next_call;
177 /* List of conditions (non-nil atom means all) which cause a backtrace
178 if an error is handled by the command loop's error handler. */
179 Lisp_Object Vstack_trace_on_error;
181 /* List of conditions (non-nil atom means all) which enter the debugger
182 if an error is handled by the command loop's error handler. */
183 Lisp_Object Vdebug_on_error;
185 /* List of conditions and regexps specifying error messages which
186 do not enter the debugger even if Vdebug_on_error says they should. */
187 Lisp_Object Vdebug_ignored_errors;
189 /* List of conditions (non-nil atom means all) which cause a backtrace
190 if any error is signalled. */
191 Lisp_Object Vstack_trace_on_signal;
193 /* List of conditions (non-nil atom means all) which enter the debugger
194 if any error is signalled. */
195 Lisp_Object Vdebug_on_signal;
197 /* Nonzero means enter debugger if a quit signal
198 is handled by the command loop's error handler.
200 From lisp, this is a boolean variable and may have the values 0 and 1.
201 But, eval.c temporarily uses the second bit of this variable to indicate
202 that a critical_quit is in progress. The second bit is reset immediately
203 after it is processed in signal_call_debugger(). */
207 /* entering_debugger is basically equivalent */
208 /* The value of num_nonmacro_input_chars as of the last time we
209 started to enter the debugger. If we decide to enter the debugger
210 again when this is still equal to num_nonmacro_input_chars, then we
211 know that the debugger itself has an error, and we should just
212 signal the error instead of entering an infinite loop of debugger
214 int when_entered_debugger;
217 /* Nonzero means we are trying to enter the debugger.
218 This is to prevent recursive attempts.
219 Cleared by the debugger calling Fbacktrace */
220 static int entering_debugger;
222 /* Function to call to invoke the debugger */
223 Lisp_Object Vdebugger;
225 /* Chain of condition handlers currently in effect.
226 The elements of this chain are contained in the stack frames
227 of Fcondition_case and internal_condition_case.
228 When an error is signaled (by calling Fsignal, below),
229 this chain is searched for an element that applies.
231 Each element of this list is one of the following:
233 A list of a handler function and possibly args to pass to
234 the function. This is a handler established with
235 `call-with-condition-handler' (q.v.).
237 A list whose car is Qunbound and whose cdr is Qt.
238 This is a special condition-case handler established
239 by C code with condition_case_1(). All errors are
240 trapped; the debugger is not invoked even if
241 `debug-on-error' was set.
243 A list whose car is Qunbound and whose cdr is Qerror.
244 This is a special condition-case handler established
245 by C code with condition_case_1(). It is like Qt
246 except that the debugger is invoked normally if it is
249 A list whose car is Qunbound and whose cdr is a list
250 of lists (CONDITION-NAME BODY ...) exactly as in
251 `condition-case'. This is a normal `condition-case'
254 Note that in all cases *except* the first, there is a
255 corresponding catch, whose TAG is the value of
256 Vcondition_handlers just after the handler data just
257 described is pushed onto it. The reason is that
258 `condition-case' handlers need to throw back to the
259 place where the handler was installed before invoking
260 it, while `call-with-condition-handler' handlers are
261 invoked in the environment that `signal' was invoked
264 static Lisp_Object Vcondition_handlers;
267 #define DEFEND_AGAINST_THROW_RECURSION
269 #ifdef DEFEND_AGAINST_THROW_RECURSION
270 /* Used for error catching purposes by throw_or_bomb_out */
271 static int throw_level;
274 #ifdef ERROR_CHECK_TYPECHECK
275 void check_error_state_sanity (void);
279 /************************************************************************/
280 /* The subr object type */
281 /************************************************************************/
284 print_subr (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
286 Lisp_Subr *subr = XSUBR (obj);
288 (subr->max_args == UNEVALLED) ? "#<special-form " : "#<subr ";
289 const char *name = subr_name (subr);
290 const char *trailer = subr->prompt ? " (interactive)>" : ">";
293 error ("printing unreadable object %s%s%s", header, name, trailer);
295 write_c_string (header, printcharfun);
296 write_c_string (name, printcharfun);
297 write_c_string (trailer, printcharfun);
300 static const struct lrecord_description subr_description[] = {
301 { XD_DOC_STRING, offsetof (Lisp_Subr, doc) },
305 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("subr", subr,
306 0, print_subr, 0, 0, 0,
310 /************************************************************************/
311 /* Entering the debugger */
312 /************************************************************************/
314 /* unwind-protect used by call_debugger() to restore the value of
315 entering_debugger. (We cannot use specbind() because the
316 variable is not Lisp-accessible.) */
319 restore_entering_debugger (Lisp_Object arg)
321 entering_debugger = ! NILP (arg);
325 /* Actually call the debugger. ARG is a list of args that will be
326 passed to the debugger function, as follows;
328 If due to frame exit, args are `exit' and the value being returned;
329 this function's value will be returned instead of that.
330 If due to error, args are `error' and a list of the args to `signal'.
331 If due to `apply' or `funcall' entry, one arg, `lambda'.
332 If due to `eval' entry, one arg, t.
337 call_debugger_259 (Lisp_Object arg)
339 return apply1 (Vdebugger, arg);
342 /* Call the debugger, doing some encapsulation. We make sure we have
343 some room on the eval and specpdl stacks, and bind entering_debugger
344 to 1 during this call. This is used to trap errors that may occur
345 when entering the debugger (e.g. the value of `debugger' is invalid),
346 so that the debugger will not be recursively entered if debug-on-error
347 is set. (Otherwise, XEmacs would infinitely recurse, attempting to
348 enter the debugger.) entering_debugger gets reset to 0 as soon
349 as a backtrace is displayed, so that further errors can indeed be
352 We also establish a catch for 'debugger. If the debugger function
353 throws to this instead of returning a value, it means that the user
354 pressed 'c' (pretend like the debugger was never entered). The
355 function then returns Qunbound. (If the user pressed 'r', for
356 return a value, then the debugger function returns normally with
359 The difference between 'c' and 'r' is as follows:
362 No difference. The call proceeds as normal.
364 With 'r', the specified value is returned as the function's
365 return value. With 'c', the value that would normally be
366 returned is returned.
368 With 'r', the specified value is returned as the return
369 value of `signal'. (This is the only time that `signal'
370 can return, instead of making a non-local exit.) With `c',
371 `signal' will continue looking for handlers as if the
372 debugger was never entered, and will probably end up
373 throwing to a handler or to top-level.
377 call_debugger (Lisp_Object arg)
383 if (lisp_eval_depth + 20 > max_lisp_eval_depth)
384 max_lisp_eval_depth = lisp_eval_depth + 20;
385 if (specpdl_size + 40 > max_specpdl_size)
386 max_specpdl_size = specpdl_size + 40;
387 debug_on_next_call = 0;
389 speccount = specpdl_depth();
390 record_unwind_protect (restore_entering_debugger,
391 (entering_debugger ? Qt : Qnil));
392 entering_debugger = 1;
393 val = internal_catch (Qdebugger, call_debugger_259, arg, &threw);
395 return unbind_to (speccount, ((threw)
396 ? Qunbound /* Not returning a value */
400 /* Called when debug-on-exit behavior is called for. Enter the debugger
401 with the appropriate args for this. VAL is the exit value that is
402 about to be returned. */
405 do_debug_on_exit (Lisp_Object val)
407 /* This is falsified by call_debugger */
408 Lisp_Object v = call_debugger (list2 (Qexit, val));
410 return !UNBOUNDP (v) ? v : val;
413 /* Called when debug-on-call behavior is called for. Enter the debugger
414 with the appropriate args for this. VAL is either t for a call
415 through `eval' or 'lambda for a call through `funcall'.
417 #### The differentiation here between EVAL and FUNCALL is bogus.
418 FUNCALL can be defined as
420 (defmacro func (fun &rest args)
421 (cons (eval fun) args))
423 and should be treated as such.
427 do_debug_on_call (Lisp_Object code)
429 debug_on_next_call = 0;
430 backtrace_list->debug_on_exit = 1;
431 call_debugger (list1 (code));
434 /* LIST is the value of one of the variables `debug-on-error',
435 `debug-on-signal', `stack-trace-on-error', or `stack-trace-on-signal',
436 and CONDITIONS is the list of error conditions associated with
437 the error being signalled. This returns non-nil if LIST
438 matches CONDITIONS. (A nil value for LIST does not match
439 CONDITIONS. A non-list value for LIST does match CONDITIONS.
440 A list matches CONDITIONS when one of the symbols in LIST is the
441 same as one of the symbols in CONDITIONS.) */
444 wants_debugger (Lisp_Object list, Lisp_Object conditions)
451 while (CONSP (conditions))
453 Lisp_Object this, tail;
454 this = XCAR (conditions);
455 for (tail = list; CONSP (tail); tail = XCDR (tail))
456 if (EQ (XCAR (tail), this))
458 conditions = XCDR (conditions);
464 /* Return 1 if an error with condition-symbols CONDITIONS,
465 and described by SIGNAL-DATA, should skip the debugger
466 according to debugger-ignore-errors. */
469 skip_debugger (Lisp_Object conditions, Lisp_Object data)
471 /* This function can GC */
473 int first_string = 1;
474 Lisp_Object error_message = Qnil;
476 for (tail = Vdebug_ignored_errors; CONSP (tail); tail = XCDR (tail))
478 if (STRINGP (XCAR (tail)))
482 error_message = Ferror_message_string (data);
485 if (fast_lisp_string_match (XCAR (tail), error_message) >= 0)
492 for (contail = conditions; CONSP (contail); contail = XCDR (contail))
493 if (EQ (XCAR (tail), XCAR (contail)))
501 /* Actually generate a backtrace on STREAM. */
504 backtrace_259 (Lisp_Object stream)
506 return Fbacktrace (stream, Qt);
509 /* An error was signaled. Maybe call the debugger, if the `debug-on-error'
510 etc. variables call for this. CONDITIONS is the list of conditions
511 associated with the error being signalled. SIG is the actual error
512 being signalled, and DATA is the associated data (these are exactly
513 the same as the arguments to `signal'). ACTIVE_HANDLERS is the
514 list of error handlers that are to be put in place while the debugger
515 is called. This is generally the remaining handlers that are
516 outside of the innermost handler trapping this error. This way,
517 if the same error occurs inside of the debugger, you usually don't get
518 the debugger entered recursively.
520 This function returns Qunbound if it didn't call the debugger or if
521 the user asked (through 'c') that XEmacs should pretend like the
522 debugger was never entered. Otherwise, it returns the value
523 that the user specified with `r'. (Note that much of the time,
524 the user will abort with C-], and we will never have a chance to
525 return anything at all.)
527 SIGNAL_VARS_ONLY means we should only look at debug-on-signal
528 and stack-trace-on-signal to control whether we do anything.
529 This is so that debug-on-error doesn't make handled errors
530 cause the debugger to get invoked.
532 STACK_TRACE_DISPLAYED and DEBUGGER_ENTERED are used so that
533 those functions aren't done more than once in a single `signal'
537 signal_call_debugger (Lisp_Object conditions,
538 Lisp_Object sig, Lisp_Object data,
539 Lisp_Object active_handlers,
540 int signal_vars_only,
541 int *stack_trace_displayed,
542 int *debugger_entered)
544 /* This function can GC */
545 Lisp_Object val = Qunbound;
546 Lisp_Object all_handlers = Vcondition_handlers;
547 Lisp_Object temp_data = Qnil;
548 int speccount = specpdl_depth();
549 struct gcpro gcpro1, gcpro2;
550 GCPRO2 (all_handlers, temp_data);
552 Vcondition_handlers = active_handlers;
554 temp_data = Fcons (sig, data); /* needed for skip_debugger */
556 if (!entering_debugger && !*stack_trace_displayed && !signal_vars_only
557 && wants_debugger (Vstack_trace_on_error, conditions)
558 && !skip_debugger (conditions, temp_data))
560 specbind (Qdebug_on_error, Qnil);
561 specbind (Qstack_trace_on_error, Qnil);
562 specbind (Qdebug_on_signal, Qnil);
563 specbind (Qstack_trace_on_signal, Qnil);
566 internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
570 else /* in batch mode, we want this going to stderr. */
571 backtrace_259 (Qnil);
572 unbind_to (speccount, Qnil);
573 *stack_trace_displayed = 1;
576 if (!entering_debugger && !*debugger_entered && !signal_vars_only
579 : wants_debugger (Vdebug_on_error, conditions))
580 && !skip_debugger (conditions, temp_data))
582 debug_on_quit &= ~2; /* reset critical bit */
583 specbind (Qdebug_on_error, Qnil);
584 specbind (Qstack_trace_on_error, Qnil);
585 specbind (Qdebug_on_signal, Qnil);
586 specbind (Qstack_trace_on_signal, Qnil);
588 val = call_debugger (list2 (Qerror, (Fcons (sig, data))));
589 *debugger_entered = 1;
592 if (!entering_debugger && !*stack_trace_displayed
593 && wants_debugger (Vstack_trace_on_signal, conditions))
595 specbind (Qdebug_on_error, Qnil);
596 specbind (Qstack_trace_on_error, Qnil);
597 specbind (Qdebug_on_signal, Qnil);
598 specbind (Qstack_trace_on_signal, Qnil);
601 internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
605 else /* in batch mode, we want this going to stderr. */
606 backtrace_259 (Qnil);
607 unbind_to (speccount, Qnil);
608 *stack_trace_displayed = 1;
611 if (!entering_debugger && !*debugger_entered
614 : wants_debugger (Vdebug_on_signal, conditions)))
616 debug_on_quit &= ~2; /* reset critical bit */
617 specbind (Qdebug_on_error, Qnil);
618 specbind (Qstack_trace_on_error, Qnil);
619 specbind (Qdebug_on_signal, Qnil);
620 specbind (Qstack_trace_on_signal, Qnil);
622 val = call_debugger (list2 (Qerror, (Fcons (sig, data))));
623 *debugger_entered = 1;
627 Vcondition_handlers = all_handlers;
628 return unbind_to (speccount, val);
632 /************************************************************************/
633 /* The basic special forms */
634 /************************************************************************/
636 /* Except for Fprogn(), the basic special forms below are only called
637 from interpreted code. The byte compiler turns them into bytecodes. */
639 DEFUN ("or", For, 0, UNEVALLED, 0, /*
640 Eval args until one of them yields non-nil, then return that value.
641 The remaining args are not evalled at all.
642 If all args return nil, return nil.
646 /* This function can GC */
647 REGISTER Lisp_Object val;
649 LIST_LOOP_2 (arg, args)
651 if (!NILP (val = Feval (arg)))
658 DEFUN ("and", Fand, 0, UNEVALLED, 0, /*
659 Eval args until one of them yields nil, then return nil.
660 The remaining args are not evalled at all.
661 If no arg yields nil, return the last arg's value.
665 /* This function can GC */
666 REGISTER Lisp_Object val = Qt;
668 LIST_LOOP_2 (arg, args)
670 if (NILP (val = Feval (arg)))
677 DEFUN ("if", Fif, 2, UNEVALLED, 0, /*
678 \(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...
679 Returns the value of THEN or the value of the last of the ELSE's.
680 THEN must be one expression, but ELSE... can be zero or more expressions.
681 If COND yields nil, and there are no ELSE's, the value is nil.
685 /* This function can GC */
686 Lisp_Object condition = XCAR (args);
687 Lisp_Object then_form = XCAR (XCDR (args));
688 Lisp_Object else_forms = XCDR (XCDR (args));
690 if (!NILP (Feval (condition)))
691 return Feval (then_form);
693 return Fprogn (else_forms);
696 /* Macros `when' and `unless' are trivially defined in Lisp,
697 but it helps for bootstrapping to have them ALWAYS defined. */
699 DEFUN ("when", Fwhen, 1, MANY, 0, /*
700 \(when COND BODY...): if COND yields non-nil, do BODY, else return nil.
701 BODY can be zero or more expressions. If BODY is nil, return nil.
703 (int nargs, Lisp_Object *args))
705 Lisp_Object cond = args[0];
710 case 1: body = Qnil; break;
711 case 2: body = args[1]; break;
712 default: body = Fcons (Qprogn, Flist (nargs-1, args+1)); break;
715 return list3 (Qif, cond, body);
718 DEFUN ("unless", Funless, 1, MANY, 0, /*
719 \(unless COND BODY...): if COND yields nil, do BODY, else return nil.
720 BODY can be zero or more expressions. If BODY is nil, return nil.
722 (int nargs, Lisp_Object *args))
724 Lisp_Object cond = args[0];
725 Lisp_Object body = Flist (nargs-1, args+1);
726 return Fcons (Qif, Fcons (cond, Fcons (Qnil, body)));
729 DEFUN ("cond", Fcond, 0, UNEVALLED, 0, /*
730 \(cond CLAUSES...): try each clause until one succeeds.
731 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
732 and, if the value is non-nil, this clause succeeds:
733 then the expressions in BODY are evaluated and the last one's
734 value is the value of the cond-form.
735 If no clause succeeds, cond returns nil.
736 If a clause has one element, as in (CONDITION),
737 CONDITION's value if non-nil is returned from the cond-form.
741 /* This function can GC */
742 REGISTER Lisp_Object val;
744 LIST_LOOP_2 (clause, args)
747 if (!NILP (val = Feval (XCAR (clause))))
749 if (!NILP (clause = XCDR (clause)))
751 CHECK_TRUE_LIST (clause);
752 val = Fprogn (clause);
761 DEFUN ("progn", Fprogn, 0, UNEVALLED, 0, /*
762 \(progn BODY...): eval BODY forms sequentially and return value of last one.
766 /* This function can GC */
767 /* Caller must provide a true list in ARGS */
768 REGISTER Lisp_Object val = Qnil;
774 LIST_LOOP_2 (form, args)
782 /* Fprog1() is the canonical example of a function that must GCPRO a
783 Lisp_Object across calls to Feval(). */
785 DEFUN ("prog1", Fprog1, 1, UNEVALLED, 0, /*
786 Similar to `progn', but the value of the first form is returned.
787 \(prog1 FIRST BODY...): All the arguments are evaluated sequentially.
788 The value of FIRST is saved during evaluation of the remaining args,
789 whose values are discarded.
793 /* This function can GC */
794 REGISTER Lisp_Object val;
797 val = Feval (XCAR (args));
802 LIST_LOOP_2 (form, XCDR (args))
810 DEFUN ("prog2", Fprog2, 2, UNEVALLED, 0, /*
811 Similar to `progn', but the value of the second form is returned.
812 \(prog2 FIRST SECOND BODY...): All the arguments are evaluated sequentially.
813 The value of SECOND is saved during evaluation of the remaining args,
814 whose values are discarded.
818 /* This function can GC */
819 REGISTER Lisp_Object val;
824 val = Feval (XCAR (args));
830 LIST_LOOP_2 (form, args)
838 DEFUN ("let*", FletX, 1, UNEVALLED, 0, /*
839 \(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.
840 The value of the last form in BODY is returned.
841 Each element of VARLIST is a symbol (which is bound to nil)
842 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
843 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
847 /* This function can GC */
848 Lisp_Object varlist = XCAR (args);
849 Lisp_Object body = XCDR (args);
850 int speccount = specpdl_depth();
852 EXTERNAL_LIST_LOOP_3 (var, varlist, tail)
854 Lisp_Object symbol, value, tem;
856 symbol = var, value = Qnil;
867 value = Feval (XCAR (tem));
868 if (!NILP (XCDR (tem)))
870 ("`let' bindings can have only one value-form", var);
873 specbind (symbol, value);
875 return unbind_to (speccount, Fprogn (body));
878 DEFUN ("let", Flet, 1, UNEVALLED, 0, /*
879 \(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.
880 The value of the last form in BODY is returned.
881 Each element of VARLIST is a symbol (which is bound to nil)
882 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
883 All the VALUEFORMs are evalled before any symbols are bound.
887 /* This function can GC */
888 Lisp_Object varlist = XCAR (args);
889 Lisp_Object body = XCDR (args);
890 int speccount = specpdl_depth();
895 /* Make space to hold the values to give the bound variables. */
898 GET_EXTERNAL_LIST_LENGTH (varlist, varcount);
899 temps = alloca_array (Lisp_Object, varcount);
902 /* Compute the values and store them in `temps' */
908 LIST_LOOP_2 (var, varlist)
910 Lisp_Object *value = &temps[idx++];
923 *value = Feval (XCAR (tem));
926 if (!NILP (XCDR (tem)))
928 ("`let' bindings can have only one value-form", var);
936 LIST_LOOP_2 (var, varlist)
938 specbind (SYMBOLP (var) ? var : XCAR (var), temps[idx++]);
944 return unbind_to (speccount, Fprogn (body));
947 DEFUN ("while", Fwhile, 1, UNEVALLED, 0, /*
948 \(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.
949 The order of execution is thus TEST, BODY, TEST, BODY and so on
950 until TEST returns nil.
954 /* This function can GC */
955 Lisp_Object test = XCAR (args);
956 Lisp_Object body = XCDR (args);
958 while (!NILP (Feval (test)))
967 DEFUN ("setq", Fsetq, 0, UNEVALLED, 0, /*
968 \(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.
969 The symbols SYM are variables; they are literal (not evaluated).
970 The values VAL are expressions; they are evaluated.
971 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
972 The second VAL is not computed until after the first SYM is set, and so on;
973 each VAL can use the new value of variables set earlier in the `setq'.
974 The return value of the `setq' form is the value of the last VAL.
978 /* This function can GC */
979 Lisp_Object symbol, tail, val = Qnil;
983 GET_LIST_LENGTH (args, nargs);
985 if (nargs & 1) /* Odd number of arguments? */
986 Fsignal (Qwrong_number_of_arguments, list2 (Qsetq, make_int (nargs)));
990 PROPERTY_LIST_LOOP (tail, symbol, val, args)
1000 DEFUN ("quote", Fquote, 1, UNEVALLED, 0, /*
1001 Return the argument, without evaluating it. `(quote x)' yields `x'.
1008 DEFUN ("function", Ffunction, 1, UNEVALLED, 0, /*
1009 Like `quote', but preferred for objects which are functions.
1010 In byte compilation, `function' causes its argument to be compiled.
1011 `quote' cannot do that.
1019 /************************************************************************/
1020 /* Defining functions/variables */
1021 /************************************************************************/
1023 define_function (Lisp_Object name, Lisp_Object defn)
1026 LOADHIST_ATTACH (name);
1030 DEFUN ("defun", Fdefun, 2, UNEVALLED, 0, /*
1031 \(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.
1032 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
1033 See also the function `interactive'.
1037 /* This function can GC */
1038 return define_function (XCAR (args),
1039 Fcons (Qlambda, XCDR (args)));
1042 DEFUN ("defmacro", Fdefmacro, 2, UNEVALLED, 0, /*
1043 \(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.
1044 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).
1045 When the macro is called, as in (NAME ARGS...),
1046 the function (lambda ARGLIST BODY...) is applied to
1047 the list ARGS... as it appears in the expression,
1048 and the result should be a form to be evaluated instead of the original.
1052 /* This function can GC */
1053 return define_function (XCAR (args),
1054 Fcons (Qmacro, Fcons (Qlambda, XCDR (args))));
1057 DEFUN ("defvar", Fdefvar, 1, UNEVALLED, 0, /*
1058 \(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.
1059 You are not required to define a variable in order to use it,
1060 but the definition can supply documentation and an initial value
1061 in a way that tags can recognize.
1063 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is
1064 void. (However, when you evaluate a defvar interactively, it acts like a
1065 defconst: SYMBOL's value is always set regardless of whether it's currently
1067 If SYMBOL is buffer-local, its default value is what is set;
1068 buffer-local values are not affected.
1069 INITVALUE and DOCSTRING are optional.
1070 If DOCSTRING starts with *, this variable is identified as a user option.
1071 This means that M-x set-variable recognizes it.
1072 If INITVALUE is missing, SYMBOL's value is not set.
1074 In lisp-interaction-mode defvar is treated as defconst.
1078 /* This function can GC */
1079 Lisp_Object sym = XCAR (args);
1081 if (!NILP (args = XCDR (args)))
1083 Lisp_Object val = XCAR (args);
1085 if (NILP (Fdefault_boundp (sym)))
1087 struct gcpro gcpro1;
1090 Fset_default (sym, val);
1094 if (!NILP (args = XCDR (args)))
1096 Lisp_Object doc = XCAR (args);
1097 Fput (sym, Qvariable_documentation, doc);
1098 if (!NILP (args = XCDR (args)))
1099 error ("too many arguments");
1104 if (!NILP (Vfile_domain))
1105 Fput (sym, Qvariable_domain, Vfile_domain);
1108 LOADHIST_ATTACH (sym);
1112 DEFUN ("defconst", Fdefconst, 2, UNEVALLED, 0, /*
1113 \(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant
1115 The intent is that programs do not change this value, but users may.
1116 Always sets the value of SYMBOL to the result of evalling INITVALUE.
1117 If SYMBOL is buffer-local, its default value is what is set;
1118 buffer-local values are not affected.
1119 DOCSTRING is optional.
1120 If DOCSTRING starts with *, this variable is identified as a user option.
1121 This means that M-x set-variable recognizes it.
1123 Note: do not use `defconst' for user options in libraries that are not
1124 normally loaded, since it is useful for users to be able to specify
1125 their own values for such variables before loading the library.
1126 Since `defconst' unconditionally assigns the variable,
1127 it would override the user's choice.
1131 /* This function can GC */
1132 Lisp_Object sym = XCAR (args);
1133 Lisp_Object val = Feval (XCAR (args = XCDR (args)));
1134 struct gcpro gcpro1;
1138 Fset_default (sym, val);
1142 if (!NILP (args = XCDR (args)))
1144 Lisp_Object doc = XCAR (args);
1145 Fput (sym, Qvariable_documentation, doc);
1146 if (!NILP (args = XCDR (args)))
1147 error ("too many arguments");
1151 if (!NILP (Vfile_domain))
1152 Fput (sym, Qvariable_domain, Vfile_domain);
1155 LOADHIST_ATTACH (sym);
1159 DEFUN ("user-variable-p", Fuser_variable_p, 1, 1, 0, /*
1160 Return t if VARIABLE is intended to be set and modified by users.
1161 \(The alternative is a variable used internally in a Lisp program.)
1162 Determined by whether the first character of the documentation
1163 for the variable is `*'.
1167 Lisp_Object documentation = Fget (variable, Qvariable_documentation, Qnil);
1170 ((INTP (documentation) && XINT (documentation) < 0) ||
1172 (STRINGP (documentation) &&
1173 (string_byte (XSTRING (documentation), 0) == '*')) ||
1175 /* If (STRING . INTEGER), a negative integer means a user variable. */
1176 (CONSP (documentation)
1177 && STRINGP (XCAR (documentation))
1178 && INTP (XCDR (documentation))
1179 && XINT (XCDR (documentation)) < 0)) ?
1183 DEFUN ("macroexpand-internal", Fmacroexpand_internal, 1, 2, 0, /*
1184 Return result of expanding macros at top level of FORM.
1185 If FORM is not a macro call, it is returned unchanged.
1186 Otherwise, the macro is expanded and the expansion is considered
1187 in place of FORM. When a non-macro-call results, it is returned.
1189 The second optional arg ENVIRONMENT specifies an environment of macro
1190 definitions to shadow the loaded ones for use in file byte-compilation.
1192 (form, environment))
1194 /* This function can GC */
1195 /* With cleanups from Hallvard Furuseth. */
1196 REGISTER Lisp_Object expander, sym, def, tem;
1200 /* Come back here each time we expand a macro call,
1201 in case it expands into another macro call. */
1204 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1205 def = sym = XCAR (form);
1207 /* Trace symbols aliases to other symbols
1208 until we get a symbol that is not an alias. */
1209 while (SYMBOLP (def))
1213 tem = Fassq (sym, environment);
1216 def = XSYMBOL (sym)->function;
1217 if (!UNBOUNDP (def))
1222 /* Right now TEM is the result from SYM in ENVIRONMENT,
1223 and if TEM is nil then DEF is SYM's function definition. */
1226 /* SYM is not mentioned in ENVIRONMENT.
1227 Look at its function definition. */
1230 /* Not defined or definition not suitable */
1232 if (EQ (XCAR (def), Qautoload))
1234 /* Autoloading function: will it be a macro when loaded? */
1235 tem = Felt (def, make_int (4));
1236 if (EQ (tem, Qt) || EQ (tem, Qmacro))
1238 /* Yes, load it and try again. */
1239 do_autoload (def, sym);
1245 else if (!EQ (XCAR (def), Qmacro))
1247 else expander = XCDR (def);
1251 expander = XCDR (tem);
1252 if (NILP (expander))
1255 form = apply1 (expander, XCDR (form));
1261 /************************************************************************/
1262 /* Non-local exits */
1263 /************************************************************************/
1265 DEFUN ("catch", Fcatch, 1, UNEVALLED, 0, /*
1266 \(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.
1267 TAG is evalled to get the tag to use. Then the BODY is executed.
1268 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.
1269 If no throw happens, `catch' returns the value of the last BODY form.
1270 If a throw happens, it specifies the value to return from `catch'.
1274 /* This function can GC */
1275 Lisp_Object tag = Feval (XCAR (args));
1276 Lisp_Object body = XCDR (args);
1277 return internal_catch (tag, Fprogn, body, 0);
1280 /* Set up a catch, then call C function FUNC on argument ARG.
1281 FUNC should return a Lisp_Object.
1282 This is how catches are done from within C code. */
1285 internal_catch (Lisp_Object tag,
1286 Lisp_Object (*func) (Lisp_Object arg),
1288 int * volatile threw)
1290 /* This structure is made part of the chain `catchlist'. */
1293 /* Fill in the components of c, and put it on the list. */
1297 c.backlist = backtrace_list;
1300 c.handlerlist = handlerlist;
1302 c.lisp_eval_depth = lisp_eval_depth;
1303 c.pdlcount = specpdl_depth();
1305 c.poll_suppress_count = async_timer_suppress_count;
1307 c.gcpro = gcprolist;
1313 /* Throw works by a longjmp that comes right here. */
1314 if (threw) *threw = 1;
1317 c.val = (*func) (arg);
1318 if (threw) *threw = 0;
1320 #ifdef ERROR_CHECK_TYPECHECK
1321 check_error_state_sanity ();
1327 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1328 jump to that CATCH, returning VALUE as the value of that catch.
1330 This is the guts Fthrow and Fsignal; they differ only in the way
1331 they choose the catch tag to throw to. A catch tag for a
1332 condition-case form has a TAG of Qnil.
1334 Before each catch is discarded, unbind all special bindings and
1335 execute all unwind-protect clauses made above that catch. Unwind
1336 the handler stack as we go, so that the proper handlers are in
1337 effect for each unwind-protect clause we run. At the end, restore
1338 some static info saved in CATCH, and longjmp to the location
1341 This is used for correct unwinding in Fthrow and Fsignal. */
1344 unwind_to_catch (struct catchtag *c, Lisp_Object val)
1348 REGISTER int last_time;
1351 /* Unwind the specbind, catch, and handler stacks back to CATCH
1352 Before each catch is discarded, unbind all special bindings
1353 and execute all unwind-protect clauses made above that catch.
1354 At the end, restore some static info saved in CATCH,
1355 and longjmp to the location specified.
1358 /* Save the value somewhere it will be GC'ed.
1359 (Can't overwrite tag slot because an unwind-protect may
1360 want to throw to this same tag, which isn't yet invalid.) */
1364 /* Restore the polling-suppression count. */
1365 set_poll_suppress_count (catch->poll_suppress_count);
1369 /* #### FSFmacs has the following loop. Is it more correct? */
1372 last_time = catchlist == c;
1374 /* Unwind the specpdl stack, and then restore the proper set of
1376 unbind_to (catchlist->pdlcount, Qnil);
1377 handlerlist = catchlist->handlerlist;
1378 catchlist = catchlist->next;
1379 #ifdef ERROR_CHECK_TYPECHECK
1380 check_error_state_sanity ();
1383 while (! last_time);
1384 #else /* Actual XEmacs code */
1385 /* Unwind the specpdl stack */
1386 unbind_to (c->pdlcount, Qnil);
1387 catchlist = c->next;
1388 #ifdef ERROR_CHECK_TYPECHECK
1389 check_error_state_sanity ();
1393 gcprolist = c->gcpro;
1394 backtrace_list = c->backlist;
1395 lisp_eval_depth = c->lisp_eval_depth;
1397 #ifdef DEFEND_AGAINST_THROW_RECURSION
1400 LONGJMP (c->jmp, 1);
1403 static DOESNT_RETURN
1404 throw_or_bomb_out (Lisp_Object tag, Lisp_Object val, int bomb_out_p,
1405 Lisp_Object sig, Lisp_Object data)
1407 #ifdef DEFEND_AGAINST_THROW_RECURSION
1408 /* die if we recurse more than is reasonable */
1409 if (++throw_level > 20)
1413 /* If bomb_out_p is t, this is being called from Fsignal as a
1414 "last resort" when there is no handler for this error and
1415 the debugger couldn't be invoked, so we are throwing to
1416 'top-level. If this tag doesn't exist (happens during the
1417 initialization stages) we would get in an infinite recursive
1418 Fsignal/Fthrow loop, so instead we bomb out to the
1419 really-early-error-handler.
1421 Note that in fact the only time that the "last resort"
1422 occurs is when there's no catch for 'top-level -- the
1423 'top-level catch and the catch-all error handler are
1424 established at the same time, in initial_command_loop/
1427 #### Fix this horrifitude!
1432 REGISTER struct catchtag *c;
1435 if (!NILP (tag)) /* #### */
1437 for (c = catchlist; c; c = c->next)
1439 if (EQ (c->tag, tag))
1440 unwind_to_catch (c, val);
1443 tag = Fsignal (Qno_catch, list2 (tag, val));
1445 call1 (Qreally_early_error_handler, Fcons (sig, data));
1448 /* can't happen. who cares? - (Sun's compiler does) */
1449 /* throw_level--; */
1450 /* getting tired of compilation warnings */
1454 /* See above, where CATCHLIST is defined, for a description of how
1457 Fthrow() is also called by Fsignal(), to do a non-local jump
1458 back to the appropriate condition-case handler after (maybe)
1459 the debugger is entered. In that case, TAG is the value
1460 of Vcondition_handlers that was in place just after the
1461 condition-case handler was set up. The car of this will be
1462 some data referring to the handler: Its car will be Qunbound
1463 (thus, this tag can never be generated by Lisp code), and
1464 its CDR will be the HANDLERS argument to condition_case_1()
1465 (either Qerror, Qt, or a list of handlers as in `condition-case').
1466 This works fine because Fthrow() does not care what TAG was
1467 passed to it: it just looks up the catch list for something
1468 that is EQ() to TAG. When it finds it, it will longjmp()
1469 back to the place that established the catch (in this case,
1470 condition_case_1). See below for more info.
1473 DEFUN ("throw", Fthrow, 2, 2, 0, /*
1474 Throw to the catch for TAG and return VALUE from it.
1475 Both TAG and VALUE are evalled.
1479 throw_or_bomb_out (tag, value, 0, Qnil, Qnil); /* Doesn't return */
1483 DEFUN ("unwind-protect", Funwind_protect, 1, UNEVALLED, 0, /*
1484 Do BODYFORM, protecting with UNWINDFORMS.
1485 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).
1486 If BODYFORM completes normally, its value is returned
1487 after executing the UNWINDFORMS.
1488 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1492 /* This function can GC */
1493 int speccount = specpdl_depth();
1495 record_unwind_protect (Fprogn, XCDR (args));
1496 return unbind_to (speccount, Feval (XCAR (args)));
1500 /************************************************************************/
1501 /* Signalling and trapping errors */
1502 /************************************************************************/
1505 condition_bind_unwind (Lisp_Object loser)
1508 /* ((handler-fun . handler-args) ... other handlers) */
1509 Lisp_Object tem = XCAR (loser);
1513 victim = XCONS (tem);
1517 victim = XCONS (loser);
1519 if (EQ (loser, Vcondition_handlers)) /* may have been rebound to some tail */
1520 Vcondition_handlers = victim->cdr;
1527 condition_case_unwind (Lisp_Object loser)
1531 /* ((<unbound> . clauses) ... other handlers */
1532 victim = XCONS (XCAR (loser));
1535 victim = XCONS (loser);
1536 if (EQ (loser, Vcondition_handlers)) /* may have been rebound to some tail */
1537 Vcondition_handlers = victim->cdr;
1543 /* Split out from condition_case_3 so that primitive C callers
1544 don't have to cons up a lisp handler form to be evaluated. */
1546 /* Call a function BFUN of one argument BARG, trapping errors as
1547 specified by HANDLERS. If no error occurs that is indicated by
1548 HANDLERS as something to be caught, the return value of this
1549 function is the return value from BFUN. If such an error does
1550 occur, HFUN is called, and its return value becomes the
1551 return value of condition_case_1(). The second argument passed
1552 to HFUN will always be HARG. The first argument depends on
1555 If HANDLERS is Qt, all errors (this includes QUIT, but not
1556 non-local exits with `throw') cause HFUN to be invoked, and VAL
1557 (the first argument to HFUN) is a cons (SIG . DATA) of the
1558 arguments passed to `signal'. The debugger is not invoked even if
1559 `debug-on-error' was set.
1561 A HANDLERS value of Qerror is the same as Qt except that the
1562 debugger is invoked if `debug-on-error' was set.
1564 Otherwise, HANDLERS should be a list of lists (CONDITION-NAME BODY ...)
1565 exactly as in `condition-case', and errors will be trapped
1566 as indicated in HANDLERS. VAL (the first argument to HFUN) will
1567 be a cons whose car is the cons (SIG . DATA) and whose CDR is the
1568 list (BODY ...) from the appropriate slot in HANDLERS.
1570 This function pushes HANDLERS onto the front of Vcondition_handlers
1571 (actually with a Qunbound marker as well -- see Fthrow() above
1572 for why), establishes a catch whose tag is this new value of
1573 Vcondition_handlers, and calls BFUN. When Fsignal() is called,
1574 it calls Fthrow(), setting TAG to this same new value of
1575 Vcondition_handlers and setting VAL to the same thing that will
1576 be passed to HFUN, as above. Fthrow() longjmp()s back to the
1577 jump point we just established, and we in turn just call the
1578 HFUN and return its value.
1580 For a real condition-case, HFUN will always be
1581 run_condition_case_handlers() and HARG is the argument VAR
1582 to condition-case. That function just binds VAR to the cons
1583 (SIG . DATA) that is the CAR of VAL, and calls the handler
1584 (BODY ...) that is the CDR of VAL. Note that before calling
1585 Fthrow(), Fsignal() restored Vcondition_handlers to the value
1586 it had *before* condition_case_1() was called. This maintains
1587 consistency (so that the state of things at exit of
1588 condition_case_1() is the same as at entry), and implies
1589 that the handler can signal the same error again (possibly
1590 after processing of its own), without getting in an infinite
1594 condition_case_1 (Lisp_Object handlers,
1595 Lisp_Object (*bfun) (Lisp_Object barg),
1597 Lisp_Object (*hfun) (Lisp_Object val, Lisp_Object harg),
1600 int speccount = specpdl_depth();
1602 struct gcpro gcpro1;
1607 /* Do consing now so out-of-memory error happens up front */
1608 /* (unbound . stuff) is a special condition-case kludge marker
1609 which is known specially by Fsignal.
1610 This is an abomination, but to fix it would require either
1611 making condition_case cons (a union of the conditions of the clauses)
1612 or changing the byte-compiler output (no thanks). */
1613 c.tag = noseeum_cons (noseeum_cons (Qunbound, handlers),
1614 Vcondition_handlers);
1617 c.backlist = backtrace_list;
1620 c.handlerlist = handlerlist;
1622 c.lisp_eval_depth = lisp_eval_depth;
1623 c.pdlcount = specpdl_depth();
1625 c.poll_suppress_count = async_timer_suppress_count;
1627 c.gcpro = gcprolist;
1628 /* #### FSFmacs does the following statement *after* the setjmp(). */
1633 /* throw does ungcpro, etc */
1634 return (*hfun) (c.val, harg);
1637 record_unwind_protect (condition_case_unwind, c.tag);
1641 h.handler = handlers;
1643 h.next = handlerlist;
1647 Vcondition_handlers = c.tag;
1649 GCPRO1 (harg); /* Somebody has to gc-protect */
1651 c.val = ((*bfun) (barg));
1653 /* The following is *not* true: (ben)
1655 ungcpro, restoring catchlist and condition_handlers are actually
1656 redundant since unbind_to now restores them. But it looks funny not to
1657 have this code here, and it doesn't cost anything, so I'm leaving it.*/
1660 #ifdef ERROR_CHECK_TYPECHECK
1661 check_error_state_sanity ();
1663 Vcondition_handlers = XCDR (c.tag);
1665 return unbind_to (speccount, c.val);
1669 run_condition_case_handlers (Lisp_Object val, Lisp_Object var)
1671 /* This function can GC */
1674 specbind (h.var, c.val);
1675 val = Fprogn (Fcdr (h.chosen_clause));
1677 /* Note that this just undoes the binding of h.var; whoever
1678 longjmp()ed to us unwound the stack to c.pdlcount before
1680 unbind_to (c.pdlcount, Qnil);
1685 CHECK_TRUE_LIST (val);
1687 return Fprogn (Fcdr (val)); /* tail call */
1689 speccount = specpdl_depth();
1690 specbind (var, Fcar (val));
1691 val = Fprogn (Fcdr (val));
1692 return unbind_to (speccount, val);
1696 /* Here for bytecode to call non-consfully. This is exactly like
1697 condition-case except that it takes three arguments rather
1698 than a single list of arguments. */
1700 condition_case_3 (Lisp_Object bodyform, Lisp_Object var, Lisp_Object handlers)
1702 /* This function can GC */
1703 EXTERNAL_LIST_LOOP_2 (handler, handlers)
1707 else if (CONSP (handler))
1709 Lisp_Object conditions = XCAR (handler);
1710 /* CONDITIONS must a condition name or a list of condition names */
1711 if (SYMBOLP (conditions))
1715 EXTERNAL_LIST_LOOP_2 (condition, conditions)
1716 if (!SYMBOLP (condition))
1717 goto invalid_condition_handler;
1722 invalid_condition_handler:
1723 signal_simple_error ("Invalid condition handler", handler);
1729 return condition_case_1 (handlers,
1731 run_condition_case_handlers,
1735 DEFUN ("condition-case", Fcondition_case, 2, UNEVALLED, 0, /*
1736 Regain control when an error is signalled.
1737 Usage looks like (condition-case VAR BODYFORM HANDLERS...).
1738 Executes BODYFORM and returns its value if no error happens.
1739 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1740 where the BODY is made of Lisp expressions.
1742 A handler is applicable to an error if CONDITION-NAME is one of the
1743 error's condition names. If an error happens, the first applicable
1744 handler is run. As a special case, a CONDITION-NAME of t matches
1745 all errors, even those without the `error' condition name on them
1748 The car of a handler may be a list of condition names
1749 instead of a single condition name.
1751 When a handler handles an error,
1752 control returns to the condition-case and the handler BODY... is executed
1753 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).
1754 VAR may be nil; then you do not get access to the signal information.
1756 The value of the last BODY form is returned from the condition-case.
1757 See also the function `signal' for more info.
1759 Note that at the time the condition handler is invoked, the Lisp stack
1760 and the current catches, condition-cases, and bindings have all been
1761 popped back to the state they were in just before the call to
1762 `condition-case'. This means that resignalling the error from
1763 within the handler will not result in an infinite loop.
1765 If you want to establish an error handler that is called with the
1766 Lisp stack, bindings, etc. as they were when `signal' was called,
1767 rather than when the handler was set, use `call-with-condition-handler'.
1771 /* This function can GC */
1772 Lisp_Object var = XCAR (args);
1773 Lisp_Object bodyform = XCAR (XCDR (args));
1774 Lisp_Object handlers = XCDR (XCDR (args));
1775 return condition_case_3 (bodyform, var, handlers);
1778 DEFUN ("call-with-condition-handler", Fcall_with_condition_handler, 2, MANY, 0, /*
1779 Regain control when an error is signalled, without popping the stack.
1780 Usage looks like (call-with-condition-handler HANDLER FUNCTION &rest ARGS).
1781 This function is similar to `condition-case', but the handler is invoked
1782 with the same environment (Lisp stack, bindings, catches, condition-cases)
1783 that was current when `signal' was called, rather than when the handler
1786 HANDLER should be a function of one argument, which is a cons of the args
1787 \(SIG . DATA) that were passed to `signal'. It is invoked whenever
1788 `signal' is called (this differs from `condition-case', which allows
1789 you to specify which errors are trapped). If the handler function
1790 returns, `signal' continues as if the handler were never invoked.
1791 \(It continues to look for handlers established earlier than this one,
1792 and invokes the standard error-handler if none is found.)
1794 (int nargs, Lisp_Object *args)) /* Note! Args side-effected! */
1796 /* This function can GC */
1797 int speccount = specpdl_depth();
1800 /* #### If there were a way to check that args[0] were a function
1801 which accepted one arg, that should be done here ... */
1803 /* (handler-fun . handler-args) */
1804 tem = noseeum_cons (list1 (args[0]), Vcondition_handlers);
1805 record_unwind_protect (condition_bind_unwind, tem);
1806 Vcondition_handlers = tem;
1808 /* Caller should have GC-protected args */
1809 return unbind_to (speccount, Ffuncall (nargs - 1, args + 1));
1813 condition_type_p (Lisp_Object type, Lisp_Object conditions)
1816 /* (condition-case c # (t c)) catches -all- signals
1817 * Use with caution! */
1821 return !NILP (Fmemq (type, conditions));
1823 for (; CONSP (type); type = XCDR (type))
1824 if (!NILP (Fmemq (XCAR (type), conditions)))
1831 return_from_signal (Lisp_Object value)
1834 /* Most callers are not prepared to handle gc if this
1835 returns. So, since this feature is not very useful,
1837 /* Have called debugger; return value to signaller */
1839 #else /* But the reality is that that stinks, because: */
1840 /* GACK!!! Really want some way for debug-on-quit errors
1841 to be continuable!! */
1842 error ("Returning a value from an error is no longer supported");
1846 extern int in_display;
1849 /************************************************************************/
1850 /* the workhorse error-signaling function */
1851 /************************************************************************/
1853 /* #### This function has not been synched with FSF. It diverges
1857 signal_1 (Lisp_Object sig, Lisp_Object data)
1859 /* This function can GC */
1860 struct gcpro gcpro1, gcpro2;
1861 Lisp_Object conditions;
1862 Lisp_Object handlers;
1863 /* signal_call_debugger() could get called more than once
1864 (once when a call-with-condition-handler is about to
1865 be dealt with, and another when a condition-case handler
1866 is about to be invoked). So make sure the debugger and/or
1867 stack trace aren't done more than once. */
1868 int stack_trace_displayed = 0;
1869 int debugger_entered = 0;
1870 GCPRO2 (conditions, handlers);
1874 /* who knows how much has been initialized? Safest bet is
1875 just to bomb out immediately. */
1876 /* let's not use stderr_out() here, because that does a bunch of
1877 things that might not be safe yet. */
1878 fprintf (stderr, "Error before initialization is complete!\n");
1882 if (gc_in_progress || in_display)
1883 /* This is one of many reasons why you can't run lisp code from redisplay.
1884 There is no sensible way to handle errors there. */
1887 conditions = Fget (sig, Qerror_conditions, Qnil);
1889 for (handlers = Vcondition_handlers;
1891 handlers = XCDR (handlers))
1893 Lisp_Object handler_fun = XCAR (XCAR (handlers));
1894 Lisp_Object handler_data = XCDR (XCAR (handlers));
1895 Lisp_Object outer_handlers = XCDR (handlers);
1897 if (!UNBOUNDP (handler_fun))
1899 /* call-with-condition-handler */
1901 Lisp_Object all_handlers = Vcondition_handlers;
1902 struct gcpro ngcpro1;
1903 NGCPRO1 (all_handlers);
1904 Vcondition_handlers = outer_handlers;
1906 tem = signal_call_debugger (conditions, sig, data,
1908 &stack_trace_displayed,
1910 if (!UNBOUNDP (tem))
1911 RETURN_NUNGCPRO (return_from_signal (tem));
1913 tem = Fcons (sig, data);
1914 if (NILP (handler_data))
1915 tem = call1 (handler_fun, tem);
1918 /* (This code won't be used (for now?).) */
1919 struct gcpro nngcpro1;
1920 Lisp_Object args[3];
1923 args[0] = handler_fun;
1925 args[2] = handler_data;
1926 nngcpro1.var = args;
1927 tem = Fapply (3, args);
1932 if (!EQ (tem, Qsignal))
1933 return return_from_signal (tem);
1935 /* If handler didn't throw, try another handler */
1936 Vcondition_handlers = all_handlers;
1939 /* It's a condition-case handler */
1941 /* t is used by handlers for all conditions, set up by C code.
1942 * debugger is not called even if debug_on_error */
1943 else if (EQ (handler_data, Qt))
1946 return Fthrow (handlers, Fcons (sig, data));
1948 /* `error' is used similarly to the way `t' is used, but in
1949 addition it invokes the debugger if debug_on_error.
1950 This is normally used for the outer command-loop error
1952 else if (EQ (handler_data, Qerror))
1954 Lisp_Object tem = signal_call_debugger (conditions, sig, data,
1956 &stack_trace_displayed,
1960 if (!UNBOUNDP (tem))
1961 return return_from_signal (tem);
1963 tem = Fcons (sig, data);
1964 return Fthrow (handlers, tem);
1968 /* handler established by real (Lisp) condition-case */
1971 for (h = handler_data; CONSP (h); h = Fcdr (h))
1973 Lisp_Object clause = Fcar (h);
1974 Lisp_Object tem = Fcar (clause);
1976 if (condition_type_p (tem, conditions))
1978 tem = signal_call_debugger (conditions, sig, data,
1980 &stack_trace_displayed,
1983 if (!UNBOUNDP (tem))
1984 return return_from_signal (tem);
1986 /* Doesn't return */
1987 tem = Fcons (Fcons (sig, data), Fcdr (clause));
1988 return Fthrow (handlers, tem);
1994 /* If no handler is present now, try to run the debugger,
1995 and if that fails, throw to top level.
1997 #### The only time that no handler is present is during
1998 temacs or perhaps very early in XEmacs. In both cases,
1999 there is no 'top-level catch. (That's why the
2000 "bomb-out" hack was added.)
2002 #### Fix this horrifitude!
2004 signal_call_debugger (conditions, sig, data, Qnil, 0,
2005 &stack_trace_displayed,
2008 throw_or_bomb_out (Qtop_level, Qt, 1, sig, data); /* Doesn't return */
2013 /****************** Error functions class 1 ******************/
2015 /* Class 1: General functions that signal an error.
2016 These functions take an error type and a list of associated error
2019 /* The simplest external error function: it would be called
2020 signal_continuable_error() in the terminology below, but it's
2023 DEFUN ("signal", Fsignal, 2, 2, 0, /*
2024 Signal a continuable error. Args are ERROR-SYMBOL, and associated DATA.
2025 An error symbol is a symbol defined using `define-error'.
2026 DATA should be a list. Its elements are printed as part of the error message.
2027 If the signal is handled, DATA is made available to the handler.
2028 See also the function `signal-error', and the functions to handle errors:
2029 `condition-case' and `call-with-condition-handler'.
2031 Note that this function can return, if the debugger is invoked and the
2032 user invokes the "return from signal" option.
2034 (error_symbol, data))
2036 /* Fsignal() is one of these functions that's called all the time
2037 with newly-created Lisp objects. We allow this; but we must GC-
2038 protect the objects because all sorts of weird stuff could
2041 struct gcpro gcpro1;
2044 if (!NILP (Vcurrent_error_state))
2046 if (!NILP (Vcurrent_warning_class))
2047 warn_when_safe_lispobj (Vcurrent_warning_class, Qwarning,
2048 Fcons (error_symbol, data));
2049 Fthrow (Qunbound_suspended_errors_tag, Qnil);
2050 abort (); /* Better not get here! */
2052 RETURN_UNGCPRO (signal_1 (error_symbol, data));
2055 /* Signal a non-continuable error. */
2058 signal_error (Lisp_Object sig, Lisp_Object data)
2061 Fsignal (sig, data);
2063 #ifdef ERROR_CHECK_TYPECHECK
2065 check_error_state_sanity (void)
2068 int found_error_tag = 0;
2070 for (c = catchlist; c; c = c->next)
2072 if (EQ (c->tag, Qunbound_suspended_errors_tag))
2074 found_error_tag = 1;
2079 assert (found_error_tag || NILP (Vcurrent_error_state));
2084 restore_current_warning_class (Lisp_Object warning_class)
2086 Vcurrent_warning_class = warning_class;
2091 restore_current_error_state (Lisp_Object error_state)
2093 Vcurrent_error_state = error_state;
2098 call_with_suspended_errors_1 (Lisp_Object opaque_arg)
2101 Lisp_Object *kludgy_args = (Lisp_Object *) get_opaque_ptr (opaque_arg);
2102 Lisp_Object no_error = kludgy_args[2];
2103 int speccount = specpdl_depth ();
2105 if (!EQ (Vcurrent_error_state, no_error))
2107 record_unwind_protect (restore_current_error_state,
2108 Vcurrent_error_state);
2109 Vcurrent_error_state = no_error;
2111 PRIMITIVE_FUNCALL (val, get_opaque_ptr (kludgy_args[0]),
2112 kludgy_args + 3, XINT (kludgy_args[1]));
2113 return unbind_to (speccount, val);
2116 /* Many functions would like to do one of three things if an error
2119 (1) signal the error, as usual.
2120 (2) silently fail and return some error value.
2121 (3) do as (2) but issue a warning in the process.
2123 Currently there's lots of stuff that passes an Error_behavior
2124 value and calls maybe_signal_error() and other such functions.
2125 This approach is inherently error-prone and broken. A much
2126 more robust and easier approach is to use call_with_suspended_errors().
2127 Wrap this around any function in which you might want errors
2132 call_with_suspended_errors (lisp_fn_t fun, volatile Lisp_Object retval,
2133 Lisp_Object class, Error_behavior errb,
2138 Lisp_Object kludgy_args[23];
2139 Lisp_Object *args = kludgy_args + 3;
2141 Lisp_Object no_error;
2143 assert (SYMBOLP (class)); /* sanity-check */
2144 assert (!NILP (class));
2145 assert (nargs >= 0 && nargs < 20);
2147 /* ERROR_ME means don't trap errors. (However, if errors are
2148 already trapped, we leave them trapped.)
2150 Otherwise, we trap errors, and trap warnings if ERROR_ME_WARN.
2152 If ERROR_ME_NOT, it causes no warnings even if warnings
2153 were previously enabled. However, we never change the
2154 warning class from one to another. */
2155 if (!ERRB_EQ (errb, ERROR_ME))
2157 if (ERRB_EQ (errb, ERROR_ME_NOT)) /* person wants no warnings */
2159 errb = ERROR_ME_NOT;
2165 va_start (vargs, nargs);
2166 for (i = 0; i < nargs; i++)
2167 args[i] = va_arg (vargs, Lisp_Object);
2170 /* If error-checking is not disabled, just call the function.
2171 It's important not to override disabled error-checking with
2172 enabled error-checking. */
2174 if (ERRB_EQ (errb, ERROR_ME))
2177 PRIMITIVE_FUNCALL (val, fun, args, nargs);
2181 speccount = specpdl_depth ();
2182 if (NILP (class) || NILP (Vcurrent_warning_class))
2184 /* If we're currently calling for no warnings, then make it so.
2185 If we're currently calling for warnings and we weren't
2186 previously, then set our warning class; otherwise, leave
2187 the existing one alone. */
2188 record_unwind_protect (restore_current_warning_class,
2189 Vcurrent_warning_class);
2190 Vcurrent_warning_class = class;
2195 Lisp_Object the_retval;
2196 Lisp_Object opaque1 = make_opaque_ptr (kludgy_args);
2197 Lisp_Object opaque2 = make_opaque_ptr ((void *) fun);
2198 struct gcpro gcpro1, gcpro2;
2200 GCPRO2 (opaque1, opaque2);
2201 kludgy_args[0] = opaque2;
2202 kludgy_args[1] = make_int (nargs);
2203 kludgy_args[2] = no_error;
2204 the_retval = internal_catch (Qunbound_suspended_errors_tag,
2205 call_with_suspended_errors_1,
2207 free_opaque_ptr (opaque1);
2208 free_opaque_ptr (opaque2);
2210 /* Use the returned value except in non-local exit, when
2212 /* Some perverse compilers require the perverse cast below. */
2213 return unbind_to (speccount,
2214 threw ? *((Lisp_Object*) &(retval)) : the_retval);
2218 /* Signal a non-continuable error or display a warning or do nothing,
2219 according to ERRB. CLASS is the class of warning and should
2220 refer to what sort of operation is being done (e.g. Qtoolbar,
2221 Qresource, etc.). */
2224 maybe_signal_error (Lisp_Object sig, Lisp_Object data, Lisp_Object class,
2225 Error_behavior errb)
2227 if (ERRB_EQ (errb, ERROR_ME_NOT))
2229 else if (ERRB_EQ (errb, ERROR_ME_WARN))
2230 warn_when_safe_lispobj (class, Qwarning, Fcons (sig, data));
2233 Fsignal (sig, data);
2236 /* Signal a continuable error or display a warning or do nothing,
2237 according to ERRB. */
2240 maybe_signal_continuable_error (Lisp_Object sig, Lisp_Object data,
2241 Lisp_Object class, Error_behavior errb)
2243 if (ERRB_EQ (errb, ERROR_ME_NOT))
2245 else if (ERRB_EQ (errb, ERROR_ME_WARN))
2247 warn_when_safe_lispobj (class, Qwarning, Fcons (sig, data));
2251 return Fsignal (sig, data);
2255 /****************** Error functions class 2 ******************/
2257 /* Class 2: Printf-like functions that signal an error.
2258 These functions signal an error of a specified type, whose data
2259 is a single string, created using the arguments. */
2261 /* dump an error message; called like printf */
2264 type_error (Lisp_Object type, const char *fmt, ...)
2269 va_start (args, fmt);
2270 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2274 /* Fsignal GC-protects its args */
2275 signal_error (type, list1 (obj));
2279 maybe_type_error (Lisp_Object type, Lisp_Object class, Error_behavior errb,
2280 const char *fmt, ...)
2286 if (ERRB_EQ (errb, ERROR_ME_NOT))
2289 va_start (args, fmt);
2290 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2294 /* Fsignal GC-protects its args */
2295 maybe_signal_error (type, list1 (obj), class, errb);
2299 continuable_type_error (Lisp_Object type, const char *fmt, ...)
2304 va_start (args, fmt);
2305 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2309 /* Fsignal GC-protects its args */
2310 return Fsignal (type, list1 (obj));
2314 maybe_continuable_type_error (Lisp_Object type, Lisp_Object class,
2315 Error_behavior errb, const char *fmt, ...)
2321 if (ERRB_EQ (errb, ERROR_ME_NOT))
2324 va_start (args, fmt);
2325 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2329 /* Fsignal GC-protects its args */
2330 return maybe_signal_continuable_error (type, list1 (obj), class, errb);
2334 /****************** Error functions class 3 ******************/
2336 /* Class 3: Signal an error with a string and an associated object.
2337 These functions signal an error of a specified type, whose data
2338 is two objects, a string and a related Lisp object (usually the object
2339 where the error is occurring). */
2342 signal_type_error (Lisp_Object type, const char *reason, Lisp_Object frob)
2344 if (UNBOUNDP (frob))
2345 signal_error (type, list1 (build_translated_string (reason)));
2347 signal_error (type, list2 (build_translated_string (reason), frob));
2351 maybe_signal_type_error (Lisp_Object type, const char *reason,
2352 Lisp_Object frob, Lisp_Object class,
2353 Error_behavior errb)
2356 if (ERRB_EQ (errb, ERROR_ME_NOT))
2358 maybe_signal_error (type, list2 (build_translated_string (reason), frob),
2363 signal_type_continuable_error (Lisp_Object type, const char *reason,
2366 return Fsignal (type, list2 (build_translated_string (reason), frob));
2370 maybe_signal_type_continuable_error (Lisp_Object type, const char *reason,
2371 Lisp_Object frob, Lisp_Object class,
2372 Error_behavior errb)
2375 if (ERRB_EQ (errb, ERROR_ME_NOT))
2377 return maybe_signal_continuable_error
2378 (type, list2 (build_translated_string (reason),
2379 frob), class, errb);
2383 /****************** Error functions class 4 ******************/
2385 /* Class 4: Printf-like functions that signal an error.
2386 These functions signal an error of a specified type, whose data
2387 is a two objects, a string (created using the arguments) and a
2392 type_error_with_frob (Lisp_Object type, Lisp_Object frob, const char *fmt, ...)
2397 va_start (args, fmt);
2398 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2402 /* Fsignal GC-protects its args */
2403 signal_error (type, list2 (obj, frob));
2407 maybe_type_error_with_frob (Lisp_Object type, Lisp_Object frob,
2408 Lisp_Object class, Error_behavior errb,
2409 const char *fmt, ...)
2415 if (ERRB_EQ (errb, ERROR_ME_NOT))
2418 va_start (args, fmt);
2419 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2423 /* Fsignal GC-protects its args */
2424 maybe_signal_error (type, list2 (obj, frob), class, errb);
2428 continuable_type_error_with_frob (Lisp_Object type, Lisp_Object frob,
2429 const char *fmt, ...)
2434 va_start (args, fmt);
2435 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2439 /* Fsignal GC-protects its args */
2440 return Fsignal (type, list2 (obj, frob));
2444 maybe_continuable_type_error_with_frob (Lisp_Object type, Lisp_Object frob,
2445 Lisp_Object class, Error_behavior errb,
2446 const char *fmt, ...)
2452 if (ERRB_EQ (errb, ERROR_ME_NOT))
2455 va_start (args, fmt);
2456 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2460 /* Fsignal GC-protects its args */
2461 return maybe_signal_continuable_error (type, list2 (obj, frob),
2466 /****************** Error functions class 5 ******************/
2468 /* Class 5: Signal an error with a string and two associated objects.
2469 These functions signal an error of a specified type, whose data
2470 is three objects, a string and two related Lisp objects. */
2473 signal_type_error_2 (Lisp_Object type, const char *reason,
2474 Lisp_Object frob0, Lisp_Object frob1)
2476 signal_error (type, list3 (build_translated_string (reason), frob0,
2481 maybe_signal_type_error_2 (Lisp_Object type, const char *reason,
2482 Lisp_Object frob0, Lisp_Object frob1,
2483 Lisp_Object class, Error_behavior errb)
2486 if (ERRB_EQ (errb, ERROR_ME_NOT))
2488 maybe_signal_error (type, list3 (build_translated_string (reason), frob0,
2489 frob1), class, errb);
2494 signal_type_continuable_error_2 (Lisp_Object type, const char *reason,
2495 Lisp_Object frob0, Lisp_Object frob1)
2497 return Fsignal (type, list3 (build_translated_string (reason), frob0,
2502 maybe_signal_type_continuable_error_2 (Lisp_Object type, const char *reason,
2503 Lisp_Object frob0, Lisp_Object frob1,
2504 Lisp_Object class, Error_behavior errb)
2507 if (ERRB_EQ (errb, ERROR_ME_NOT))
2509 return maybe_signal_continuable_error
2510 (type, list3 (build_translated_string (reason), frob0,
2516 /****************** Simple error functions class 2 ******************/
2518 /* Simple class 2: Printf-like functions that signal an error.
2519 These functions signal an error of type Qerror, whose data
2520 is a single string, created using the arguments. */
2522 /* dump an error message; called like printf */
2525 error (const char *fmt, ...)
2530 va_start (args, fmt);
2531 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2535 /* Fsignal GC-protects its args */
2536 signal_error (Qerror, list1 (obj));
2540 maybe_error (Lisp_Object class, Error_behavior errb, const char *fmt, ...)
2546 if (ERRB_EQ (errb, ERROR_ME_NOT))
2549 va_start (args, fmt);
2550 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2554 /* Fsignal GC-protects its args */
2555 maybe_signal_error (Qerror, list1 (obj), class, errb);
2559 continuable_error (const char *fmt, ...)
2564 va_start (args, fmt);
2565 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2569 /* Fsignal GC-protects its args */
2570 return Fsignal (Qerror, list1 (obj));
2574 maybe_continuable_error (Lisp_Object class, Error_behavior errb,
2575 const char *fmt, ...)
2581 if (ERRB_EQ (errb, ERROR_ME_NOT))
2584 va_start (args, fmt);
2585 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2589 /* Fsignal GC-protects its args */
2590 return maybe_signal_continuable_error (Qerror, list1 (obj), class, errb);
2594 /****************** Simple error functions class 3 ******************/
2596 /* Simple class 3: Signal an error with a string and an associated object.
2597 These functions signal an error of type Qerror, whose data
2598 is two objects, a string and a related Lisp object (usually the object
2599 where the error is occurring). */
2602 signal_simple_error (const char *reason, Lisp_Object frob)
2604 signal_error (Qerror, list2 (build_translated_string (reason), frob));
2608 maybe_signal_simple_error (const char *reason, Lisp_Object frob,
2609 Lisp_Object class, Error_behavior errb)
2612 if (ERRB_EQ (errb, ERROR_ME_NOT))
2614 maybe_signal_error (Qerror, list2 (build_translated_string (reason), frob),
2619 signal_simple_continuable_error (const char *reason, Lisp_Object frob)
2621 return Fsignal (Qerror, list2 (build_translated_string (reason), frob));
2625 maybe_signal_simple_continuable_error (const char *reason, Lisp_Object frob,
2626 Lisp_Object class, Error_behavior errb)
2629 if (ERRB_EQ (errb, ERROR_ME_NOT))
2631 return maybe_signal_continuable_error
2632 (Qerror, list2 (build_translated_string (reason),
2633 frob), class, errb);
2637 /****************** Simple error functions class 4 ******************/
2639 /* Simple class 4: Printf-like functions that signal an error.
2640 These functions signal an error of type Qerror, whose data
2641 is a two objects, a string (created using the arguments) and a
2646 error_with_frob (Lisp_Object frob, const char *fmt, ...)
2651 va_start (args, fmt);
2652 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2656 /* Fsignal GC-protects its args */
2657 signal_error (Qerror, list2 (obj, frob));
2661 maybe_error_with_frob (Lisp_Object frob, Lisp_Object class,
2662 Error_behavior errb, const char *fmt, ...)
2668 if (ERRB_EQ (errb, ERROR_ME_NOT))
2671 va_start (args, fmt);
2672 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2676 /* Fsignal GC-protects its args */
2677 maybe_signal_error (Qerror, list2 (obj, frob), class, errb);
2681 continuable_error_with_frob (Lisp_Object frob, const char *fmt, ...)
2686 va_start (args, fmt);
2687 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2691 /* Fsignal GC-protects its args */
2692 return Fsignal (Qerror, list2 (obj, frob));
2696 maybe_continuable_error_with_frob (Lisp_Object frob, Lisp_Object class,
2697 Error_behavior errb, const char *fmt, ...)
2703 if (ERRB_EQ (errb, ERROR_ME_NOT))
2706 va_start (args, fmt);
2707 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2711 /* Fsignal GC-protects its args */
2712 return maybe_signal_continuable_error (Qerror, list2 (obj, frob),
2717 /****************** Simple error functions class 5 ******************/
2719 /* Simple class 5: Signal an error with a string and two associated objects.
2720 These functions signal an error of type Qerror, whose data
2721 is three objects, a string and two related Lisp objects. */
2724 signal_simple_error_2 (const char *reason,
2725 Lisp_Object frob0, Lisp_Object frob1)
2727 signal_error (Qerror, list3 (build_translated_string (reason), frob0,
2732 maybe_signal_simple_error_2 (const char *reason, Lisp_Object frob0,
2733 Lisp_Object frob1, Lisp_Object class,
2734 Error_behavior errb)
2737 if (ERRB_EQ (errb, ERROR_ME_NOT))
2739 maybe_signal_error (Qerror, list3 (build_translated_string (reason), frob0,
2740 frob1), class, errb);
2745 signal_simple_continuable_error_2 (const char *reason, Lisp_Object frob0,
2748 return Fsignal (Qerror, list3 (build_translated_string (reason), frob0,
2753 maybe_signal_simple_continuable_error_2 (const char *reason, Lisp_Object frob0,
2754 Lisp_Object frob1, Lisp_Object class,
2755 Error_behavior errb)
2758 if (ERRB_EQ (errb, ERROR_ME_NOT))
2760 return maybe_signal_continuable_error
2761 (Qerror, list3 (build_translated_string (reason), frob0,
2767 /* This is what the QUIT macro calls to signal a quit */
2771 /* This function can GC */
2772 if (EQ (Vquit_flag, Qcritical))
2773 debug_on_quit |= 2; /* set critical bit. */
2775 /* note that this is continuable. */
2776 Fsignal (Qquit, Qnil);
2780 /* Used in core lisp functions for efficiency */
2782 signal_void_function_error (Lisp_Object function)
2784 return Fsignal (Qvoid_function, list1 (function));
2788 signal_invalid_function_error (Lisp_Object function)
2790 return Fsignal (Qinvalid_function, list1 (function));
2794 signal_wrong_number_of_arguments_error (Lisp_Object function, int nargs)
2796 return Fsignal (Qwrong_number_of_arguments,
2797 list2 (function, make_int (nargs)));
2800 /* Used in list traversal macros for efficiency. */
2802 signal_malformed_list_error (Lisp_Object list)
2804 signal_error (Qmalformed_list, list1 (list));
2808 signal_malformed_property_list_error (Lisp_Object list)
2810 signal_error (Qmalformed_property_list, list1 (list));
2814 signal_circular_list_error (Lisp_Object list)
2816 signal_error (Qcircular_list, list1 (list));
2820 signal_circular_property_list_error (Lisp_Object list)
2822 signal_error (Qcircular_property_list, list1 (list));
2826 syntax_error (const char *reason, Lisp_Object frob)
2828 signal_type_error (Qsyntax_error, reason, frob);
2832 syntax_error_2 (const char *reason, Lisp_Object frob1, Lisp_Object frob2)
2834 signal_type_error_2 (Qsyntax_error, reason, frob1, frob2);
2838 invalid_argument (const char *reason, Lisp_Object frob)
2840 signal_type_error (Qinvalid_argument, reason, frob);
2844 invalid_argument_2 (const char *reason, Lisp_Object frob1, Lisp_Object frob2)
2846 signal_type_error_2 (Qinvalid_argument, reason, frob1, frob2);
2850 invalid_operation (const char *reason, Lisp_Object frob)
2852 signal_type_error (Qinvalid_operation, reason, frob);
2856 invalid_operation_2 (const char *reason, Lisp_Object frob1, Lisp_Object frob2)
2858 signal_type_error_2 (Qinvalid_operation, reason, frob1, frob2);
2862 invalid_change (const char *reason, Lisp_Object frob)
2864 signal_type_error (Qinvalid_change, reason, frob);
2868 invalid_change_2 (const char *reason, Lisp_Object frob1, Lisp_Object frob2)
2870 signal_type_error_2 (Qinvalid_change, reason, frob1, frob2);
2874 /************************************************************************/
2876 /************************************************************************/
2878 DEFUN ("commandp", Fcommandp, 1, 1, 0, /*
2879 Return t if FUNCTION makes provisions for interactive calling.
2880 This means it contains a description for how to read arguments to give it.
2881 The value is nil for an invalid function or a symbol with no function
2884 Interactively callable functions include
2886 -- strings and vectors (treated as keyboard macros)
2887 -- lambda-expressions that contain a top-level call to `interactive'
2888 -- autoload definitions made by `autoload' with non-nil fourth argument
2889 (i.e. the interactive flag)
2890 -- compiled-function objects with a non-nil `compiled-function-interactive'
2892 -- subrs (built-in functions) that are interactively callable
2894 Also, a symbol satisfies `commandp' if its function definition does so.
2898 Lisp_Object fun = indirect_function (function, 0);
2900 if (COMPILED_FUNCTIONP (fun))
2901 return XCOMPILED_FUNCTION (fun)->flags.interactivep ? Qt : Qnil;
2903 /* Lists may represent commands. */
2906 Lisp_Object funcar = XCAR (fun);
2907 if (EQ (funcar, Qlambda))
2908 return Fassq (Qinteractive, Fcdr (Fcdr (fun)));
2909 if (EQ (funcar, Qautoload))
2910 return Fcar (Fcdr (Fcdr (Fcdr (fun))));
2915 /* Emacs primitives are interactive if their DEFUN specifies an
2916 interactive spec. */
2918 return XSUBR (fun)->prompt ? Qt : Qnil;
2920 /* Strings and vectors are keyboard macros. */
2921 if (VECTORP (fun) || STRINGP (fun))
2924 /* Everything else (including Qunbound) is not a command. */
2928 DEFUN ("command-execute", Fcommand_execute, 1, 3, 0, /*
2929 Execute CMD as an editor command.
2930 CMD must be an object that satisfies the `commandp' predicate.
2931 Optional second arg RECORD-FLAG is as in `call-interactively'.
2932 The argument KEYS specifies the value to use instead of (this-command-keys)
2933 when reading the arguments.
2935 (cmd, record_flag, keys))
2937 /* This function can GC */
2938 Lisp_Object prefixarg;
2939 Lisp_Object final = cmd;
2940 struct backtrace backtrace;
2941 struct console *con = XCONSOLE (Vselected_console);
2943 prefixarg = con->prefix_arg;
2944 con->prefix_arg = Qnil;
2945 Vcurrent_prefix_arg = prefixarg;
2946 debug_on_next_call = 0; /* #### from FSFmacs; correct? */
2948 if (SYMBOLP (cmd) && !NILP (Fget (cmd, Qdisabled, Qnil)))
2949 return run_hook (Vdisabled_command_hook);
2953 final = indirect_function (cmd, 1);
2954 if (CONSP (final) && EQ (Fcar (final), Qautoload))
2955 do_autoload (final, cmd);
2960 if (CONSP (final) || SUBRP (final) || COMPILED_FUNCTIONP (final))
2962 backtrace.function = &Qcall_interactively;
2963 backtrace.args = &cmd;
2964 backtrace.nargs = 1;
2965 backtrace.evalargs = 0;
2966 backtrace.pdlcount = specpdl_depth();
2967 backtrace.debug_on_exit = 0;
2968 PUSH_BACKTRACE (backtrace);
2970 final = Fcall_interactively (cmd, record_flag, keys);
2972 POP_BACKTRACE (backtrace);
2975 else if (STRINGP (final) || VECTORP (final))
2977 return Fexecute_kbd_macro (final, prefixarg);
2981 Fsignal (Qwrong_type_argument,
2985 : list2 (cmd, final))));
2990 DEFUN ("interactive-p", Finteractive_p, 0, 0, 0, /*
2991 Return t if function in which this appears was called interactively.
2992 This means that the function was called with call-interactively (which
2993 includes being called as the binding of a key)
2994 and input is currently coming from the keyboard (not in keyboard macro).
2998 REGISTER struct backtrace *btp;
2999 REGISTER Lisp_Object fun;
3004 /* Unless the object was compiled, skip the frame of interactive-p itself
3005 (if interpreted) or the frame of byte-code (if called from a compiled
3006 function). Note that *btp->function may be a symbol pointing at a
3007 compiled function. */
3008 btp = backtrace_list;
3012 /* #### FSFmacs does the following instead. I can't figure
3013 out which one is more correct. */
3014 /* If this isn't a byte-compiled function, there may be a frame at
3015 the top for Finteractive_p itself. If so, skip it. */
3016 fun = Findirect_function (*btp->function);
3017 if (SUBRP (fun) && XSUBR (fun) == &Sinteractive_p)
3020 /* If we're running an Emacs 18-style byte-compiled function, there
3021 may be a frame for Fbyte_code. Now, given the strictest
3022 definition, this function isn't really being called
3023 interactively, but because that's the way Emacs 18 always builds
3024 byte-compiled functions, we'll accept it for now. */
3025 if (EQ (*btp->function, Qbyte_code))
3028 /* If this isn't a byte-compiled function, then we may now be
3029 looking at several frames for special forms. Skip past them. */
3031 btp->nargs == UNEVALLED)
3036 if (! (COMPILED_FUNCTIONP (Findirect_function (*btp->function))))
3039 btp && (btp->nargs == UNEVALLED
3040 || EQ (*btp->function, Qbyte_code));
3043 /* btp now points at the frame of the innermost function
3044 that DOES eval its args.
3045 If it is a built-in function (such as load or eval-region)
3047 /* Beats me why this is necessary, but it is */
3048 if (btp && EQ (*btp->function, Qcall_interactively))
3053 fun = Findirect_function (*btp->function);
3056 /* btp points to the frame of a Lisp function that called interactive-p.
3057 Return t if that function was called interactively. */
3058 if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively))
3064 /************************************************************************/
3066 /************************************************************************/
3068 DEFUN ("autoload", Fautoload, 2, 5, 0, /*
3069 Define FUNCTION to autoload from FILENAME.
3070 FUNCTION is a symbol; FILENAME is a file name string to pass to `load'.
3071 The remaining optional arguments provide additional info about the
3073 DOCSTRING is documentation for FUNCTION.
3074 INTERACTIVE, if non-nil, says FUNCTION can be called interactively.
3075 TYPE indicates the type of the object:
3076 nil or omitted says FUNCTION is a function,
3077 `keymap' says FUNCTION is really a keymap, and
3078 `macro' or t says FUNCTION is really a macro.
3079 If FUNCTION already has a non-void function definition that is not an
3080 autoload object, this function does nothing and returns nil.
3082 (function, filename, docstring, interactive, type))
3084 /* This function can GC */
3085 CHECK_SYMBOL (function);
3086 CHECK_STRING (filename);
3088 /* If function is defined and not as an autoload, don't override */
3090 Lisp_Object f = XSYMBOL (function)->function;
3091 if (!UNBOUNDP (f) && !(CONSP (f) && EQ (XCAR (f), Qautoload)))
3097 /* Attempt to avoid consing identical (string=) pure strings. */
3098 filename = Fsymbol_name (Fintern (filename, Qnil));
3101 return Ffset (function, Fcons (Qautoload, list4 (filename,
3108 un_autoload (Lisp_Object oldqueue)
3110 /* This function can GC */
3111 REGISTER Lisp_Object queue, first, second;
3113 /* Queue to unwind is current value of Vautoload_queue.
3114 oldqueue is the shadowed value to leave in Vautoload_queue. */
3115 queue = Vautoload_queue;
3116 Vautoload_queue = oldqueue;
3117 while (CONSP (queue))
3119 first = XCAR (queue);
3120 second = Fcdr (first);
3121 first = Fcar (first);
3125 Ffset (first, second);
3126 queue = Fcdr (queue);
3132 do_autoload (Lisp_Object fundef,
3133 Lisp_Object funname)
3135 /* This function can GC */
3136 int speccount = specpdl_depth();
3137 Lisp_Object fun = funname;
3138 struct gcpro gcpro1, gcpro2;
3140 CHECK_SYMBOL (funname);
3141 GCPRO2 (fun, funname);
3143 /* Value saved here is to be restored into Vautoload_queue */
3144 record_unwind_protect (un_autoload, Vautoload_queue);
3145 Vautoload_queue = Qt;
3146 call4 (Qload, Fcar (Fcdr (fundef)), Qnil, noninteractive ? Qt : Qnil, Qnil);
3151 /* Save the old autoloads, in case we ever do an unload. */
3152 for (queue = Vautoload_queue; CONSP (queue); queue = XCDR (queue))
3154 Lisp_Object first = XCAR (queue);
3155 Lisp_Object second = Fcdr (first);
3157 first = Fcar (first);
3159 /* Note: This test is subtle. The cdr of an autoload-queue entry
3160 may be an atom if the autoload entry was generated by a defalias
3163 Fput (first, Qautoload, (XCDR (second)));
3167 /* Once loading finishes, don't undo it. */
3168 Vautoload_queue = Qt;
3169 unbind_to (speccount, Qnil);
3171 fun = indirect_function (fun, 0);
3174 if (!NILP (Fequal (fun, fundef)))
3178 && EQ (XCAR (fun), Qautoload)))
3180 error ("Autoloading failed to define function %s",
3181 string_data (XSYMBOL (funname)->name));
3186 /************************************************************************/
3187 /* eval, funcall, apply */
3188 /************************************************************************/
3190 static Lisp_Object funcall_lambda (Lisp_Object fun,
3191 int nargs, Lisp_Object args[]);
3192 static int in_warnings;
3195 in_warnings_restore (Lisp_Object minimus)
3201 DEFUN ("eval", Feval, 1, 1, 0, /*
3202 Evaluate FORM and return its value.
3206 /* This function can GC */
3207 Lisp_Object fun, val, original_fun, original_args;
3209 struct backtrace backtrace;
3211 /* I think this is a pretty safe place to call Lisp code, don't you? */
3212 while (!in_warnings && !NILP (Vpending_warnings))
3214 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
3215 int speccount = specpdl_depth();
3216 Lisp_Object this_warning_cons, this_warning, class, level, messij;
3218 record_unwind_protect (in_warnings_restore, Qnil);
3220 this_warning_cons = Vpending_warnings;
3221 this_warning = XCAR (this_warning_cons);
3222 /* in case an error occurs in the warn function, at least
3223 it won't happen infinitely */
3224 Vpending_warnings = XCDR (Vpending_warnings);
3225 free_cons (XCONS (this_warning_cons));
3226 class = XCAR (this_warning);
3227 level = XCAR (XCDR (this_warning));
3228 messij = XCAR (XCDR (XCDR (this_warning)));
3229 free_list (this_warning);
3231 if (NILP (Vpending_warnings))
3232 Vpending_warnings_tail = Qnil; /* perhaps not strictly necessary,
3235 GCPRO4 (form, class, level, messij);
3236 if (!STRINGP (messij))
3237 messij = Fprin1_to_string (messij, Qnil);
3238 call3 (Qdisplay_warning, class, messij, level);
3240 unbind_to (speccount, Qnil);
3246 return Fsymbol_value (form);
3252 if ((consing_since_gc > gc_cons_threshold) || always_gc)
3254 struct gcpro gcpro1;
3256 garbage_collect_1 ();
3260 if (++lisp_eval_depth > max_lisp_eval_depth)
3262 if (max_lisp_eval_depth < 100)
3263 max_lisp_eval_depth = 100;
3264 if (lisp_eval_depth > max_lisp_eval_depth)
3265 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
3268 /* We guaranteed CONSP (form) above */
3269 original_fun = XCAR (form);
3270 original_args = XCDR (form);
3272 GET_EXTERNAL_LIST_LENGTH (original_args, nargs);
3274 backtrace.pdlcount = specpdl_depth();
3275 backtrace.function = &original_fun; /* This also protects them from gc */
3276 backtrace.args = &original_args;
3277 backtrace.nargs = UNEVALLED;
3278 backtrace.evalargs = 1;
3279 backtrace.debug_on_exit = 0;
3280 PUSH_BACKTRACE (backtrace);
3282 if (debug_on_next_call)
3283 do_debug_on_call (Qt);
3285 if (profiling_active)
3286 profile_increase_call_count (original_fun);
3288 /* At this point, only original_fun and original_args
3289 have values that will be used below. */
3291 fun = indirect_function (original_fun, 1);
3295 Lisp_Subr *subr = XSUBR (fun);
3296 int max_args = subr->max_args;
3298 if (nargs < subr->min_args)
3299 goto wrong_number_of_arguments;
3301 if (max_args == UNEVALLED) /* Optimize for the common case */
3303 backtrace.evalargs = 0;
3304 val = (((Lisp_Object (*) (Lisp_Object)) subr_function (subr))
3307 else if (nargs <= max_args)
3309 struct gcpro gcpro1;
3310 Lisp_Object args[SUBR_MAX_ARGS];
3311 REGISTER Lisp_Object *p = args;
3317 LIST_LOOP_2 (arg, original_args)
3324 /* &optional args default to nil. */
3325 while (p - args < max_args)
3328 backtrace.args = args;
3329 backtrace.nargs = nargs;
3331 FUNCALL_SUBR (val, subr, args, max_args);
3335 else if (max_args == MANY)
3337 /* Pass a vector of evaluated arguments */
3338 struct gcpro gcpro1;
3339 Lisp_Object *args = alloca_array (Lisp_Object, nargs);
3340 REGISTER Lisp_Object *p = args;
3346 LIST_LOOP_2 (arg, original_args)
3353 backtrace.args = args;
3354 backtrace.nargs = nargs;
3356 val = (((Lisp_Object (*) (int, Lisp_Object *)) subr_function (subr))
3363 wrong_number_of_arguments:
3364 val = signal_wrong_number_of_arguments_error (original_fun, nargs);
3367 else if (COMPILED_FUNCTIONP (fun))
3369 struct gcpro gcpro1;
3370 Lisp_Object *args = alloca_array (Lisp_Object, nargs);
3371 REGISTER Lisp_Object *p = args;
3377 LIST_LOOP_2 (arg, original_args)
3384 backtrace.args = args;
3385 backtrace.nargs = nargs;
3386 backtrace.evalargs = 0;
3388 val = funcall_compiled_function (fun, nargs, args);
3390 /* Do the debug-on-exit now, while args is still GCPROed. */
3391 if (backtrace.debug_on_exit)
3392 val = do_debug_on_exit (val);
3393 /* Don't do it again when we return to eval. */
3394 backtrace.debug_on_exit = 0;
3398 else if (CONSP (fun))
3400 Lisp_Object funcar = XCAR (fun);
3402 if (EQ (funcar, Qautoload))
3404 do_autoload (fun, original_fun);
3407 else if (EQ (funcar, Qmacro))
3409 val = Feval (apply1 (XCDR (fun), original_args));
3411 else if (EQ (funcar, Qlambda))
3413 struct gcpro gcpro1;
3414 Lisp_Object *args = alloca_array (Lisp_Object, nargs);
3415 REGISTER Lisp_Object *p = args;
3421 LIST_LOOP_2 (arg, original_args)
3430 backtrace.args = args; /* this also GCPROs `args' */
3431 backtrace.nargs = nargs;
3432 backtrace.evalargs = 0;
3434 val = funcall_lambda (fun, nargs, args);
3436 /* Do the debug-on-exit now, while args is still GCPROed. */
3437 if (backtrace.debug_on_exit)
3438 val = do_debug_on_exit (val);
3439 /* Don't do it again when we return to eval. */
3440 backtrace.debug_on_exit = 0;
3444 goto invalid_function;
3447 else /* ! (SUBRP (fun) || COMPILED_FUNCTIONP (fun) || CONSP (fun)) */
3450 val = signal_invalid_function_error (fun);
3454 if (backtrace.debug_on_exit)
3455 val = do_debug_on_exit (val);
3456 POP_BACKTRACE (backtrace);
3461 DEFUN ("funcall", Ffuncall, 1, MANY, 0, /*
3462 Call first argument as a function, passing the remaining arguments to it.
3463 Thus, (funcall 'cons 'x 'y) returns (x . y).
3465 (int nargs, Lisp_Object *args))
3467 /* This function can GC */
3470 struct backtrace backtrace;
3471 int fun_nargs = nargs - 1;
3472 Lisp_Object *fun_args = args + 1;
3475 if ((consing_since_gc > gc_cons_threshold) || always_gc)
3476 /* Callers should gcpro lexpr args */
3477 garbage_collect_1 ();
3479 if (++lisp_eval_depth > max_lisp_eval_depth)
3481 if (max_lisp_eval_depth < 100)
3482 max_lisp_eval_depth = 100;
3483 if (lisp_eval_depth > max_lisp_eval_depth)
3484 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
3487 backtrace.pdlcount = specpdl_depth();
3488 backtrace.function = &args[0];
3489 backtrace.args = fun_args;
3490 backtrace.nargs = fun_nargs;
3491 backtrace.evalargs = 0;
3492 backtrace.debug_on_exit = 0;
3493 PUSH_BACKTRACE (backtrace);
3495 if (debug_on_next_call)
3496 do_debug_on_call (Qlambda);
3502 /* It might be useful to place this *after* all the checks. */
3503 if (profiling_active)
3504 profile_increase_call_count (fun);
3506 /* We could call indirect_function directly, but profiling shows
3507 this is worth optimizing by partially unrolling the loop. */
3510 fun = XSYMBOL (fun)->function;
3513 fun = XSYMBOL (fun)->function;
3515 fun = indirect_function (fun, 1);
3521 Lisp_Subr *subr = XSUBR (fun);
3522 int max_args = subr->max_args;
3523 Lisp_Object spacious_args[SUBR_MAX_ARGS];
3525 if (fun_nargs == max_args) /* Optimize for the common case */
3528 FUNCALL_SUBR (val, subr, fun_args, max_args);
3530 else if (fun_nargs < subr->min_args)
3532 goto wrong_number_of_arguments;
3534 else if (fun_nargs < max_args)
3536 Lisp_Object *p = spacious_args;
3538 /* Default optionals to nil */
3541 while (p - spacious_args < max_args)
3544 fun_args = spacious_args;
3547 else if (max_args == MANY)
3549 val = SUBR_FUNCTION (subr, MANY) (fun_nargs, fun_args);
3551 else if (max_args == UNEVALLED) /* Can't funcall a special form */
3553 goto invalid_function;
3557 wrong_number_of_arguments:
3558 val = signal_wrong_number_of_arguments_error (fun, fun_nargs);
3561 else if (COMPILED_FUNCTIONP (fun))
3563 val = funcall_compiled_function (fun, fun_nargs, fun_args);
3565 else if (CONSP (fun))
3567 Lisp_Object funcar = XCAR (fun);
3569 if (EQ (funcar, Qlambda))
3571 val = funcall_lambda (fun, fun_nargs, fun_args);
3573 else if (EQ (funcar, Qautoload))
3575 do_autoload (fun, args[0]);
3578 else /* Can't funcall a macro */
3580 goto invalid_function;
3583 else if (UNBOUNDP (fun))
3585 val = signal_void_function_error (args[0]);
3590 val = signal_invalid_function_error (fun);
3594 if (backtrace.debug_on_exit)
3595 val = do_debug_on_exit (val);
3596 POP_BACKTRACE (backtrace);
3600 DEFUN ("functionp", Ffunctionp, 1, 1, 0, /*
3601 Return t if OBJECT can be called as a function, else nil.
3602 A function is an object that can be applied to arguments,
3603 using for example `funcall' or `apply'.
3607 if (SYMBOLP (object))
3608 object = indirect_function (object, 0);
3612 COMPILED_FUNCTIONP (object) ||
3614 (EQ (XCAR (object), Qlambda) ||
3615 EQ (XCAR (object), Qautoload))))
3620 function_argcount (Lisp_Object function, int function_min_args_p)
3622 Lisp_Object orig_function = function;
3623 Lisp_Object arglist;
3627 if (SYMBOLP (function))
3628 function = indirect_function (function, 1);
3630 if (SUBRP (function))
3632 /* Using return with the ?: operator tickles a DEC CC compiler bug. */
3633 if (function_min_args_p)
3634 return Fsubr_min_args (function);
3636 return Fsubr_max_args (function);
3638 else if (COMPILED_FUNCTIONP (function))
3640 arglist = compiled_function_arglist (XCOMPILED_FUNCTION (function));
3642 else if (CONSP (function))
3644 Lisp_Object funcar = XCAR (function);
3646 if (EQ (funcar, Qmacro))
3648 function = XCDR (function);
3651 else if (EQ (funcar, Qautoload))
3653 struct gcpro gcpro1;
3656 do_autoload (function, orig_function);
3658 function = orig_function;
3661 else if (EQ (funcar, Qlambda))
3663 arglist = Fcar (XCDR (function));
3667 goto invalid_function;
3673 return signal_invalid_function_error (orig_function);
3679 EXTERNAL_LIST_LOOP_2 (arg, arglist)
3681 if (EQ (arg, Qand_optional))
3683 if (function_min_args_p)
3686 else if (EQ (arg, Qand_rest))
3688 if (function_min_args_p)
3699 return make_int (argcount);
3703 DEFUN ("function-min-args", Ffunction_min_args, 1, 1, 0, /*
3704 Return the number of arguments a function may be called with.
3705 The function may be any form that can be passed to `funcall',
3706 any special form, or any macro.
3710 return function_argcount (function, 1);
3713 DEFUN ("function-max-args", Ffunction_max_args, 1, 1, 0, /*
3714 Return the number of arguments a function may be called with.
3715 The function may be any form that can be passed to `funcall',
3716 any special form, or any macro.
3717 If the function takes an arbitrary number of arguments or is
3718 a built-in special form, nil is returned.
3722 return function_argcount (function, 0);
3726 DEFUN ("apply", Fapply, 2, MANY, 0, /*
3727 Call FUNCTION with the remaining args, using the last arg as a list of args.
3728 Thus, (apply '+ 1 2 '(3 4)) returns 10.
3730 (int nargs, Lisp_Object *args))
3732 /* This function can GC */
3733 Lisp_Object fun = args[0];
3734 Lisp_Object spread_arg = args [nargs - 1];
3738 GET_EXTERNAL_LIST_LENGTH (spread_arg, numargs);
3741 /* (apply foo 0 1 '()) */
3742 return Ffuncall (nargs - 1, args);
3743 else if (numargs == 1)
3745 /* (apply foo 0 1 '(2)) */
3746 args [nargs - 1] = XCAR (spread_arg);
3747 return Ffuncall (nargs, args);
3750 /* -1 for function, -1 for spread arg */
3751 numargs = nargs - 2 + numargs;
3752 /* +1 for function */
3753 funcall_nargs = 1 + numargs;
3756 fun = indirect_function (fun, 0);
3760 Lisp_Subr *subr = XSUBR (fun);
3761 int max_args = subr->max_args;
3763 if (numargs < subr->min_args
3764 || (max_args >= 0 && max_args < numargs))
3766 /* Let funcall get the error */
3768 else if (max_args > numargs)
3770 /* Avoid having funcall cons up yet another new vector of arguments
3771 by explicitly supplying nil's for optional values */
3772 funcall_nargs += (max_args - numargs);
3775 else if (UNBOUNDP (fun))
3777 /* Let funcall get the error */
3783 Lisp_Object *funcall_args = alloca_array (Lisp_Object, funcall_nargs);
3784 struct gcpro gcpro1;
3786 GCPRO1 (*funcall_args);
3787 gcpro1.nvars = funcall_nargs;
3789 /* Copy in the unspread args */
3790 memcpy (funcall_args, args, (nargs - 1) * sizeof (Lisp_Object));
3791 /* Spread the last arg we got. Its first element goes in
3792 the slot that it used to occupy, hence this value of I. */
3794 !NILP (spread_arg); /* i < 1 + numargs */
3795 i++, spread_arg = XCDR (spread_arg))
3797 funcall_args [i] = XCAR (spread_arg);
3799 /* Supply nil for optional args (to subrs) */
3800 for (; i < funcall_nargs; i++)
3801 funcall_args[i] = Qnil;
3804 RETURN_UNGCPRO (Ffuncall (funcall_nargs, funcall_args));
3809 /* Apply lambda list FUN to the NARGS evaluated arguments in ARGS and
3810 return the result of evaluation. */
3813 funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object args[])
3815 /* This function can GC */
3816 Lisp_Object arglist, body, tail;
3817 int speccount = specpdl_depth();
3823 goto invalid_function;
3825 arglist = XCAR (tail);
3829 int optional = 0, rest = 0;
3831 EXTERNAL_LIST_LOOP_2 (symbol, arglist)
3833 if (!SYMBOLP (symbol))
3834 goto invalid_function;
3835 if (EQ (symbol, Qand_rest))
3837 else if (EQ (symbol, Qand_optional))
3841 specbind (symbol, Flist (nargs - i, &args[i]));
3845 specbind (symbol, args[i++]);
3847 goto wrong_number_of_arguments;
3849 specbind (symbol, Qnil);
3854 goto wrong_number_of_arguments;
3856 return unbind_to (speccount, Fprogn (body));
3858 wrong_number_of_arguments:
3859 return signal_wrong_number_of_arguments_error (fun, nargs);
3862 return signal_invalid_function_error (fun);
3866 /************************************************************************/
3867 /* Run hook variables in various ways. */
3868 /************************************************************************/
3870 DEFUN ("run-hooks", Frun_hooks, 1, MANY, 0, /*
3871 Run each hook in HOOKS. Major mode functions use this.
3872 Each argument should be a symbol, a hook variable.
3873 These symbols are processed in the order specified.
3874 If a hook symbol has a non-nil value, that value may be a function
3875 or a list of functions to be called to run the hook.
3876 If the value is a function, it is called with no arguments.
3877 If it is a list, the elements are called, in order, with no arguments.
3879 To make a hook variable buffer-local, use `make-local-hook',
3880 not `make-local-variable'.
3882 (int nargs, Lisp_Object *args))
3886 for (i = 0; i < nargs; i++)
3887 run_hook_with_args (1, args + i, RUN_HOOKS_TO_COMPLETION);
3892 DEFUN ("run-hook-with-args", Frun_hook_with_args, 1, MANY, 0, /*
3893 Run HOOK with the specified arguments ARGS.
3894 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
3895 value, that value may be a function or a list of functions to be
3896 called to run the hook. If the value is a function, it is called with
3897 the given arguments and its return value is returned. If it is a list
3898 of functions, those functions are called, in order,
3899 with the given arguments ARGS.
3900 It is best not to depend on the value returned by `run-hook-with-args',
3903 To make a hook variable buffer-local, use `make-local-hook',
3904 not `make-local-variable'.
3906 (int nargs, Lisp_Object *args))
3908 return run_hook_with_args (nargs, args, RUN_HOOKS_TO_COMPLETION);
3911 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success, 1, MANY, 0, /*
3912 Run HOOK with the specified arguments ARGS.
3913 HOOK should be a symbol, a hook variable. Its value should
3914 be a list of functions. We call those functions, one by one,
3915 passing arguments ARGS to each of them, until one of them
3916 returns a non-nil value. Then we return that value.
3917 If all the functions return nil, we return nil.
3919 To make a hook variable buffer-local, use `make-local-hook',
3920 not `make-local-variable'.
3922 (int nargs, Lisp_Object *args))
3924 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_SUCCESS);
3927 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure, 1, MANY, 0, /*
3928 Run HOOK with the specified arguments ARGS.
3929 HOOK should be a symbol, a hook variable. Its value should
3930 be a list of functions. We call those functions, one by one,
3931 passing arguments ARGS to each of them, until one of them
3932 returns nil. Then we return nil.
3933 If all the functions return non-nil, we return non-nil.
3935 To make a hook variable buffer-local, use `make-local-hook',
3936 not `make-local-variable'.
3938 (int nargs, Lisp_Object *args))
3940 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_FAILURE);
3943 /* ARGS[0] should be a hook symbol.
3944 Call each of the functions in the hook value, passing each of them
3945 as arguments all the rest of ARGS (all NARGS - 1 elements).
3946 COND specifies a condition to test after each call
3947 to decide whether to stop.
3948 The caller (or its caller, etc) must gcpro all of ARGS,
3949 except that it isn't necessary to gcpro ARGS[0]. */
3952 run_hook_with_args_in_buffer (struct buffer *buf, int nargs, Lisp_Object *args,
3953 enum run_hooks_condition cond)
3955 Lisp_Object sym, val, ret;
3957 if (!initialized || preparing_for_armageddon)
3958 /* We need to bail out of here pronto. */
3961 /* Whenever gc_in_progress is true, preparing_for_armageddon
3962 will also be true unless something is really hosed. */
3963 assert (!gc_in_progress);
3966 val = symbol_value_in_buffer (sym, make_buffer (buf));
3967 ret = (cond == RUN_HOOKS_UNTIL_FAILURE ? Qt : Qnil);
3969 if (UNBOUNDP (val) || NILP (val))
3971 else if (!CONSP (val) || EQ (XCAR (val), Qlambda))
3974 return Ffuncall (nargs, args);
3978 struct gcpro gcpro1, gcpro2, gcpro3;
3979 Lisp_Object globals = Qnil;
3980 GCPRO3 (sym, val, globals);
3983 CONSP (val) && ((cond == RUN_HOOKS_TO_COMPLETION)
3984 || (cond == RUN_HOOKS_UNTIL_SUCCESS ? NILP (ret)
3988 if (EQ (XCAR (val), Qt))
3990 /* t indicates this hook has a local binding;
3991 it means to run the global binding too. */
3992 globals = Fdefault_value (sym);
3994 if ((! CONSP (globals) || EQ (XCAR (globals), Qlambda)) &&
3998 ret = Ffuncall (nargs, args);
4003 CONSP (globals) && ((cond == RUN_HOOKS_TO_COMPLETION)
4004 || (cond == RUN_HOOKS_UNTIL_SUCCESS
4007 globals = XCDR (globals))
4009 args[0] = XCAR (globals);
4010 /* In a global value, t should not occur. If it does, we
4011 must ignore it to avoid an endless loop. */
4012 if (!EQ (args[0], Qt))
4013 ret = Ffuncall (nargs, args);
4019 args[0] = XCAR (val);
4020 ret = Ffuncall (nargs, args);
4030 run_hook_with_args (int nargs, Lisp_Object *args,
4031 enum run_hooks_condition cond)
4033 return run_hook_with_args_in_buffer (current_buffer, nargs, args, cond);
4038 /* From FSF 19.30, not currently used */
4040 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
4041 present value of that symbol.
4042 Call each element of FUNLIST,
4043 passing each of them the rest of ARGS.
4044 The caller (or its caller, etc) must gcpro all of ARGS,
4045 except that it isn't necessary to gcpro ARGS[0]. */
4048 run_hook_list_with_args (Lisp_Object funlist, int nargs, Lisp_Object *args)
4050 Lisp_Object sym = args[0];
4052 struct gcpro gcpro1, gcpro2;
4056 for (val = funlist; CONSP (val); val = XCDR (val))
4058 if (EQ (XCAR (val), Qt))
4060 /* t indicates this hook has a local binding;
4061 it means to run the global binding too. */
4062 Lisp_Object globals;
4064 for (globals = Fdefault_value (sym);
4066 globals = XCDR (globals))
4068 args[0] = XCAR (globals);
4069 /* In a global value, t should not occur. If it does, we
4070 must ignore it to avoid an endless loop. */
4071 if (!EQ (args[0], Qt))
4072 Ffuncall (nargs, args);
4077 args[0] = XCAR (val);
4078 Ffuncall (nargs, args);
4088 va_run_hook_with_args (Lisp_Object hook_var, int nargs, ...)
4090 /* This function can GC */
4091 struct gcpro gcpro1;
4094 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs);
4096 va_start (vargs, nargs);
4097 funcall_args[0] = hook_var;
4098 for (i = 0; i < nargs; i++)
4099 funcall_args[i + 1] = va_arg (vargs, Lisp_Object);
4102 GCPRO1 (*funcall_args);
4103 gcpro1.nvars = nargs + 1;
4104 run_hook_with_args (nargs + 1, funcall_args, RUN_HOOKS_TO_COMPLETION);
4109 va_run_hook_with_args_in_buffer (struct buffer *buf, Lisp_Object hook_var,
4112 /* This function can GC */
4113 struct gcpro gcpro1;
4116 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs);
4118 va_start (vargs, nargs);
4119 funcall_args[0] = hook_var;
4120 for (i = 0; i < nargs; i++)
4121 funcall_args[i + 1] = va_arg (vargs, Lisp_Object);
4124 GCPRO1 (*funcall_args);
4125 gcpro1.nvars = nargs + 1;
4126 run_hook_with_args_in_buffer (buf, nargs + 1, funcall_args,
4127 RUN_HOOKS_TO_COMPLETION);
4132 run_hook (Lisp_Object hook)
4134 Frun_hooks (1, &hook);
4139 /************************************************************************/
4140 /* Front-ends to eval, funcall, apply */
4141 /************************************************************************/
4143 /* Apply fn to arg */
4145 apply1 (Lisp_Object fn, Lisp_Object arg)
4147 /* This function can GC */
4148 struct gcpro gcpro1;
4149 Lisp_Object args[2];
4152 return Ffuncall (1, &fn);
4157 RETURN_UNGCPRO (Fapply (2, args));
4160 /* Call function fn on no arguments */
4162 call0 (Lisp_Object fn)
4164 /* This function can GC */
4165 struct gcpro gcpro1;
4168 RETURN_UNGCPRO (Ffuncall (1, &fn));
4171 /* Call function fn with argument arg0 */
4173 call1 (Lisp_Object fn,
4176 /* This function can GC */
4177 struct gcpro gcpro1;
4178 Lisp_Object args[2];
4183 RETURN_UNGCPRO (Ffuncall (2, args));
4186 /* Call function fn with arguments arg0, arg1 */
4188 call2 (Lisp_Object fn,
4189 Lisp_Object arg0, Lisp_Object arg1)
4191 /* This function can GC */
4192 struct gcpro gcpro1;
4193 Lisp_Object args[3];
4199 RETURN_UNGCPRO (Ffuncall (3, args));
4202 /* Call function fn with arguments arg0, arg1, arg2 */
4204 call3 (Lisp_Object fn,
4205 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2)
4207 /* This function can GC */
4208 struct gcpro gcpro1;
4209 Lisp_Object args[4];
4216 RETURN_UNGCPRO (Ffuncall (4, args));
4219 /* Call function fn with arguments arg0, arg1, arg2, arg3 */
4221 call4 (Lisp_Object fn,
4222 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4225 /* This function can GC */
4226 struct gcpro gcpro1;
4227 Lisp_Object args[5];
4235 RETURN_UNGCPRO (Ffuncall (5, args));
4238 /* Call function fn with arguments arg0, arg1, arg2, arg3, arg4 */
4240 call5 (Lisp_Object fn,
4241 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4242 Lisp_Object arg3, Lisp_Object arg4)
4244 /* This function can GC */
4245 struct gcpro gcpro1;
4246 Lisp_Object args[6];
4255 RETURN_UNGCPRO (Ffuncall (6, args));
4259 call6 (Lisp_Object fn,
4260 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4261 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5)
4263 /* This function can GC */
4264 struct gcpro gcpro1;
4265 Lisp_Object args[7];
4275 RETURN_UNGCPRO (Ffuncall (7, args));
4279 call7 (Lisp_Object fn,
4280 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4281 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5,
4284 /* This function can GC */
4285 struct gcpro gcpro1;
4286 Lisp_Object args[8];
4297 RETURN_UNGCPRO (Ffuncall (8, args));
4301 call8 (Lisp_Object fn,
4302 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4303 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5,
4304 Lisp_Object arg6, Lisp_Object arg7)
4306 /* This function can GC */
4307 struct gcpro gcpro1;
4308 Lisp_Object args[9];
4320 RETURN_UNGCPRO (Ffuncall (9, args));
4324 call0_in_buffer (struct buffer *buf, Lisp_Object fn)
4326 if (current_buffer == buf)
4331 int speccount = specpdl_depth();
4332 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4333 set_buffer_internal (buf);
4335 unbind_to (speccount, Qnil);
4341 call1_in_buffer (struct buffer *buf, Lisp_Object fn,
4344 if (current_buffer == buf)
4345 return call1 (fn, arg0);
4349 int speccount = specpdl_depth();
4350 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4351 set_buffer_internal (buf);
4352 val = call1 (fn, arg0);
4353 unbind_to (speccount, Qnil);
4359 call2_in_buffer (struct buffer *buf, Lisp_Object fn,
4360 Lisp_Object arg0, Lisp_Object arg1)
4362 if (current_buffer == buf)
4363 return call2 (fn, arg0, arg1);
4367 int speccount = specpdl_depth();
4368 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4369 set_buffer_internal (buf);
4370 val = call2 (fn, arg0, arg1);
4371 unbind_to (speccount, Qnil);
4377 call3_in_buffer (struct buffer *buf, Lisp_Object fn,
4378 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2)
4380 if (current_buffer == buf)
4381 return call3 (fn, arg0, arg1, arg2);
4385 int speccount = specpdl_depth();
4386 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4387 set_buffer_internal (buf);
4388 val = call3 (fn, arg0, arg1, arg2);
4389 unbind_to (speccount, Qnil);
4395 call4_in_buffer (struct buffer *buf, Lisp_Object fn,
4396 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4399 if (current_buffer == buf)
4400 return call4 (fn, arg0, arg1, arg2, arg3);
4404 int speccount = specpdl_depth();
4405 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4406 set_buffer_internal (buf);
4407 val = call4 (fn, arg0, arg1, arg2, arg3);
4408 unbind_to (speccount, Qnil);
4414 eval_in_buffer (struct buffer *buf, Lisp_Object form)
4416 if (current_buffer == buf)
4417 return Feval (form);
4421 int speccount = specpdl_depth();
4422 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4423 set_buffer_internal (buf);
4425 unbind_to (speccount, Qnil);
4431 /************************************************************************/
4432 /* Error-catching front-ends to eval, funcall, apply */
4433 /************************************************************************/
4435 /* Call function fn on no arguments, with condition handler */
4437 call0_with_handler (Lisp_Object handler, Lisp_Object fn)
4439 /* This function can GC */
4440 struct gcpro gcpro1;
4441 Lisp_Object args[2];
4446 RETURN_UNGCPRO (Fcall_with_condition_handler (2, args));
4449 /* Call function fn with argument arg0, with condition handler */
4451 call1_with_handler (Lisp_Object handler, Lisp_Object fn,
4454 /* This function can GC */
4455 struct gcpro gcpro1;
4456 Lisp_Object args[3];
4462 RETURN_UNGCPRO (Fcall_with_condition_handler (3, args));
4466 /* The following functions provide you with error-trapping versions
4467 of the various front-ends above. They take an additional
4468 "warning_string" argument; if non-zero, a warning with this
4469 string and the actual error that occurred will be displayed
4470 in the *Warnings* buffer if an error occurs. In all cases,
4471 QUIT is inhibited while these functions are running, and if
4472 an error occurs, Qunbound is returned instead of the normal
4476 /* #### This stuff needs to catch throws as well. We need to
4477 improve internal_catch() so it can take a "catch anything"
4478 argument similar to Qt or Qerror for condition_case_1(). */
4481 caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg)
4483 if (!NILP (errordata))
4485 Lisp_Object args[2];
4489 char *str = (char *) get_opaque_ptr (arg);
4490 args[0] = build_string (str);
4493 args[0] = build_string ("error");
4494 /* #### This should call
4495 (with-output-to-string (display-error errordata))
4496 but that stuff is all in Lisp currently. */
4497 args[1] = errordata;
4498 warn_when_safe_lispobj
4500 emacs_doprnt_string_lisp ((const Bufbyte *) "%s: %s",
4501 Qnil, -1, 2, args));
4507 allow_quit_caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg)
4509 if (CONSP (errordata) && EQ (XCAR (errordata), Qquit))
4510 return Fsignal (Qquit, XCDR (errordata));
4511 return caught_a_squirmer (errordata, arg);
4515 safe_run_hook_caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg)
4517 Lisp_Object hook = Fcar (arg);
4519 /* Clear out the hook. */
4521 return caught_a_squirmer (errordata, arg);
4525 allow_quit_safe_run_hook_caught_a_squirmer (Lisp_Object errordata,
4528 Lisp_Object hook = Fcar (arg);
4530 if (!CONSP (errordata) || !EQ (XCAR (errordata), Qquit))
4531 /* Clear out the hook. */
4533 return allow_quit_caught_a_squirmer (errordata, arg);
4537 catch_them_squirmers_eval_in_buffer (Lisp_Object cons)
4539 return eval_in_buffer (XBUFFER (XCAR (cons)), XCDR (cons));
4543 eval_in_buffer_trapping_errors (const char *warning_string,
4544 struct buffer *buf, Lisp_Object form)
4546 int speccount = specpdl_depth();
4551 struct gcpro gcpro1, gcpro2;
4553 XSETBUFFER (buffer, buf);
4555 specbind (Qinhibit_quit, Qt);
4556 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4558 cons = noseeum_cons (buffer, form);
4559 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
4560 GCPRO2 (cons, opaque);
4561 /* Qerror not Qt, so you can get a backtrace */
4562 tem = condition_case_1 (Qerror,
4563 catch_them_squirmers_eval_in_buffer, cons,
4564 caught_a_squirmer, opaque);
4565 free_cons (XCONS (cons));
4566 if (OPAQUE_PTRP (opaque))
4567 free_opaque_ptr (opaque);
4570 /* gc_currently_forbidden = 0; */
4571 return unbind_to (speccount, tem);
4575 catch_them_squirmers_run_hook (Lisp_Object hook_symbol)
4577 /* This function can GC */
4578 run_hook (hook_symbol);
4583 run_hook_trapping_errors (const char *warning_string, Lisp_Object hook_symbol)
4588 struct gcpro gcpro1;
4590 if (!initialized || preparing_for_armageddon)
4592 tem = find_symbol_value (hook_symbol);
4593 if (NILP (tem) || UNBOUNDP (tem))
4596 speccount = specpdl_depth();
4597 specbind (Qinhibit_quit, Qt);
4599 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
4601 /* Qerror not Qt, so you can get a backtrace */
4602 tem = condition_case_1 (Qerror,
4603 catch_them_squirmers_run_hook, hook_symbol,
4604 caught_a_squirmer, opaque);
4605 if (OPAQUE_PTRP (opaque))
4606 free_opaque_ptr (opaque);
4609 return unbind_to (speccount, tem);
4612 /* Same as run_hook_trapping_errors() but also set the hook to nil
4613 if an error occurs. */
4616 safe_run_hook_trapping_errors (const char *warning_string,
4617 Lisp_Object hook_symbol,
4620 int speccount = specpdl_depth();
4622 Lisp_Object cons = Qnil;
4623 struct gcpro gcpro1;
4625 if (!initialized || preparing_for_armageddon)
4627 tem = find_symbol_value (hook_symbol);
4628 if (NILP (tem) || UNBOUNDP (tem))
4632 specbind (Qinhibit_quit, Qt);
4634 cons = noseeum_cons (hook_symbol,
4635 warning_string ? make_opaque_ptr ((void *)warning_string)
4638 /* Qerror not Qt, so you can get a backtrace */
4639 tem = condition_case_1 (Qerror,
4640 catch_them_squirmers_run_hook,
4643 allow_quit_safe_run_hook_caught_a_squirmer :
4644 safe_run_hook_caught_a_squirmer,
4646 if (OPAQUE_PTRP (XCDR (cons)))
4647 free_opaque_ptr (XCDR (cons));
4648 free_cons (XCONS (cons));
4651 return unbind_to (speccount, tem);
4655 catch_them_squirmers_call0 (Lisp_Object function)
4657 /* This function can GC */
4658 return call0 (function);
4662 call0_trapping_errors (const char *warning_string, Lisp_Object function)
4666 Lisp_Object opaque = Qnil;
4667 struct gcpro gcpro1, gcpro2;
4669 if (SYMBOLP (function))
4671 tem = XSYMBOL (function)->function;
4672 if (NILP (tem) || UNBOUNDP (tem))
4676 GCPRO2 (opaque, function);
4677 speccount = specpdl_depth();
4678 specbind (Qinhibit_quit, Qt);
4679 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4681 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
4682 /* Qerror not Qt, so you can get a backtrace */
4683 tem = condition_case_1 (Qerror,
4684 catch_them_squirmers_call0, function,
4685 caught_a_squirmer, opaque);
4686 if (OPAQUE_PTRP (opaque))
4687 free_opaque_ptr (opaque);
4690 /* gc_currently_forbidden = 0; */
4691 return unbind_to (speccount, tem);
4695 catch_them_squirmers_call1 (Lisp_Object cons)
4697 /* This function can GC */
4698 return call1 (XCAR (cons), XCDR (cons));
4702 catch_them_squirmers_call2 (Lisp_Object cons)
4704 /* This function can GC */
4705 return call2 (XCAR (cons), XCAR (XCDR (cons)), XCAR (XCDR (XCDR (cons))));
4709 call1_trapping_errors (const char *warning_string, Lisp_Object function,
4712 int speccount = specpdl_depth();
4714 Lisp_Object cons = Qnil;
4715 Lisp_Object opaque = Qnil;
4716 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
4718 if (SYMBOLP (function))
4720 tem = XSYMBOL (function)->function;
4721 if (NILP (tem) || UNBOUNDP (tem))
4725 GCPRO4 (cons, opaque, function, object);
4727 specbind (Qinhibit_quit, Qt);
4728 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4730 cons = noseeum_cons (function, object);
4731 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
4732 /* Qerror not Qt, so you can get a backtrace */
4733 tem = condition_case_1 (Qerror,
4734 catch_them_squirmers_call1, cons,
4735 caught_a_squirmer, opaque);
4736 if (OPAQUE_PTRP (opaque))
4737 free_opaque_ptr (opaque);
4738 free_cons (XCONS (cons));
4741 /* gc_currently_forbidden = 0; */
4742 return unbind_to (speccount, tem);
4746 call2_trapping_errors (const char *warning_string, Lisp_Object function,
4747 Lisp_Object object1, Lisp_Object object2)
4749 int speccount = specpdl_depth();
4751 Lisp_Object cons = Qnil;
4752 Lisp_Object opaque = Qnil;
4753 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
4755 if (SYMBOLP (function))
4757 tem = XSYMBOL (function)->function;
4758 if (NILP (tem) || UNBOUNDP (tem))
4762 GCPRO5 (cons, opaque, function, object1, object2);
4763 specbind (Qinhibit_quit, Qt);
4764 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4766 cons = list3 (function, object1, object2);
4767 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
4768 /* Qerror not Qt, so you can get a backtrace */
4769 tem = condition_case_1 (Qerror,
4770 catch_them_squirmers_call2, cons,
4771 caught_a_squirmer, opaque);
4772 if (OPAQUE_PTRP (opaque))
4773 free_opaque_ptr (opaque);
4777 /* gc_currently_forbidden = 0; */
4778 return unbind_to (speccount, tem);
4782 /************************************************************************/
4783 /* The special binding stack */
4784 /* Most C code should simply use specbind() and unbind_to(). */
4785 /* When performance is critical, use the macros in backtrace.h. */
4786 /************************************************************************/
4788 #define min_max_specpdl_size 400
4791 grow_specpdl (size_t reserved)
4793 size_t size_needed = specpdl_depth() + reserved;
4794 if (size_needed >= max_specpdl_size)
4796 if (max_specpdl_size < min_max_specpdl_size)
4797 max_specpdl_size = min_max_specpdl_size;
4798 if (size_needed >= max_specpdl_size)
4800 if (!NILP (Vdebug_on_error) ||
4801 !NILP (Vdebug_on_signal))
4802 /* Leave room for some specpdl in the debugger. */
4803 max_specpdl_size = size_needed + 100;
4805 ("Variable binding depth exceeds max-specpdl-size");
4808 while (specpdl_size < size_needed)
4811 if (specpdl_size > max_specpdl_size)
4812 specpdl_size = max_specpdl_size;
4814 XREALLOC_ARRAY (specpdl, struct specbinding, specpdl_size);
4815 specpdl_ptr = specpdl + specpdl_depth();
4819 /* Handle unbinding buffer-local variables */
4821 specbind_unwind_local (Lisp_Object ovalue)
4823 Lisp_Object current = Fcurrent_buffer ();
4824 Lisp_Object symbol = specpdl_ptr->symbol;
4825 Lisp_Cons *victim = XCONS (ovalue);
4826 Lisp_Object buf = get_buffer (victim->car, 0);
4827 ovalue = victim->cdr;
4833 /* Deleted buffer -- do nothing */
4835 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buf)) == 0)
4837 /* Was buffer-local when binding was made, now no longer is.
4838 * (kill-local-variable can do this.)
4839 * Do nothing in this case.
4842 else if (EQ (buf, current))
4843 Fset (symbol, ovalue);
4846 /* Urk! Somebody switched buffers */
4847 struct gcpro gcpro1;
4850 Fset (symbol, ovalue);
4851 Fset_buffer (current);
4858 specbind_unwind_wasnt_local (Lisp_Object buffer)
4860 Lisp_Object current = Fcurrent_buffer ();
4861 Lisp_Object symbol = specpdl_ptr->symbol;
4863 buffer = get_buffer (buffer, 0);
4866 /* Deleted buffer -- do nothing */
4868 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buffer)) == 0)
4870 /* Was buffer-local when binding was made, now no longer is.
4871 * (kill-local-variable can do this.)
4872 * Do nothing in this case.
4875 else if (EQ (buffer, current))
4876 Fkill_local_variable (symbol);
4879 /* Urk! Somebody switched buffers */
4880 struct gcpro gcpro1;
4882 Fset_buffer (buffer);
4883 Fkill_local_variable (symbol);
4884 Fset_buffer (current);
4892 specbind (Lisp_Object symbol, Lisp_Object value)
4894 SPECBIND (symbol, value);
4898 specbind_magic (Lisp_Object symbol, Lisp_Object value)
4901 symbol_value_buffer_local_info (symbol, current_buffer);
4903 if (buffer_local == 0)
4905 specpdl_ptr->old_value = find_symbol_value (symbol);
4906 specpdl_ptr->func = 0; /* Handled specially by unbind_to */
4908 else if (buffer_local > 0)
4910 /* Already buffer-local */
4911 specpdl_ptr->old_value = noseeum_cons (Fcurrent_buffer (),
4912 find_symbol_value (symbol));
4913 specpdl_ptr->func = specbind_unwind_local;
4917 /* About to become buffer-local */
4918 specpdl_ptr->old_value = Fcurrent_buffer ();
4919 specpdl_ptr->func = specbind_unwind_wasnt_local;
4922 specpdl_ptr->symbol = symbol;
4924 specpdl_depth_counter++;
4926 Fset (symbol, value);
4929 /* Note: As long as the unwind-protect exists, its arg is automatically
4933 record_unwind_protect (Lisp_Object (*function) (Lisp_Object arg),
4936 SPECPDL_RESERVE (1);
4937 specpdl_ptr->func = function;
4938 specpdl_ptr->symbol = Qnil;
4939 specpdl_ptr->old_value = arg;
4941 specpdl_depth_counter++;
4944 extern int check_sigio (void);
4946 /* Unwind the stack till specpdl_depth() == COUNT.
4947 VALUE is not used, except that, purely as a convenience to the
4948 caller, it is protected from garbage-protection. */
4950 unbind_to (int count, Lisp_Object value)
4952 UNBIND_TO_GCPRO (count, value);
4956 /* Don't call this directly.
4957 Only for use by UNBIND_TO* macros in backtrace.h */
4959 unbind_to_hairy (int count)
4964 ++specpdl_depth_counter;
4966 check_quit (); /* make Vquit_flag accurate */
4967 quitf = !NILP (Vquit_flag);
4970 while (specpdl_depth_counter != count)
4973 --specpdl_depth_counter;
4975 if (specpdl_ptr->func != 0)
4976 /* An unwind-protect */
4977 (*specpdl_ptr->func) (specpdl_ptr->old_value);
4980 /* We checked symbol for validity when we specbound it,
4981 so only need to call Fset if symbol has magic value. */
4982 Lisp_Symbol *sym = XSYMBOL (specpdl_ptr->symbol);
4983 if (!SYMBOL_VALUE_MAGIC_P (sym->value))
4984 sym->value = specpdl_ptr->old_value;
4986 Fset (specpdl_ptr->symbol, specpdl_ptr->old_value);
4990 #ifndef EXCEEDINGLY_QUESTIONABLE_CODE
4991 /* There should never be anything here for us to remove.
4992 If so, it indicates a logic error in Emacs. Catches
4993 should get removed when a throw or signal occurs, or
4994 when a catch or condition-case exits normally. But
4995 it's too dangerous to just remove this code. --ben */
4997 /* Furthermore, this code is not in FSFmacs!!!
4998 Braino on mly's part? */
4999 /* If we're unwound past the pdlcount of a catch frame,
5000 that catch can't possibly still be valid. */
5001 while (catchlist && catchlist->pdlcount > specpdl_depth_counter)
5003 catchlist = catchlist->next;
5004 /* Don't mess with gcprolist, backtrace_list here */
5015 /* Get the value of symbol's global binding, even if that binding is
5016 not now dynamically visible. May return Qunbound or magic values. */
5019 top_level_value (Lisp_Object symbol)
5021 REGISTER struct specbinding *ptr = specpdl;
5023 CHECK_SYMBOL (symbol);
5024 for (; ptr != specpdl_ptr; ptr++)
5026 if (EQ (ptr->symbol, symbol))
5027 return ptr->old_value;
5029 return XSYMBOL (symbol)->value;
5035 top_level_set (Lisp_Object symbol, Lisp_Object newval)
5037 REGISTER struct specbinding *ptr = specpdl;
5039 CHECK_SYMBOL (symbol);
5040 for (; ptr != specpdl_ptr; ptr++)
5042 if (EQ (ptr->symbol, symbol))
5044 ptr->old_value = newval;
5048 return Fset (symbol, newval);
5054 /************************************************************************/
5056 /************************************************************************/
5058 DEFUN ("backtrace-debug", Fbacktrace_debug, 2, 2, 0, /*
5059 Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
5060 The debugger is entered when that frame exits, if the flag is non-nil.
5064 REGISTER struct backtrace *backlist = backtrace_list;
5069 for (i = 0; backlist && i < XINT (level); i++)
5071 backlist = backlist->next;
5075 backlist->debug_on_exit = !NILP (flag);
5081 backtrace_specials (int speccount, int speclimit, Lisp_Object stream)
5083 int printing_bindings = 0;
5085 for (; speccount > speclimit; speccount--)
5087 if (specpdl[speccount - 1].func == 0
5088 || specpdl[speccount - 1].func == specbind_unwind_local
5089 || specpdl[speccount - 1].func == specbind_unwind_wasnt_local)
5091 write_c_string (((!printing_bindings) ? " # bind (" : " "),
5093 Fprin1 (specpdl[speccount - 1].symbol, stream);
5094 printing_bindings = 1;
5098 if (printing_bindings) write_c_string (")\n", stream);
5099 write_c_string (" # (unwind-protect ...)\n", stream);
5100 printing_bindings = 0;
5103 if (printing_bindings) write_c_string (")\n", stream);
5106 DEFUN ("backtrace", Fbacktrace, 0, 2, "", /*
5107 Print a trace of Lisp function calls currently active.
5108 Optional arg STREAM specifies the output stream to send the backtrace to,
5109 and defaults to the value of `standard-output'.
5110 Optional second arg DETAILED non-nil means show places where currently
5111 active variable bindings, catches, condition-cases, and
5112 unwind-protects, as well as function calls, were made.
5116 /* This function can GC */
5117 struct backtrace *backlist = backtrace_list;
5118 struct catchtag *catches = catchlist;
5119 int speccount = specpdl_depth();
5121 int old_nl = print_escape_newlines;
5122 int old_pr = print_readably;
5123 Lisp_Object old_level = Vprint_level;
5124 Lisp_Object oiq = Vinhibit_quit;
5125 struct gcpro gcpro1, gcpro2;
5127 /* We can't allow quits in here because that could cause the values
5128 of print_readably and print_escape_newlines to get screwed up.
5129 Normally we would use a record_unwind_protect but that would
5130 screw up the functioning of this function. */
5133 entering_debugger = 0;
5135 Vprint_level = make_int (3);
5137 print_escape_newlines = 1;
5139 GCPRO2 (stream, old_level);
5142 stream = Vstandard_output;
5143 if (!noninteractive && (NILP (stream) || EQ (stream, Qt)))
5144 stream = Fselected_frame (Qnil);
5148 if (!NILP (detailed) && catches && catches->backlist == backlist)
5150 int catchpdl = catches->pdlcount;
5151 if (speccount > catchpdl
5152 && specpdl[catchpdl].func == condition_case_unwind)
5153 /* This is a condition-case catchpoint */
5154 catchpdl = catchpdl + 1;
5156 backtrace_specials (speccount, catchpdl, stream);
5158 speccount = catches->pdlcount;
5159 if (catchpdl == speccount)
5161 write_c_string (" # (catch ", stream);
5162 Fprin1 (catches->tag, stream);
5163 write_c_string (" ...)\n", stream);
5167 write_c_string (" # (condition-case ... . ", stream);
5168 Fprin1 (Fcdr (Fcar (catches->tag)), stream);
5169 write_c_string (")\n", stream);
5171 catches = catches->next;
5177 if (!NILP (detailed) && backlist->pdlcount < speccount)
5179 backtrace_specials (speccount, backlist->pdlcount, stream);
5180 speccount = backlist->pdlcount;
5182 write_c_string (((backlist->debug_on_exit) ? "* " : " "),
5184 if (backlist->nargs == UNEVALLED)
5186 Fprin1 (Fcons (*backlist->function, *backlist->args), stream);
5187 write_c_string ("\n", stream); /* from FSFmacs 19.30 */
5191 Lisp_Object tem = *backlist->function;
5192 Fprin1 (tem, stream); /* This can QUIT */
5193 write_c_string ("(", stream);
5194 if (backlist->nargs == MANY)
5197 Lisp_Object tail = Qnil;
5198 struct gcpro ngcpro1;
5201 for (tail = *backlist->args, i = 0;
5203 tail = Fcdr (tail), i++)
5205 if (i != 0) write_c_string (" ", stream);
5206 Fprin1 (Fcar (tail), stream);
5213 for (i = 0; i < backlist->nargs; i++)
5215 if (!i && EQ(tem, Qbyte_code)) {
5216 write_c_string("\"...\"", stream);
5219 if (i != 0) write_c_string (" ", stream);
5220 Fprin1 (backlist->args[i], stream);
5223 write_c_string (")\n", stream);
5225 backlist = backlist->next;
5228 Vprint_level = old_level;
5229 print_readably = old_pr;
5230 print_escape_newlines = old_nl;
5232 Vinhibit_quit = oiq;
5237 DEFUN ("backtrace-frame", Fbacktrace_frame, 1, 1, 0, /*
5238 Return the function and arguments NFRAMES up from current execution point.
5239 If that frame has not evaluated the arguments yet (or is a special form),
5240 the value is (nil FUNCTION ARG-FORMS...).
5241 If that frame has evaluated its arguments and called its function already,
5242 the value is (t FUNCTION ARG-VALUES...).
5243 A &rest arg is represented as the tail of the list ARG-VALUES.
5244 FUNCTION is whatever was supplied as car of evaluated list,
5245 or a lambda expression for macro calls.
5246 If NFRAMES is more than the number of frames, the value is nil.
5250 REGISTER struct backtrace *backlist = backtrace_list;
5254 CHECK_NATNUM (nframes);
5256 /* Find the frame requested. */
5257 for (i = XINT (nframes); backlist && (i-- > 0);)
5258 backlist = backlist->next;
5262 if (backlist->nargs == UNEVALLED)
5263 return Fcons (Qnil, Fcons (*backlist->function, *backlist->args));
5266 if (backlist->nargs == MANY)
5267 tem = *backlist->args;
5269 tem = Flist (backlist->nargs, backlist->args);
5271 return Fcons (Qt, Fcons (*backlist->function, tem));
5276 /************************************************************************/
5278 /************************************************************************/
5281 warn_when_safe_lispobj (Lisp_Object class, Lisp_Object level,
5284 obj = list1 (list3 (class, level, obj));
5285 if (NILP (Vpending_warnings))
5286 Vpending_warnings = Vpending_warnings_tail = obj;
5289 Fsetcdr (Vpending_warnings_tail, obj);
5290 Vpending_warnings_tail = obj;
5294 /* #### This should probably accept Lisp objects; but then we have
5295 to make sure that Feval() isn't called, since it might not be safe.
5297 An alternative approach is to just pass some non-string type of
5298 Lisp_Object to warn_when_safe_lispobj(); `prin1-to-string' will
5299 automatically be called when it is safe to do so. */
5302 warn_when_safe (Lisp_Object class, Lisp_Object level, const char *fmt, ...)
5307 va_start (args, fmt);
5308 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt),
5312 warn_when_safe_lispobj (class, level, obj);
5318 /************************************************************************/
5319 /* Initialization */
5320 /************************************************************************/
5325 INIT_LRECORD_IMPLEMENTATION (subr);
5327 defsymbol (&Qinhibit_quit, "inhibit-quit");
5328 defsymbol (&Qautoload, "autoload");
5329 defsymbol (&Qdebug_on_error, "debug-on-error");
5330 defsymbol (&Qstack_trace_on_error, "stack-trace-on-error");
5331 defsymbol (&Qdebug_on_signal, "debug-on-signal");
5332 defsymbol (&Qstack_trace_on_signal, "stack-trace-on-signal");
5333 defsymbol (&Qdebugger, "debugger");
5334 defsymbol (&Qmacro, "macro");
5335 defsymbol (&Qand_rest, "&rest");
5336 defsymbol (&Qand_optional, "&optional");
5337 /* Note that the process code also uses Qexit */
5338 defsymbol (&Qexit, "exit");
5339 defsymbol (&Qsetq, "setq");
5340 defsymbol (&Qinteractive, "interactive");
5341 defsymbol (&Qcommandp, "commandp");
5342 defsymbol (&Qdefun, "defun");
5343 defsymbol (&Qprogn, "progn");
5344 defsymbol (&Qvalues, "values");
5345 defsymbol (&Qdisplay_warning, "display-warning");
5346 defsymbol (&Qrun_hooks, "run-hooks");
5347 defsymbol (&Qif, "if");
5352 DEFSUBR_MACRO (Fwhen);
5353 DEFSUBR_MACRO (Funless);
5360 DEFSUBR (Ffunction);
5362 DEFSUBR (Fdefmacro);
5364 DEFSUBR (Fdefconst);
5365 DEFSUBR (Fuser_variable_p);
5369 DEFSUBR (Fmacroexpand_internal);
5372 DEFSUBR (Funwind_protect);
5373 DEFSUBR (Fcondition_case);
5374 DEFSUBR (Fcall_with_condition_handler);
5376 DEFSUBR (Finteractive_p);
5377 DEFSUBR (Fcommandp);
5378 DEFSUBR (Fcommand_execute);
5379 DEFSUBR (Fautoload);
5383 DEFSUBR (Ffunctionp);
5384 DEFSUBR (Ffunction_min_args);
5385 DEFSUBR (Ffunction_max_args);
5386 DEFSUBR (Frun_hooks);
5387 DEFSUBR (Frun_hook_with_args);
5388 DEFSUBR (Frun_hook_with_args_until_success);
5389 DEFSUBR (Frun_hook_with_args_until_failure);
5390 DEFSUBR (Fbacktrace_debug);
5391 DEFSUBR (Fbacktrace);
5392 DEFSUBR (Fbacktrace_frame);
5398 specpdl_ptr = specpdl;
5399 specpdl_depth_counter = 0;
5401 Vcondition_handlers = Qnil;
5404 debug_on_next_call = 0;
5405 lisp_eval_depth = 0;
5406 entering_debugger = 0;
5410 reinit_vars_of_eval (void)
5412 preparing_for_armageddon = 0;
5414 Qunbound_suspended_errors_tag = make_opaque_ptr (&Qunbound_suspended_errors_tag);
5415 staticpro_nodump (&Qunbound_suspended_errors_tag);
5418 specpdl = xnew_array (struct specbinding, specpdl_size);
5419 /* XEmacs change: increase these values. */
5420 max_specpdl_size = 3000;
5421 max_lisp_eval_depth = 1000;
5422 #ifdef DEFEND_AGAINST_THROW_RECURSION
5430 reinit_vars_of_eval ();
5432 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size /*
5433 Limit on number of Lisp variable bindings & unwind-protects before error.
5436 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth /*
5437 Limit on depth in `eval', `apply' and `funcall' before error.
5438 This limit is to catch infinite recursions for you before they cause
5439 actual stack overflow in C, which would be fatal for Emacs.
5440 You can safely make it considerably larger than its default value,
5441 if that proves inconveniently small.
5444 DEFVAR_LISP ("quit-flag", &Vquit_flag /*
5445 Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
5446 Typing C-G sets `quit-flag' non-nil, regardless of `inhibit-quit'.
5450 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit /*
5451 Non-nil inhibits C-g quitting from happening immediately.
5452 Note that `quit-flag' will still be set by typing C-g,
5453 so a quit will be signalled as soon as `inhibit-quit' is nil.
5454 To prevent this happening, set `quit-flag' to nil
5455 before making `inhibit-quit' nil. The value of `inhibit-quit' is
5456 ignored if a critical quit is requested by typing control-shift-G in
5459 Vinhibit_quit = Qnil;
5461 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error /*
5462 *Non-nil means automatically display a backtrace buffer
5463 after any error that is not handled by a `condition-case'.
5464 If the value is a list, an error only means to display a backtrace
5465 if one of its condition symbols appears in the list.
5466 See also variable `stack-trace-on-signal'.
5468 Vstack_trace_on_error = Qnil;
5470 DEFVAR_LISP ("stack-trace-on-signal", &Vstack_trace_on_signal /*
5471 *Non-nil means automatically display a backtrace buffer
5472 after any error that is signalled, whether or not it is handled by
5474 If the value is a list, an error only means to display a backtrace
5475 if one of its condition symbols appears in the list.
5476 See also variable `stack-trace-on-error'.
5478 Vstack_trace_on_signal = Qnil;
5480 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors /*
5481 *List of errors for which the debugger should not be called.
5482 Each element may be a condition-name or a regexp that matches error messages.
5483 If any element applies to a given error, that error skips the debugger
5484 and just returns to top level.
5485 This overrides the variable `debug-on-error'.
5486 It does not apply to errors handled by `condition-case'.
5488 Vdebug_ignored_errors = Qnil;
5490 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error /*
5491 *Non-nil means enter debugger if an unhandled error is signalled.
5492 The debugger will not be entered if the error is handled by
5494 If the value is a list, an error only means to enter the debugger
5495 if one of its condition symbols appears in the list.
5496 This variable is overridden by `debug-ignored-errors'.
5497 See also variables `debug-on-quit' and `debug-on-signal'.
5499 Vdebug_on_error = Qnil;
5501 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal /*
5502 *Non-nil means enter debugger if an error is signalled.
5503 The debugger will be entered whether or not the error is handled by
5505 If the value is a list, an error only means to enter the debugger
5506 if one of its condition symbols appears in the list.
5507 See also variable `debug-on-quit'.
5509 Vdebug_on_signal = Qnil;
5511 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit /*
5512 *Non-nil means enter debugger if quit is signalled (C-G, for example).
5513 Does not apply if quit is handled by a `condition-case'. Entering the
5514 debugger can also be achieved at any time (for X11 console) by typing
5515 control-shift-G to signal a critical quit.
5519 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call /*
5520 Non-nil means enter debugger before next `eval', `apply' or `funcall'.
5523 DEFVAR_LISP ("debugger", &Vdebugger /*
5524 Function to call to invoke debugger.
5525 If due to frame exit, args are `exit' and the value being returned;
5526 this function's value will be returned instead of that.
5527 If due to error, args are `error' and a list of the args to `signal'.
5528 If due to `apply' or `funcall' entry, one arg, `lambda'.
5529 If due to `eval' entry, one arg, t.
5533 staticpro (&Vpending_warnings);
5534 Vpending_warnings = Qnil;
5535 dump_add_root_object (&Vpending_warnings_tail);
5536 Vpending_warnings_tail = Qnil;
5538 staticpro (&Vautoload_queue);
5539 Vautoload_queue = Qnil;
5541 staticpro (&Vcondition_handlers);
5543 staticpro (&Vcurrent_warning_class);
5544 Vcurrent_warning_class = Qnil;
5546 staticpro (&Vcurrent_error_state);
5547 Vcurrent_error_state = Qnil; /* errors as normal */