1 /* Evaluator for XEmacs Lisp interpreter.
2 Copyright (C) 1985-1987, 1992-1994 Free Software Foundation, Inc.
3 Copyright (C) 1995 Sun Microsystems, Inc.
5 This file is part of XEmacs.
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 /* Synched up with: FSF 19.30 (except for Fsignal), Mule 2.0. */
28 #include "backtrace.h"
35 int always_gc; /* Debugging hack */
40 struct backtrace *backtrace_list;
42 /* Note: you must always fill in all of the fields in a backtrace structure
43 before pushing them on the backtrace_list. The profiling code depends
46 #define PUSH_BACKTRACE(bt) do { \
47 (bt).next = backtrace_list; \
48 backtrace_list = &(bt); \
51 #define POP_BACKTRACE(bt) do { \
52 backtrace_list = (bt).next; \
55 /* Macros for calling subrs with an argument list whose length is only
56 known at runtime. See EXFUN and DEFUN for similar hackery. */
59 #define AV_1(av) av[0]
60 #define AV_2(av) AV_1(av), av[1]
61 #define AV_3(av) AV_2(av), av[2]
62 #define AV_4(av) AV_3(av), av[3]
63 #define AV_5(av) AV_4(av), av[4]
64 #define AV_6(av) AV_5(av), av[5]
65 #define AV_7(av) AV_6(av), av[6]
66 #define AV_8(av) AV_7(av), av[7]
68 #define PRIMITIVE_FUNCALL_1(fn, av, ac) \
69 (((Lisp_Object (*)(EXFUN_##ac)) (fn)) (AV_##ac (av)))
71 /* If subrs take more than 8 arguments, more cases need to be added
72 to this switch. (But wait - don't do it - if you really need
73 a SUBR with more than 8 arguments, use max_args == MANY.
74 See the DEFUN macro in lisp.h) */
75 #define PRIMITIVE_FUNCALL(rv, fn, av, ac) do { \
76 void (*PF_fn)(void) = (void (*)(void)) fn; \
77 Lisp_Object *PF_av = (av); \
80 default:rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 0); break; \
81 case 1: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 1); break; \
82 case 2: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 2); break; \
83 case 3: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 3); break; \
84 case 4: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 4); break; \
85 case 5: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 5); break; \
86 case 6: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 6); break; \
87 case 7: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 7); break; \
88 case 8: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 8); break; \
92 #define FUNCALL_SUBR(rv, subr, av, ac) \
93 PRIMITIVE_FUNCALL (rv, subr_function (subr), av, ac);
96 /* This is the list of current catches (and also condition-cases).
97 This is a stack: the most recent catch is at the head of the
98 list. Catches are created by declaring a 'struct catchtag'
99 locally, filling the .TAG field in with the tag, and doing
100 a setjmp() on .JMP. Fthrow() will store the value passed
101 to it in .VAL and longjmp() back to .JMP, back to the function
102 that established the catch. This will always be either
103 internal_catch() (catches established internally or through
104 `catch') or condition_case_1 (condition-cases established
105 internally or through `condition-case').
107 The catchtag also records the current position in the
108 call stack (stored in BACKTRACE_LIST), the current position
109 in the specpdl stack (used for variable bindings and
110 unwind-protects), the value of LISP_EVAL_DEPTH, and the
111 current position in the GCPRO stack. All of these are
112 restored by Fthrow().
115 struct catchtag *catchlist;
117 Lisp_Object Qautoload, Qmacro, Qexit;
118 Lisp_Object Qinteractive, Qcommandp, Qdefun, Qprogn, Qvalues;
119 Lisp_Object Vquit_flag, Vinhibit_quit;
120 Lisp_Object Qand_rest, Qand_optional;
121 Lisp_Object Qdebug_on_error, Qstack_trace_on_error;
122 Lisp_Object Qdebug_on_signal, Qstack_trace_on_signal;
123 Lisp_Object Qdebugger;
124 Lisp_Object Qinhibit_quit;
125 Lisp_Object Qrun_hooks;
127 Lisp_Object Qdisplay_warning;
128 Lisp_Object Vpending_warnings, Vpending_warnings_tail;
131 /* Records whether we want errors to occur. This will be a boolean,
132 nil (errors OK) or t (no errors). If t, an error will cause a
133 throw to Qunbound_suspended_errors_tag.
135 See call_with_suspended_errors(). */
136 Lisp_Object Vcurrent_error_state;
138 /* Current warning class when warnings occur, or nil for no warnings.
139 Only meaningful when Vcurrent_error_state is non-nil.
140 See call_with_suspended_errors(). */
141 Lisp_Object Vcurrent_warning_class;
143 /* Special catch tag used in call_with_suspended_errors(). */
144 Lisp_Object Qunbound_suspended_errors_tag;
146 /* Non-nil means record all fset's and provide's, to be undone
147 if the file being autoloaded is not fully loaded.
148 They are recorded by being consed onto the front of Vautoload_queue:
149 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */
150 Lisp_Object Vautoload_queue;
152 /* Current number of specbindings allocated in specpdl. */
155 /* Pointer to beginning of specpdl. */
156 struct specbinding *specpdl;
158 /* Pointer to first unused element in specpdl. */
159 struct specbinding *specpdl_ptr;
161 /* specpdl_ptr - specpdl */
162 int specpdl_depth_counter;
164 /* Maximum size allowed for specpdl allocation */
165 int max_specpdl_size;
167 /* Depth in Lisp evaluations and function calls. */
168 static int lisp_eval_depth;
170 /* Maximum allowed depth in Lisp evaluations and function calls. */
171 int max_lisp_eval_depth;
173 /* Nonzero means enter debugger before next function call */
174 static int debug_on_next_call;
176 /* List of conditions (non-nil atom means all) which cause a backtrace
177 if an error is handled by the command loop's error handler. */
178 Lisp_Object Vstack_trace_on_error;
180 /* List of conditions (non-nil atom means all) which enter the debugger
181 if an error is handled by the command loop's error handler. */
182 Lisp_Object Vdebug_on_error;
184 /* List of conditions and regexps specifying error messages which
185 do not enter the debugger even if Vdebug_on_error says they should. */
186 Lisp_Object Vdebug_ignored_errors;
188 /* List of conditions (non-nil atom means all) which cause a backtrace
189 if any error is signalled. */
190 Lisp_Object Vstack_trace_on_signal;
192 /* List of conditions (non-nil atom means all) which enter the debugger
193 if any error is signalled. */
194 Lisp_Object Vdebug_on_signal;
196 /* Nonzero means enter debugger if a quit signal
197 is handled by the command loop's error handler.
199 From lisp, this is a boolean variable and may have the values 0 and 1.
200 But, eval.c temporarily uses the second bit of this variable to indicate
201 that a critical_quit is in progress. The second bit is reset immediately
202 after it is processed in signal_call_debugger(). */
206 /* entering_debugger is basically equivalent */
207 /* The value of num_nonmacro_input_chars as of the last time we
208 started to enter the debugger. If we decide to enter the debugger
209 again when this is still equal to num_nonmacro_input_chars, then we
210 know that the debugger itself has an error, and we should just
211 signal the error instead of entering an infinite loop of debugger
213 int when_entered_debugger;
216 /* Nonzero means we are trying to enter the debugger.
217 This is to prevent recursive attempts.
218 Cleared by the debugger calling Fbacktrace */
219 static int entering_debugger;
221 /* Function to call to invoke the debugger */
222 Lisp_Object Vdebugger;
224 /* Chain of condition handlers currently in effect.
225 The elements of this chain are contained in the stack frames
226 of Fcondition_case and internal_condition_case.
227 When an error is signaled (by calling Fsignal, below),
228 this chain is searched for an element that applies.
230 Each element of this list is one of the following:
232 A list of a handler function and possibly args to pass to
233 the function. This is a handler established with
234 `call-with-condition-handler' (q.v.).
236 A list whose car is Qunbound and whose cdr is Qt.
237 This is a special condition-case handler established
238 by C code with condition_case_1(). All errors are
239 trapped; the debugger is not invoked even if
240 `debug-on-error' was set.
242 A list whose car is Qunbound and whose cdr is Qerror.
243 This is a special condition-case handler established
244 by C code with condition_case_1(). It is like Qt
245 except that the debugger is invoked normally if it is
248 A list whose car is Qunbound and whose cdr is a list
249 of lists (CONDITION-NAME BODY ...) exactly as in
250 `condition-case'. This is a normal `condition-case'
253 Note that in all cases *except* the first, there is a
254 corresponding catch, whose TAG is the value of
255 Vcondition_handlers just after the handler data just
256 described is pushed onto it. The reason is that
257 `condition-case' handlers need to throw back to the
258 place where the handler was installed before invoking
259 it, while `call-with-condition-handler' handlers are
260 invoked in the environment that `signal' was invoked
263 static Lisp_Object Vcondition_handlers;
266 #define DEFEND_AGAINST_THROW_RECURSION
268 #ifdef DEFEND_AGAINST_THROW_RECURSION
269 /* Used for error catching purposes by throw_or_bomb_out */
270 static int throw_level;
273 #ifdef ERROR_CHECK_TYPECHECK
274 void check_error_state_sanity (void);
278 /************************************************************************/
279 /* The subr object type */
280 /************************************************************************/
283 print_subr (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
285 Lisp_Subr *subr = XSUBR (obj);
287 (subr->max_args == UNEVALLED) ? "#<special-form " : "#<subr ";
288 const char *name = subr_name (subr);
289 const char *trailer = subr->prompt ? " (interactive)>" : ">";
292 error ("printing unreadable object %s%s%s", header, name, trailer);
294 write_c_string (header, printcharfun);
295 write_c_string (name, printcharfun);
296 write_c_string (trailer, printcharfun);
299 static const struct lrecord_description subr_description[] = {
300 { XD_DOC_STRING, offsetof (Lisp_Subr, doc) },
304 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("subr", subr,
305 0, print_subr, 0, 0, 0,
309 /************************************************************************/
310 /* Entering the debugger */
311 /************************************************************************/
313 /* unwind-protect used by call_debugger() to restore the value of
314 entering_debugger. (We cannot use specbind() because the
315 variable is not Lisp-accessible.) */
318 restore_entering_debugger (Lisp_Object arg)
320 entering_debugger = ! NILP (arg);
324 /* Actually call the debugger. ARG is a list of args that will be
325 passed to the debugger function, as follows;
327 If due to frame exit, args are `exit' and the value being returned;
328 this function's value will be returned instead of that.
329 If due to error, args are `error' and a list of the args to `signal'.
330 If due to `apply' or `funcall' entry, one arg, `lambda'.
331 If due to `eval' entry, one arg, t.
336 call_debugger_259 (Lisp_Object arg)
338 return apply1 (Vdebugger, arg);
341 /* Call the debugger, doing some encapsulation. We make sure we have
342 some room on the eval and specpdl stacks, and bind entering_debugger
343 to 1 during this call. This is used to trap errors that may occur
344 when entering the debugger (e.g. the value of `debugger' is invalid),
345 so that the debugger will not be recursively entered if debug-on-error
346 is set. (Otherwise, XEmacs would infinitely recurse, attempting to
347 enter the debugger.) entering_debugger gets reset to 0 as soon
348 as a backtrace is displayed, so that further errors can indeed be
351 We also establish a catch for 'debugger. If the debugger function
352 throws to this instead of returning a value, it means that the user
353 pressed 'c' (pretend like the debugger was never entered). The
354 function then returns Qunbound. (If the user pressed 'r', for
355 return a value, then the debugger function returns normally with
358 The difference between 'c' and 'r' is as follows:
361 No difference. The call proceeds as normal.
363 With 'r', the specified value is returned as the function's
364 return value. With 'c', the value that would normally be
365 returned is returned.
367 With 'r', the specified value is returned as the return
368 value of `signal'. (This is the only time that `signal'
369 can return, instead of making a non-local exit.) With `c',
370 `signal' will continue looking for handlers as if the
371 debugger was never entered, and will probably end up
372 throwing to a handler or to top-level.
376 call_debugger (Lisp_Object arg)
382 if (lisp_eval_depth + 20 > max_lisp_eval_depth)
383 max_lisp_eval_depth = lisp_eval_depth + 20;
384 if (specpdl_size + 40 > max_specpdl_size)
385 max_specpdl_size = specpdl_size + 40;
386 debug_on_next_call = 0;
388 speccount = specpdl_depth();
389 record_unwind_protect (restore_entering_debugger,
390 (entering_debugger ? Qt : Qnil));
391 entering_debugger = 1;
392 val = internal_catch (Qdebugger, call_debugger_259, arg, &threw);
394 return unbind_to (speccount, ((threw)
395 ? Qunbound /* Not returning a value */
399 /* Called when debug-on-exit behavior is called for. Enter the debugger
400 with the appropriate args for this. VAL is the exit value that is
401 about to be returned. */
404 do_debug_on_exit (Lisp_Object val)
406 /* This is falsified by call_debugger */
407 Lisp_Object v = call_debugger (list2 (Qexit, val));
409 return !UNBOUNDP (v) ? v : val;
412 /* Called when debug-on-call behavior is called for. Enter the debugger
413 with the appropriate args for this. VAL is either t for a call
414 through `eval' or 'lambda for a call through `funcall'.
416 #### The differentiation here between EVAL and FUNCALL is bogus.
417 FUNCALL can be defined as
419 (defmacro func (fun &rest args)
420 (cons (eval fun) args))
422 and should be treated as such.
426 do_debug_on_call (Lisp_Object code)
428 debug_on_next_call = 0;
429 backtrace_list->debug_on_exit = 1;
430 call_debugger (list1 (code));
433 /* LIST is the value of one of the variables `debug-on-error',
434 `debug-on-signal', `stack-trace-on-error', or `stack-trace-on-signal',
435 and CONDITIONS is the list of error conditions associated with
436 the error being signalled. This returns non-nil if LIST
437 matches CONDITIONS. (A nil value for LIST does not match
438 CONDITIONS. A non-list value for LIST does match CONDITIONS.
439 A list matches CONDITIONS when one of the symbols in LIST is the
440 same as one of the symbols in CONDITIONS.) */
443 wants_debugger (Lisp_Object list, Lisp_Object conditions)
450 while (CONSP (conditions))
452 Lisp_Object this, tail;
453 this = XCAR (conditions);
454 for (tail = list; CONSP (tail); tail = XCDR (tail))
455 if (EQ (XCAR (tail), this))
457 conditions = XCDR (conditions);
463 /* Return 1 if an error with condition-symbols CONDITIONS,
464 and described by SIGNAL-DATA, should skip the debugger
465 according to debugger-ignore-errors. */
468 skip_debugger (Lisp_Object conditions, Lisp_Object data)
470 /* This function can GC */
472 int first_string = 1;
473 Lisp_Object error_message = Qnil;
475 for (tail = Vdebug_ignored_errors; CONSP (tail); tail = XCDR (tail))
477 if (STRINGP (XCAR (tail)))
481 error_message = Ferror_message_string (data);
484 if (fast_lisp_string_match (XCAR (tail), error_message) >= 0)
491 for (contail = conditions; CONSP (contail); contail = XCDR (contail))
492 if (EQ (XCAR (tail), XCAR (contail)))
500 /* Actually generate a backtrace on STREAM. */
503 backtrace_259 (Lisp_Object stream)
505 return Fbacktrace (stream, Qt);
508 /* An error was signaled. Maybe call the debugger, if the `debug-on-error'
509 etc. variables call for this. CONDITIONS is the list of conditions
510 associated with the error being signalled. SIG is the actual error
511 being signalled, and DATA is the associated data (these are exactly
512 the same as the arguments to `signal'). ACTIVE_HANDLERS is the
513 list of error handlers that are to be put in place while the debugger
514 is called. This is generally the remaining handlers that are
515 outside of the innermost handler trapping this error. This way,
516 if the same error occurs inside of the debugger, you usually don't get
517 the debugger entered recursively.
519 This function returns Qunbound if it didn't call the debugger or if
520 the user asked (through 'c') that XEmacs should pretend like the
521 debugger was never entered. Otherwise, it returns the value
522 that the user specified with `r'. (Note that much of the time,
523 the user will abort with C-], and we will never have a chance to
524 return anything at all.)
526 SIGNAL_VARS_ONLY means we should only look at debug-on-signal
527 and stack-trace-on-signal to control whether we do anything.
528 This is so that debug-on-error doesn't make handled errors
529 cause the debugger to get invoked.
531 STACK_TRACE_DISPLAYED and DEBUGGER_ENTERED are used so that
532 those functions aren't done more than once in a single `signal'
536 signal_call_debugger (Lisp_Object conditions,
537 Lisp_Object sig, Lisp_Object data,
538 Lisp_Object active_handlers,
539 int signal_vars_only,
540 int *stack_trace_displayed,
541 int *debugger_entered)
543 /* This function can GC */
544 Lisp_Object val = Qunbound;
545 Lisp_Object all_handlers = Vcondition_handlers;
546 Lisp_Object temp_data = Qnil;
547 int speccount = specpdl_depth();
548 struct gcpro gcpro1, gcpro2;
549 GCPRO2 (all_handlers, temp_data);
551 Vcondition_handlers = active_handlers;
553 temp_data = Fcons (sig, data); /* needed for skip_debugger */
555 if (!entering_debugger && !*stack_trace_displayed && !signal_vars_only
556 && wants_debugger (Vstack_trace_on_error, conditions)
557 && !skip_debugger (conditions, temp_data))
559 specbind (Qdebug_on_error, Qnil);
560 specbind (Qstack_trace_on_error, Qnil);
561 specbind (Qdebug_on_signal, Qnil);
562 specbind (Qstack_trace_on_signal, Qnil);
564 internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
568 unbind_to (speccount, Qnil);
569 *stack_trace_displayed = 1;
572 if (!entering_debugger && !*debugger_entered && !signal_vars_only
575 : wants_debugger (Vdebug_on_error, conditions))
576 && !skip_debugger (conditions, temp_data))
578 debug_on_quit &= ~2; /* reset critical bit */
579 specbind (Qdebug_on_error, Qnil);
580 specbind (Qstack_trace_on_error, Qnil);
581 specbind (Qdebug_on_signal, Qnil);
582 specbind (Qstack_trace_on_signal, Qnil);
584 val = call_debugger (list2 (Qerror, (Fcons (sig, data))));
585 *debugger_entered = 1;
588 if (!entering_debugger && !*stack_trace_displayed
589 && wants_debugger (Vstack_trace_on_signal, conditions))
591 specbind (Qdebug_on_error, Qnil);
592 specbind (Qstack_trace_on_error, Qnil);
593 specbind (Qdebug_on_signal, Qnil);
594 specbind (Qstack_trace_on_signal, Qnil);
596 internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
600 unbind_to (speccount, Qnil);
601 *stack_trace_displayed = 1;
604 if (!entering_debugger && !*debugger_entered
607 : wants_debugger (Vdebug_on_signal, conditions)))
609 debug_on_quit &= ~2; /* reset critical bit */
610 specbind (Qdebug_on_error, Qnil);
611 specbind (Qstack_trace_on_error, Qnil);
612 specbind (Qdebug_on_signal, Qnil);
613 specbind (Qstack_trace_on_signal, Qnil);
615 val = call_debugger (list2 (Qerror, (Fcons (sig, data))));
616 *debugger_entered = 1;
620 Vcondition_handlers = all_handlers;
621 return unbind_to (speccount, val);
625 /************************************************************************/
626 /* The basic special forms */
627 /************************************************************************/
629 /* Except for Fprogn(), the basic special forms below are only called
630 from interpreted code. The byte compiler turns them into bytecodes. */
632 DEFUN ("or", For, 0, UNEVALLED, 0, /*
633 Eval args until one of them yields non-nil, then return that value.
634 The remaining args are not evalled at all.
635 If all args return nil, return nil.
639 /* This function can GC */
640 REGISTER Lisp_Object arg, val;
642 LIST_LOOP_2 (arg, args)
644 if (!NILP (val = Feval (arg)))
651 DEFUN ("and", Fand, 0, UNEVALLED, 0, /*
652 Eval args until one of them yields nil, then return nil.
653 The remaining args are not evalled at all.
654 If no arg yields nil, return the last arg's value.
658 /* This function can GC */
659 REGISTER Lisp_Object arg, val = Qt;
661 LIST_LOOP_2 (arg, args)
663 if (NILP (val = Feval (arg)))
670 DEFUN ("if", Fif, 2, UNEVALLED, 0, /*
671 \(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...
672 Returns the value of THEN or the value of the last of the ELSE's.
673 THEN must be one expression, but ELSE... can be zero or more expressions.
674 If COND yields nil, and there are no ELSE's, the value is nil.
678 /* This function can GC */
679 Lisp_Object condition = XCAR (args);
680 Lisp_Object then_form = XCAR (XCDR (args));
681 Lisp_Object else_forms = XCDR (XCDR (args));
683 if (!NILP (Feval (condition)))
684 return Feval (then_form);
686 return Fprogn (else_forms);
689 /* Macros `when' and `unless' are trivially defined in Lisp,
690 but it helps for bootstrapping to have them ALWAYS defined. */
692 DEFUN ("when", Fwhen, 1, MANY, 0, /*
693 \(when COND BODY...): if COND yields non-nil, do BODY, else return nil.
694 BODY can be zero or more expressions. If BODY is nil, return nil.
696 (int nargs, Lisp_Object *args))
698 Lisp_Object cond = args[0];
703 case 1: body = Qnil; break;
704 case 2: body = args[1]; break;
705 default: body = Fcons (Qprogn, Flist (nargs-1, args+1)); break;
708 return list3 (Qif, cond, body);
711 DEFUN ("unless", Funless, 1, MANY, 0, /*
712 \(unless COND BODY...): if COND yields nil, do BODY, else return nil.
713 BODY can be zero or more expressions. If BODY is nil, return nil.
715 (int nargs, Lisp_Object *args))
717 Lisp_Object cond = args[0];
718 Lisp_Object body = Flist (nargs-1, args+1);
719 return Fcons (Qif, Fcons (cond, Fcons (Qnil, body)));
722 DEFUN ("cond", Fcond, 0, UNEVALLED, 0, /*
723 (cond CLAUSES...): try each clause until one succeeds.
724 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
725 and, if the value is non-nil, this clause succeeds:
726 then the expressions in BODY are evaluated and the last one's
727 value is the value of the cond-form.
728 If no clause succeeds, cond returns nil.
729 If a clause has one element, as in (CONDITION),
730 CONDITION's value if non-nil is returned from the cond-form.
734 /* This function can GC */
735 REGISTER Lisp_Object val, clause;
737 LIST_LOOP_2 (clause, args)
740 if (!NILP (val = Feval (XCAR (clause))))
742 if (!NILP (clause = XCDR (clause)))
744 CHECK_TRUE_LIST (clause);
745 val = Fprogn (clause);
754 DEFUN ("progn", Fprogn, 0, UNEVALLED, 0, /*
755 \(progn BODY...): eval BODY forms sequentially and return value of last one.
759 /* This function can GC */
760 /* Caller must provide a true list in ARGS */
761 REGISTER Lisp_Object form, val = Qnil;
767 LIST_LOOP_2 (form, args)
775 /* Fprog1() is the canonical example of a function that must GCPRO a
776 Lisp_Object across calls to Feval(). */
778 DEFUN ("prog1", Fprog1, 1, UNEVALLED, 0, /*
779 Similar to `progn', but the value of the first form is returned.
780 \(prog1 FIRST BODY...): All the arguments are evaluated sequentially.
781 The value of FIRST is saved during evaluation of the remaining args,
782 whose values are discarded.
786 /* This function can GC */
787 REGISTER Lisp_Object val, form;
790 val = Feval (XCAR (args));
795 LIST_LOOP_2 (form, XCDR (args))
803 DEFUN ("prog2", Fprog2, 2, UNEVALLED, 0, /*
804 Similar to `progn', but the value of the second form is returned.
805 \(prog2 FIRST SECOND BODY...): All the arguments are evaluated sequentially.
806 The value of SECOND is saved during evaluation of the remaining args,
807 whose values are discarded.
811 /* This function can GC */
812 REGISTER Lisp_Object val, form, tail;
817 val = Feval (XCAR (args));
822 LIST_LOOP_3 (form, args, tail)
829 DEFUN ("let*", FletX, 1, UNEVALLED, 0, /*
830 \(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.
831 The value of the last form in BODY is returned.
832 Each element of VARLIST is a symbol (which is bound to nil)
833 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
834 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
838 /* This function can GC */
839 Lisp_Object var, tail;
840 Lisp_Object varlist = XCAR (args);
841 Lisp_Object body = XCDR (args);
842 int speccount = specpdl_depth();
844 EXTERNAL_LIST_LOOP_3 (var, varlist, tail)
846 Lisp_Object symbol, value, tem;
848 symbol = var, value = Qnil;
859 value = Feval (XCAR (tem));
860 if (!NILP (XCDR (tem)))
862 ("`let' bindings can have only one value-form", var);
865 specbind (symbol, value);
867 return unbind_to (speccount, Fprogn (body));
870 DEFUN ("let", Flet, 1, UNEVALLED, 0, /*
871 \(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.
872 The value of the last form in BODY is returned.
873 Each element of VARLIST is a symbol (which is bound to nil)
874 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
875 All the VALUEFORMs are evalled before any symbols are bound.
879 /* This function can GC */
880 Lisp_Object var, tail;
881 Lisp_Object varlist = XCAR (args);
882 Lisp_Object body = XCDR (args);
883 int speccount = specpdl_depth();
888 /* Make space to hold the values to give the bound variables. */
891 GET_EXTERNAL_LIST_LENGTH (varlist, varcount);
892 temps = alloca_array (Lisp_Object, varcount);
895 /* Compute the values and store them in `temps' */
900 LIST_LOOP_3 (var, varlist, tail)
902 Lisp_Object *value = &temps[idx++];
915 *value = Feval (XCAR (tem));
918 if (!NILP (XCDR (tem)))
920 ("`let' bindings can have only one value-form", var);
926 LIST_LOOP_3 (var, varlist, tail)
928 specbind (SYMBOLP (var) ? var : XCAR (var), temps[idx++]);
933 return unbind_to (speccount, Fprogn (body));
936 DEFUN ("while", Fwhile, 1, UNEVALLED, 0, /*
937 \(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.
938 The order of execution is thus TEST, BODY, TEST, BODY and so on
939 until TEST returns nil.
943 /* This function can GC */
944 Lisp_Object test = XCAR (args);
945 Lisp_Object body = XCDR (args);
947 while (!NILP (Feval (test)))
956 DEFUN ("setq", Fsetq, 0, UNEVALLED, 0, /*
957 \(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.
958 The symbols SYM are variables; they are literal (not evaluated).
959 The values VAL are expressions; they are evaluated.
960 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
961 The second VAL is not computed until after the first SYM is set, and so on;
962 each VAL can use the new value of variables set earlier in the `setq'.
963 The return value of the `setq' form is the value of the last VAL.
967 /* This function can GC */
968 Lisp_Object symbol, tail, val = Qnil;
972 GET_LIST_LENGTH (args, nargs);
974 if (nargs & 1) /* Odd number of arguments? */
975 Fsignal (Qwrong_number_of_arguments, list2 (Qsetq, make_int (nargs)));
979 PROPERTY_LIST_LOOP (tail, symbol, val, args)
989 DEFUN ("quote", Fquote, 1, UNEVALLED, 0, /*
990 Return the argument, without evaluating it. `(quote x)' yields `x'.
997 DEFUN ("function", Ffunction, 1, UNEVALLED, 0, /*
998 Like `quote', but preferred for objects which are functions.
999 In byte compilation, `function' causes its argument to be compiled.
1000 `quote' cannot do that.
1008 /************************************************************************/
1009 /* Defining functions/variables */
1010 /************************************************************************/
1012 define_function (Lisp_Object name, Lisp_Object defn)
1015 LOADHIST_ATTACH (name);
1019 DEFUN ("defun", Fdefun, 2, UNEVALLED, 0, /*
1020 \(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.
1021 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
1022 See also the function `interactive'.
1026 /* This function can GC */
1027 return define_function (XCAR (args),
1028 Fcons (Qlambda, XCDR (args)));
1031 DEFUN ("defmacro", Fdefmacro, 2, UNEVALLED, 0, /*
1032 \(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.
1033 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).
1034 When the macro is called, as in (NAME ARGS...),
1035 the function (lambda ARGLIST BODY...) is applied to
1036 the list ARGS... as it appears in the expression,
1037 and the result should be a form to be evaluated instead of the original.
1041 /* This function can GC */
1042 return define_function (XCAR (args),
1043 Fcons (Qmacro, Fcons (Qlambda, XCDR (args))));
1046 DEFUN ("defvar", Fdefvar, 1, UNEVALLED, 0, /*
1047 \(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.
1048 You are not required to define a variable in order to use it,
1049 but the definition can supply documentation and an initial value
1050 in a way that tags can recognize.
1052 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is
1053 void. (However, when you evaluate a defvar interactively, it acts like a
1054 defconst: SYMBOL's value is always set regardless of whether it's currently
1056 If SYMBOL is buffer-local, its default value is what is set;
1057 buffer-local values are not affected.
1058 INITVALUE and DOCSTRING are optional.
1059 If DOCSTRING starts with *, this variable is identified as a user option.
1060 This means that M-x set-variable recognizes it.
1061 If INITVALUE is missing, SYMBOL's value is not set.
1063 In lisp-interaction-mode defvar is treated as defconst.
1067 /* This function can GC */
1068 Lisp_Object sym = XCAR (args);
1070 if (!NILP (args = XCDR (args)))
1072 Lisp_Object val = XCAR (args);
1074 if (NILP (Fdefault_boundp (sym)))
1076 struct gcpro gcpro1;
1079 Fset_default (sym, val);
1083 if (!NILP (args = XCDR (args)))
1085 Lisp_Object doc = XCAR (args);
1086 Fput (sym, Qvariable_documentation, doc);
1087 if (!NILP (args = XCDR (args)))
1088 error ("too many arguments");
1093 if (!NILP (Vfile_domain))
1094 Fput (sym, Qvariable_domain, Vfile_domain);
1097 LOADHIST_ATTACH (sym);
1101 DEFUN ("defconst", Fdefconst, 2, UNEVALLED, 0, /*
1102 \(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant
1104 The intent is that programs do not change this value, but users may.
1105 Always sets the value of SYMBOL to the result of evalling INITVALUE.
1106 If SYMBOL is buffer-local, its default value is what is set;
1107 buffer-local values are not affected.
1108 DOCSTRING is optional.
1109 If DOCSTRING starts with *, this variable is identified as a user option.
1110 This means that M-x set-variable recognizes it.
1112 Note: do not use `defconst' for user options in libraries that are not
1113 normally loaded, since it is useful for users to be able to specify
1114 their own values for such variables before loading the library.
1115 Since `defconst' unconditionally assigns the variable,
1116 it would override the user's choice.
1120 /* This function can GC */
1121 Lisp_Object sym = XCAR (args);
1122 Lisp_Object val = Feval (XCAR (args = XCDR (args)));
1123 struct gcpro gcpro1;
1127 Fset_default (sym, val);
1131 if (!NILP (args = XCDR (args)))
1133 Lisp_Object doc = XCAR (args);
1134 Fput (sym, Qvariable_documentation, doc);
1135 if (!NILP (args = XCDR (args)))
1136 error ("too many arguments");
1140 if (!NILP (Vfile_domain))
1141 Fput (sym, Qvariable_domain, Vfile_domain);
1144 LOADHIST_ATTACH (sym);
1148 DEFUN ("user-variable-p", Fuser_variable_p, 1, 1, 0, /*
1149 Return t if VARIABLE is intended to be set and modified by users.
1150 \(The alternative is a variable used internally in a Lisp program.)
1151 Determined by whether the first character of the documentation
1152 for the variable is `*'.
1156 Lisp_Object documentation = Fget (variable, Qvariable_documentation, Qnil);
1159 ((INTP (documentation) && XINT (documentation) < 0) ||
1161 (STRINGP (documentation) &&
1162 (string_byte (XSTRING (documentation), 0) == '*')) ||
1164 /* If (STRING . INTEGER), a negative integer means a user variable. */
1165 (CONSP (documentation)
1166 && STRINGP (XCAR (documentation))
1167 && INTP (XCDR (documentation))
1168 && XINT (XCDR (documentation)) < 0)) ?
1172 DEFUN ("macroexpand-internal", Fmacroexpand_internal, 1, 2, 0, /*
1173 Return result of expanding macros at top level of FORM.
1174 If FORM is not a macro call, it is returned unchanged.
1175 Otherwise, the macro is expanded and the expansion is considered
1176 in place of FORM. When a non-macro-call results, it is returned.
1178 The second optional arg ENVIRONMENT species an environment of macro
1179 definitions to shadow the loaded ones for use in file byte-compilation.
1183 /* This function can GC */
1184 /* With cleanups from Hallvard Furuseth. */
1185 REGISTER Lisp_Object expander, sym, def, tem;
1189 /* Come back here each time we expand a macro call,
1190 in case it expands into another macro call. */
1193 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1194 def = sym = XCAR (form);
1196 /* Trace symbols aliases to other symbols
1197 until we get a symbol that is not an alias. */
1198 while (SYMBOLP (def))
1202 tem = Fassq (sym, env);
1205 def = XSYMBOL (sym)->function;
1206 if (!UNBOUNDP (def))
1211 /* Right now TEM is the result from SYM in ENV,
1212 and if TEM is nil then DEF is SYM's function definition. */
1215 /* SYM is not mentioned in ENV.
1216 Look at its function definition. */
1219 /* Not defined or definition not suitable */
1221 if (EQ (XCAR (def), Qautoload))
1223 /* Autoloading function: will it be a macro when loaded? */
1224 tem = Felt (def, make_int (4));
1225 if (EQ (tem, Qt) || EQ (tem, Qmacro))
1227 /* Yes, load it and try again. */
1228 do_autoload (def, sym);
1234 else if (!EQ (XCAR (def), Qmacro))
1236 else expander = XCDR (def);
1240 expander = XCDR (tem);
1241 if (NILP (expander))
1244 form = apply1 (expander, XCDR (form));
1250 /************************************************************************/
1251 /* Non-local exits */
1252 /************************************************************************/
1254 DEFUN ("catch", Fcatch, 1, UNEVALLED, 0, /*
1255 \(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.
1256 TAG is evalled to get the tag to use. Then the BODY is executed.
1257 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.
1258 If no throw happens, `catch' returns the value of the last BODY form.
1259 If a throw happens, it specifies the value to return from `catch'.
1263 /* This function can GC */
1264 Lisp_Object tag = Feval (XCAR (args));
1265 Lisp_Object body = XCDR (args);
1266 return internal_catch (tag, Fprogn, body, 0);
1269 /* Set up a catch, then call C function FUNC on argument ARG.
1270 FUNC should return a Lisp_Object.
1271 This is how catches are done from within C code. */
1274 internal_catch (Lisp_Object tag,
1275 Lisp_Object (*func) (Lisp_Object arg),
1277 int * volatile threw)
1279 /* This structure is made part of the chain `catchlist'. */
1282 /* Fill in the components of c, and put it on the list. */
1286 c.backlist = backtrace_list;
1289 c.handlerlist = handlerlist;
1291 c.lisp_eval_depth = lisp_eval_depth;
1292 c.pdlcount = specpdl_depth();
1294 c.poll_suppress_count = async_timer_suppress_count;
1296 c.gcpro = gcprolist;
1302 /* Throw works by a longjmp that comes right here. */
1303 if (threw) *threw = 1;
1306 c.val = (*func) (arg);
1307 if (threw) *threw = 0;
1309 #ifdef ERROR_CHECK_TYPECHECK
1310 check_error_state_sanity ();
1316 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1317 jump to that CATCH, returning VALUE as the value of that catch.
1319 This is the guts Fthrow and Fsignal; they differ only in the way
1320 they choose the catch tag to throw to. A catch tag for a
1321 condition-case form has a TAG of Qnil.
1323 Before each catch is discarded, unbind all special bindings and
1324 execute all unwind-protect clauses made above that catch. Unwind
1325 the handler stack as we go, so that the proper handlers are in
1326 effect for each unwind-protect clause we run. At the end, restore
1327 some static info saved in CATCH, and longjmp to the location
1330 This is used for correct unwinding in Fthrow and Fsignal. */
1333 unwind_to_catch (struct catchtag *c, Lisp_Object val)
1337 REGISTER int last_time;
1340 /* Unwind the specbind, catch, and handler stacks back to CATCH
1341 Before each catch is discarded, unbind all special bindings
1342 and execute all unwind-protect clauses made above that catch.
1343 At the end, restore some static info saved in CATCH,
1344 and longjmp to the location specified.
1347 /* Save the value somewhere it will be GC'ed.
1348 (Can't overwrite tag slot because an unwind-protect may
1349 want to throw to this same tag, which isn't yet invalid.) */
1353 /* Restore the polling-suppression count. */
1354 set_poll_suppress_count (catch->poll_suppress_count);
1358 /* #### FSFmacs has the following loop. Is it more correct? */
1361 last_time = catchlist == c;
1363 /* Unwind the specpdl stack, and then restore the proper set of
1365 unbind_to (catchlist->pdlcount, Qnil);
1366 handlerlist = catchlist->handlerlist;
1367 catchlist = catchlist->next;
1368 #ifdef ERROR_CHECK_TYPECHECK
1369 check_error_state_sanity ();
1372 while (! last_time);
1373 #else /* Actual XEmacs code */
1374 /* Unwind the specpdl stack */
1375 unbind_to (c->pdlcount, Qnil);
1376 catchlist = c->next;
1377 #ifdef ERROR_CHECK_TYPECHECK
1378 check_error_state_sanity ();
1382 gcprolist = c->gcpro;
1383 backtrace_list = c->backlist;
1384 lisp_eval_depth = c->lisp_eval_depth;
1386 #ifdef DEFEND_AGAINST_THROW_RECURSION
1389 LONGJMP (c->jmp, 1);
1392 static DOESNT_RETURN
1393 throw_or_bomb_out (Lisp_Object tag, Lisp_Object val, int bomb_out_p,
1394 Lisp_Object sig, Lisp_Object data)
1396 #ifdef DEFEND_AGAINST_THROW_RECURSION
1397 /* die if we recurse more than is reasonable */
1398 if (++throw_level > 20)
1402 /* If bomb_out_p is t, this is being called from Fsignal as a
1403 "last resort" when there is no handler for this error and
1404 the debugger couldn't be invoked, so we are throwing to
1405 'top-level. If this tag doesn't exist (happens during the
1406 initialization stages) we would get in an infinite recursive
1407 Fsignal/Fthrow loop, so instead we bomb out to the
1408 really-early-error-handler.
1410 Note that in fact the only time that the "last resort"
1411 occurs is when there's no catch for 'top-level -- the
1412 'top-level catch and the catch-all error handler are
1413 established at the same time, in initial_command_loop/
1416 #### Fix this horrifitude!
1421 REGISTER struct catchtag *c;
1424 if (!NILP (tag)) /* #### */
1426 for (c = catchlist; c; c = c->next)
1428 if (EQ (c->tag, tag))
1429 unwind_to_catch (c, val);
1432 tag = Fsignal (Qno_catch, list2 (tag, val));
1434 call1 (Qreally_early_error_handler, Fcons (sig, data));
1437 /* can't happen. who cares? - (Sun's compiler does) */
1438 /* throw_level--; */
1439 /* getting tired of compilation warnings */
1443 /* See above, where CATCHLIST is defined, for a description of how
1446 Fthrow() is also called by Fsignal(), to do a non-local jump
1447 back to the appropriate condition-case handler after (maybe)
1448 the debugger is entered. In that case, TAG is the value
1449 of Vcondition_handlers that was in place just after the
1450 condition-case handler was set up. The car of this will be
1451 some data referring to the handler: Its car will be Qunbound
1452 (thus, this tag can never be generated by Lisp code), and
1453 its CDR will be the HANDLERS argument to condition_case_1()
1454 (either Qerror, Qt, or a list of handlers as in `condition-case').
1455 This works fine because Fthrow() does not care what TAG was
1456 passed to it: it just looks up the catch list for something
1457 that is EQ() to TAG. When it finds it, it will longjmp()
1458 back to the place that established the catch (in this case,
1459 condition_case_1). See below for more info.
1462 DEFUN ("throw", Fthrow, 2, 2, 0, /*
1463 \(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.
1464 Both TAG and VALUE are evalled.
1468 throw_or_bomb_out (tag, val, 0, Qnil, Qnil); /* Doesn't return */
1472 DEFUN ("unwind-protect", Funwind_protect, 1, UNEVALLED, 0, /*
1473 Do BODYFORM, protecting with UNWINDFORMS.
1474 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).
1475 If BODYFORM completes normally, its value is returned
1476 after executing the UNWINDFORMS.
1477 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1481 /* This function can GC */
1482 int speccount = specpdl_depth();
1484 record_unwind_protect (Fprogn, XCDR (args));
1485 return unbind_to (speccount, Feval (XCAR (args)));
1489 /************************************************************************/
1490 /* Signalling and trapping errors */
1491 /************************************************************************/
1494 condition_bind_unwind (Lisp_Object loser)
1497 /* ((handler-fun . handler-args) ... other handlers) */
1498 Lisp_Object tem = XCAR (loser);
1502 victim = XCONS (tem);
1506 victim = XCONS (loser);
1508 if (EQ (loser, Vcondition_handlers)) /* may have been rebound to some tail */
1509 Vcondition_handlers = victim->cdr;
1516 condition_case_unwind (Lisp_Object loser)
1520 /* ((<unbound> . clauses) ... other handlers */
1521 victim = XCONS (XCAR (loser));
1524 victim = XCONS (loser);
1525 if (EQ (loser, Vcondition_handlers)) /* may have been rebound to some tail */
1526 Vcondition_handlers = victim->cdr;
1532 /* Split out from condition_case_3 so that primitive C callers
1533 don't have to cons up a lisp handler form to be evaluated. */
1535 /* Call a function BFUN of one argument BARG, trapping errors as
1536 specified by HANDLERS. If no error occurs that is indicated by
1537 HANDLERS as something to be caught, the return value of this
1538 function is the return value from BFUN. If such an error does
1539 occur, HFUN is called, and its return value becomes the
1540 return value of condition_case_1(). The second argument passed
1541 to HFUN will always be HARG. The first argument depends on
1544 If HANDLERS is Qt, all errors (this includes QUIT, but not
1545 non-local exits with `throw') cause HFUN to be invoked, and VAL
1546 (the first argument to HFUN) is a cons (SIG . DATA) of the
1547 arguments passed to `signal'. The debugger is not invoked even if
1548 `debug-on-error' was set.
1550 A HANDLERS value of Qerror is the same as Qt except that the
1551 debugger is invoked if `debug-on-error' was set.
1553 Otherwise, HANDLERS should be a list of lists (CONDITION-NAME BODY ...)
1554 exactly as in `condition-case', and errors will be trapped
1555 as indicated in HANDLERS. VAL (the first argument to HFUN) will
1556 be a cons whose car is the cons (SIG . DATA) and whose CDR is the
1557 list (BODY ...) from the appropriate slot in HANDLERS.
1559 This function pushes HANDLERS onto the front of Vcondition_handlers
1560 (actually with a Qunbound marker as well -- see Fthrow() above
1561 for why), establishes a catch whose tag is this new value of
1562 Vcondition_handlers, and calls BFUN. When Fsignal() is called,
1563 it calls Fthrow(), setting TAG to this same new value of
1564 Vcondition_handlers and setting VAL to the same thing that will
1565 be passed to HFUN, as above. Fthrow() longjmp()s back to the
1566 jump point we just established, and we in turn just call the
1567 HFUN and return its value.
1569 For a real condition-case, HFUN will always be
1570 run_condition_case_handlers() and HARG is the argument VAR
1571 to condition-case. That function just binds VAR to the cons
1572 (SIG . DATA) that is the CAR of VAL, and calls the handler
1573 (BODY ...) that is the CDR of VAL. Note that before calling
1574 Fthrow(), Fsignal() restored Vcondition_handlers to the value
1575 it had *before* condition_case_1() was called. This maintains
1576 consistency (so that the state of things at exit of
1577 condition_case_1() is the same as at entry), and implies
1578 that the handler can signal the same error again (possibly
1579 after processing of its own), without getting in an infinite
1583 condition_case_1 (Lisp_Object handlers,
1584 Lisp_Object (*bfun) (Lisp_Object barg),
1586 Lisp_Object (*hfun) (Lisp_Object val, Lisp_Object harg),
1589 int speccount = specpdl_depth();
1591 struct gcpro gcpro1;
1596 /* Do consing now so out-of-memory error happens up front */
1597 /* (unbound . stuff) is a special condition-case kludge marker
1598 which is known specially by Fsignal.
1599 This is an abomination, but to fix it would require either
1600 making condition_case cons (a union of the conditions of the clauses)
1601 or changing the byte-compiler output (no thanks). */
1602 c.tag = noseeum_cons (noseeum_cons (Qunbound, handlers),
1603 Vcondition_handlers);
1606 c.backlist = backtrace_list;
1609 c.handlerlist = handlerlist;
1611 c.lisp_eval_depth = lisp_eval_depth;
1612 c.pdlcount = specpdl_depth();
1614 c.poll_suppress_count = async_timer_suppress_count;
1616 c.gcpro = gcprolist;
1617 /* #### FSFmacs does the following statement *after* the setjmp(). */
1622 /* throw does ungcpro, etc */
1623 return (*hfun) (c.val, harg);
1626 record_unwind_protect (condition_case_unwind, c.tag);
1630 h.handler = handlers;
1632 h.next = handlerlist;
1636 Vcondition_handlers = c.tag;
1638 GCPRO1 (harg); /* Somebody has to gc-protect */
1640 c.val = ((*bfun) (barg));
1642 /* The following is *not* true: (ben)
1644 ungcpro, restoring catchlist and condition_handlers are actually
1645 redundant since unbind_to now restores them. But it looks funny not to
1646 have this code here, and it doesn't cost anything, so I'm leaving it.*/
1649 #ifdef ERROR_CHECK_TYPECHECK
1650 check_error_state_sanity ();
1652 Vcondition_handlers = XCDR (c.tag);
1654 return unbind_to (speccount, c.val);
1658 run_condition_case_handlers (Lisp_Object val, Lisp_Object var)
1660 /* This function can GC */
1663 specbind (h.var, c.val);
1664 val = Fprogn (Fcdr (h.chosen_clause));
1666 /* Note that this just undoes the binding of h.var; whoever
1667 longjmp()ed to us unwound the stack to c.pdlcount before
1669 unbind_to (c.pdlcount, Qnil);
1674 CHECK_TRUE_LIST (val);
1676 return Fprogn (Fcdr (val)); /* tail call */
1678 speccount = specpdl_depth();
1679 specbind (var, Fcar (val));
1680 val = Fprogn (Fcdr (val));
1681 return unbind_to (speccount, val);
1685 /* Here for bytecode to call non-consfully. This is exactly like
1686 condition-case except that it takes three arguments rather
1687 than a single list of arguments. */
1689 condition_case_3 (Lisp_Object bodyform, Lisp_Object var, Lisp_Object handlers)
1691 /* This function can GC */
1692 Lisp_Object handler;
1694 EXTERNAL_LIST_LOOP_2 (handler, handlers)
1698 else if (CONSP (handler))
1700 Lisp_Object conditions = XCAR (handler);
1701 /* CONDITIONS must a condition name or a list of condition names */
1702 if (SYMBOLP (conditions))
1706 Lisp_Object condition;
1707 EXTERNAL_LIST_LOOP_2 (condition, conditions)
1708 if (!SYMBOLP (condition))
1709 goto invalid_condition_handler;
1714 invalid_condition_handler:
1715 signal_simple_error ("Invalid condition handler", handler);
1721 return condition_case_1 (handlers,
1723 run_condition_case_handlers,
1727 DEFUN ("condition-case", Fcondition_case, 2, UNEVALLED, 0, /*
1728 Regain control when an error is signalled.
1729 Usage looks like (condition-case VAR BODYFORM HANDLERS...).
1730 Executes BODYFORM and returns its value if no error happens.
1731 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1732 where the BODY is made of Lisp expressions.
1734 A handler is applicable to an error if CONDITION-NAME is one of the
1735 error's condition names. If an error happens, the first applicable
1736 handler is run. As a special case, a CONDITION-NAME of t matches
1737 all errors, even those without the `error' condition name on them
1740 The car of a handler may be a list of condition names
1741 instead of a single condition name.
1743 When a handler handles an error,
1744 control returns to the condition-case and the handler BODY... is executed
1745 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).
1746 VAR may be nil; then you do not get access to the signal information.
1748 The value of the last BODY form is returned from the condition-case.
1749 See also the function `signal' for more info.
1751 Note that at the time the condition handler is invoked, the Lisp stack
1752 and the current catches, condition-cases, and bindings have all been
1753 popped back to the state they were in just before the call to
1754 `condition-case'. This means that resignalling the error from
1755 within the handler will not result in an infinite loop.
1757 If you want to establish an error handler that is called with the
1758 Lisp stack, bindings, etc. as they were when `signal' was called,
1759 rather than when the handler was set, use `call-with-condition-handler'.
1763 /* This function can GC */
1764 Lisp_Object var = XCAR (args);
1765 Lisp_Object bodyform = XCAR (XCDR (args));
1766 Lisp_Object handlers = XCDR (XCDR (args));
1767 return condition_case_3 (bodyform, var, handlers);
1770 DEFUN ("call-with-condition-handler", Fcall_with_condition_handler, 2, MANY, 0, /*
1771 Regain control when an error is signalled, without popping the stack.
1772 Usage looks like (call-with-condition-handler HANDLER FUNCTION &rest ARGS).
1773 This function is similar to `condition-case', but the handler is invoked
1774 with the same environment (Lisp stack, bindings, catches, condition-cases)
1775 that was current when `signal' was called, rather than when the handler
1778 HANDLER should be a function of one argument, which is a cons of the args
1779 \(SIG . DATA) that were passed to `signal'. It is invoked whenever
1780 `signal' is called (this differs from `condition-case', which allows
1781 you to specify which errors are trapped). If the handler function
1782 returns, `signal' continues as if the handler were never invoked.
1783 \(It continues to look for handlers established earlier than this one,
1784 and invokes the standard error-handler if none is found.)
1786 (int nargs, Lisp_Object *args)) /* Note! Args side-effected! */
1788 /* This function can GC */
1789 int speccount = specpdl_depth();
1792 /* #### If there were a way to check that args[0] were a function
1793 which accepted one arg, that should be done here ... */
1795 /* (handler-fun . handler-args) */
1796 tem = noseeum_cons (list1 (args[0]), Vcondition_handlers);
1797 record_unwind_protect (condition_bind_unwind, tem);
1798 Vcondition_handlers = tem;
1800 /* Caller should have GC-protected args */
1801 return unbind_to (speccount, Ffuncall (nargs - 1, args + 1));
1805 condition_type_p (Lisp_Object type, Lisp_Object conditions)
1808 /* (condition-case c # (t c)) catches -all- signals
1809 * Use with caution! */
1813 return !NILP (Fmemq (type, conditions));
1815 for (; CONSP (type); type = XCDR (type))
1816 if (!NILP (Fmemq (XCAR (type), conditions)))
1823 return_from_signal (Lisp_Object value)
1826 /* Most callers are not prepared to handle gc if this
1827 returns. So, since this feature is not very useful,
1829 /* Have called debugger; return value to signaller */
1831 #else /* But the reality is that that stinks, because: */
1832 /* GACK!!! Really want some way for debug-on-quit errors
1833 to be continuable!! */
1834 error ("Returning a value from an error is no longer supported");
1838 extern int in_display;
1841 /************************************************************************/
1842 /* the workhorse error-signaling function */
1843 /************************************************************************/
1845 /* #### This function has not been synched with FSF. It diverges
1849 signal_1 (Lisp_Object sig, Lisp_Object data)
1851 /* This function can GC */
1852 struct gcpro gcpro1, gcpro2;
1853 Lisp_Object conditions;
1854 Lisp_Object handlers;
1855 /* signal_call_debugger() could get called more than once
1856 (once when a call-with-condition-handler is about to
1857 be dealt with, and another when a condition-case handler
1858 is about to be invoked). So make sure the debugger and/or
1859 stack trace aren't done more than once. */
1860 int stack_trace_displayed = 0;
1861 int debugger_entered = 0;
1862 GCPRO2 (conditions, handlers);
1866 /* who knows how much has been initialized? Safest bet is
1867 just to bomb out immediately. */
1868 /* let's not use stderr_out() here, because that does a bunch of
1869 things that might not be safe yet. */
1870 fprintf (stderr, "Error before initialization is complete!\n");
1874 if (gc_in_progress || in_display)
1875 /* This is one of many reasons why you can't run lisp code from redisplay.
1876 There is no sensible way to handle errors there. */
1879 conditions = Fget (sig, Qerror_conditions, Qnil);
1881 for (handlers = Vcondition_handlers;
1883 handlers = XCDR (handlers))
1885 Lisp_Object handler_fun = XCAR (XCAR (handlers));
1886 Lisp_Object handler_data = XCDR (XCAR (handlers));
1887 Lisp_Object outer_handlers = XCDR (handlers);
1889 if (!UNBOUNDP (handler_fun))
1891 /* call-with-condition-handler */
1893 Lisp_Object all_handlers = Vcondition_handlers;
1894 struct gcpro ngcpro1;
1895 NGCPRO1 (all_handlers);
1896 Vcondition_handlers = outer_handlers;
1898 tem = signal_call_debugger (conditions, sig, data,
1900 &stack_trace_displayed,
1902 if (!UNBOUNDP (tem))
1903 RETURN_NUNGCPRO (return_from_signal (tem));
1905 tem = Fcons (sig, data);
1906 if (NILP (handler_data))
1907 tem = call1 (handler_fun, tem);
1910 /* (This code won't be used (for now?).) */
1911 struct gcpro nngcpro1;
1912 Lisp_Object args[3];
1915 args[0] = handler_fun;
1917 args[2] = handler_data;
1918 nngcpro1.var = args;
1919 tem = Fapply (3, args);
1924 if (!EQ (tem, Qsignal))
1925 return return_from_signal (tem);
1927 /* If handler didn't throw, try another handler */
1928 Vcondition_handlers = all_handlers;
1931 /* It's a condition-case handler */
1933 /* t is used by handlers for all conditions, set up by C code.
1934 * debugger is not called even if debug_on_error */
1935 else if (EQ (handler_data, Qt))
1938 return Fthrow (handlers, Fcons (sig, data));
1940 /* `error' is used similarly to the way `t' is used, but in
1941 addition it invokes the debugger if debug_on_error.
1942 This is normally used for the outer command-loop error
1944 else if (EQ (handler_data, Qerror))
1946 Lisp_Object tem = signal_call_debugger (conditions, sig, data,
1948 &stack_trace_displayed,
1952 if (!UNBOUNDP (tem))
1953 return return_from_signal (tem);
1955 tem = Fcons (sig, data);
1956 return Fthrow (handlers, tem);
1960 /* handler established by real (Lisp) condition-case */
1963 for (h = handler_data; CONSP (h); h = Fcdr (h))
1965 Lisp_Object clause = Fcar (h);
1966 Lisp_Object tem = Fcar (clause);
1968 if (condition_type_p (tem, conditions))
1970 tem = signal_call_debugger (conditions, sig, data,
1972 &stack_trace_displayed,
1975 if (!UNBOUNDP (tem))
1976 return return_from_signal (tem);
1978 /* Doesn't return */
1979 tem = Fcons (Fcons (sig, data), Fcdr (clause));
1980 return Fthrow (handlers, tem);
1986 /* If no handler is present now, try to run the debugger,
1987 and if that fails, throw to top level.
1989 #### The only time that no handler is present is during
1990 temacs or perhaps very early in XEmacs. In both cases,
1991 there is no 'top-level catch. (That's why the
1992 "bomb-out" hack was added.)
1994 #### Fix this horrifitude!
1996 signal_call_debugger (conditions, sig, data, Qnil, 0,
1997 &stack_trace_displayed,
2000 throw_or_bomb_out (Qtop_level, Qt, 1, sig, data); /* Doesn't return */
2005 /****************** Error functions class 1 ******************/
2007 /* Class 1: General functions that signal an error.
2008 These functions take an error type and a list of associated error
2011 /* The simplest external error function: it would be called
2012 signal_continuable_error() in the terminology below, but it's
2015 DEFUN ("signal", Fsignal, 2, 2, 0, /*
2016 Signal a continuable error. Args are ERROR-SYMBOL, and associated DATA.
2017 An error symbol is a symbol defined using `define-error'.
2018 DATA should be a list. Its elements are printed as part of the error message.
2019 If the signal is handled, DATA is made available to the handler.
2020 See also the function `signal-error', and the functions to handle errors:
2021 `condition-case' and `call-with-condition-handler'.
2023 Note that this function can return, if the debugger is invoked and the
2024 user invokes the "return from signal" option.
2026 (error_symbol, data))
2028 /* Fsignal() is one of these functions that's called all the time
2029 with newly-created Lisp objects. We allow this; but we must GC-
2030 protect the objects because all sorts of weird stuff could
2033 struct gcpro gcpro1;
2036 if (!NILP (Vcurrent_error_state))
2038 if (!NILP (Vcurrent_warning_class))
2039 warn_when_safe_lispobj (Vcurrent_warning_class, Qwarning,
2040 Fcons (error_symbol, data));
2041 Fthrow (Qunbound_suspended_errors_tag, Qnil);
2042 abort (); /* Better not get here! */
2044 RETURN_UNGCPRO (signal_1 (error_symbol, data));
2047 /* Signal a non-continuable error. */
2050 signal_error (Lisp_Object sig, Lisp_Object data)
2053 Fsignal (sig, data);
2055 #ifdef ERROR_CHECK_TYPECHECK
2057 check_error_state_sanity (void)
2060 int found_error_tag = 0;
2062 for (c = catchlist; c; c = c->next)
2064 if (EQ (c->tag, Qunbound_suspended_errors_tag))
2066 found_error_tag = 1;
2071 assert (found_error_tag || NILP (Vcurrent_error_state));
2076 restore_current_warning_class (Lisp_Object warning_class)
2078 Vcurrent_warning_class = warning_class;
2083 restore_current_error_state (Lisp_Object error_state)
2085 Vcurrent_error_state = error_state;
2090 call_with_suspended_errors_1 (Lisp_Object opaque_arg)
2093 Lisp_Object *kludgy_args = (Lisp_Object *) get_opaque_ptr (opaque_arg);
2094 Lisp_Object no_error = kludgy_args[2];
2095 int speccount = specpdl_depth ();
2097 if (!EQ (Vcurrent_error_state, no_error))
2099 record_unwind_protect (restore_current_error_state,
2100 Vcurrent_error_state);
2101 Vcurrent_error_state = no_error;
2103 PRIMITIVE_FUNCALL (val, get_opaque_ptr (kludgy_args[0]),
2104 kludgy_args + 3, XINT (kludgy_args[1]));
2105 return unbind_to (speccount, val);
2108 /* Many functions would like to do one of three things if an error
2111 (1) signal the error, as usual.
2112 (2) silently fail and return some error value.
2113 (3) do as (2) but issue a warning in the process.
2115 Currently there's lots of stuff that passes an Error_behavior
2116 value and calls maybe_signal_error() and other such functions.
2117 This approach is inherently error-prone and broken. A much
2118 more robust and easier approach is to use call_with_suspended_errors().
2119 Wrap this around any function in which you might want errors
2124 call_with_suspended_errors (lisp_fn_t fun, volatile Lisp_Object retval,
2125 Lisp_Object class, Error_behavior errb,
2130 Lisp_Object kludgy_args[23];
2131 Lisp_Object *args = kludgy_args + 3;
2133 Lisp_Object no_error;
2135 assert (SYMBOLP (class)); /* sanity-check */
2136 assert (!NILP (class));
2137 assert (nargs >= 0 && nargs < 20);
2139 /* ERROR_ME means don't trap errors. (However, if errors are
2140 already trapped, we leave them trapped.)
2142 Otherwise, we trap errors, and trap warnings if ERROR_ME_WARN.
2144 If ERROR_ME_NOT, it causes no warnings even if warnings
2145 were previously enabled. However, we never change the
2146 warning class from one to another. */
2147 if (!ERRB_EQ (errb, ERROR_ME))
2149 if (ERRB_EQ (errb, ERROR_ME_NOT)) /* person wants no warnings */
2151 errb = ERROR_ME_NOT;
2157 va_start (vargs, nargs);
2158 for (i = 0; i < nargs; i++)
2159 args[i] = va_arg (vargs, Lisp_Object);
2162 /* If error-checking is not disabled, just call the function.
2163 It's important not to override disabled error-checking with
2164 enabled error-checking. */
2166 if (ERRB_EQ (errb, ERROR_ME))
2169 PRIMITIVE_FUNCALL (val, fun, args, nargs);
2173 speccount = specpdl_depth ();
2174 if (NILP (class) || NILP (Vcurrent_warning_class))
2176 /* If we're currently calling for no warnings, then make it so.
2177 If we're currently calling for warnings and we weren't
2178 previously, then set our warning class; otherwise, leave
2179 the existing one alone. */
2180 record_unwind_protect (restore_current_warning_class,
2181 Vcurrent_warning_class);
2182 Vcurrent_warning_class = class;
2187 Lisp_Object the_retval;
2188 Lisp_Object opaque1 = make_opaque_ptr (kludgy_args);
2189 Lisp_Object opaque2 = make_opaque_ptr ((void *) fun);
2190 struct gcpro gcpro1, gcpro2;
2192 GCPRO2 (opaque1, opaque2);
2193 kludgy_args[0] = opaque2;
2194 kludgy_args[1] = make_int (nargs);
2195 kludgy_args[2] = no_error;
2196 the_retval = internal_catch (Qunbound_suspended_errors_tag,
2197 call_with_suspended_errors_1,
2199 free_opaque_ptr (opaque1);
2200 free_opaque_ptr (opaque2);
2202 /* Use the returned value except in non-local exit, when
2204 /* Some perverse compilers require the perverse cast below. */
2205 return unbind_to (speccount,
2206 threw ? *((Lisp_Object*) &(retval)) : the_retval);
2210 /* Signal a non-continuable error or display a warning or do nothing,
2211 according to ERRB. CLASS is the class of warning and should
2212 refer to what sort of operation is being done (e.g. Qtoolbar,
2213 Qresource, etc.). */
2216 maybe_signal_error (Lisp_Object sig, Lisp_Object data, Lisp_Object class,
2217 Error_behavior errb)
2219 if (ERRB_EQ (errb, ERROR_ME_NOT))
2221 else if (ERRB_EQ (errb, ERROR_ME_WARN))
2222 warn_when_safe_lispobj (class, Qwarning, Fcons (sig, data));
2225 Fsignal (sig, data);
2228 /* Signal a continuable error or display a warning or do nothing,
2229 according to ERRB. */
2232 maybe_signal_continuable_error (Lisp_Object sig, Lisp_Object data,
2233 Lisp_Object class, Error_behavior errb)
2235 if (ERRB_EQ (errb, ERROR_ME_NOT))
2237 else if (ERRB_EQ (errb, ERROR_ME_WARN))
2239 warn_when_safe_lispobj (class, Qwarning, Fcons (sig, data));
2243 return Fsignal (sig, data);
2247 /****************** Error functions class 2 ******************/
2249 /* Class 2: Printf-like functions that signal an error.
2250 These functions signal an error of type Qerror, whose data
2251 is a single string, created using the arguments. */
2253 /* dump an error message; called like printf */
2256 error (const char *fmt, ...)
2261 va_start (args, fmt);
2262 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2266 /* Fsignal GC-protects its args */
2267 signal_error (Qerror, list1 (obj));
2271 maybe_error (Lisp_Object class, Error_behavior errb, const char *fmt, ...)
2277 if (ERRB_EQ (errb, ERROR_ME_NOT))
2280 va_start (args, fmt);
2281 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2285 /* Fsignal GC-protects its args */
2286 maybe_signal_error (Qerror, list1 (obj), class, errb);
2290 continuable_error (const char *fmt, ...)
2295 va_start (args, fmt);
2296 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2300 /* Fsignal GC-protects its args */
2301 return Fsignal (Qerror, list1 (obj));
2305 maybe_continuable_error (Lisp_Object class, Error_behavior errb,
2306 const char *fmt, ...)
2312 if (ERRB_EQ (errb, ERROR_ME_NOT))
2315 va_start (args, fmt);
2316 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2320 /* Fsignal GC-protects its args */
2321 return maybe_signal_continuable_error (Qerror, list1 (obj), class, errb);
2325 /****************** Error functions class 3 ******************/
2327 /* Class 3: Signal an error with a string and an associated object.
2328 These functions signal an error of type Qerror, whose data
2329 is two objects, a string and a related Lisp object (usually the object
2330 where the error is occurring). */
2333 signal_simple_error (const char *reason, Lisp_Object frob)
2335 signal_error (Qerror, list2 (build_translated_string (reason), frob));
2339 maybe_signal_simple_error (const char *reason, Lisp_Object frob,
2340 Lisp_Object class, Error_behavior errb)
2343 if (ERRB_EQ (errb, ERROR_ME_NOT))
2345 maybe_signal_error (Qerror, list2 (build_translated_string (reason), frob),
2350 signal_simple_continuable_error (const char *reason, Lisp_Object frob)
2352 return Fsignal (Qerror, list2 (build_translated_string (reason), frob));
2356 maybe_signal_simple_continuable_error (const char *reason, Lisp_Object frob,
2357 Lisp_Object class, Error_behavior errb)
2360 if (ERRB_EQ (errb, ERROR_ME_NOT))
2362 return maybe_signal_continuable_error
2363 (Qerror, list2 (build_translated_string (reason),
2364 frob), class, errb);
2368 /****************** Error functions class 4 ******************/
2370 /* Class 4: Printf-like functions that signal an error.
2371 These functions signal an error of type Qerror, whose data
2372 is a two objects, a string (created using the arguments) and a
2377 error_with_frob (Lisp_Object frob, const char *fmt, ...)
2382 va_start (args, fmt);
2383 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2387 /* Fsignal GC-protects its args */
2388 signal_error (Qerror, list2 (obj, frob));
2392 maybe_error_with_frob (Lisp_Object frob, Lisp_Object class,
2393 Error_behavior errb, const char *fmt, ...)
2399 if (ERRB_EQ (errb, ERROR_ME_NOT))
2402 va_start (args, fmt);
2403 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2407 /* Fsignal GC-protects its args */
2408 maybe_signal_error (Qerror, list2 (obj, frob), class, errb);
2412 continuable_error_with_frob (Lisp_Object frob, const char *fmt, ...)
2417 va_start (args, fmt);
2418 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2422 /* Fsignal GC-protects its args */
2423 return Fsignal (Qerror, list2 (obj, frob));
2427 maybe_continuable_error_with_frob (Lisp_Object frob, Lisp_Object class,
2428 Error_behavior errb, const char *fmt, ...)
2434 if (ERRB_EQ (errb, ERROR_ME_NOT))
2437 va_start (args, fmt);
2438 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2442 /* Fsignal GC-protects its args */
2443 return maybe_signal_continuable_error (Qerror, list2 (obj, frob),
2448 /****************** Error functions class 5 ******************/
2450 /* Class 5: Signal an error with a string and two associated objects.
2451 These functions signal an error of type Qerror, whose data
2452 is three objects, a string and two related Lisp objects. */
2455 signal_simple_error_2 (const char *reason,
2456 Lisp_Object frob0, Lisp_Object frob1)
2458 signal_error (Qerror, list3 (build_translated_string (reason), frob0,
2463 maybe_signal_simple_error_2 (const char *reason, Lisp_Object frob0,
2464 Lisp_Object frob1, Lisp_Object class,
2465 Error_behavior errb)
2468 if (ERRB_EQ (errb, ERROR_ME_NOT))
2470 maybe_signal_error (Qerror, list3 (build_translated_string (reason), frob0,
2471 frob1), class, errb);
2476 signal_simple_continuable_error_2 (const char *reason, Lisp_Object frob0,
2479 return Fsignal (Qerror, list3 (build_translated_string (reason), frob0,
2484 maybe_signal_simple_continuable_error_2 (const char *reason, Lisp_Object frob0,
2485 Lisp_Object frob1, Lisp_Object class,
2486 Error_behavior errb)
2489 if (ERRB_EQ (errb, ERROR_ME_NOT))
2491 return maybe_signal_continuable_error
2492 (Qerror, list3 (build_translated_string (reason), frob0,
2498 /* This is what the QUIT macro calls to signal a quit */
2502 /* This function can GC */
2503 if (EQ (Vquit_flag, Qcritical))
2504 debug_on_quit |= 2; /* set critical bit. */
2506 /* note that this is continuable. */
2507 Fsignal (Qquit, Qnil);
2511 /* Used in core lisp functions for efficiency */
2513 signal_void_function_error (Lisp_Object function)
2515 return Fsignal (Qvoid_function, list1 (function));
2519 signal_invalid_function_error (Lisp_Object function)
2521 return Fsignal (Qinvalid_function, list1 (function));
2525 signal_wrong_number_of_arguments_error (Lisp_Object function, int nargs)
2527 return Fsignal (Qwrong_number_of_arguments,
2528 list2 (function, make_int (nargs)));
2531 /* Used in list traversal macros for efficiency. */
2533 signal_malformed_list_error (Lisp_Object list)
2535 signal_error (Qmalformed_list, list1 (list));
2539 signal_malformed_property_list_error (Lisp_Object list)
2541 signal_error (Qmalformed_property_list, list1 (list));
2545 signal_circular_list_error (Lisp_Object list)
2547 signal_error (Qcircular_list, list1 (list));
2551 signal_circular_property_list_error (Lisp_Object list)
2553 signal_error (Qcircular_property_list, list1 (list));
2556 /************************************************************************/
2558 /************************************************************************/
2560 DEFUN ("commandp", Fcommandp, 1, 1, 0, /*
2561 Return t if FUNCTION makes provisions for interactive calling.
2562 This means it contains a description for how to read arguments to give it.
2563 The value is nil for an invalid function or a symbol with no function
2566 Interactively callable functions include
2568 -- strings and vectors (treated as keyboard macros)
2569 -- lambda-expressions that contain a top-level call to `interactive'
2570 -- autoload definitions made by `autoload' with non-nil fourth argument
2571 (i.e. the interactive flag)
2572 -- compiled-function objects with a non-nil `compiled-function-interactive'
2574 -- subrs (built-in functions) that are interactively callable
2576 Also, a symbol satisfies `commandp' if its function definition does so.
2580 Lisp_Object fun = indirect_function (function, 0);
2582 if (COMPILED_FUNCTIONP (fun))
2583 return XCOMPILED_FUNCTION (fun)->flags.interactivep ? Qt : Qnil;
2585 /* Lists may represent commands. */
2588 Lisp_Object funcar = XCAR (fun);
2589 if (EQ (funcar, Qlambda))
2590 return Fassq (Qinteractive, Fcdr (Fcdr (fun)));
2591 if (EQ (funcar, Qautoload))
2592 return Fcar (Fcdr (Fcdr (Fcdr (fun))));
2597 /* Emacs primitives are interactive if their DEFUN specifies an
2598 interactive spec. */
2600 return XSUBR (fun)->prompt ? Qt : Qnil;
2602 /* Strings and vectors are keyboard macros. */
2603 if (VECTORP (fun) || STRINGP (fun))
2606 /* Everything else (including Qunbound) is not a command. */
2610 DEFUN ("command-execute", Fcommand_execute, 1, 3, 0, /*
2611 Execute CMD as an editor command.
2612 CMD must be an object that satisfies the `commandp' predicate.
2613 Optional second arg RECORD-FLAG is as in `call-interactively'.
2614 The argument KEYS specifies the value to use instead of (this-command-keys)
2615 when reading the arguments.
2617 (cmd, record, keys))
2619 /* This function can GC */
2620 Lisp_Object prefixarg;
2621 Lisp_Object final = cmd;
2622 struct backtrace backtrace;
2623 struct console *con = XCONSOLE (Vselected_console);
2625 prefixarg = con->prefix_arg;
2626 con->prefix_arg = Qnil;
2627 Vcurrent_prefix_arg = prefixarg;
2628 debug_on_next_call = 0; /* #### from FSFmacs; correct? */
2630 if (SYMBOLP (cmd) && !NILP (Fget (cmd, Qdisabled, Qnil)))
2631 return run_hook (Vdisabled_command_hook);
2635 final = indirect_function (cmd, 1);
2636 if (CONSP (final) && EQ (Fcar (final), Qautoload))
2637 do_autoload (final, cmd);
2642 if (CONSP (final) || SUBRP (final) || COMPILED_FUNCTIONP (final))
2644 backtrace.function = &Qcall_interactively;
2645 backtrace.args = &cmd;
2646 backtrace.nargs = 1;
2647 backtrace.evalargs = 0;
2648 backtrace.pdlcount = specpdl_depth();
2649 backtrace.debug_on_exit = 0;
2650 PUSH_BACKTRACE (backtrace);
2652 final = Fcall_interactively (cmd, record, keys);
2654 POP_BACKTRACE (backtrace);
2657 else if (STRINGP (final) || VECTORP (final))
2659 return Fexecute_kbd_macro (final, prefixarg);
2663 Fsignal (Qwrong_type_argument,
2667 : list2 (cmd, final))));
2672 DEFUN ("interactive-p", Finteractive_p, 0, 0, 0, /*
2673 Return t if function in which this appears was called interactively.
2674 This means that the function was called with call-interactively (which
2675 includes being called as the binding of a key)
2676 and input is currently coming from the keyboard (not in keyboard macro).
2680 REGISTER struct backtrace *btp;
2681 REGISTER Lisp_Object fun;
2686 /* Unless the object was compiled, skip the frame of interactive-p itself
2687 (if interpreted) or the frame of byte-code (if called from a compiled
2688 function). Note that *btp->function may be a symbol pointing at a
2689 compiled function. */
2690 btp = backtrace_list;
2694 /* #### FSFmacs does the following instead. I can't figure
2695 out which one is more correct. */
2696 /* If this isn't a byte-compiled function, there may be a frame at
2697 the top for Finteractive_p itself. If so, skip it. */
2698 fun = Findirect_function (*btp->function);
2699 if (SUBRP (fun) && XSUBR (fun) == &Sinteractive_p)
2702 /* If we're running an Emacs 18-style byte-compiled function, there
2703 may be a frame for Fbyte_code. Now, given the strictest
2704 definition, this function isn't really being called
2705 interactively, but because that's the way Emacs 18 always builds
2706 byte-compiled functions, we'll accept it for now. */
2707 if (EQ (*btp->function, Qbyte_code))
2710 /* If this isn't a byte-compiled function, then we may now be
2711 looking at several frames for special forms. Skip past them. */
2713 btp->nargs == UNEVALLED)
2718 if (! (COMPILED_FUNCTIONP (Findirect_function (*btp->function))))
2721 btp && (btp->nargs == UNEVALLED
2722 || EQ (*btp->function, Qbyte_code));
2725 /* btp now points at the frame of the innermost function
2726 that DOES eval its args.
2727 If it is a built-in function (such as load or eval-region)
2729 /* Beats me why this is necessary, but it is */
2730 if (btp && EQ (*btp->function, Qcall_interactively))
2735 fun = Findirect_function (*btp->function);
2738 /* btp points to the frame of a Lisp function that called interactive-p.
2739 Return t if that function was called interactively. */
2740 if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively))
2746 /************************************************************************/
2748 /************************************************************************/
2750 DEFUN ("autoload", Fautoload, 2, 5, 0, /*
2751 Define FUNCTION to autoload from FILE.
2752 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
2753 Third arg DOCSTRING is documentation for the function.
2754 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
2755 Fifth arg TYPE indicates the type of the object:
2756 nil or omitted says FUNCTION is a function,
2757 `keymap' says FUNCTION is really a keymap, and
2758 `macro' or t says FUNCTION is really a macro.
2759 Third through fifth args give info about the real definition.
2760 They default to nil.
2761 If FUNCTION is already defined other than as an autoload,
2762 this does nothing and returns nil.
2764 (function, file, docstring, interactive, type))
2766 /* This function can GC */
2767 CHECK_SYMBOL (function);
2768 CHECK_STRING (file);
2770 /* If function is defined and not as an autoload, don't override */
2772 Lisp_Object f = XSYMBOL (function)->function;
2773 if (!UNBOUNDP (f) && !(CONSP (f) && EQ (XCAR (f), Qautoload)))
2779 /* Attempt to avoid consing identical (string=) pure strings. */
2780 file = Fsymbol_name (Fintern (file, Qnil));
2783 return Ffset (function, Fcons (Qautoload, list4 (file,
2790 un_autoload (Lisp_Object oldqueue)
2792 /* This function can GC */
2793 REGISTER Lisp_Object queue, first, second;
2795 /* Queue to unwind is current value of Vautoload_queue.
2796 oldqueue is the shadowed value to leave in Vautoload_queue. */
2797 queue = Vautoload_queue;
2798 Vautoload_queue = oldqueue;
2799 while (CONSP (queue))
2801 first = XCAR (queue);
2802 second = Fcdr (first);
2803 first = Fcar (first);
2807 Ffset (first, second);
2808 queue = Fcdr (queue);
2814 do_autoload (Lisp_Object fundef,
2815 Lisp_Object funname)
2817 /* This function can GC */
2818 int speccount = specpdl_depth();
2819 Lisp_Object fun = funname;
2820 struct gcpro gcpro1, gcpro2;
2822 CHECK_SYMBOL (funname);
2823 GCPRO2 (fun, funname);
2825 /* Value saved here is to be restored into Vautoload_queue */
2826 record_unwind_protect (un_autoload, Vautoload_queue);
2827 Vautoload_queue = Qt;
2828 call4 (Qload, Fcar (Fcdr (fundef)), Qnil, noninteractive ? Qt : Qnil, Qnil);
2833 /* Save the old autoloads, in case we ever do an unload. */
2834 for (queue = Vautoload_queue; CONSP (queue); queue = XCDR (queue))
2836 Lisp_Object first = XCAR (queue);
2837 Lisp_Object second = Fcdr (first);
2839 first = Fcar (first);
2841 /* Note: This test is subtle. The cdr of an autoload-queue entry
2842 may be an atom if the autoload entry was generated by a defalias
2845 Fput (first, Qautoload, (XCDR (second)));
2849 /* Once loading finishes, don't undo it. */
2850 Vautoload_queue = Qt;
2851 unbind_to (speccount, Qnil);
2853 fun = indirect_function (fun, 0);
2856 if (!NILP (Fequal (fun, fundef)))
2860 && EQ (XCAR (fun), Qautoload)))
2862 error ("Autoloading failed to define function %s",
2863 string_data (XSYMBOL (funname)->name));
2868 /************************************************************************/
2869 /* eval, funcall, apply */
2870 /************************************************************************/
2872 static Lisp_Object funcall_lambda (Lisp_Object fun,
2873 int nargs, Lisp_Object args[]);
2874 static int in_warnings;
2877 in_warnings_restore (Lisp_Object minimus)
2883 DEFUN ("eval", Feval, 1, 1, 0, /*
2884 Evaluate FORM and return its value.
2888 /* This function can GC */
2889 Lisp_Object fun, val, original_fun, original_args;
2891 struct backtrace backtrace;
2893 /* I think this is a pretty safe place to call Lisp code, don't you? */
2894 while (!in_warnings && !NILP (Vpending_warnings))
2896 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
2897 int speccount = specpdl_depth();
2898 Lisp_Object this_warning_cons, this_warning, class, level, messij;
2900 record_unwind_protect (in_warnings_restore, Qnil);
2902 this_warning_cons = Vpending_warnings;
2903 this_warning = XCAR (this_warning_cons);
2904 /* in case an error occurs in the warn function, at least
2905 it won't happen infinitely */
2906 Vpending_warnings = XCDR (Vpending_warnings);
2907 free_cons (XCONS (this_warning_cons));
2908 class = XCAR (this_warning);
2909 level = XCAR (XCDR (this_warning));
2910 messij = XCAR (XCDR (XCDR (this_warning)));
2911 free_list (this_warning);
2913 if (NILP (Vpending_warnings))
2914 Vpending_warnings_tail = Qnil; /* perhaps not strictly necessary,
2917 GCPRO4 (form, class, level, messij);
2918 if (!STRINGP (messij))
2919 messij = Fprin1_to_string (messij, Qnil);
2920 call3 (Qdisplay_warning, class, messij, level);
2922 unbind_to (speccount, Qnil);
2928 return Fsymbol_value (form);
2934 if ((consing_since_gc > gc_cons_threshold) || always_gc)
2936 struct gcpro gcpro1;
2938 garbage_collect_1 ();
2942 if (++lisp_eval_depth > max_lisp_eval_depth)
2944 if (max_lisp_eval_depth < 100)
2945 max_lisp_eval_depth = 100;
2946 if (lisp_eval_depth > max_lisp_eval_depth)
2947 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2950 /* We guaranteed CONSP (form) above */
2951 original_fun = XCAR (form);
2952 original_args = XCDR (form);
2954 GET_EXTERNAL_LIST_LENGTH (original_args, nargs);
2956 backtrace.pdlcount = specpdl_depth();
2957 backtrace.function = &original_fun; /* This also protects them from gc */
2958 backtrace.args = &original_args;
2959 backtrace.nargs = UNEVALLED;
2960 backtrace.evalargs = 1;
2961 backtrace.debug_on_exit = 0;
2962 PUSH_BACKTRACE (backtrace);
2964 if (debug_on_next_call)
2965 do_debug_on_call (Qt);
2967 if (profiling_active)
2968 profile_increase_call_count (original_fun);
2970 /* At this point, only original_fun and original_args
2971 have values that will be used below. */
2973 fun = indirect_function (original_fun, 1);
2977 Lisp_Subr *subr = XSUBR (fun);
2978 int max_args = subr->max_args;
2980 if (nargs < subr->min_args)
2981 goto wrong_number_of_arguments;
2983 if (max_args == UNEVALLED) /* Optimize for the common case */
2985 backtrace.evalargs = 0;
2986 val = (((Lisp_Object (*) (Lisp_Object)) subr_function (subr))
2989 else if (nargs <= max_args)
2991 struct gcpro gcpro1;
2992 Lisp_Object args[SUBR_MAX_ARGS];
2993 REGISTER Lisp_Object *p = args;
2999 REGISTER Lisp_Object arg;
3000 LIST_LOOP_2 (arg, original_args)
3007 /* &optional args default to nil. */
3008 while (p - args < max_args)
3011 backtrace.args = args;
3012 backtrace.nargs = nargs;
3014 FUNCALL_SUBR (val, subr, args, max_args);
3018 else if (max_args == MANY)
3020 /* Pass a vector of evaluated arguments */
3021 struct gcpro gcpro1;
3022 Lisp_Object *args = alloca_array (Lisp_Object, nargs);
3023 REGISTER Lisp_Object *p = args;
3029 REGISTER Lisp_Object arg;
3030 LIST_LOOP_2 (arg, original_args)
3037 backtrace.args = args;
3038 backtrace.nargs = nargs;
3040 val = (((Lisp_Object (*) (int, Lisp_Object *)) subr_function (subr))
3047 wrong_number_of_arguments:
3048 val = signal_wrong_number_of_arguments_error (original_fun, nargs);
3051 else if (COMPILED_FUNCTIONP (fun))
3053 struct gcpro gcpro1;
3054 Lisp_Object *args = alloca_array (Lisp_Object, nargs);
3055 REGISTER Lisp_Object *p = args;
3061 REGISTER Lisp_Object arg;
3062 LIST_LOOP_2 (arg, original_args)
3069 backtrace.args = args;
3070 backtrace.nargs = nargs;
3071 backtrace.evalargs = 0;
3073 val = funcall_compiled_function (fun, nargs, args);
3075 /* Do the debug-on-exit now, while args is still GCPROed. */
3076 if (backtrace.debug_on_exit)
3077 val = do_debug_on_exit (val);
3078 /* Don't do it again when we return to eval. */
3079 backtrace.debug_on_exit = 0;
3083 else if (CONSP (fun))
3085 Lisp_Object funcar = XCAR (fun);
3087 if (EQ (funcar, Qautoload))
3089 do_autoload (fun, original_fun);
3092 else if (EQ (funcar, Qmacro))
3094 val = Feval (apply1 (XCDR (fun), original_args));
3096 else if (EQ (funcar, Qlambda))
3098 struct gcpro gcpro1;
3099 Lisp_Object *args = alloca_array (Lisp_Object, nargs);
3100 REGISTER Lisp_Object *p = args;
3106 REGISTER Lisp_Object arg;
3107 LIST_LOOP_2 (arg, original_args)
3116 backtrace.args = args; /* this also GCPROs `args' */
3117 backtrace.nargs = nargs;
3118 backtrace.evalargs = 0;
3120 val = funcall_lambda (fun, nargs, args);
3122 /* Do the debug-on-exit now, while args is still GCPROed. */
3123 if (backtrace.debug_on_exit)
3124 val = do_debug_on_exit (val);
3125 /* Don't do it again when we return to eval. */
3126 backtrace.debug_on_exit = 0;
3130 goto invalid_function;
3133 else /* ! (SUBRP (fun) || COMPILED_FUNCTIONP (fun) || CONSP (fun)) */
3136 val = signal_invalid_function_error (fun);
3140 if (backtrace.debug_on_exit)
3141 val = do_debug_on_exit (val);
3142 POP_BACKTRACE (backtrace);
3147 DEFUN ("funcall", Ffuncall, 1, MANY, 0, /*
3148 Call first argument as a function, passing the remaining arguments to it.
3149 Thus, (funcall 'cons 'x 'y) returns (x . y).
3151 (int nargs, Lisp_Object *args))
3153 /* This function can GC */
3156 struct backtrace backtrace;
3157 int fun_nargs = nargs - 1;
3158 Lisp_Object *fun_args = args + 1;
3161 if ((consing_since_gc > gc_cons_threshold) || always_gc)
3162 /* Callers should gcpro lexpr args */
3163 garbage_collect_1 ();
3165 if (++lisp_eval_depth > max_lisp_eval_depth)
3167 if (max_lisp_eval_depth < 100)
3168 max_lisp_eval_depth = 100;
3169 if (lisp_eval_depth > max_lisp_eval_depth)
3170 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
3173 backtrace.pdlcount = specpdl_depth();
3174 backtrace.function = &args[0];
3175 backtrace.args = fun_args;
3176 backtrace.nargs = fun_nargs;
3177 backtrace.evalargs = 0;
3178 backtrace.debug_on_exit = 0;
3179 PUSH_BACKTRACE (backtrace);
3181 if (debug_on_next_call)
3182 do_debug_on_call (Qlambda);
3188 /* It might be useful to place this *after* all the checks. */
3189 if (profiling_active)
3190 profile_increase_call_count (fun);
3192 /* We could call indirect_function directly, but profiling shows
3193 this is worth optimizing by partially unrolling the loop. */
3196 fun = XSYMBOL (fun)->function;
3199 fun = XSYMBOL (fun)->function;
3201 fun = indirect_function (fun, 1);
3207 Lisp_Subr *subr = XSUBR (fun);
3208 int max_args = subr->max_args;
3209 Lisp_Object spacious_args[SUBR_MAX_ARGS];
3211 if (fun_nargs == max_args) /* Optimize for the common case */
3214 FUNCALL_SUBR (val, subr, fun_args, max_args);
3216 else if (fun_nargs < subr->min_args)
3218 goto wrong_number_of_arguments;
3220 else if (fun_nargs < max_args)
3222 Lisp_Object *p = spacious_args;
3224 /* Default optionals to nil */
3227 while (p - spacious_args < max_args)
3230 fun_args = spacious_args;
3233 else if (max_args == MANY)
3235 val = SUBR_FUNCTION (subr, MANY) (fun_nargs, fun_args);
3237 else if (max_args == UNEVALLED) /* Can't funcall a special form */
3239 goto invalid_function;
3243 wrong_number_of_arguments:
3244 val = signal_wrong_number_of_arguments_error (fun, fun_nargs);
3247 else if (COMPILED_FUNCTIONP (fun))
3249 val = funcall_compiled_function (fun, fun_nargs, fun_args);
3251 else if (CONSP (fun))
3253 Lisp_Object funcar = XCAR (fun);
3255 if (EQ (funcar, Qlambda))
3257 val = funcall_lambda (fun, fun_nargs, fun_args);
3259 else if (EQ (funcar, Qautoload))
3261 do_autoload (fun, args[0]);
3264 else /* Can't funcall a macro */
3266 goto invalid_function;
3269 else if (UNBOUNDP (fun))
3271 val = signal_void_function_error (args[0]);
3276 val = signal_invalid_function_error (fun);
3280 if (backtrace.debug_on_exit)
3281 val = do_debug_on_exit (val);
3282 POP_BACKTRACE (backtrace);
3286 DEFUN ("functionp", Ffunctionp, 1, 1, 0, /*
3287 Return t if OBJECT can be called as a function, else nil.
3288 A function is an object that can be applied to arguments,
3289 using for example `funcall' or `apply'.
3293 if (SYMBOLP (object))
3294 object = indirect_function (object, 0);
3298 COMPILED_FUNCTIONP (object) ||
3300 (EQ (XCAR (object), Qlambda) ||
3301 EQ (XCAR (object), Qautoload))))
3306 function_argcount (Lisp_Object function, int function_min_args_p)
3308 Lisp_Object orig_function = function;
3309 Lisp_Object arglist;
3313 if (SYMBOLP (function))
3314 function = indirect_function (function, 1);
3316 if (SUBRP (function))
3318 /* Using return with the ?: operator tickles a DEC CC compiler bug. */
3319 if (function_min_args_p)
3320 return Fsubr_min_args (function);
3322 return Fsubr_max_args (function);
3324 else if (COMPILED_FUNCTIONP (function))
3326 arglist = compiled_function_arglist (XCOMPILED_FUNCTION (function));
3328 else if (CONSP (function))
3330 Lisp_Object funcar = XCAR (function);
3332 if (EQ (funcar, Qmacro))
3334 function = XCDR (function);
3337 else if (EQ (funcar, Qautoload))
3339 do_autoload (function, orig_function);
3342 else if (EQ (funcar, Qlambda))
3344 arglist = Fcar (XCDR (function));
3348 goto invalid_function;
3354 return signal_invalid_function_error (function);
3361 EXTERNAL_LIST_LOOP_2 (arg, arglist)
3363 if (EQ (arg, Qand_optional))
3365 if (function_min_args_p)
3368 else if (EQ (arg, Qand_rest))
3370 if (function_min_args_p)
3381 return make_int (argcount);
3385 DEFUN ("function-min-args", Ffunction_min_args, 1, 1, 0, /*
3386 Return the number of arguments a function may be called with.
3387 The function may be any form that can be passed to `funcall',
3388 any special form, or any macro.
3392 return function_argcount (function, 1);
3395 DEFUN ("function-max-args", Ffunction_max_args, 1, 1, 0, /*
3396 Return the number of arguments a function may be called with.
3397 The function may be any form that can be passed to `funcall',
3398 any special form, or any macro.
3399 If the function takes an arbitrary number of arguments or is
3400 a built-in special form, nil is returned.
3404 return function_argcount (function, 0);
3408 DEFUN ("apply", Fapply, 2, MANY, 0, /*
3409 Call FUNCTION with the remaining args, using the last arg as a list of args.
3410 Thus, (apply '+ 1 2 '(3 4)) returns 10.
3412 (int nargs, Lisp_Object *args))
3414 /* This function can GC */
3415 Lisp_Object fun = args[0];
3416 Lisp_Object spread_arg = args [nargs - 1];
3420 GET_EXTERNAL_LIST_LENGTH (spread_arg, numargs);
3423 /* (apply foo 0 1 '()) */
3424 return Ffuncall (nargs - 1, args);
3425 else if (numargs == 1)
3427 /* (apply foo 0 1 '(2)) */
3428 args [nargs - 1] = XCAR (spread_arg);
3429 return Ffuncall (nargs, args);
3432 /* -1 for function, -1 for spread arg */
3433 numargs = nargs - 2 + numargs;
3434 /* +1 for function */
3435 funcall_nargs = 1 + numargs;
3438 fun = indirect_function (fun, 0);
3442 Lisp_Subr *subr = XSUBR (fun);
3443 int max_args = subr->max_args;
3445 if (numargs < subr->min_args
3446 || (max_args >= 0 && max_args < numargs))
3448 /* Let funcall get the error */
3450 else if (max_args > numargs)
3452 /* Avoid having funcall cons up yet another new vector of arguments
3453 by explicitly supplying nil's for optional values */
3454 funcall_nargs += (max_args - numargs);
3457 else if (UNBOUNDP (fun))
3459 /* Let funcall get the error */
3465 Lisp_Object *funcall_args = alloca_array (Lisp_Object, funcall_nargs);
3466 struct gcpro gcpro1;
3468 GCPRO1 (*funcall_args);
3469 gcpro1.nvars = funcall_nargs;
3471 /* Copy in the unspread args */
3472 memcpy (funcall_args, args, (nargs - 1) * sizeof (Lisp_Object));
3473 /* Spread the last arg we got. Its first element goes in
3474 the slot that it used to occupy, hence this value of I. */
3476 !NILP (spread_arg); /* i < 1 + numargs */
3477 i++, spread_arg = XCDR (spread_arg))
3479 funcall_args [i] = XCAR (spread_arg);
3481 /* Supply nil for optional args (to subrs) */
3482 for (; i < funcall_nargs; i++)
3483 funcall_args[i] = Qnil;
3486 RETURN_UNGCPRO (Ffuncall (funcall_nargs, funcall_args));
3491 /* Apply lambda list FUN to the NARGS evaluated arguments in ARGS and
3492 return the result of evaluation. */
3495 funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object args[])
3497 /* This function can GC */
3498 Lisp_Object symbol, arglist, body, tail;
3499 int speccount = specpdl_depth();
3505 goto invalid_function;
3507 arglist = XCAR (tail);
3511 int optional = 0, rest = 0;
3513 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
3515 if (!SYMBOLP (symbol))
3516 goto invalid_function;
3517 if (EQ (symbol, Qand_rest))
3519 else if (EQ (symbol, Qand_optional))
3523 specbind (symbol, Flist (nargs - i, &args[i]));
3527 specbind (symbol, args[i++]);
3529 goto wrong_number_of_arguments;
3531 specbind (symbol, Qnil);
3536 goto wrong_number_of_arguments;
3538 return unbind_to (speccount, Fprogn (body));
3540 wrong_number_of_arguments:
3541 return signal_wrong_number_of_arguments_error (fun, nargs);
3544 return signal_invalid_function_error (fun);
3548 /************************************************************************/
3549 /* Run hook variables in various ways. */
3550 /************************************************************************/
3552 DEFUN ("run-hooks", Frun_hooks, 1, MANY, 0, /*
3553 Run each hook in HOOKS. Major mode functions use this.
3554 Each argument should be a symbol, a hook variable.
3555 These symbols are processed in the order specified.
3556 If a hook symbol has a non-nil value, that value may be a function
3557 or a list of functions to be called to run the hook.
3558 If the value is a function, it is called with no arguments.
3559 If it is a list, the elements are called, in order, with no arguments.
3561 To make a hook variable buffer-local, use `make-local-hook',
3562 not `make-local-variable'.
3564 (int nargs, Lisp_Object *args))
3568 for (i = 0; i < nargs; i++)
3569 run_hook_with_args (1, args + i, RUN_HOOKS_TO_COMPLETION);
3574 DEFUN ("run-hook-with-args", Frun_hook_with_args, 1, MANY, 0, /*
3575 Run HOOK with the specified arguments ARGS.
3576 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
3577 value, that value may be a function or a list of functions to be
3578 called to run the hook. If the value is a function, it is called with
3579 the given arguments and its return value is returned. If it is a list
3580 of functions, those functions are called, in order,
3581 with the given arguments ARGS.
3582 It is best not to depend on the value return by `run-hook-with-args',
3585 To make a hook variable buffer-local, use `make-local-hook',
3586 not `make-local-variable'.
3588 (int nargs, Lisp_Object *args))
3590 return run_hook_with_args (nargs, args, RUN_HOOKS_TO_COMPLETION);
3593 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success, 1, MANY, 0, /*
3594 Run HOOK with the specified arguments ARGS.
3595 HOOK should be a symbol, a hook variable. Its value should
3596 be a list of functions. We call those functions, one by one,
3597 passing arguments ARGS to each of them, until one of them
3598 returns a non-nil value. Then we return that value.
3599 If all the functions return nil, we return nil.
3601 To make a hook variable buffer-local, use `make-local-hook',
3602 not `make-local-variable'.
3604 (int nargs, Lisp_Object *args))
3606 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_SUCCESS);
3609 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure, 1, MANY, 0, /*
3610 Run HOOK with the specified arguments ARGS.
3611 HOOK should be a symbol, a hook variable. Its value should
3612 be a list of functions. We call those functions, one by one,
3613 passing arguments ARGS to each of them, until one of them
3614 returns nil. Then we return nil.
3615 If all the functions return non-nil, we return non-nil.
3617 To make a hook variable buffer-local, use `make-local-hook',
3618 not `make-local-variable'.
3620 (int nargs, Lisp_Object *args))
3622 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_FAILURE);
3625 /* ARGS[0] should be a hook symbol.
3626 Call each of the functions in the hook value, passing each of them
3627 as arguments all the rest of ARGS (all NARGS - 1 elements).
3628 COND specifies a condition to test after each call
3629 to decide whether to stop.
3630 The caller (or its caller, etc) must gcpro all of ARGS,
3631 except that it isn't necessary to gcpro ARGS[0]. */
3634 run_hook_with_args_in_buffer (struct buffer *buf, int nargs, Lisp_Object *args,
3635 enum run_hooks_condition cond)
3637 Lisp_Object sym, val, ret;
3639 if (!initialized || preparing_for_armageddon)
3640 /* We need to bail out of here pronto. */
3643 /* Whenever gc_in_progress is true, preparing_for_armageddon
3644 will also be true unless something is really hosed. */
3645 assert (!gc_in_progress);
3648 val = symbol_value_in_buffer (sym, make_buffer (buf));
3649 ret = (cond == RUN_HOOKS_UNTIL_FAILURE ? Qt : Qnil);
3651 if (UNBOUNDP (val) || NILP (val))
3653 else if (!CONSP (val) || EQ (XCAR (val), Qlambda))
3656 return Ffuncall (nargs, args);
3660 struct gcpro gcpro1, gcpro2, gcpro3;
3661 Lisp_Object globals = Qnil;
3662 GCPRO3 (sym, val, globals);
3665 CONSP (val) && ((cond == RUN_HOOKS_TO_COMPLETION)
3666 || (cond == RUN_HOOKS_UNTIL_SUCCESS ? NILP (ret)
3670 if (EQ (XCAR (val), Qt))
3672 /* t indicates this hook has a local binding;
3673 it means to run the global binding too. */
3674 globals = Fdefault_value (sym);
3676 if ((! CONSP (globals) || EQ (XCAR (globals), Qlambda)) &&
3680 ret = Ffuncall (nargs, args);
3685 CONSP (globals) && ((cond == RUN_HOOKS_TO_COMPLETION)
3686 || (cond == RUN_HOOKS_UNTIL_SUCCESS
3689 globals = XCDR (globals))
3691 args[0] = XCAR (globals);
3692 /* In a global value, t should not occur. If it does, we
3693 must ignore it to avoid an endless loop. */
3694 if (!EQ (args[0], Qt))
3695 ret = Ffuncall (nargs, args);
3701 args[0] = XCAR (val);
3702 ret = Ffuncall (nargs, args);
3712 run_hook_with_args (int nargs, Lisp_Object *args,
3713 enum run_hooks_condition cond)
3715 return run_hook_with_args_in_buffer (current_buffer, nargs, args, cond);
3720 /* From FSF 19.30, not currently used */
3722 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
3723 present value of that symbol.
3724 Call each element of FUNLIST,
3725 passing each of them the rest of ARGS.
3726 The caller (or its caller, etc) must gcpro all of ARGS,
3727 except that it isn't necessary to gcpro ARGS[0]. */
3730 run_hook_list_with_args (Lisp_Object funlist, int nargs, Lisp_Object *args)
3732 Lisp_Object sym = args[0];
3734 struct gcpro gcpro1, gcpro2;
3738 for (val = funlist; CONSP (val); val = XCDR (val))
3740 if (EQ (XCAR (val), Qt))
3742 /* t indicates this hook has a local binding;
3743 it means to run the global binding too. */
3744 Lisp_Object globals;
3746 for (globals = Fdefault_value (sym);
3748 globals = XCDR (globals))
3750 args[0] = XCAR (globals);
3751 /* In a global value, t should not occur. If it does, we
3752 must ignore it to avoid an endless loop. */
3753 if (!EQ (args[0], Qt))
3754 Ffuncall (nargs, args);
3759 args[0] = XCAR (val);
3760 Ffuncall (nargs, args);
3770 va_run_hook_with_args (Lisp_Object hook_var, int nargs, ...)
3772 /* This function can GC */
3773 struct gcpro gcpro1;
3776 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs);
3778 va_start (vargs, nargs);
3779 funcall_args[0] = hook_var;
3780 for (i = 0; i < nargs; i++)
3781 funcall_args[i + 1] = va_arg (vargs, Lisp_Object);
3784 GCPRO1 (*funcall_args);
3785 gcpro1.nvars = nargs + 1;
3786 run_hook_with_args (nargs + 1, funcall_args, RUN_HOOKS_TO_COMPLETION);
3791 va_run_hook_with_args_in_buffer (struct buffer *buf, Lisp_Object hook_var,
3794 /* This function can GC */
3795 struct gcpro gcpro1;
3798 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs);
3800 va_start (vargs, nargs);
3801 funcall_args[0] = hook_var;
3802 for (i = 0; i < nargs; i++)
3803 funcall_args[i + 1] = va_arg (vargs, Lisp_Object);
3806 GCPRO1 (*funcall_args);
3807 gcpro1.nvars = nargs + 1;
3808 run_hook_with_args_in_buffer (buf, nargs + 1, funcall_args,
3809 RUN_HOOKS_TO_COMPLETION);
3814 run_hook (Lisp_Object hook)
3816 Frun_hooks (1, &hook);
3821 /************************************************************************/
3822 /* Front-ends to eval, funcall, apply */
3823 /************************************************************************/
3825 /* Apply fn to arg */
3827 apply1 (Lisp_Object fn, Lisp_Object arg)
3829 /* This function can GC */
3830 struct gcpro gcpro1;
3831 Lisp_Object args[2];
3834 return Ffuncall (1, &fn);
3839 RETURN_UNGCPRO (Fapply (2, args));
3842 /* Call function fn on no arguments */
3844 call0 (Lisp_Object fn)
3846 /* This function can GC */
3847 struct gcpro gcpro1;
3850 RETURN_UNGCPRO (Ffuncall (1, &fn));
3853 /* Call function fn with argument arg0 */
3855 call1 (Lisp_Object fn,
3858 /* This function can GC */
3859 struct gcpro gcpro1;
3860 Lisp_Object args[2];
3865 RETURN_UNGCPRO (Ffuncall (2, args));
3868 /* Call function fn with arguments arg0, arg1 */
3870 call2 (Lisp_Object fn,
3871 Lisp_Object arg0, Lisp_Object arg1)
3873 /* This function can GC */
3874 struct gcpro gcpro1;
3875 Lisp_Object args[3];
3881 RETURN_UNGCPRO (Ffuncall (3, args));
3884 /* Call function fn with arguments arg0, arg1, arg2 */
3886 call3 (Lisp_Object fn,
3887 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2)
3889 /* This function can GC */
3890 struct gcpro gcpro1;
3891 Lisp_Object args[4];
3898 RETURN_UNGCPRO (Ffuncall (4, args));
3901 /* Call function fn with arguments arg0, arg1, arg2, arg3 */
3903 call4 (Lisp_Object fn,
3904 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3907 /* This function can GC */
3908 struct gcpro gcpro1;
3909 Lisp_Object args[5];
3917 RETURN_UNGCPRO (Ffuncall (5, args));
3920 /* Call function fn with arguments arg0, arg1, arg2, arg3, arg4 */
3922 call5 (Lisp_Object fn,
3923 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3924 Lisp_Object arg3, Lisp_Object arg4)
3926 /* This function can GC */
3927 struct gcpro gcpro1;
3928 Lisp_Object args[6];
3937 RETURN_UNGCPRO (Ffuncall (6, args));
3941 call6 (Lisp_Object fn,
3942 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3943 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5)
3945 /* This function can GC */
3946 struct gcpro gcpro1;
3947 Lisp_Object args[7];
3957 RETURN_UNGCPRO (Ffuncall (7, args));
3961 call7 (Lisp_Object fn,
3962 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3963 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5,
3966 /* This function can GC */
3967 struct gcpro gcpro1;
3968 Lisp_Object args[8];
3979 RETURN_UNGCPRO (Ffuncall (8, args));
3983 call8 (Lisp_Object fn,
3984 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3985 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5,
3986 Lisp_Object arg6, Lisp_Object arg7)
3988 /* This function can GC */
3989 struct gcpro gcpro1;
3990 Lisp_Object args[9];
4002 RETURN_UNGCPRO (Ffuncall (9, args));
4006 call0_in_buffer (struct buffer *buf, Lisp_Object fn)
4008 if (current_buffer == buf)
4013 int speccount = specpdl_depth();
4014 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4015 set_buffer_internal (buf);
4017 unbind_to (speccount, Qnil);
4023 call1_in_buffer (struct buffer *buf, Lisp_Object fn,
4026 if (current_buffer == buf)
4027 return call1 (fn, arg0);
4031 int speccount = specpdl_depth();
4032 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4033 set_buffer_internal (buf);
4034 val = call1 (fn, arg0);
4035 unbind_to (speccount, Qnil);
4041 call2_in_buffer (struct buffer *buf, Lisp_Object fn,
4042 Lisp_Object arg0, Lisp_Object arg1)
4044 if (current_buffer == buf)
4045 return call2 (fn, arg0, arg1);
4049 int speccount = specpdl_depth();
4050 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4051 set_buffer_internal (buf);
4052 val = call2 (fn, arg0, arg1);
4053 unbind_to (speccount, Qnil);
4059 call3_in_buffer (struct buffer *buf, Lisp_Object fn,
4060 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2)
4062 if (current_buffer == buf)
4063 return call3 (fn, arg0, arg1, arg2);
4067 int speccount = specpdl_depth();
4068 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4069 set_buffer_internal (buf);
4070 val = call3 (fn, arg0, arg1, arg2);
4071 unbind_to (speccount, Qnil);
4077 call4_in_buffer (struct buffer *buf, Lisp_Object fn,
4078 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4081 if (current_buffer == buf)
4082 return call4 (fn, arg0, arg1, arg2, arg3);
4086 int speccount = specpdl_depth();
4087 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4088 set_buffer_internal (buf);
4089 val = call4 (fn, arg0, arg1, arg2, arg3);
4090 unbind_to (speccount, Qnil);
4096 eval_in_buffer (struct buffer *buf, Lisp_Object form)
4098 if (current_buffer == buf)
4099 return Feval (form);
4103 int speccount = specpdl_depth();
4104 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4105 set_buffer_internal (buf);
4107 unbind_to (speccount, Qnil);
4113 /************************************************************************/
4114 /* Error-catching front-ends to eval, funcall, apply */
4115 /************************************************************************/
4117 /* Call function fn on no arguments, with condition handler */
4119 call0_with_handler (Lisp_Object handler, Lisp_Object fn)
4121 /* This function can GC */
4122 struct gcpro gcpro1;
4123 Lisp_Object args[2];
4128 RETURN_UNGCPRO (Fcall_with_condition_handler (2, args));
4131 /* Call function fn with argument arg0, with condition handler */
4133 call1_with_handler (Lisp_Object handler, Lisp_Object fn,
4136 /* This function can GC */
4137 struct gcpro gcpro1;
4138 Lisp_Object args[3];
4144 RETURN_UNGCPRO (Fcall_with_condition_handler (3, args));
4148 /* The following functions provide you with error-trapping versions
4149 of the various front-ends above. They take an additional
4150 "warning_string" argument; if non-zero, a warning with this
4151 string and the actual error that occurred will be displayed
4152 in the *Warnings* buffer if an error occurs. In all cases,
4153 QUIT is inhibited while these functions are running, and if
4154 an error occurs, Qunbound is returned instead of the normal
4158 /* #### This stuff needs to catch throws as well. We need to
4159 improve internal_catch() so it can take a "catch anything"
4160 argument similar to Qt or Qerror for condition_case_1(). */
4163 caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg)
4165 if (!NILP (errordata))
4167 Lisp_Object args[2];
4171 char *str = (char *) get_opaque_ptr (arg);
4172 args[0] = build_string (str);
4175 args[0] = build_string ("error");
4176 /* #### This should call
4177 (with-output-to-string (display-error errordata))
4178 but that stuff is all in Lisp currently. */
4179 args[1] = errordata;
4180 warn_when_safe_lispobj
4182 emacs_doprnt_string_lisp ((const Bufbyte *) "%s: %s",
4183 Qnil, -1, 2, args));
4189 allow_quit_caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg)
4191 if (CONSP (errordata) && EQ (XCAR (errordata), Qquit))
4192 return Fsignal (Qquit, XCDR (errordata));
4193 return caught_a_squirmer (errordata, arg);
4197 safe_run_hook_caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg)
4199 Lisp_Object hook = Fcar (arg);
4201 /* Clear out the hook. */
4203 return caught_a_squirmer (errordata, arg);
4207 allow_quit_safe_run_hook_caught_a_squirmer (Lisp_Object errordata,
4210 Lisp_Object hook = Fcar (arg);
4212 if (!CONSP (errordata) || !EQ (XCAR (errordata), Qquit))
4213 /* Clear out the hook. */
4215 return allow_quit_caught_a_squirmer (errordata, arg);
4219 catch_them_squirmers_eval_in_buffer (Lisp_Object cons)
4221 return eval_in_buffer (XBUFFER (XCAR (cons)), XCDR (cons));
4225 eval_in_buffer_trapping_errors (const char *warning_string,
4226 struct buffer *buf, Lisp_Object form)
4228 int speccount = specpdl_depth();
4233 struct gcpro gcpro1, gcpro2;
4235 XSETBUFFER (buffer, buf);
4237 specbind (Qinhibit_quit, Qt);
4238 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4240 cons = noseeum_cons (buffer, form);
4241 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
4242 GCPRO2 (cons, opaque);
4243 /* Qerror not Qt, so you can get a backtrace */
4244 tem = condition_case_1 (Qerror,
4245 catch_them_squirmers_eval_in_buffer, cons,
4246 caught_a_squirmer, opaque);
4247 free_cons (XCONS (cons));
4248 if (OPAQUE_PTRP (opaque))
4249 free_opaque_ptr (opaque);
4252 /* gc_currently_forbidden = 0; */
4253 return unbind_to (speccount, tem);
4257 catch_them_squirmers_run_hook (Lisp_Object hook_symbol)
4259 /* This function can GC */
4260 run_hook (hook_symbol);
4265 run_hook_trapping_errors (const char *warning_string, Lisp_Object hook_symbol)
4270 struct gcpro gcpro1;
4272 if (!initialized || preparing_for_armageddon)
4274 tem = find_symbol_value (hook_symbol);
4275 if (NILP (tem) || UNBOUNDP (tem))
4278 speccount = specpdl_depth();
4279 specbind (Qinhibit_quit, Qt);
4281 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
4283 /* Qerror not Qt, so you can get a backtrace */
4284 tem = condition_case_1 (Qerror,
4285 catch_them_squirmers_run_hook, hook_symbol,
4286 caught_a_squirmer, opaque);
4287 if (OPAQUE_PTRP (opaque))
4288 free_opaque_ptr (opaque);
4291 return unbind_to (speccount, tem);
4294 /* Same as run_hook_trapping_errors() but also set the hook to nil
4295 if an error occurs. */
4298 safe_run_hook_trapping_errors (const char *warning_string,
4299 Lisp_Object hook_symbol,
4302 int speccount = specpdl_depth();
4304 Lisp_Object cons = Qnil;
4305 struct gcpro gcpro1;
4307 if (!initialized || preparing_for_armageddon)
4309 tem = find_symbol_value (hook_symbol);
4310 if (NILP (tem) || UNBOUNDP (tem))
4314 specbind (Qinhibit_quit, Qt);
4316 cons = noseeum_cons (hook_symbol,
4317 warning_string ? make_opaque_ptr ((void *)warning_string)
4320 /* Qerror not Qt, so you can get a backtrace */
4321 tem = condition_case_1 (Qerror,
4322 catch_them_squirmers_run_hook,
4325 allow_quit_safe_run_hook_caught_a_squirmer :
4326 safe_run_hook_caught_a_squirmer,
4328 if (OPAQUE_PTRP (XCDR (cons)))
4329 free_opaque_ptr (XCDR (cons));
4330 free_cons (XCONS (cons));
4333 return unbind_to (speccount, tem);
4337 catch_them_squirmers_call0 (Lisp_Object function)
4339 /* This function can GC */
4340 return call0 (function);
4344 call0_trapping_errors (const char *warning_string, Lisp_Object function)
4348 Lisp_Object opaque = Qnil;
4349 struct gcpro gcpro1, gcpro2;
4351 if (SYMBOLP (function))
4353 tem = XSYMBOL (function)->function;
4354 if (NILP (tem) || UNBOUNDP (tem))
4358 GCPRO2 (opaque, function);
4359 speccount = specpdl_depth();
4360 specbind (Qinhibit_quit, Qt);
4361 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4363 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
4364 /* Qerror not Qt, so you can get a backtrace */
4365 tem = condition_case_1 (Qerror,
4366 catch_them_squirmers_call0, function,
4367 caught_a_squirmer, opaque);
4368 if (OPAQUE_PTRP (opaque))
4369 free_opaque_ptr (opaque);
4372 /* gc_currently_forbidden = 0; */
4373 return unbind_to (speccount, tem);
4377 catch_them_squirmers_call1 (Lisp_Object cons)
4379 /* This function can GC */
4380 return call1 (XCAR (cons), XCDR (cons));
4384 catch_them_squirmers_call2 (Lisp_Object cons)
4386 /* This function can GC */
4387 return call2 (XCAR (cons), XCAR (XCDR (cons)), XCAR (XCDR (XCDR (cons))));
4391 call1_trapping_errors (const char *warning_string, Lisp_Object function,
4394 int speccount = specpdl_depth();
4396 Lisp_Object cons = Qnil;
4397 Lisp_Object opaque = Qnil;
4398 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
4400 if (SYMBOLP (function))
4402 tem = XSYMBOL (function)->function;
4403 if (NILP (tem) || UNBOUNDP (tem))
4407 GCPRO4 (cons, opaque, function, object);
4409 specbind (Qinhibit_quit, Qt);
4410 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4412 cons = noseeum_cons (function, object);
4413 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
4414 /* Qerror not Qt, so you can get a backtrace */
4415 tem = condition_case_1 (Qerror,
4416 catch_them_squirmers_call1, cons,
4417 caught_a_squirmer, opaque);
4418 if (OPAQUE_PTRP (opaque))
4419 free_opaque_ptr (opaque);
4420 free_cons (XCONS (cons));
4423 /* gc_currently_forbidden = 0; */
4424 return unbind_to (speccount, tem);
4428 call2_trapping_errors (const char *warning_string, Lisp_Object function,
4429 Lisp_Object object1, Lisp_Object object2)
4431 int speccount = specpdl_depth();
4433 Lisp_Object cons = Qnil;
4434 Lisp_Object opaque = Qnil;
4435 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
4437 if (SYMBOLP (function))
4439 tem = XSYMBOL (function)->function;
4440 if (NILP (tem) || UNBOUNDP (tem))
4444 GCPRO5 (cons, opaque, function, object1, object2);
4445 specbind (Qinhibit_quit, Qt);
4446 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4448 cons = list3 (function, object1, object2);
4449 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
4450 /* Qerror not Qt, so you can get a backtrace */
4451 tem = condition_case_1 (Qerror,
4452 catch_them_squirmers_call2, cons,
4453 caught_a_squirmer, opaque);
4454 if (OPAQUE_PTRP (opaque))
4455 free_opaque_ptr (opaque);
4459 /* gc_currently_forbidden = 0; */
4460 return unbind_to (speccount, tem);
4464 /************************************************************************/
4465 /* The special binding stack */
4466 /* Most C code should simply use specbind() and unbind_to(). */
4467 /* When performance is critical, use the macros in backtrace.h. */
4468 /************************************************************************/
4470 #define min_max_specpdl_size 400
4473 grow_specpdl (size_t reserved)
4475 size_t size_needed = specpdl_depth() + reserved;
4476 if (size_needed >= max_specpdl_size)
4478 if (max_specpdl_size < min_max_specpdl_size)
4479 max_specpdl_size = min_max_specpdl_size;
4480 if (size_needed >= max_specpdl_size)
4482 if (!NILP (Vdebug_on_error) ||
4483 !NILP (Vdebug_on_signal))
4484 /* Leave room for some specpdl in the debugger. */
4485 max_specpdl_size = size_needed + 100;
4487 ("Variable binding depth exceeds max-specpdl-size");
4490 while (specpdl_size < size_needed)
4493 if (specpdl_size > max_specpdl_size)
4494 specpdl_size = max_specpdl_size;
4496 XREALLOC_ARRAY (specpdl, struct specbinding, specpdl_size);
4497 specpdl_ptr = specpdl + specpdl_depth();
4501 /* Handle unbinding buffer-local variables */
4503 specbind_unwind_local (Lisp_Object ovalue)
4505 Lisp_Object current = Fcurrent_buffer ();
4506 Lisp_Object symbol = specpdl_ptr->symbol;
4507 Lisp_Cons *victim = XCONS (ovalue);
4508 Lisp_Object buf = get_buffer (victim->car, 0);
4509 ovalue = victim->cdr;
4515 /* Deleted buffer -- do nothing */
4517 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buf)) == 0)
4519 /* Was buffer-local when binding was made, now no longer is.
4520 * (kill-local-variable can do this.)
4521 * Do nothing in this case.
4524 else if (EQ (buf, current))
4525 Fset (symbol, ovalue);
4528 /* Urk! Somebody switched buffers */
4529 struct gcpro gcpro1;
4532 Fset (symbol, ovalue);
4533 Fset_buffer (current);
4540 specbind_unwind_wasnt_local (Lisp_Object buffer)
4542 Lisp_Object current = Fcurrent_buffer ();
4543 Lisp_Object symbol = specpdl_ptr->symbol;
4545 buffer = get_buffer (buffer, 0);
4548 /* Deleted buffer -- do nothing */
4550 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buffer)) == 0)
4552 /* Was buffer-local when binding was made, now no longer is.
4553 * (kill-local-variable can do this.)
4554 * Do nothing in this case.
4557 else if (EQ (buffer, current))
4558 Fkill_local_variable (symbol);
4561 /* Urk! Somebody switched buffers */
4562 struct gcpro gcpro1;
4564 Fset_buffer (buffer);
4565 Fkill_local_variable (symbol);
4566 Fset_buffer (current);
4574 specbind (Lisp_Object symbol, Lisp_Object value)
4576 SPECBIND (symbol, value);
4580 specbind_magic (Lisp_Object symbol, Lisp_Object value)
4583 symbol_value_buffer_local_info (symbol, current_buffer);
4585 if (buffer_local == 0)
4587 specpdl_ptr->old_value = find_symbol_value (symbol);
4588 specpdl_ptr->func = 0; /* Handled specially by unbind_to */
4590 else if (buffer_local > 0)
4592 /* Already buffer-local */
4593 specpdl_ptr->old_value = noseeum_cons (Fcurrent_buffer (),
4594 find_symbol_value (symbol));
4595 specpdl_ptr->func = specbind_unwind_local;
4599 /* About to become buffer-local */
4600 specpdl_ptr->old_value = Fcurrent_buffer ();
4601 specpdl_ptr->func = specbind_unwind_wasnt_local;
4604 specpdl_ptr->symbol = symbol;
4606 specpdl_depth_counter++;
4608 Fset (symbol, value);
4612 record_unwind_protect (Lisp_Object (*function) (Lisp_Object arg),
4615 SPECPDL_RESERVE (1);
4616 specpdl_ptr->func = function;
4617 specpdl_ptr->symbol = Qnil;
4618 specpdl_ptr->old_value = arg;
4620 specpdl_depth_counter++;
4623 extern int check_sigio (void);
4625 /* Unwind the stack till specpdl_depth() == COUNT.
4626 VALUE is not used, except that, purely as a convenience to the
4627 caller, it is protected from garbage-protection. */
4629 unbind_to (int count, Lisp_Object value)
4631 UNBIND_TO_GCPRO (count, value);
4635 /* Don't call this directly.
4636 Only for use by UNBIND_TO* macros in backtrace.h */
4638 unbind_to_hairy (int count)
4643 ++specpdl_depth_counter;
4645 check_quit (); /* make Vquit_flag accurate */
4646 quitf = !NILP (Vquit_flag);
4649 while (specpdl_depth_counter != count)
4652 --specpdl_depth_counter;
4654 if (specpdl_ptr->func != 0)
4655 /* An unwind-protect */
4656 (*specpdl_ptr->func) (specpdl_ptr->old_value);
4659 /* We checked symbol for validity when we specbound it,
4660 so only need to call Fset if symbol has magic value. */
4661 Lisp_Symbol *sym = XSYMBOL (specpdl_ptr->symbol);
4662 if (!SYMBOL_VALUE_MAGIC_P (sym->value))
4663 sym->value = specpdl_ptr->old_value;
4665 Fset (specpdl_ptr->symbol, specpdl_ptr->old_value);
4669 #ifndef EXCEEDINGLY_QUESTIONABLE_CODE
4670 /* There should never be anything here for us to remove.
4671 If so, it indicates a logic error in Emacs. Catches
4672 should get removed when a throw or signal occurs, or
4673 when a catch or condition-case exits normally. But
4674 it's too dangerous to just remove this code. --ben */
4676 /* Furthermore, this code is not in FSFmacs!!!
4677 Braino on mly's part? */
4678 /* If we're unwound past the pdlcount of a catch frame,
4679 that catch can't possibly still be valid. */
4680 while (catchlist && catchlist->pdlcount > specpdl_depth_counter)
4682 catchlist = catchlist->next;
4683 /* Don't mess with gcprolist, backtrace_list here */
4694 /* Get the value of symbol's global binding, even if that binding is
4695 not now dynamically visible. May return Qunbound or magic values. */
4698 top_level_value (Lisp_Object symbol)
4700 REGISTER struct specbinding *ptr = specpdl;
4702 CHECK_SYMBOL (symbol);
4703 for (; ptr != specpdl_ptr; ptr++)
4705 if (EQ (ptr->symbol, symbol))
4706 return ptr->old_value;
4708 return XSYMBOL (symbol)->value;
4714 top_level_set (Lisp_Object symbol, Lisp_Object newval)
4716 REGISTER struct specbinding *ptr = specpdl;
4718 CHECK_SYMBOL (symbol);
4719 for (; ptr != specpdl_ptr; ptr++)
4721 if (EQ (ptr->symbol, symbol))
4723 ptr->old_value = newval;
4727 return Fset (symbol, newval);
4733 /************************************************************************/
4735 /************************************************************************/
4737 DEFUN ("backtrace-debug", Fbacktrace_debug, 2, 2, 0, /*
4738 Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
4739 The debugger is entered when that frame exits, if the flag is non-nil.
4743 REGISTER struct backtrace *backlist = backtrace_list;
4748 for (i = 0; backlist && i < XINT (level); i++)
4750 backlist = backlist->next;
4754 backlist->debug_on_exit = !NILP (flag);
4760 backtrace_specials (int speccount, int speclimit, Lisp_Object stream)
4762 int printing_bindings = 0;
4764 for (; speccount > speclimit; speccount--)
4766 if (specpdl[speccount - 1].func == 0
4767 || specpdl[speccount - 1].func == specbind_unwind_local
4768 || specpdl[speccount - 1].func == specbind_unwind_wasnt_local)
4770 write_c_string (((!printing_bindings) ? " # bind (" : " "),
4772 Fprin1 (specpdl[speccount - 1].symbol, stream);
4773 printing_bindings = 1;
4777 if (printing_bindings) write_c_string (")\n", stream);
4778 write_c_string (" # (unwind-protect ...)\n", stream);
4779 printing_bindings = 0;
4782 if (printing_bindings) write_c_string (")\n", stream);
4785 DEFUN ("backtrace", Fbacktrace, 0, 2, "", /*
4786 Print a trace of Lisp function calls currently active.
4787 Optional arg STREAM specifies the output stream to send the backtrace to,
4788 and defaults to the value of `standard-output'. Optional second arg
4789 DETAILED means show places where currently active variable bindings,
4790 catches, condition-cases, and unwind-protects were made as well as
4795 /* This function can GC */
4796 struct backtrace *backlist = backtrace_list;
4797 struct catchtag *catches = catchlist;
4798 int speccount = specpdl_depth();
4800 int old_nl = print_escape_newlines;
4801 int old_pr = print_readably;
4802 Lisp_Object old_level = Vprint_level;
4803 Lisp_Object oiq = Vinhibit_quit;
4804 struct gcpro gcpro1, gcpro2;
4806 /* We can't allow quits in here because that could cause the values
4807 of print_readably and print_escape_newlines to get screwed up.
4808 Normally we would use a record_unwind_protect but that would
4809 screw up the functioning of this function. */
4812 entering_debugger = 0;
4814 Vprint_level = make_int (3);
4816 print_escape_newlines = 1;
4818 GCPRO2 (stream, old_level);
4821 stream = Vstandard_output;
4822 if (!noninteractive && (NILP (stream) || EQ (stream, Qt)))
4823 stream = Fselected_frame (Qnil);
4827 if (!NILP (detailed) && catches && catches->backlist == backlist)
4829 int catchpdl = catches->pdlcount;
4830 if (speccount > catchpdl
4831 && specpdl[catchpdl].func == condition_case_unwind)
4832 /* This is a condition-case catchpoint */
4833 catchpdl = catchpdl + 1;
4835 backtrace_specials (speccount, catchpdl, stream);
4837 speccount = catches->pdlcount;
4838 if (catchpdl == speccount)
4840 write_c_string (" # (catch ", stream);
4841 Fprin1 (catches->tag, stream);
4842 write_c_string (" ...)\n", stream);
4846 write_c_string (" # (condition-case ... . ", stream);
4847 Fprin1 (Fcdr (Fcar (catches->tag)), stream);
4848 write_c_string (")\n", stream);
4850 catches = catches->next;
4856 if (!NILP (detailed) && backlist->pdlcount < speccount)
4858 backtrace_specials (speccount, backlist->pdlcount, stream);
4859 speccount = backlist->pdlcount;
4861 write_c_string (((backlist->debug_on_exit) ? "* " : " "),
4863 if (backlist->nargs == UNEVALLED)
4865 Fprin1 (Fcons (*backlist->function, *backlist->args), stream);
4866 write_c_string ("\n", stream); /* from FSFmacs 19.30 */
4870 Lisp_Object tem = *backlist->function;
4871 Fprin1 (tem, stream); /* This can QUIT */
4872 write_c_string ("(", stream);
4873 if (backlist->nargs == MANY)
4876 Lisp_Object tail = Qnil;
4877 struct gcpro ngcpro1;
4880 for (tail = *backlist->args, i = 0;
4882 tail = Fcdr (tail), i++)
4884 if (i != 0) write_c_string (" ", stream);
4885 Fprin1 (Fcar (tail), stream);
4892 for (i = 0; i < backlist->nargs; i++)
4894 if (!i && EQ(tem, Qbyte_code)) {
4895 write_c_string("\"...\"", stream);
4898 if (i != 0) write_c_string (" ", stream);
4899 Fprin1 (backlist->args[i], stream);
4902 write_c_string (")\n", stream);
4904 backlist = backlist->next;
4907 Vprint_level = old_level;
4908 print_readably = old_pr;
4909 print_escape_newlines = old_nl;
4911 Vinhibit_quit = oiq;
4916 DEFUN ("backtrace-frame", Fbacktrace_frame, 1, 1, "", /*
4917 Return the function and arguments N frames up from current execution point.
4918 If that frame has not evaluated the arguments yet (or is a special form),
4919 the value is (nil FUNCTION ARG-FORMS...).
4920 If that frame has evaluated its arguments and called its function already,
4921 the value is (t FUNCTION ARG-VALUES...).
4922 A &rest arg is represented as the tail of the list ARG-VALUES.
4923 FUNCTION is whatever was supplied as car of evaluated list,
4924 or a lambda expression for macro calls.
4925 If N is more than the number of frames, the value is nil.
4929 REGISTER struct backtrace *backlist = backtrace_list;
4933 CHECK_NATNUM (nframes);
4935 /* Find the frame requested. */
4936 for (i = XINT (nframes); backlist && (i-- > 0);)
4937 backlist = backlist->next;
4941 if (backlist->nargs == UNEVALLED)
4942 return Fcons (Qnil, Fcons (*backlist->function, *backlist->args));
4945 if (backlist->nargs == MANY)
4946 tem = *backlist->args;
4948 tem = Flist (backlist->nargs, backlist->args);
4950 return Fcons (Qt, Fcons (*backlist->function, tem));
4955 /************************************************************************/
4957 /************************************************************************/
4960 warn_when_safe_lispobj (Lisp_Object class, Lisp_Object level,
4963 obj = list1 (list3 (class, level, obj));
4964 if (NILP (Vpending_warnings))
4965 Vpending_warnings = Vpending_warnings_tail = obj;
4968 Fsetcdr (Vpending_warnings_tail, obj);
4969 Vpending_warnings_tail = obj;
4973 /* #### This should probably accept Lisp objects; but then we have
4974 to make sure that Feval() isn't called, since it might not be safe.
4976 An alternative approach is to just pass some non-string type of
4977 Lisp_Object to warn_when_safe_lispobj(); `prin1-to-string' will
4978 automatically be called when it is safe to do so. */
4981 warn_when_safe (Lisp_Object class, Lisp_Object level, const char *fmt, ...)
4986 va_start (args, fmt);
4987 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt),
4991 warn_when_safe_lispobj (class, level, obj);
4997 /************************************************************************/
4998 /* Initialization */
4999 /************************************************************************/
5004 INIT_LRECORD_IMPLEMENTATION (subr);
5006 defsymbol (&Qinhibit_quit, "inhibit-quit");
5007 defsymbol (&Qautoload, "autoload");
5008 defsymbol (&Qdebug_on_error, "debug-on-error");
5009 defsymbol (&Qstack_trace_on_error, "stack-trace-on-error");
5010 defsymbol (&Qdebug_on_signal, "debug-on-signal");
5011 defsymbol (&Qstack_trace_on_signal, "stack-trace-on-signal");
5012 defsymbol (&Qdebugger, "debugger");
5013 defsymbol (&Qmacro, "macro");
5014 defsymbol (&Qand_rest, "&rest");
5015 defsymbol (&Qand_optional, "&optional");
5016 /* Note that the process code also uses Qexit */
5017 defsymbol (&Qexit, "exit");
5018 defsymbol (&Qsetq, "setq");
5019 defsymbol (&Qinteractive, "interactive");
5020 defsymbol (&Qcommandp, "commandp");
5021 defsymbol (&Qdefun, "defun");
5022 defsymbol (&Qprogn, "progn");
5023 defsymbol (&Qvalues, "values");
5024 defsymbol (&Qdisplay_warning, "display-warning");
5025 defsymbol (&Qrun_hooks, "run-hooks");
5026 defsymbol (&Qif, "if");
5031 DEFSUBR_MACRO (Fwhen);
5032 DEFSUBR_MACRO (Funless);
5039 DEFSUBR (Ffunction);
5041 DEFSUBR (Fdefmacro);
5043 DEFSUBR (Fdefconst);
5044 DEFSUBR (Fuser_variable_p);
5048 DEFSUBR (Fmacroexpand_internal);
5051 DEFSUBR (Funwind_protect);
5052 DEFSUBR (Fcondition_case);
5053 DEFSUBR (Fcall_with_condition_handler);
5055 DEFSUBR (Finteractive_p);
5056 DEFSUBR (Fcommandp);
5057 DEFSUBR (Fcommand_execute);
5058 DEFSUBR (Fautoload);
5062 DEFSUBR (Ffunctionp);
5063 DEFSUBR (Ffunction_min_args);
5064 DEFSUBR (Ffunction_max_args);
5065 DEFSUBR (Frun_hooks);
5066 DEFSUBR (Frun_hook_with_args);
5067 DEFSUBR (Frun_hook_with_args_until_success);
5068 DEFSUBR (Frun_hook_with_args_until_failure);
5069 DEFSUBR (Fbacktrace_debug);
5070 DEFSUBR (Fbacktrace);
5071 DEFSUBR (Fbacktrace_frame);
5077 specpdl_ptr = specpdl;
5078 specpdl_depth_counter = 0;
5080 Vcondition_handlers = Qnil;
5083 debug_on_next_call = 0;
5084 lisp_eval_depth = 0;
5085 entering_debugger = 0;
5089 reinit_vars_of_eval (void)
5091 preparing_for_armageddon = 0;
5093 Qunbound_suspended_errors_tag = make_opaque_ptr (&Qunbound_suspended_errors_tag);
5094 staticpro_nodump (&Qunbound_suspended_errors_tag);
5097 specpdl = xnew_array (struct specbinding, specpdl_size);
5098 /* XEmacs change: increase these values. */
5099 max_specpdl_size = 3000;
5100 max_lisp_eval_depth = 500;
5101 #ifdef DEFEND_AGAINST_THROW_RECURSION
5109 reinit_vars_of_eval ();
5111 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size /*
5112 Limit on number of Lisp variable bindings & unwind-protects before error.
5115 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth /*
5116 Limit on depth in `eval', `apply' and `funcall' before error.
5117 This limit is to catch infinite recursions for you before they cause
5118 actual stack overflow in C, which would be fatal for Emacs.
5119 You can safely make it considerably larger than its default value,
5120 if that proves inconveniently small.
5123 DEFVAR_LISP ("quit-flag", &Vquit_flag /*
5124 Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
5125 Typing C-G sets `quit-flag' non-nil, regardless of `inhibit-quit'.
5129 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit /*
5130 Non-nil inhibits C-g quitting from happening immediately.
5131 Note that `quit-flag' will still be set by typing C-g,
5132 so a quit will be signalled as soon as `inhibit-quit' is nil.
5133 To prevent this happening, set `quit-flag' to nil
5134 before making `inhibit-quit' nil. The value of `inhibit-quit' is
5135 ignored if a critical quit is requested by typing control-shift-G in
5138 Vinhibit_quit = Qnil;
5140 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error /*
5141 *Non-nil means automatically display a backtrace buffer
5142 after any error that is not handled by a `condition-case'.
5143 If the value is a list, an error only means to display a backtrace
5144 if one of its condition symbols appears in the list.
5145 See also variable `stack-trace-on-signal'.
5147 Vstack_trace_on_error = Qnil;
5149 DEFVAR_LISP ("stack-trace-on-signal", &Vstack_trace_on_signal /*
5150 *Non-nil means automatically display a backtrace buffer
5151 after any error that is signalled, whether or not it is handled by
5153 If the value is a list, an error only means to display a backtrace
5154 if one of its condition symbols appears in the list.
5155 See also variable `stack-trace-on-error'.
5157 Vstack_trace_on_signal = Qnil;
5159 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors /*
5160 *List of errors for which the debugger should not be called.
5161 Each element may be a condition-name or a regexp that matches error messages.
5162 If any element applies to a given error, that error skips the debugger
5163 and just returns to top level.
5164 This overrides the variable `debug-on-error'.
5165 It does not apply to errors handled by `condition-case'.
5167 Vdebug_ignored_errors = Qnil;
5169 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error /*
5170 *Non-nil means enter debugger if an unhandled error is signalled.
5171 The debugger will not be entered if the error is handled by
5173 If the value is a list, an error only means to enter the debugger
5174 if one of its condition symbols appears in the list.
5175 This variable is overridden by `debug-ignored-errors'.
5176 See also variables `debug-on-quit' and `debug-on-signal'.
5178 Vdebug_on_error = Qnil;
5180 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal /*
5181 *Non-nil means enter debugger if an error is signalled.
5182 The debugger will be entered whether or not the error is handled by
5184 If the value is a list, an error only means to enter the debugger
5185 if one of its condition symbols appears in the list.
5186 See also variable `debug-on-quit'.
5188 Vdebug_on_signal = Qnil;
5190 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit /*
5191 *Non-nil means enter debugger if quit is signalled (C-G, for example).
5192 Does not apply if quit is handled by a `condition-case'. Entering the
5193 debugger can also be achieved at any time (for X11 console) by typing
5194 control-shift-G to signal a critical quit.
5198 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call /*
5199 Non-nil means enter debugger before next `eval', `apply' or `funcall'.
5202 DEFVAR_LISP ("debugger", &Vdebugger /*
5203 Function to call to invoke debugger.
5204 If due to frame exit, args are `exit' and the value being returned;
5205 this function's value will be returned instead of that.
5206 If due to error, args are `error' and a list of the args to `signal'.
5207 If due to `apply' or `funcall' entry, one arg, `lambda'.
5208 If due to `eval' entry, one arg, t.
5212 staticpro (&Vpending_warnings);
5213 Vpending_warnings = Qnil;
5214 pdump_wire (&Vpending_warnings_tail);
5215 Vpending_warnings_tail = Qnil;
5217 staticpro (&Vautoload_queue);
5218 Vautoload_queue = Qnil;
5220 staticpro (&Vcondition_handlers);
5222 staticpro (&Vcurrent_warning_class);
5223 Vcurrent_warning_class = Qnil;
5225 staticpro (&Vcurrent_error_state);
5226 Vcurrent_error_state = Qnil; /* errors as normal */