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 and M-x edit-options recognize 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 and M-x edit-options recognize 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 return function_min_args_p ?
3319 Fsubr_min_args (function):
3320 Fsubr_max_args (function);
3322 else if (COMPILED_FUNCTIONP (function))
3324 arglist = compiled_function_arglist (XCOMPILED_FUNCTION (function));
3326 else if (CONSP (function))
3328 Lisp_Object funcar = XCAR (function);
3330 if (EQ (funcar, Qmacro))
3332 function = XCDR (function);
3335 else if (EQ (funcar, Qautoload))
3337 do_autoload (function, orig_function);
3340 else if (EQ (funcar, Qlambda))
3342 arglist = Fcar (XCDR (function));
3346 goto invalid_function;
3352 return signal_invalid_function_error (function);
3359 EXTERNAL_LIST_LOOP_2 (arg, arglist)
3361 if (EQ (arg, Qand_optional))
3363 if (function_min_args_p)
3366 else if (EQ (arg, Qand_rest))
3368 if (function_min_args_p)
3379 return make_int (argcount);
3383 DEFUN ("function-min-args", Ffunction_min_args, 1, 1, 0, /*
3384 Return the number of arguments a function may be called with.
3385 The function may be any form that can be passed to `funcall',
3386 any special form, or any macro.
3390 return function_argcount (function, 1);
3393 DEFUN ("function-max-args", Ffunction_max_args, 1, 1, 0, /*
3394 Return the number of arguments a function may be called with.
3395 The function may be any form that can be passed to `funcall',
3396 any special form, or any macro.
3397 If the function takes an arbitrary number of arguments or is
3398 a built-in special form, nil is returned.
3402 return function_argcount (function, 0);
3406 DEFUN ("apply", Fapply, 2, MANY, 0, /*
3407 Call FUNCTION with the remaining args, using the last arg as a list of args.
3408 Thus, (apply '+ 1 2 '(3 4)) returns 10.
3410 (int nargs, Lisp_Object *args))
3412 /* This function can GC */
3413 Lisp_Object fun = args[0];
3414 Lisp_Object spread_arg = args [nargs - 1];
3418 GET_EXTERNAL_LIST_LENGTH (spread_arg, numargs);
3421 /* (apply foo 0 1 '()) */
3422 return Ffuncall (nargs - 1, args);
3423 else if (numargs == 1)
3425 /* (apply foo 0 1 '(2)) */
3426 args [nargs - 1] = XCAR (spread_arg);
3427 return Ffuncall (nargs, args);
3430 /* -1 for function, -1 for spread arg */
3431 numargs = nargs - 2 + numargs;
3432 /* +1 for function */
3433 funcall_nargs = 1 + numargs;
3436 fun = indirect_function (fun, 0);
3440 Lisp_Subr *subr = XSUBR (fun);
3441 int max_args = subr->max_args;
3443 if (numargs < subr->min_args
3444 || (max_args >= 0 && max_args < numargs))
3446 /* Let funcall get the error */
3448 else if (max_args > numargs)
3450 /* Avoid having funcall cons up yet another new vector of arguments
3451 by explicitly supplying nil's for optional values */
3452 funcall_nargs += (max_args - numargs);
3455 else if (UNBOUNDP (fun))
3457 /* Let funcall get the error */
3463 Lisp_Object *funcall_args = alloca_array (Lisp_Object, funcall_nargs);
3464 struct gcpro gcpro1;
3466 GCPRO1 (*funcall_args);
3467 gcpro1.nvars = funcall_nargs;
3469 /* Copy in the unspread args */
3470 memcpy (funcall_args, args, (nargs - 1) * sizeof (Lisp_Object));
3471 /* Spread the last arg we got. Its first element goes in
3472 the slot that it used to occupy, hence this value of I. */
3474 !NILP (spread_arg); /* i < 1 + numargs */
3475 i++, spread_arg = XCDR (spread_arg))
3477 funcall_args [i] = XCAR (spread_arg);
3479 /* Supply nil for optional args (to subrs) */
3480 for (; i < funcall_nargs; i++)
3481 funcall_args[i] = Qnil;
3484 RETURN_UNGCPRO (Ffuncall (funcall_nargs, funcall_args));
3489 /* Apply lambda list FUN to the NARGS evaluated arguments in ARGS and
3490 return the result of evaluation. */
3493 funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object args[])
3495 /* This function can GC */
3496 Lisp_Object symbol, arglist, body, tail;
3497 int speccount = specpdl_depth();
3503 goto invalid_function;
3505 arglist = XCAR (tail);
3509 int optional = 0, rest = 0;
3511 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
3513 if (!SYMBOLP (symbol))
3514 goto invalid_function;
3515 if (EQ (symbol, Qand_rest))
3517 else if (EQ (symbol, Qand_optional))
3521 specbind (symbol, Flist (nargs - i, &args[i]));
3525 specbind (symbol, args[i++]);
3527 goto wrong_number_of_arguments;
3529 specbind (symbol, Qnil);
3534 goto wrong_number_of_arguments;
3536 return unbind_to (speccount, Fprogn (body));
3538 wrong_number_of_arguments:
3539 return signal_wrong_number_of_arguments_error (fun, nargs);
3542 return signal_invalid_function_error (fun);
3546 /************************************************************************/
3547 /* Run hook variables in various ways. */
3548 /************************************************************************/
3550 DEFUN ("run-hooks", Frun_hooks, 1, MANY, 0, /*
3551 Run each hook in HOOKS. Major mode functions use this.
3552 Each argument should be a symbol, a hook variable.
3553 These symbols are processed in the order specified.
3554 If a hook symbol has a non-nil value, that value may be a function
3555 or a list of functions to be called to run the hook.
3556 If the value is a function, it is called with no arguments.
3557 If it is a list, the elements are called, in order, with no arguments.
3559 To make a hook variable buffer-local, use `make-local-hook',
3560 not `make-local-variable'.
3562 (int nargs, Lisp_Object *args))
3566 for (i = 0; i < nargs; i++)
3567 run_hook_with_args (1, args + i, RUN_HOOKS_TO_COMPLETION);
3572 DEFUN ("run-hook-with-args", Frun_hook_with_args, 1, MANY, 0, /*
3573 Run HOOK with the specified arguments ARGS.
3574 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
3575 value, that value may be a function or a list of functions to be
3576 called to run the hook. If the value is a function, it is called with
3577 the given arguments and its return value is returned. If it is a list
3578 of functions, those functions are called, in order,
3579 with the given arguments ARGS.
3580 It is best not to depend on the value return by `run-hook-with-args',
3583 To make a hook variable buffer-local, use `make-local-hook',
3584 not `make-local-variable'.
3586 (int nargs, Lisp_Object *args))
3588 return run_hook_with_args (nargs, args, RUN_HOOKS_TO_COMPLETION);
3591 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success, 1, MANY, 0, /*
3592 Run HOOK with the specified arguments ARGS.
3593 HOOK should be a symbol, a hook variable. Its value should
3594 be a list of functions. We call those functions, one by one,
3595 passing arguments ARGS to each of them, until one of them
3596 returns a non-nil value. Then we return that value.
3597 If all the functions return nil, we return nil.
3599 To make a hook variable buffer-local, use `make-local-hook',
3600 not `make-local-variable'.
3602 (int nargs, Lisp_Object *args))
3604 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_SUCCESS);
3607 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure, 1, MANY, 0, /*
3608 Run HOOK with the specified arguments ARGS.
3609 HOOK should be a symbol, a hook variable. Its value should
3610 be a list of functions. We call those functions, one by one,
3611 passing arguments ARGS to each of them, until one of them
3612 returns nil. Then we return nil.
3613 If all the functions return non-nil, we return non-nil.
3615 To make a hook variable buffer-local, use `make-local-hook',
3616 not `make-local-variable'.
3618 (int nargs, Lisp_Object *args))
3620 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_FAILURE);
3623 /* ARGS[0] should be a hook symbol.
3624 Call each of the functions in the hook value, passing each of them
3625 as arguments all the rest of ARGS (all NARGS - 1 elements).
3626 COND specifies a condition to test after each call
3627 to decide whether to stop.
3628 The caller (or its caller, etc) must gcpro all of ARGS,
3629 except that it isn't necessary to gcpro ARGS[0]. */
3632 run_hook_with_args_in_buffer (struct buffer *buf, int nargs, Lisp_Object *args,
3633 enum run_hooks_condition cond)
3635 Lisp_Object sym, val, ret;
3637 if (!initialized || preparing_for_armageddon)
3638 /* We need to bail out of here pronto. */
3641 /* Whenever gc_in_progress is true, preparing_for_armageddon
3642 will also be true unless something is really hosed. */
3643 assert (!gc_in_progress);
3646 val = symbol_value_in_buffer (sym, make_buffer (buf));
3647 ret = (cond == RUN_HOOKS_UNTIL_FAILURE ? Qt : Qnil);
3649 if (UNBOUNDP (val) || NILP (val))
3651 else if (!CONSP (val) || EQ (XCAR (val), Qlambda))
3654 return Ffuncall (nargs, args);
3658 struct gcpro gcpro1, gcpro2, gcpro3;
3659 Lisp_Object globals = Qnil;
3660 GCPRO3 (sym, val, globals);
3663 CONSP (val) && ((cond == RUN_HOOKS_TO_COMPLETION)
3664 || (cond == RUN_HOOKS_UNTIL_SUCCESS ? NILP (ret)
3668 if (EQ (XCAR (val), Qt))
3670 /* t indicates this hook has a local binding;
3671 it means to run the global binding too. */
3672 globals = Fdefault_value (sym);
3674 if ((! CONSP (globals) || EQ (XCAR (globals), Qlambda)) &&
3678 ret = Ffuncall (nargs, args);
3683 CONSP (globals) && ((cond == RUN_HOOKS_TO_COMPLETION)
3684 || (cond == RUN_HOOKS_UNTIL_SUCCESS
3687 globals = XCDR (globals))
3689 args[0] = XCAR (globals);
3690 /* In a global value, t should not occur. If it does, we
3691 must ignore it to avoid an endless loop. */
3692 if (!EQ (args[0], Qt))
3693 ret = Ffuncall (nargs, args);
3699 args[0] = XCAR (val);
3700 ret = Ffuncall (nargs, args);
3710 run_hook_with_args (int nargs, Lisp_Object *args,
3711 enum run_hooks_condition cond)
3713 return run_hook_with_args_in_buffer (current_buffer, nargs, args, cond);
3718 /* From FSF 19.30, not currently used */
3720 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
3721 present value of that symbol.
3722 Call each element of FUNLIST,
3723 passing each of them the rest of ARGS.
3724 The caller (or its caller, etc) must gcpro all of ARGS,
3725 except that it isn't necessary to gcpro ARGS[0]. */
3728 run_hook_list_with_args (Lisp_Object funlist, int nargs, Lisp_Object *args)
3730 Lisp_Object sym = args[0];
3732 struct gcpro gcpro1, gcpro2;
3736 for (val = funlist; CONSP (val); val = XCDR (val))
3738 if (EQ (XCAR (val), Qt))
3740 /* t indicates this hook has a local binding;
3741 it means to run the global binding too. */
3742 Lisp_Object globals;
3744 for (globals = Fdefault_value (sym);
3746 globals = XCDR (globals))
3748 args[0] = XCAR (globals);
3749 /* In a global value, t should not occur. If it does, we
3750 must ignore it to avoid an endless loop. */
3751 if (!EQ (args[0], Qt))
3752 Ffuncall (nargs, args);
3757 args[0] = XCAR (val);
3758 Ffuncall (nargs, args);
3768 va_run_hook_with_args (Lisp_Object hook_var, int nargs, ...)
3770 /* This function can GC */
3771 struct gcpro gcpro1;
3774 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs);
3776 va_start (vargs, nargs);
3777 funcall_args[0] = hook_var;
3778 for (i = 0; i < nargs; i++)
3779 funcall_args[i + 1] = va_arg (vargs, Lisp_Object);
3782 GCPRO1 (*funcall_args);
3783 gcpro1.nvars = nargs + 1;
3784 run_hook_with_args (nargs + 1, funcall_args, RUN_HOOKS_TO_COMPLETION);
3789 va_run_hook_with_args_in_buffer (struct buffer *buf, Lisp_Object hook_var,
3792 /* This function can GC */
3793 struct gcpro gcpro1;
3796 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs);
3798 va_start (vargs, nargs);
3799 funcall_args[0] = hook_var;
3800 for (i = 0; i < nargs; i++)
3801 funcall_args[i + 1] = va_arg (vargs, Lisp_Object);
3804 GCPRO1 (*funcall_args);
3805 gcpro1.nvars = nargs + 1;
3806 run_hook_with_args_in_buffer (buf, nargs + 1, funcall_args,
3807 RUN_HOOKS_TO_COMPLETION);
3812 run_hook (Lisp_Object hook)
3814 Frun_hooks (1, &hook);
3819 /************************************************************************/
3820 /* Front-ends to eval, funcall, apply */
3821 /************************************************************************/
3823 /* Apply fn to arg */
3825 apply1 (Lisp_Object fn, Lisp_Object arg)
3827 /* This function can GC */
3828 struct gcpro gcpro1;
3829 Lisp_Object args[2];
3832 return Ffuncall (1, &fn);
3837 RETURN_UNGCPRO (Fapply (2, args));
3840 /* Call function fn on no arguments */
3842 call0 (Lisp_Object fn)
3844 /* This function can GC */
3845 struct gcpro gcpro1;
3848 RETURN_UNGCPRO (Ffuncall (1, &fn));
3851 /* Call function fn with argument arg0 */
3853 call1 (Lisp_Object fn,
3856 /* This function can GC */
3857 struct gcpro gcpro1;
3858 Lisp_Object args[2];
3863 RETURN_UNGCPRO (Ffuncall (2, args));
3866 /* Call function fn with arguments arg0, arg1 */
3868 call2 (Lisp_Object fn,
3869 Lisp_Object arg0, Lisp_Object arg1)
3871 /* This function can GC */
3872 struct gcpro gcpro1;
3873 Lisp_Object args[3];
3879 RETURN_UNGCPRO (Ffuncall (3, args));
3882 /* Call function fn with arguments arg0, arg1, arg2 */
3884 call3 (Lisp_Object fn,
3885 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2)
3887 /* This function can GC */
3888 struct gcpro gcpro1;
3889 Lisp_Object args[4];
3896 RETURN_UNGCPRO (Ffuncall (4, args));
3899 /* Call function fn with arguments arg0, arg1, arg2, arg3 */
3901 call4 (Lisp_Object fn,
3902 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3905 /* This function can GC */
3906 struct gcpro gcpro1;
3907 Lisp_Object args[5];
3915 RETURN_UNGCPRO (Ffuncall (5, args));
3918 /* Call function fn with arguments arg0, arg1, arg2, arg3, arg4 */
3920 call5 (Lisp_Object fn,
3921 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3922 Lisp_Object arg3, Lisp_Object arg4)
3924 /* This function can GC */
3925 struct gcpro gcpro1;
3926 Lisp_Object args[6];
3935 RETURN_UNGCPRO (Ffuncall (6, args));
3939 call6 (Lisp_Object fn,
3940 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3941 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5)
3943 /* This function can GC */
3944 struct gcpro gcpro1;
3945 Lisp_Object args[7];
3955 RETURN_UNGCPRO (Ffuncall (7, args));
3959 call7 (Lisp_Object fn,
3960 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3961 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5,
3964 /* This function can GC */
3965 struct gcpro gcpro1;
3966 Lisp_Object args[8];
3977 RETURN_UNGCPRO (Ffuncall (8, args));
3981 call8 (Lisp_Object fn,
3982 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3983 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5,
3984 Lisp_Object arg6, Lisp_Object arg7)
3986 /* This function can GC */
3987 struct gcpro gcpro1;
3988 Lisp_Object args[9];
4000 RETURN_UNGCPRO (Ffuncall (9, args));
4004 call0_in_buffer (struct buffer *buf, Lisp_Object fn)
4006 if (current_buffer == buf)
4011 int speccount = specpdl_depth();
4012 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4013 set_buffer_internal (buf);
4015 unbind_to (speccount, Qnil);
4021 call1_in_buffer (struct buffer *buf, Lisp_Object fn,
4024 if (current_buffer == buf)
4025 return call1 (fn, arg0);
4029 int speccount = specpdl_depth();
4030 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4031 set_buffer_internal (buf);
4032 val = call1 (fn, arg0);
4033 unbind_to (speccount, Qnil);
4039 call2_in_buffer (struct buffer *buf, Lisp_Object fn,
4040 Lisp_Object arg0, Lisp_Object arg1)
4042 if (current_buffer == buf)
4043 return call2 (fn, arg0, arg1);
4047 int speccount = specpdl_depth();
4048 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4049 set_buffer_internal (buf);
4050 val = call2 (fn, arg0, arg1);
4051 unbind_to (speccount, Qnil);
4057 call3_in_buffer (struct buffer *buf, Lisp_Object fn,
4058 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2)
4060 if (current_buffer == buf)
4061 return call3 (fn, arg0, arg1, arg2);
4065 int speccount = specpdl_depth();
4066 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4067 set_buffer_internal (buf);
4068 val = call3 (fn, arg0, arg1, arg2);
4069 unbind_to (speccount, Qnil);
4075 call4_in_buffer (struct buffer *buf, Lisp_Object fn,
4076 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4079 if (current_buffer == buf)
4080 return call4 (fn, arg0, arg1, arg2, arg3);
4084 int speccount = specpdl_depth();
4085 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4086 set_buffer_internal (buf);
4087 val = call4 (fn, arg0, arg1, arg2, arg3);
4088 unbind_to (speccount, Qnil);
4094 eval_in_buffer (struct buffer *buf, Lisp_Object form)
4096 if (current_buffer == buf)
4097 return Feval (form);
4101 int speccount = specpdl_depth();
4102 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4103 set_buffer_internal (buf);
4105 unbind_to (speccount, Qnil);
4111 /************************************************************************/
4112 /* Error-catching front-ends to eval, funcall, apply */
4113 /************************************************************************/
4115 /* Call function fn on no arguments, with condition handler */
4117 call0_with_handler (Lisp_Object handler, Lisp_Object fn)
4119 /* This function can GC */
4120 struct gcpro gcpro1;
4121 Lisp_Object args[2];
4126 RETURN_UNGCPRO (Fcall_with_condition_handler (2, args));
4129 /* Call function fn with argument arg0, with condition handler */
4131 call1_with_handler (Lisp_Object handler, Lisp_Object fn,
4134 /* This function can GC */
4135 struct gcpro gcpro1;
4136 Lisp_Object args[3];
4142 RETURN_UNGCPRO (Fcall_with_condition_handler (3, args));
4146 /* The following functions provide you with error-trapping versions
4147 of the various front-ends above. They take an additional
4148 "warning_string" argument; if non-zero, a warning with this
4149 string and the actual error that occurred will be displayed
4150 in the *Warnings* buffer if an error occurs. In all cases,
4151 QUIT is inhibited while these functions are running, and if
4152 an error occurs, Qunbound is returned instead of the normal
4156 /* #### This stuff needs to catch throws as well. We need to
4157 improve internal_catch() so it can take a "catch anything"
4158 argument similar to Qt or Qerror for condition_case_1(). */
4161 caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg)
4163 if (!NILP (errordata))
4165 Lisp_Object args[2];
4169 char *str = (char *) get_opaque_ptr (arg);
4170 args[0] = build_string (str);
4173 args[0] = build_string ("error");
4174 /* #### This should call
4175 (with-output-to-string (display-error errordata))
4176 but that stuff is all in Lisp currently. */
4177 args[1] = errordata;
4178 warn_when_safe_lispobj
4180 emacs_doprnt_string_lisp ((const Bufbyte *) "%s: %s",
4181 Qnil, -1, 2, args));
4187 allow_quit_caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg)
4189 if (CONSP (errordata) && EQ (XCAR (errordata), Qquit))
4190 return Fsignal (Qquit, XCDR (errordata));
4191 return caught_a_squirmer (errordata, arg);
4195 safe_run_hook_caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg)
4197 Lisp_Object hook = Fcar (arg);
4199 /* Clear out the hook. */
4201 return caught_a_squirmer (errordata, arg);
4205 allow_quit_safe_run_hook_caught_a_squirmer (Lisp_Object errordata,
4208 Lisp_Object hook = Fcar (arg);
4210 if (!CONSP (errordata) || !EQ (XCAR (errordata), Qquit))
4211 /* Clear out the hook. */
4213 return allow_quit_caught_a_squirmer (errordata, arg);
4217 catch_them_squirmers_eval_in_buffer (Lisp_Object cons)
4219 return eval_in_buffer (XBUFFER (XCAR (cons)), XCDR (cons));
4223 eval_in_buffer_trapping_errors (const char *warning_string,
4224 struct buffer *buf, Lisp_Object form)
4226 int speccount = specpdl_depth();
4231 struct gcpro gcpro1, gcpro2;
4233 XSETBUFFER (buffer, buf);
4235 specbind (Qinhibit_quit, Qt);
4236 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4238 cons = noseeum_cons (buffer, form);
4239 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
4240 GCPRO2 (cons, opaque);
4241 /* Qerror not Qt, so you can get a backtrace */
4242 tem = condition_case_1 (Qerror,
4243 catch_them_squirmers_eval_in_buffer, cons,
4244 caught_a_squirmer, opaque);
4245 free_cons (XCONS (cons));
4246 if (OPAQUE_PTRP (opaque))
4247 free_opaque_ptr (opaque);
4250 /* gc_currently_forbidden = 0; */
4251 return unbind_to (speccount, tem);
4255 catch_them_squirmers_run_hook (Lisp_Object hook_symbol)
4257 /* This function can GC */
4258 run_hook (hook_symbol);
4263 run_hook_trapping_errors (const char *warning_string, Lisp_Object hook_symbol)
4268 struct gcpro gcpro1;
4270 if (!initialized || preparing_for_armageddon)
4272 tem = find_symbol_value (hook_symbol);
4273 if (NILP (tem) || UNBOUNDP (tem))
4276 speccount = specpdl_depth();
4277 specbind (Qinhibit_quit, Qt);
4279 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
4281 /* Qerror not Qt, so you can get a backtrace */
4282 tem = condition_case_1 (Qerror,
4283 catch_them_squirmers_run_hook, hook_symbol,
4284 caught_a_squirmer, opaque);
4285 if (OPAQUE_PTRP (opaque))
4286 free_opaque_ptr (opaque);
4289 return unbind_to (speccount, tem);
4292 /* Same as run_hook_trapping_errors() but also set the hook to nil
4293 if an error occurs. */
4296 safe_run_hook_trapping_errors (const char *warning_string,
4297 Lisp_Object hook_symbol,
4300 int speccount = specpdl_depth();
4302 Lisp_Object cons = Qnil;
4303 struct gcpro gcpro1;
4305 if (!initialized || preparing_for_armageddon)
4307 tem = find_symbol_value (hook_symbol);
4308 if (NILP (tem) || UNBOUNDP (tem))
4312 specbind (Qinhibit_quit, Qt);
4314 cons = noseeum_cons (hook_symbol,
4315 warning_string ? make_opaque_ptr ((void *)warning_string)
4318 /* Qerror not Qt, so you can get a backtrace */
4319 tem = condition_case_1 (Qerror,
4320 catch_them_squirmers_run_hook,
4323 allow_quit_safe_run_hook_caught_a_squirmer :
4324 safe_run_hook_caught_a_squirmer,
4326 if (OPAQUE_PTRP (XCDR (cons)))
4327 free_opaque_ptr (XCDR (cons));
4328 free_cons (XCONS (cons));
4331 return unbind_to (speccount, tem);
4335 catch_them_squirmers_call0 (Lisp_Object function)
4337 /* This function can GC */
4338 return call0 (function);
4342 call0_trapping_errors (const char *warning_string, Lisp_Object function)
4346 Lisp_Object opaque = Qnil;
4347 struct gcpro gcpro1, gcpro2;
4349 if (SYMBOLP (function))
4351 tem = XSYMBOL (function)->function;
4352 if (NILP (tem) || UNBOUNDP (tem))
4356 GCPRO2 (opaque, function);
4357 speccount = specpdl_depth();
4358 specbind (Qinhibit_quit, Qt);
4359 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4361 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
4362 /* Qerror not Qt, so you can get a backtrace */
4363 tem = condition_case_1 (Qerror,
4364 catch_them_squirmers_call0, function,
4365 caught_a_squirmer, opaque);
4366 if (OPAQUE_PTRP (opaque))
4367 free_opaque_ptr (opaque);
4370 /* gc_currently_forbidden = 0; */
4371 return unbind_to (speccount, tem);
4375 catch_them_squirmers_call1 (Lisp_Object cons)
4377 /* This function can GC */
4378 return call1 (XCAR (cons), XCDR (cons));
4382 catch_them_squirmers_call2 (Lisp_Object cons)
4384 /* This function can GC */
4385 return call2 (XCAR (cons), XCAR (XCDR (cons)), XCAR (XCDR (XCDR (cons))));
4389 call1_trapping_errors (const char *warning_string, Lisp_Object function,
4392 int speccount = specpdl_depth();
4394 Lisp_Object cons = Qnil;
4395 Lisp_Object opaque = Qnil;
4396 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
4398 if (SYMBOLP (function))
4400 tem = XSYMBOL (function)->function;
4401 if (NILP (tem) || UNBOUNDP (tem))
4405 GCPRO4 (cons, opaque, function, object);
4407 specbind (Qinhibit_quit, Qt);
4408 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4410 cons = noseeum_cons (function, object);
4411 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
4412 /* Qerror not Qt, so you can get a backtrace */
4413 tem = condition_case_1 (Qerror,
4414 catch_them_squirmers_call1, cons,
4415 caught_a_squirmer, opaque);
4416 if (OPAQUE_PTRP (opaque))
4417 free_opaque_ptr (opaque);
4418 free_cons (XCONS (cons));
4421 /* gc_currently_forbidden = 0; */
4422 return unbind_to (speccount, tem);
4426 call2_trapping_errors (const char *warning_string, Lisp_Object function,
4427 Lisp_Object object1, Lisp_Object object2)
4429 int speccount = specpdl_depth();
4431 Lisp_Object cons = Qnil;
4432 Lisp_Object opaque = Qnil;
4433 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
4435 if (SYMBOLP (function))
4437 tem = XSYMBOL (function)->function;
4438 if (NILP (tem) || UNBOUNDP (tem))
4442 GCPRO5 (cons, opaque, function, object1, object2);
4443 specbind (Qinhibit_quit, Qt);
4444 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4446 cons = list3 (function, object1, object2);
4447 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
4448 /* Qerror not Qt, so you can get a backtrace */
4449 tem = condition_case_1 (Qerror,
4450 catch_them_squirmers_call2, cons,
4451 caught_a_squirmer, opaque);
4452 if (OPAQUE_PTRP (opaque))
4453 free_opaque_ptr (opaque);
4457 /* gc_currently_forbidden = 0; */
4458 return unbind_to (speccount, tem);
4462 /************************************************************************/
4463 /* The special binding stack */
4464 /* Most C code should simply use specbind() and unbind_to(). */
4465 /* When performance is critical, use the macros in backtrace.h. */
4466 /************************************************************************/
4468 #define min_max_specpdl_size 400
4471 grow_specpdl (size_t reserved)
4473 size_t size_needed = specpdl_depth() + reserved;
4474 if (size_needed >= max_specpdl_size)
4476 if (max_specpdl_size < min_max_specpdl_size)
4477 max_specpdl_size = min_max_specpdl_size;
4478 if (size_needed >= max_specpdl_size)
4480 if (!NILP (Vdebug_on_error) ||
4481 !NILP (Vdebug_on_signal))
4482 /* Leave room for some specpdl in the debugger. */
4483 max_specpdl_size = size_needed + 100;
4485 ("Variable binding depth exceeds max-specpdl-size");
4488 while (specpdl_size < size_needed)
4491 if (specpdl_size > max_specpdl_size)
4492 specpdl_size = max_specpdl_size;
4494 XREALLOC_ARRAY (specpdl, struct specbinding, specpdl_size);
4495 specpdl_ptr = specpdl + specpdl_depth();
4499 /* Handle unbinding buffer-local variables */
4501 specbind_unwind_local (Lisp_Object ovalue)
4503 Lisp_Object current = Fcurrent_buffer ();
4504 Lisp_Object symbol = specpdl_ptr->symbol;
4505 Lisp_Cons *victim = XCONS (ovalue);
4506 Lisp_Object buf = get_buffer (victim->car, 0);
4507 ovalue = victim->cdr;
4513 /* Deleted buffer -- do nothing */
4515 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buf)) == 0)
4517 /* Was buffer-local when binding was made, now no longer is.
4518 * (kill-local-variable can do this.)
4519 * Do nothing in this case.
4522 else if (EQ (buf, current))
4523 Fset (symbol, ovalue);
4526 /* Urk! Somebody switched buffers */
4527 struct gcpro gcpro1;
4530 Fset (symbol, ovalue);
4531 Fset_buffer (current);
4538 specbind_unwind_wasnt_local (Lisp_Object buffer)
4540 Lisp_Object current = Fcurrent_buffer ();
4541 Lisp_Object symbol = specpdl_ptr->symbol;
4543 buffer = get_buffer (buffer, 0);
4546 /* Deleted buffer -- do nothing */
4548 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buffer)) == 0)
4550 /* Was buffer-local when binding was made, now no longer is.
4551 * (kill-local-variable can do this.)
4552 * Do nothing in this case.
4555 else if (EQ (buffer, current))
4556 Fkill_local_variable (symbol);
4559 /* Urk! Somebody switched buffers */
4560 struct gcpro gcpro1;
4562 Fset_buffer (buffer);
4563 Fkill_local_variable (symbol);
4564 Fset_buffer (current);
4572 specbind (Lisp_Object symbol, Lisp_Object value)
4574 SPECBIND (symbol, value);
4578 specbind_magic (Lisp_Object symbol, Lisp_Object value)
4581 symbol_value_buffer_local_info (symbol, current_buffer);
4583 if (buffer_local == 0)
4585 specpdl_ptr->old_value = find_symbol_value (symbol);
4586 specpdl_ptr->func = 0; /* Handled specially by unbind_to */
4588 else if (buffer_local > 0)
4590 /* Already buffer-local */
4591 specpdl_ptr->old_value = noseeum_cons (Fcurrent_buffer (),
4592 find_symbol_value (symbol));
4593 specpdl_ptr->func = specbind_unwind_local;
4597 /* About to become buffer-local */
4598 specpdl_ptr->old_value = Fcurrent_buffer ();
4599 specpdl_ptr->func = specbind_unwind_wasnt_local;
4602 specpdl_ptr->symbol = symbol;
4604 specpdl_depth_counter++;
4606 Fset (symbol, value);
4610 record_unwind_protect (Lisp_Object (*function) (Lisp_Object arg),
4613 SPECPDL_RESERVE (1);
4614 specpdl_ptr->func = function;
4615 specpdl_ptr->symbol = Qnil;
4616 specpdl_ptr->old_value = arg;
4618 specpdl_depth_counter++;
4621 extern int check_sigio (void);
4623 /* Unwind the stack till specpdl_depth() == COUNT.
4624 VALUE is not used, except that, purely as a convenience to the
4625 caller, it is protected from garbage-protection. */
4627 unbind_to (int count, Lisp_Object value)
4629 UNBIND_TO_GCPRO (count, value);
4633 /* Don't call this directly.
4634 Only for use by UNBIND_TO* macros in backtrace.h */
4636 unbind_to_hairy (int count)
4641 ++specpdl_depth_counter;
4643 check_quit (); /* make Vquit_flag accurate */
4644 quitf = !NILP (Vquit_flag);
4647 while (specpdl_depth_counter != count)
4650 --specpdl_depth_counter;
4652 if (specpdl_ptr->func != 0)
4653 /* An unwind-protect */
4654 (*specpdl_ptr->func) (specpdl_ptr->old_value);
4657 /* We checked symbol for validity when we specbound it,
4658 so only need to call Fset if symbol has magic value. */
4659 Lisp_Symbol *sym = XSYMBOL (specpdl_ptr->symbol);
4660 if (!SYMBOL_VALUE_MAGIC_P (sym->value))
4661 sym->value = specpdl_ptr->old_value;
4663 Fset (specpdl_ptr->symbol, specpdl_ptr->old_value);
4667 #ifndef EXCEEDINGLY_QUESTIONABLE_CODE
4668 /* There should never be anything here for us to remove.
4669 If so, it indicates a logic error in Emacs. Catches
4670 should get removed when a throw or signal occurs, or
4671 when a catch or condition-case exits normally. But
4672 it's too dangerous to just remove this code. --ben */
4674 /* Furthermore, this code is not in FSFmacs!!!
4675 Braino on mly's part? */
4676 /* If we're unwound past the pdlcount of a catch frame,
4677 that catch can't possibly still be valid. */
4678 while (catchlist && catchlist->pdlcount > specpdl_depth_counter)
4680 catchlist = catchlist->next;
4681 /* Don't mess with gcprolist, backtrace_list here */
4692 /* Get the value of symbol's global binding, even if that binding is
4693 not now dynamically visible. May return Qunbound or magic values. */
4696 top_level_value (Lisp_Object symbol)
4698 REGISTER struct specbinding *ptr = specpdl;
4700 CHECK_SYMBOL (symbol);
4701 for (; ptr != specpdl_ptr; ptr++)
4703 if (EQ (ptr->symbol, symbol))
4704 return ptr->old_value;
4706 return XSYMBOL (symbol)->value;
4712 top_level_set (Lisp_Object symbol, Lisp_Object newval)
4714 REGISTER struct specbinding *ptr = specpdl;
4716 CHECK_SYMBOL (symbol);
4717 for (; ptr != specpdl_ptr; ptr++)
4719 if (EQ (ptr->symbol, symbol))
4721 ptr->old_value = newval;
4725 return Fset (symbol, newval);
4731 /************************************************************************/
4733 /************************************************************************/
4735 DEFUN ("backtrace-debug", Fbacktrace_debug, 2, 2, 0, /*
4736 Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
4737 The debugger is entered when that frame exits, if the flag is non-nil.
4741 REGISTER struct backtrace *backlist = backtrace_list;
4746 for (i = 0; backlist && i < XINT (level); i++)
4748 backlist = backlist->next;
4752 backlist->debug_on_exit = !NILP (flag);
4758 backtrace_specials (int speccount, int speclimit, Lisp_Object stream)
4760 int printing_bindings = 0;
4762 for (; speccount > speclimit; speccount--)
4764 if (specpdl[speccount - 1].func == 0
4765 || specpdl[speccount - 1].func == specbind_unwind_local
4766 || specpdl[speccount - 1].func == specbind_unwind_wasnt_local)
4768 write_c_string (((!printing_bindings) ? " # bind (" : " "),
4770 Fprin1 (specpdl[speccount - 1].symbol, stream);
4771 printing_bindings = 1;
4775 if (printing_bindings) write_c_string (")\n", stream);
4776 write_c_string (" # (unwind-protect ...)\n", stream);
4777 printing_bindings = 0;
4780 if (printing_bindings) write_c_string (")\n", stream);
4783 DEFUN ("backtrace", Fbacktrace, 0, 2, "", /*
4784 Print a trace of Lisp function calls currently active.
4785 Optional arg STREAM specifies the output stream to send the backtrace to,
4786 and defaults to the value of `standard-output'. Optional second arg
4787 DETAILED means show places where currently active variable bindings,
4788 catches, condition-cases, and unwind-protects were made as well as
4793 /* This function can GC */
4794 struct backtrace *backlist = backtrace_list;
4795 struct catchtag *catches = catchlist;
4796 int speccount = specpdl_depth();
4798 int old_nl = print_escape_newlines;
4799 int old_pr = print_readably;
4800 Lisp_Object old_level = Vprint_level;
4801 Lisp_Object oiq = Vinhibit_quit;
4802 struct gcpro gcpro1, gcpro2;
4804 /* We can't allow quits in here because that could cause the values
4805 of print_readably and print_escape_newlines to get screwed up.
4806 Normally we would use a record_unwind_protect but that would
4807 screw up the functioning of this function. */
4810 entering_debugger = 0;
4812 Vprint_level = make_int (3);
4814 print_escape_newlines = 1;
4816 GCPRO2 (stream, old_level);
4819 stream = Vstandard_output;
4820 if (!noninteractive && (NILP (stream) || EQ (stream, Qt)))
4821 stream = Fselected_frame (Qnil);
4825 if (!NILP (detailed) && catches && catches->backlist == backlist)
4827 int catchpdl = catches->pdlcount;
4828 if (speccount > catchpdl
4829 && specpdl[catchpdl].func == condition_case_unwind)
4830 /* This is a condition-case catchpoint */
4831 catchpdl = catchpdl + 1;
4833 backtrace_specials (speccount, catchpdl, stream);
4835 speccount = catches->pdlcount;
4836 if (catchpdl == speccount)
4838 write_c_string (" # (catch ", stream);
4839 Fprin1 (catches->tag, stream);
4840 write_c_string (" ...)\n", stream);
4844 write_c_string (" # (condition-case ... . ", stream);
4845 Fprin1 (Fcdr (Fcar (catches->tag)), stream);
4846 write_c_string (")\n", stream);
4848 catches = catches->next;
4854 if (!NILP (detailed) && backlist->pdlcount < speccount)
4856 backtrace_specials (speccount, backlist->pdlcount, stream);
4857 speccount = backlist->pdlcount;
4859 write_c_string (((backlist->debug_on_exit) ? "* " : " "),
4861 if (backlist->nargs == UNEVALLED)
4863 Fprin1 (Fcons (*backlist->function, *backlist->args), stream);
4864 write_c_string ("\n", stream); /* from FSFmacs 19.30 */
4868 Lisp_Object tem = *backlist->function;
4869 Fprin1 (tem, stream); /* This can QUIT */
4870 write_c_string ("(", stream);
4871 if (backlist->nargs == MANY)
4874 Lisp_Object tail = Qnil;
4875 struct gcpro ngcpro1;
4878 for (tail = *backlist->args, i = 0;
4880 tail = Fcdr (tail), i++)
4882 if (i != 0) write_c_string (" ", stream);
4883 Fprin1 (Fcar (tail), stream);
4890 for (i = 0; i < backlist->nargs; i++)
4892 if (!i && EQ(tem, Qbyte_code)) {
4893 write_c_string("\"...\"", stream);
4896 if (i != 0) write_c_string (" ", stream);
4897 Fprin1 (backlist->args[i], stream);
4900 write_c_string (")\n", stream);
4902 backlist = backlist->next;
4905 Vprint_level = old_level;
4906 print_readably = old_pr;
4907 print_escape_newlines = old_nl;
4909 Vinhibit_quit = oiq;
4914 DEFUN ("backtrace-frame", Fbacktrace_frame, 1, 1, "", /*
4915 Return the function and arguments N frames up from current execution point.
4916 If that frame has not evaluated the arguments yet (or is a special form),
4917 the value is (nil FUNCTION ARG-FORMS...).
4918 If that frame has evaluated its arguments and called its function already,
4919 the value is (t FUNCTION ARG-VALUES...).
4920 A &rest arg is represented as the tail of the list ARG-VALUES.
4921 FUNCTION is whatever was supplied as car of evaluated list,
4922 or a lambda expression for macro calls.
4923 If N is more than the number of frames, the value is nil.
4927 REGISTER struct backtrace *backlist = backtrace_list;
4931 CHECK_NATNUM (nframes);
4933 /* Find the frame requested. */
4934 for (i = XINT (nframes); backlist && (i-- > 0);)
4935 backlist = backlist->next;
4939 if (backlist->nargs == UNEVALLED)
4940 return Fcons (Qnil, Fcons (*backlist->function, *backlist->args));
4943 if (backlist->nargs == MANY)
4944 tem = *backlist->args;
4946 tem = Flist (backlist->nargs, backlist->args);
4948 return Fcons (Qt, Fcons (*backlist->function, tem));
4953 /************************************************************************/
4955 /************************************************************************/
4958 warn_when_safe_lispobj (Lisp_Object class, Lisp_Object level,
4961 obj = list1 (list3 (class, level, obj));
4962 if (NILP (Vpending_warnings))
4963 Vpending_warnings = Vpending_warnings_tail = obj;
4966 Fsetcdr (Vpending_warnings_tail, obj);
4967 Vpending_warnings_tail = obj;
4971 /* #### This should probably accept Lisp objects; but then we have
4972 to make sure that Feval() isn't called, since it might not be safe.
4974 An alternative approach is to just pass some non-string type of
4975 Lisp_Object to warn_when_safe_lispobj(); `prin1-to-string' will
4976 automatically be called when it is safe to do so. */
4979 warn_when_safe (Lisp_Object class, Lisp_Object level, const char *fmt, ...)
4984 va_start (args, fmt);
4985 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt),
4989 warn_when_safe_lispobj (class, level, obj);
4995 /************************************************************************/
4996 /* Initialization */
4997 /************************************************************************/
5002 INIT_LRECORD_IMPLEMENTATION (subr);
5004 defsymbol (&Qinhibit_quit, "inhibit-quit");
5005 defsymbol (&Qautoload, "autoload");
5006 defsymbol (&Qdebug_on_error, "debug-on-error");
5007 defsymbol (&Qstack_trace_on_error, "stack-trace-on-error");
5008 defsymbol (&Qdebug_on_signal, "debug-on-signal");
5009 defsymbol (&Qstack_trace_on_signal, "stack-trace-on-signal");
5010 defsymbol (&Qdebugger, "debugger");
5011 defsymbol (&Qmacro, "macro");
5012 defsymbol (&Qand_rest, "&rest");
5013 defsymbol (&Qand_optional, "&optional");
5014 /* Note that the process code also uses Qexit */
5015 defsymbol (&Qexit, "exit");
5016 defsymbol (&Qsetq, "setq");
5017 defsymbol (&Qinteractive, "interactive");
5018 defsymbol (&Qcommandp, "commandp");
5019 defsymbol (&Qdefun, "defun");
5020 defsymbol (&Qprogn, "progn");
5021 defsymbol (&Qvalues, "values");
5022 defsymbol (&Qdisplay_warning, "display-warning");
5023 defsymbol (&Qrun_hooks, "run-hooks");
5024 defsymbol (&Qif, "if");
5029 DEFSUBR_MACRO (Fwhen);
5030 DEFSUBR_MACRO (Funless);
5037 DEFSUBR (Ffunction);
5039 DEFSUBR (Fdefmacro);
5041 DEFSUBR (Fdefconst);
5042 DEFSUBR (Fuser_variable_p);
5046 DEFSUBR (Fmacroexpand_internal);
5049 DEFSUBR (Funwind_protect);
5050 DEFSUBR (Fcondition_case);
5051 DEFSUBR (Fcall_with_condition_handler);
5053 DEFSUBR (Finteractive_p);
5054 DEFSUBR (Fcommandp);
5055 DEFSUBR (Fcommand_execute);
5056 DEFSUBR (Fautoload);
5060 DEFSUBR (Ffunctionp);
5061 DEFSUBR (Ffunction_min_args);
5062 DEFSUBR (Ffunction_max_args);
5063 DEFSUBR (Frun_hooks);
5064 DEFSUBR (Frun_hook_with_args);
5065 DEFSUBR (Frun_hook_with_args_until_success);
5066 DEFSUBR (Frun_hook_with_args_until_failure);
5067 DEFSUBR (Fbacktrace_debug);
5068 DEFSUBR (Fbacktrace);
5069 DEFSUBR (Fbacktrace_frame);
5075 specpdl_ptr = specpdl;
5076 specpdl_depth_counter = 0;
5078 Vcondition_handlers = Qnil;
5081 debug_on_next_call = 0;
5082 lisp_eval_depth = 0;
5083 entering_debugger = 0;
5087 reinit_vars_of_eval (void)
5089 preparing_for_armageddon = 0;
5091 Qunbound_suspended_errors_tag = make_opaque_ptr (&Qunbound_suspended_errors_tag);
5092 staticpro_nodump (&Qunbound_suspended_errors_tag);
5095 specpdl = xnew_array (struct specbinding, specpdl_size);
5096 /* XEmacs change: increase these values. */
5097 max_specpdl_size = 3000;
5098 max_lisp_eval_depth = 500;
5099 #ifdef DEFEND_AGAINST_THROW_RECURSION
5107 reinit_vars_of_eval ();
5109 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size /*
5110 Limit on number of Lisp variable bindings & unwind-protects before error.
5113 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth /*
5114 Limit on depth in `eval', `apply' and `funcall' before error.
5115 This limit is to catch infinite recursions for you before they cause
5116 actual stack overflow in C, which would be fatal for Emacs.
5117 You can safely make it considerably larger than its default value,
5118 if that proves inconveniently small.
5121 DEFVAR_LISP ("quit-flag", &Vquit_flag /*
5122 Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
5123 Typing C-G sets `quit-flag' non-nil, regardless of `inhibit-quit'.
5127 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit /*
5128 Non-nil inhibits C-g quitting from happening immediately.
5129 Note that `quit-flag' will still be set by typing C-g,
5130 so a quit will be signalled as soon as `inhibit-quit' is nil.
5131 To prevent this happening, set `quit-flag' to nil
5132 before making `inhibit-quit' nil. The value of `inhibit-quit' is
5133 ignored if a critical quit is requested by typing control-shift-G in
5136 Vinhibit_quit = Qnil;
5138 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error /*
5139 *Non-nil means automatically display a backtrace buffer
5140 after any error that is not handled by a `condition-case'.
5141 If the value is a list, an error only means to display a backtrace
5142 if one of its condition symbols appears in the list.
5143 See also variable `stack-trace-on-signal'.
5145 Vstack_trace_on_error = Qnil;
5147 DEFVAR_LISP ("stack-trace-on-signal", &Vstack_trace_on_signal /*
5148 *Non-nil means automatically display a backtrace buffer
5149 after any error that is signalled, whether or not it is handled by
5151 If the value is a list, an error only means to display a backtrace
5152 if one of its condition symbols appears in the list.
5153 See also variable `stack-trace-on-error'.
5155 Vstack_trace_on_signal = Qnil;
5157 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors /*
5158 *List of errors for which the debugger should not be called.
5159 Each element may be a condition-name or a regexp that matches error messages.
5160 If any element applies to a given error, that error skips the debugger
5161 and just returns to top level.
5162 This overrides the variable `debug-on-error'.
5163 It does not apply to errors handled by `condition-case'.
5165 Vdebug_ignored_errors = Qnil;
5167 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error /*
5168 *Non-nil means enter debugger if an unhandled error is signalled.
5169 The debugger will not be entered if the error is handled by
5171 If the value is a list, an error only means to enter the debugger
5172 if one of its condition symbols appears in the list.
5173 This variable is overridden by `debug-ignored-errors'.
5174 See also variables `debug-on-quit' and `debug-on-signal'.
5176 Vdebug_on_error = Qnil;
5178 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal /*
5179 *Non-nil means enter debugger if an error is signalled.
5180 The debugger will be entered whether or not the error is handled by
5182 If the value is a list, an error only means to enter the debugger
5183 if one of its condition symbols appears in the list.
5184 See also variable `debug-on-quit'.
5186 Vdebug_on_signal = Qnil;
5188 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit /*
5189 *Non-nil means enter debugger if quit is signalled (C-G, for example).
5190 Does not apply if quit is handled by a `condition-case'. Entering the
5191 debugger can also be achieved at any time (for X11 console) by typing
5192 control-shift-G to signal a critical quit.
5196 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call /*
5197 Non-nil means enter debugger before next `eval', `apply' or `funcall'.
5200 DEFVAR_LISP ("debugger", &Vdebugger /*
5201 Function to call to invoke debugger.
5202 If due to frame exit, args are `exit' and the value being returned;
5203 this function's value will be returned instead of that.
5204 If due to error, args are `error' and a list of the args to `signal'.
5205 If due to `apply' or `funcall' entry, one arg, `lambda'.
5206 If due to `eval' entry, one arg, t.
5210 staticpro (&Vpending_warnings);
5211 Vpending_warnings = Qnil;
5212 pdump_wire (&Vpending_warnings_tail);
5213 Vpending_warnings_tail = Qnil;
5215 staticpro (&Vautoload_queue);
5216 Vautoload_queue = Qnil;
5218 staticpro (&Vcondition_handlers);
5220 staticpro (&Vcurrent_warning_class);
5221 Vcurrent_warning_class = Qnil;
5223 staticpro (&Vcurrent_error_state);
5224 Vcurrent_error_state = Qnil; /* errors as normal */