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 (*)()) (fn); \
77 Lisp_Object *PF_av = (av); \
81 case 0: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 0); break; \
82 case 1: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 1); break; \
83 case 2: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 2); break; \
84 case 3: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 3); break; \
85 case 4: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 4); break; \
86 case 5: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 5); break; \
87 case 6: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 6); break; \
88 case 7: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 7); break; \
89 case 8: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 8); break; \
93 #define FUNCALL_SUBR(rv, subr, av, ac) \
94 PRIMITIVE_FUNCALL (rv, subr_function (subr), av, ac);
97 /* This is the list of current catches (and also condition-cases).
98 This is a stack: the most recent catch is at the head of the
99 list. Catches are created by declaring a 'struct catchtag'
100 locally, filling the .TAG field in with the tag, and doing
101 a setjmp() on .JMP. Fthrow() will store the value passed
102 to it in .VAL and longjmp() back to .JMP, back to the function
103 that established the catch. This will always be either
104 internal_catch() (catches established internally or through
105 `catch') or condition_case_1 (condition-cases established
106 internally or through `condition-case').
108 The catchtag also records the current position in the
109 call stack (stored in BACKTRACE_LIST), the current position
110 in the specpdl stack (used for variable bindings and
111 unwind-protects), the value of LISP_EVAL_DEPTH, and the
112 current position in the GCPRO stack. All of these are
113 restored by Fthrow().
116 struct catchtag *catchlist;
118 Lisp_Object Qautoload, Qmacro, Qexit;
119 Lisp_Object Qinteractive, Qcommandp, Qdefun, Qprogn, Qvalues;
120 Lisp_Object Vquit_flag, Vinhibit_quit;
121 Lisp_Object Qand_rest, Qand_optional;
122 Lisp_Object Qdebug_on_error, Qstack_trace_on_error;
123 Lisp_Object Qdebug_on_signal, Qstack_trace_on_signal;
124 Lisp_Object Qdebugger;
125 Lisp_Object Qinhibit_quit;
126 Lisp_Object Qrun_hooks;
128 Lisp_Object Qdisplay_warning;
129 Lisp_Object Vpending_warnings, Vpending_warnings_tail;
132 /* Records whether we want errors to occur. This will be a boolean,
133 nil (errors OK) or t (no errors). If t, an error will cause a
134 throw to Qunbound_suspended_errors_tag.
136 See call_with_suspended_errors(). */
137 Lisp_Object Vcurrent_error_state;
139 /* Current warning class when warnings occur, or nil for no warnings.
140 Only meaningful when Vcurrent_error_state is non-nil.
141 See call_with_suspended_errors(). */
142 Lisp_Object Vcurrent_warning_class;
144 /* Special catch tag used in call_with_suspended_errors(). */
145 Lisp_Object Qunbound_suspended_errors_tag;
147 /* Non-nil means we're going down, so we better not run any hooks
148 or do other non-essential stuff. */
149 int preparing_for_armageddon;
151 /* Non-nil means record all fset's and provide's, to be undone
152 if the file being autoloaded is not fully loaded.
153 They are recorded by being consed onto the front of Vautoload_queue:
154 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */
155 Lisp_Object Vautoload_queue;
157 /* Current number of specbindings allocated in specpdl. */
160 /* Pointer to beginning of specpdl. */
161 struct specbinding *specpdl;
163 /* Pointer to first unused element in specpdl. */
164 struct specbinding *specpdl_ptr;
166 /* specpdl_ptr - specpdl */
167 int specpdl_depth_counter;
169 /* Maximum size allowed for specpdl allocation */
170 int max_specpdl_size;
172 /* Depth in Lisp evaluations and function calls. */
175 /* Maximum allowed depth in Lisp evaluations and function calls. */
176 int max_lisp_eval_depth;
178 /* Nonzero means enter debugger before next function call */
179 static int debug_on_next_call;
181 /* List of conditions (non-nil atom means all) which cause a backtrace
182 if an error is handled by the command loop's error handler. */
183 Lisp_Object Vstack_trace_on_error;
185 /* List of conditions (non-nil atom means all) which enter the debugger
186 if an error is handled by the command loop's error handler. */
187 Lisp_Object Vdebug_on_error;
189 /* List of conditions and regexps specifying error messages which
190 do not enter the debugger even if Vdebug_on_error says they should. */
191 Lisp_Object Vdebug_ignored_errors;
193 /* List of conditions (non-nil atom means all) which cause a backtrace
194 if any error is signalled. */
195 Lisp_Object Vstack_trace_on_signal;
197 /* List of conditions (non-nil atom means all) which enter the debugger
198 if any error is signalled. */
199 Lisp_Object Vdebug_on_signal;
201 /* Nonzero means enter debugger if a quit signal
202 is handled by the command loop's error handler.
204 From lisp, this is a boolean variable and may have the values 0 and 1.
205 But, eval.c temporarily uses the second bit of this variable to indicate
206 that a critical_quit is in progress. The second bit is reset immediately
207 after it is processed in signal_call_debugger(). */
211 /* entering_debugger is basically equivalent */
212 /* The value of num_nonmacro_input_chars as of the last time we
213 started to enter the debugger. If we decide to enter the debugger
214 again when this is still equal to num_nonmacro_input_chars, then we
215 know that the debugger itself has an error, and we should just
216 signal the error instead of entering an infinite loop of debugger
218 int when_entered_debugger;
221 /* Nonzero means we are trying to enter the debugger.
222 This is to prevent recursive attempts.
223 Cleared by the debugger calling Fbacktrace */
224 static int entering_debugger;
226 /* Function to call to invoke the debugger */
227 Lisp_Object Vdebugger;
229 /* Chain of condition handlers currently in effect.
230 The elements of this chain are contained in the stack frames
231 of Fcondition_case and internal_condition_case.
232 When an error is signaled (by calling Fsignal, below),
233 this chain is searched for an element that applies.
235 Each element of this list is one of the following:
237 A list of a handler function and possibly args to pass to
238 the function. This is a handler established with
239 `call-with-condition-handler' (q.v.).
241 A list whose car is Qunbound and whose cdr is Qt.
242 This is a special condition-case handler established
243 by C code with condition_case_1(). All errors are
244 trapped; the debugger is not invoked even if
245 `debug-on-error' was set.
247 A list whose car is Qunbound and whose cdr is Qerror.
248 This is a special condition-case handler established
249 by C code with condition_case_1(). It is like Qt
250 except that the debugger is invoked normally if it is
253 A list whose car is Qunbound and whose cdr is a list
254 of lists (CONDITION-NAME BODY ...) exactly as in
255 `condition-case'. This is a normal `condition-case'
258 Note that in all cases *except* the first, there is a
259 corresponding catch, whose TAG is the value of
260 Vcondition_handlers just after the handler data just
261 described is pushed onto it. The reason is that
262 `condition-case' handlers need to throw back to the
263 place where the handler was installed before invoking
264 it, while `call-with-condition-handler' handlers are
265 invoked in the environment that `signal' was invoked
268 static Lisp_Object Vcondition_handlers;
271 #if 0 /* no longer used */
272 /* Used for error catching purposes by throw_or_bomb_out */
273 static int throw_level;
277 /************************************************************************/
278 /* The subr object type */
279 /************************************************************************/
282 print_subr (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
284 Lisp_Subr *subr = XSUBR (obj);
286 (subr->max_args == UNEVALLED) ? "#<special-form " : "#<subr ";
287 CONST char *name = subr_name (subr);
288 CONST char *trailer = subr->prompt ? " (interactive)>" : ">";
291 error ("printing unreadable object %s%s%s", header, name, trailer);
293 write_c_string (header, printcharfun);
294 write_c_string (name, printcharfun);
295 write_c_string (trailer, printcharfun);
298 DEFINE_LRECORD_IMPLEMENTATION ("subr", subr,
299 this_one_is_unmarkable, print_subr, 0, 0, 0,
302 /************************************************************************/
303 /* Entering the debugger */
304 /************************************************************************/
306 /* unwind-protect used by call_debugger() to restore the value of
307 entering_debugger. (We cannot use specbind() because the
308 variable is not Lisp-accessible.) */
311 restore_entering_debugger (Lisp_Object arg)
313 entering_debugger = ! NILP (arg);
317 /* Actually call the debugger. ARG is a list of args that will be
318 passed to the debugger function, as follows;
320 If due to frame exit, args are `exit' and the value being returned;
321 this function's value will be returned instead of that.
322 If due to error, args are `error' and a list of the args to `signal'.
323 If due to `apply' or `funcall' entry, one arg, `lambda'.
324 If due to `eval' entry, one arg, t.
329 call_debugger_259 (Lisp_Object arg)
331 return apply1 (Vdebugger, arg);
334 /* Call the debugger, doing some encapsulation. We make sure we have
335 some room on the eval and specpdl stacks, and bind entering_debugger
336 to 1 during this call. This is used to trap errors that may occur
337 when entering the debugger (e.g. the value of `debugger' is invalid),
338 so that the debugger will not be recursively entered if debug-on-error
339 is set. (Otherwise, XEmacs would infinitely recurse, attempting to
340 enter the debugger.) entering_debugger gets reset to 0 as soon
341 as a backtrace is displayed, so that further errors can indeed be
344 We also establish a catch for 'debugger. If the debugger function
345 throws to this instead of returning a value, it means that the user
346 pressed 'c' (pretend like the debugger was never entered). The
347 function then returns Qunbound. (If the user pressed 'r', for
348 return a value, then the debugger function returns normally with
351 The difference between 'c' and 'r' is as follows:
354 No difference. The call proceeds as normal.
356 With 'r', the specified value is returned as the function's
357 return value. With 'c', the value that would normally be
358 returned is returned.
360 With 'r', the specified value is returned as the return
361 value of `signal'. (This is the only time that `signal'
362 can return, instead of making a non-local exit.) With `c',
363 `signal' will continue looking for handlers as if the
364 debugger was never entered, and will probably end up
365 throwing to a handler or to top-level.
369 call_debugger (Lisp_Object arg)
375 if (lisp_eval_depth + 20 > max_lisp_eval_depth)
376 max_lisp_eval_depth = lisp_eval_depth + 20;
377 if (specpdl_size + 40 > max_specpdl_size)
378 max_specpdl_size = specpdl_size + 40;
379 debug_on_next_call = 0;
381 speccount = specpdl_depth();
382 record_unwind_protect (restore_entering_debugger,
383 (entering_debugger ? Qt : Qnil));
384 entering_debugger = 1;
385 val = internal_catch (Qdebugger, call_debugger_259, arg, &threw);
387 return unbind_to (speccount, ((threw)
388 ? Qunbound /* Not returning a value */
392 /* Called when debug-on-exit behavior is called for. Enter the debugger
393 with the appropriate args for this. VAL is the exit value that is
394 about to be returned. */
397 do_debug_on_exit (Lisp_Object val)
399 /* This is falsified by call_debugger */
400 Lisp_Object v = call_debugger (list2 (Qexit, val));
402 return !UNBOUNDP (v) ? v : val;
405 /* Called when debug-on-call behavior is called for. Enter the debugger
406 with the appropriate args for this. VAL is either t for a call
407 through `eval' or 'lambda for a call through `funcall'.
409 #### The differentiation here between EVAL and FUNCALL is bogus.
410 FUNCALL can be defined as
412 (defmacro func (fun &rest args)
413 (cons (eval fun) args))
415 and should be treated as such.
419 do_debug_on_call (Lisp_Object code)
421 debug_on_next_call = 0;
422 backtrace_list->debug_on_exit = 1;
423 call_debugger (list1 (code));
426 /* LIST is the value of one of the variables `debug-on-error',
427 `debug-on-signal', `stack-trace-on-error', or `stack-trace-on-signal',
428 and CONDITIONS is the list of error conditions associated with
429 the error being signalled. This returns non-nil if LIST
430 matches CONDITIONS. (A nil value for LIST does not match
431 CONDITIONS. A non-list value for LIST does match CONDITIONS.
432 A list matches CONDITIONS when one of the symbols in LIST is the
433 same as one of the symbols in CONDITIONS.) */
436 wants_debugger (Lisp_Object list, Lisp_Object conditions)
443 while (CONSP (conditions))
445 Lisp_Object this, tail;
446 this = XCAR (conditions);
447 for (tail = list; CONSP (tail); tail = XCDR (tail))
448 if (EQ (XCAR (tail), this))
450 conditions = XCDR (conditions);
456 /* Return 1 if an error with condition-symbols CONDITIONS,
457 and described by SIGNAL-DATA, should skip the debugger
458 according to debugger-ignore-errors. */
461 skip_debugger (Lisp_Object conditions, Lisp_Object data)
463 /* This function can GC */
465 int first_string = 1;
466 Lisp_Object error_message = Qnil;
468 for (tail = Vdebug_ignored_errors; CONSP (tail); tail = XCDR (tail))
470 if (STRINGP (XCAR (tail)))
474 error_message = Ferror_message_string (data);
477 if (fast_lisp_string_match (XCAR (tail), error_message) >= 0)
484 for (contail = conditions; CONSP (contail); contail = XCDR (contail))
485 if (EQ (XCAR (tail), XCAR (contail)))
493 /* Actually generate a backtrace on STREAM. */
496 backtrace_259 (Lisp_Object stream)
498 return Fbacktrace (stream, Qt);
501 /* An error was signaled. Maybe call the debugger, if the `debug-on-error'
502 etc. variables call for this. CONDITIONS is the list of conditions
503 associated with the error being signalled. SIG is the actual error
504 being signalled, and DATA is the associated data (these are exactly
505 the same as the arguments to `signal'). ACTIVE_HANDLERS is the
506 list of error handlers that are to be put in place while the debugger
507 is called. This is generally the remaining handlers that are
508 outside of the innermost handler trapping this error. This way,
509 if the same error occurs inside of the debugger, you usually don't get
510 the debugger entered recursively.
512 This function returns Qunbound if it didn't call the debugger or if
513 the user asked (through 'c') that XEmacs should pretend like the
514 debugger was never entered. Otherwise, it returns the value
515 that the user specified with `r'. (Note that much of the time,
516 the user will abort with C-], and we will never have a chance to
517 return anything at all.)
519 SIGNAL_VARS_ONLY means we should only look at debug-on-signal
520 and stack-trace-on-signal to control whether we do anything.
521 This is so that debug-on-error doesn't make handled errors
522 cause the debugger to get invoked.
524 STACK_TRACE_DISPLAYED and DEBUGGER_ENTERED are used so that
525 those functions aren't done more than once in a single `signal'
529 signal_call_debugger (Lisp_Object conditions,
530 Lisp_Object sig, Lisp_Object data,
531 Lisp_Object active_handlers,
532 int signal_vars_only,
533 int *stack_trace_displayed,
534 int *debugger_entered)
536 /* This function can GC */
537 Lisp_Object val = Qunbound;
538 Lisp_Object all_handlers = Vcondition_handlers;
539 Lisp_Object temp_data = Qnil;
540 int speccount = specpdl_depth();
541 struct gcpro gcpro1, gcpro2;
542 GCPRO2 (all_handlers, temp_data);
544 Vcondition_handlers = active_handlers;
546 temp_data = Fcons (sig, data); /* needed for skip_debugger */
548 if (!entering_debugger && !*stack_trace_displayed && !signal_vars_only
549 && wants_debugger (Vstack_trace_on_error, conditions)
550 && !skip_debugger (conditions, temp_data))
552 specbind (Qdebug_on_error, Qnil);
553 specbind (Qstack_trace_on_error, Qnil);
554 specbind (Qdebug_on_signal, Qnil);
555 specbind (Qstack_trace_on_signal, Qnil);
557 internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
561 unbind_to (speccount, Qnil);
562 *stack_trace_displayed = 1;
565 if (!entering_debugger && !*debugger_entered && !signal_vars_only
568 : wants_debugger (Vdebug_on_error, conditions))
569 && !skip_debugger (conditions, temp_data))
571 debug_on_quit &= ~2; /* reset critical bit */
572 specbind (Qdebug_on_error, Qnil);
573 specbind (Qstack_trace_on_error, Qnil);
574 specbind (Qdebug_on_signal, Qnil);
575 specbind (Qstack_trace_on_signal, Qnil);
577 val = call_debugger (list2 (Qerror, (Fcons (sig, data))));
578 *debugger_entered = 1;
581 if (!entering_debugger && !*stack_trace_displayed
582 && wants_debugger (Vstack_trace_on_signal, conditions))
584 specbind (Qdebug_on_error, Qnil);
585 specbind (Qstack_trace_on_error, Qnil);
586 specbind (Qdebug_on_signal, Qnil);
587 specbind (Qstack_trace_on_signal, Qnil);
589 internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
593 unbind_to (speccount, Qnil);
594 *stack_trace_displayed = 1;
597 if (!entering_debugger && !*debugger_entered
600 : wants_debugger (Vdebug_on_signal, conditions)))
602 debug_on_quit &= ~2; /* reset critical bit */
603 specbind (Qdebug_on_error, Qnil);
604 specbind (Qstack_trace_on_error, Qnil);
605 specbind (Qdebug_on_signal, Qnil);
606 specbind (Qstack_trace_on_signal, Qnil);
608 val = call_debugger (list2 (Qerror, (Fcons (sig, data))));
609 *debugger_entered = 1;
613 Vcondition_handlers = all_handlers;
614 return unbind_to (speccount, val);
618 /************************************************************************/
619 /* The basic special forms */
620 /************************************************************************/
622 /* Except for Fprogn(), the basic special forms below are only called
623 from interpreted code. The byte compiler turns them into bytecodes. */
625 DEFUN ("or", For, 0, UNEVALLED, 0, /*
626 Eval args until one of them yields non-nil, then return that value.
627 The remaining args are not evalled at all.
628 If all args return nil, return nil.
632 /* This function can GC */
633 REGISTER Lisp_Object arg, val;
635 LIST_LOOP_2 (arg, args)
637 if (!NILP (val = Feval (arg)))
644 DEFUN ("and", Fand, 0, UNEVALLED, 0, /*
645 Eval args until one of them yields nil, then return nil.
646 The remaining args are not evalled at all.
647 If no arg yields nil, return the last arg's value.
651 /* This function can GC */
652 REGISTER Lisp_Object arg, val = Qt;
654 LIST_LOOP_2 (arg, args)
656 if (NILP (val = Feval (arg)))
663 DEFUN ("if", Fif, 2, UNEVALLED, 0, /*
664 \(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...
665 Returns the value of THEN or the value of the last of the ELSE's.
666 THEN must be one expression, but ELSE... can be zero or more expressions.
667 If COND yields nil, and there are no ELSE's, the value is nil.
671 /* This function can GC */
672 Lisp_Object condition = XCAR (args);
673 Lisp_Object then_form = XCAR (XCDR (args));
674 Lisp_Object else_forms = XCDR (XCDR (args));
676 if (!NILP (Feval (condition)))
677 return Feval (then_form);
679 return Fprogn (else_forms);
682 /* Macros `when' and `unless' are trivially defined in Lisp,
683 but it helps for bootstrapping to have them ALWAYS defined. */
685 DEFUN ("when", Fwhen, 1, MANY, 0, /*
686 \(when COND BODY...): if COND yields non-nil, do BODY, else return nil.
687 BODY can be zero or more expressions. If BODY is nil, return nil.
689 (int nargs, Lisp_Object *args))
691 Lisp_Object cond = args[0];
696 case 1: body = Qnil; break;
697 case 2: body = args[1]; break;
698 default: body = Fcons (Qprogn, Flist (nargs-1, args+1)); break;
701 return list3 (Qif, cond, body);
704 DEFUN ("unless", Funless, 1, MANY, 0, /*
705 \(unless COND BODY...): if COND yields nil, do BODY, else return nil.
706 BODY can be zero or more expressions. If BODY is nil, return nil.
708 (int nargs, Lisp_Object *args))
710 Lisp_Object cond = args[0];
711 Lisp_Object body = Flist (nargs-1, args+1);
712 return Fcons (Qif, Fcons (cond, Fcons (Qnil, body)));
715 DEFUN ("cond", Fcond, 0, UNEVALLED, 0, /*
716 (cond CLAUSES...): try each clause until one succeeds.
717 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
718 and, if the value is non-nil, this clause succeeds:
719 then the expressions in BODY are evaluated and the last one's
720 value is the value of the cond-form.
721 If no clause succeeds, cond returns nil.
722 If a clause has one element, as in (CONDITION),
723 CONDITION's value if non-nil is returned from the cond-form.
727 /* This function can GC */
728 REGISTER Lisp_Object val, clause;
730 LIST_LOOP_2 (clause, args)
733 if (!NILP (val = Feval (XCAR (clause))))
735 if (!NILP (clause = XCDR (clause)))
737 CHECK_TRUE_LIST (clause);
738 val = Fprogn (clause);
747 DEFUN ("progn", Fprogn, 0, UNEVALLED, 0, /*
748 \(progn BODY...): eval BODY forms sequentially and return value of last one.
752 /* This function can GC */
753 /* Caller must provide a true list in ARGS */
754 REGISTER Lisp_Object form, val = Qnil;
760 LIST_LOOP_2 (form, args)
768 /* Fprog1() is the canonical example of a function that must GCPRO a
769 Lisp_Object across calls to Feval(). */
771 DEFUN ("prog1", Fprog1, 1, UNEVALLED, 0, /*
772 Similar to `progn', but the value of the first form is returned.
773 \(prog1 FIRST BODY...): All the arguments are evaluated sequentially.
774 The value of FIRST is saved during evaluation of the remaining args,
775 whose values are discarded.
779 /* This function can GC */
780 REGISTER Lisp_Object val, form;
783 val = Feval (XCAR (args));
788 LIST_LOOP_2 (form, XCDR (args))
796 DEFUN ("prog2", Fprog2, 2, UNEVALLED, 0, /*
797 Similar to `progn', but the value of the second form is returned.
798 \(prog2 FIRST SECOND BODY...): All the arguments are evaluated sequentially.
799 The value of SECOND is saved during evaluation of the remaining args,
800 whose values are discarded.
804 /* This function can GC */
805 REGISTER Lisp_Object val, form, tail;
810 val = Feval (XCAR (args));
815 LIST_LOOP_3 (form, args, tail)
822 DEFUN ("let*", FletX, 1, UNEVALLED, 0, /*
823 \(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.
824 The value of the last form in BODY is returned.
825 Each element of VARLIST is a symbol (which is bound to nil)
826 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
827 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
831 /* This function can GC */
832 Lisp_Object var, tail;
833 Lisp_Object varlist = XCAR (args);
834 Lisp_Object body = XCDR (args);
835 int speccount = specpdl_depth();
837 EXTERNAL_LIST_LOOP_3 (var, varlist, tail)
839 Lisp_Object symbol, value, tem;
841 symbol = var, value = Qnil;
852 value = Feval (XCAR (tem));
853 if (!NILP (XCDR (tem)))
855 ("`let' bindings can have only one value-form", var);
858 specbind (symbol, value);
860 return unbind_to (speccount, Fprogn (body));
863 DEFUN ("let", Flet, 1, UNEVALLED, 0, /*
864 \(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.
865 The value of the last form in BODY is returned.
866 Each element of VARLIST is a symbol (which is bound to nil)
867 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
868 All the VALUEFORMs are evalled before any symbols are bound.
872 /* This function can GC */
873 Lisp_Object var, tail;
874 Lisp_Object varlist = XCAR (args);
875 Lisp_Object body = XCDR (args);
876 int speccount = specpdl_depth();
881 /* Make space to hold the values to give the bound variables. */
884 GET_EXTERNAL_LIST_LENGTH (varlist, varcount);
885 temps = alloca_array (Lisp_Object, varcount);
888 /* Compute the values and store them in `temps' */
893 LIST_LOOP_3 (var, varlist, tail)
895 Lisp_Object *value = &temps[idx++];
908 *value = Feval (XCAR (tem));
911 if (!NILP (XCDR (tem)))
913 ("`let' bindings can have only one value-form", var);
919 LIST_LOOP_3 (var, varlist, tail)
921 specbind (SYMBOLP (var) ? var : XCAR (var), temps[idx++]);
926 return unbind_to (speccount, Fprogn (body));
929 DEFUN ("while", Fwhile, 1, UNEVALLED, 0, /*
930 \(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.
931 The order of execution is thus TEST, BODY, TEST, BODY and so on
932 until TEST returns nil.
936 /* This function can GC */
937 Lisp_Object test = XCAR (args);
938 Lisp_Object body = XCDR (args);
940 while (!NILP (Feval (test)))
949 DEFUN ("setq", Fsetq, 0, UNEVALLED, 0, /*
950 \(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.
951 The symbols SYM are variables; they are literal (not evaluated).
952 The values VAL are expressions; they are evaluated.
953 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
954 The second VAL is not computed until after the first SYM is set, and so on;
955 each VAL can use the new value of variables set earlier in the `setq'.
956 The return value of the `setq' form is the value of the last VAL.
960 /* This function can GC */
961 Lisp_Object symbol, tail, val = Qnil;
965 GET_LIST_LENGTH (args, nargs);
967 if (nargs & 1) /* Odd number of arguments? */
968 Fsignal (Qwrong_number_of_arguments, list2 (Qsetq, make_int (nargs)));
972 PROPERTY_LIST_LOOP (tail, symbol, val, args)
982 DEFUN ("quote", Fquote, 1, UNEVALLED, 0, /*
983 Return the argument, without evaluating it. `(quote x)' yields `x'.
990 DEFUN ("function", Ffunction, 1, UNEVALLED, 0, /*
991 Like `quote', but preferred for objects which are functions.
992 In byte compilation, `function' causes its argument to be compiled.
993 `quote' cannot do that.
1001 /************************************************************************/
1002 /* Defining functions/variables */
1003 /************************************************************************/
1005 define_function (Lisp_Object name, Lisp_Object defn)
1008 defn = Fpurecopy (defn);
1010 LOADHIST_ATTACH (name);
1014 DEFUN ("defun", Fdefun, 2, UNEVALLED, 0, /*
1015 \(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.
1016 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
1017 See also the function `interactive'.
1021 /* This function can GC */
1022 return define_function (XCAR (args),
1023 Fcons (Qlambda, XCDR (args)));
1026 DEFUN ("defmacro", Fdefmacro, 2, UNEVALLED, 0, /*
1027 \(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.
1028 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).
1029 When the macro is called, as in (NAME ARGS...),
1030 the function (lambda ARGLIST BODY...) is applied to
1031 the list ARGS... as it appears in the expression,
1032 and the result should be a form to be evaluated instead of the original.
1036 /* This function can GC */
1037 return define_function (XCAR (args),
1038 Fcons (Qmacro, Fcons (Qlambda, XCDR (args))));
1041 DEFUN ("defvar", Fdefvar, 1, UNEVALLED, 0, /*
1042 \(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.
1043 You are not required to define a variable in order to use it,
1044 but the definition can supply documentation and an initial value
1045 in a way that tags can recognize.
1047 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is
1048 void. (However, when you evaluate a defvar interactively, it acts like a
1049 defconst: SYMBOL's value is always set regardless of whether it's currently
1051 If SYMBOL is buffer-local, its default value is what is set;
1052 buffer-local values are not affected.
1053 INITVALUE and DOCSTRING are optional.
1054 If DOCSTRING starts with *, this variable is identified as a user option.
1055 This means that M-x set-variable and M-x edit-options recognize it.
1056 If INITVALUE is missing, SYMBOL's value is not set.
1058 In lisp-interaction-mode defvar is treated as defconst.
1062 /* This function can GC */
1063 Lisp_Object sym = XCAR (args);
1065 if (!NILP (args = XCDR (args)))
1067 Lisp_Object val = XCAR (args);
1069 if (NILP (Fdefault_boundp (sym)))
1071 struct gcpro gcpro1;
1074 Fset_default (sym, val);
1078 if (!NILP (args = XCDR (args)))
1080 Lisp_Object doc = XCAR (args);
1082 /* #### We should probably do this but it might be dangerous */
1084 doc = Fpurecopy (doc);
1085 Fput (sym, Qvariable_documentation, doc);
1087 pure_put (sym, Qvariable_documentation, doc);
1089 if (!NILP (args = XCDR (args)))
1090 error ("too many arguments");
1095 if (!NILP (Vfile_domain))
1096 pure_put (sym, Qvariable_domain, Vfile_domain);
1099 LOADHIST_ATTACH (sym);
1103 DEFUN ("defconst", Fdefconst, 2, UNEVALLED, 0, /*
1104 \(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant
1106 The intent is that programs do not change this value, but users may.
1107 Always sets the value of SYMBOL to the result of evalling INITVALUE.
1108 If SYMBOL is buffer-local, its default value is what is set;
1109 buffer-local values are not affected.
1110 DOCSTRING is optional.
1111 If DOCSTRING starts with *, this variable is identified as a user option.
1112 This means that M-x set-variable and M-x edit-options recognize it.
1114 Note: do not use `defconst' for user options in libraries that are not
1115 normally loaded, since it is useful for users to be able to specify
1116 their own values for such variables before loading the library.
1117 Since `defconst' unconditionally assigns the variable,
1118 it would override the user's choice.
1122 /* This function can GC */
1123 Lisp_Object sym = XCAR (args);
1124 Lisp_Object val = Feval (XCAR (args = XCDR (args)));
1125 struct gcpro gcpro1;
1129 Fset_default (sym, val);
1133 if (!NILP (args = XCDR (args)))
1135 Lisp_Object doc = XCAR (args);
1137 /* #### We should probably do this but it might be dangerous */
1139 doc = Fpurecopy (doc);
1140 Fput (sym, Qvariable_documentation, doc);
1142 pure_put (sym, Qvariable_documentation, doc);
1144 if (!NILP (args = XCDR (args)))
1145 error ("too many arguments");
1149 if (!NILP (Vfile_domain))
1150 pure_put (sym, Qvariable_domain, Vfile_domain);
1153 LOADHIST_ATTACH (sym);
1157 DEFUN ("user-variable-p", Fuser_variable_p, 1, 1, 0, /*
1158 Return t if VARIABLE is intended to be set and modified by users.
1159 \(The alternative is a variable used internally in a Lisp program.)
1160 Determined by whether the first character of the documentation
1161 for the variable is `*'.
1165 Lisp_Object documentation = Fget (variable, Qvariable_documentation, Qnil);
1168 ((INTP (documentation) && XINT (documentation) < 0) ||
1170 ((STRINGP (documentation)) &&
1171 (string_byte (XSTRING (documentation), 0) == '*')) ||
1173 /* If (STRING . INTEGER), a negative integer means a user variable. */
1174 (CONSP (documentation)
1175 && STRINGP (XCAR (documentation))
1176 && INTP (XCDR (documentation))
1177 && XINT (XCDR (documentation)) < 0)) ?
1181 DEFUN ("macroexpand-internal", Fmacroexpand_internal, 1, 2, 0, /*
1182 Return result of expanding macros at top level of FORM.
1183 If FORM is not a macro call, it is returned unchanged.
1184 Otherwise, the macro is expanded and the expansion is considered
1185 in place of FORM. When a non-macro-call results, it is returned.
1187 The second optional arg ENVIRONMENT species an environment of macro
1188 definitions to shadow the loaded ones for use in file byte-compilation.
1192 /* This function can GC */
1193 /* With cleanups from Hallvard Furuseth. */
1194 REGISTER Lisp_Object expander, sym, def, tem;
1198 /* Come back here each time we expand a macro call,
1199 in case it expands into another macro call. */
1202 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1203 def = sym = XCAR (form);
1205 /* Trace symbols aliases to other symbols
1206 until we get a symbol that is not an alias. */
1207 while (SYMBOLP (def))
1211 tem = Fassq (sym, env);
1214 def = XSYMBOL (sym)->function;
1215 if (!UNBOUNDP (def))
1220 /* Right now TEM is the result from SYM in ENV,
1221 and if TEM is nil then DEF is SYM's function definition. */
1224 /* SYM is not mentioned in ENV.
1225 Look at its function definition. */
1228 /* Not defined or definition not suitable */
1230 if (EQ (XCAR (def), Qautoload))
1232 /* Autoloading function: will it be a macro when loaded? */
1233 tem = Felt (def, make_int (4));
1234 if (EQ (tem, Qt) || EQ (tem, Qmacro))
1236 /* Yes, load it and try again. */
1237 do_autoload (def, sym);
1243 else if (!EQ (XCAR (def), Qmacro))
1245 else expander = XCDR (def);
1249 expander = XCDR (tem);
1250 if (NILP (expander))
1253 form = apply1 (expander, XCDR (form));
1259 /************************************************************************/
1260 /* Non-local exits */
1261 /************************************************************************/
1263 DEFUN ("catch", Fcatch, 1, UNEVALLED, 0, /*
1264 \(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.
1265 TAG is evalled to get the tag to use. Then the BODY is executed.
1266 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.
1267 If no throw happens, `catch' returns the value of the last BODY form.
1268 If a throw happens, it specifies the value to return from `catch'.
1272 /* This function can GC */
1273 Lisp_Object tag = Feval (XCAR (args));
1274 Lisp_Object body = XCDR (args);
1275 return internal_catch (tag, Fprogn, body, 0);
1278 /* Set up a catch, then call C function FUNC on argument ARG.
1279 FUNC should return a Lisp_Object.
1280 This is how catches are done from within C code. */
1283 internal_catch (Lisp_Object tag,
1284 Lisp_Object (*func) (Lisp_Object arg),
1286 int * volatile threw)
1288 /* This structure is made part of the chain `catchlist'. */
1291 /* Fill in the components of c, and put it on the list. */
1295 c.backlist = backtrace_list;
1298 c.handlerlist = handlerlist;
1300 c.lisp_eval_depth = lisp_eval_depth;
1301 c.pdlcount = specpdl_depth();
1303 c.poll_suppress_count = async_timer_suppress_count;
1305 c.gcpro = gcprolist;
1311 /* Throw works by a longjmp that comes right here. */
1312 if (threw) *threw = 1;
1315 c.val = (*func) (arg);
1316 if (threw) *threw = 0;
1322 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1323 jump to that CATCH, returning VALUE as the value of that catch.
1325 This is the guts Fthrow and Fsignal; they differ only in the way
1326 they choose the catch tag to throw to. A catch tag for a
1327 condition-case form has a TAG of Qnil.
1329 Before each catch is discarded, unbind all special bindings and
1330 execute all unwind-protect clauses made above that catch. Unwind
1331 the handler stack as we go, so that the proper handlers are in
1332 effect for each unwind-protect clause we run. At the end, restore
1333 some static info saved in CATCH, and longjmp to the location
1336 This is used for correct unwinding in Fthrow and Fsignal. */
1339 unwind_to_catch (struct catchtag *c, Lisp_Object val)
1343 REGISTER int last_time;
1346 /* Unwind the specbind, catch, and handler stacks back to CATCH
1347 Before each catch is discarded, unbind all special bindings
1348 and execute all unwind-protect clauses made above that catch.
1349 At the end, restore some static info saved in CATCH,
1350 and longjmp to the location specified.
1353 /* Save the value somewhere it will be GC'ed.
1354 (Can't overwrite tag slot because an unwind-protect may
1355 want to throw to this same tag, which isn't yet invalid.) */
1359 /* Restore the polling-suppression count. */
1360 set_poll_suppress_count (catch->poll_suppress_count);
1364 /* #### FSFmacs has the following loop. Is it more correct? */
1367 last_time = catchlist == c;
1369 /* Unwind the specpdl stack, and then restore the proper set of
1371 unbind_to (catchlist->pdlcount, Qnil);
1372 handlerlist = catchlist->handlerlist;
1373 catchlist = catchlist->next;
1375 while (! last_time);
1376 #else /* Actual XEmacs code */
1377 /* Unwind the specpdl stack */
1378 unbind_to (c->pdlcount, Qnil);
1379 catchlist = c->next;
1382 gcprolist = c->gcpro;
1383 backtrace_list = c->backlist;
1384 lisp_eval_depth = c->lisp_eval_depth;
1386 #if 0 /* no longer used */
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)
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)
1496 struct Lisp_Cons *victim;
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)
1518 struct Lisp_Cons *victim;
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 Vcondition_handlers = XCDR (c.tag);
1651 return unbind_to (speccount, c.val);
1655 run_condition_case_handlers (Lisp_Object val, Lisp_Object var)
1657 /* This function can GC */
1660 specbind (h.var, c.val);
1661 val = Fprogn (Fcdr (h.chosen_clause));
1663 /* Note that this just undoes the binding of h.var; whoever
1664 longjmp()ed to us unwound the stack to c.pdlcount before
1666 unbind_to (c.pdlcount, Qnil);
1671 CHECK_TRUE_LIST (val);
1673 return Fprogn (Fcdr (val)); /* tail call */
1675 speccount = specpdl_depth();
1676 specbind (var, Fcar (val));
1677 val = Fprogn (Fcdr (val));
1678 return unbind_to (speccount, val);
1682 /* Here for bytecode to call non-consfully. This is exactly like
1683 condition-case except that it takes three arguments rather
1684 than a single list of arguments. */
1686 condition_case_3 (Lisp_Object bodyform, Lisp_Object var, Lisp_Object handlers)
1688 /* This function can GC */
1689 Lisp_Object handler;
1691 EXTERNAL_LIST_LOOP_2 (handler, handlers)
1695 else if (CONSP (handler))
1697 Lisp_Object conditions = XCAR (handler);
1698 /* CONDITIONS must a condition name or a list of condition names */
1699 if (SYMBOLP (conditions))
1703 Lisp_Object condition;
1704 EXTERNAL_LIST_LOOP_2 (condition, conditions)
1705 if (!SYMBOLP (condition))
1706 goto invalid_condition_handler;
1711 invalid_condition_handler:
1712 signal_simple_error ("Invalid condition handler", handler);
1718 return condition_case_1 (handlers,
1720 run_condition_case_handlers,
1724 DEFUN ("condition-case", Fcondition_case, 2, UNEVALLED, 0, /*
1725 Regain control when an error is signalled.
1726 Usage looks like (condition-case VAR BODYFORM HANDLERS...).
1727 Executes BODYFORM and returns its value if no error happens.
1728 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1729 where the BODY is made of Lisp expressions.
1731 A handler is applicable to an error if CONDITION-NAME is one of the
1732 error's condition names. If an error happens, the first applicable
1733 handler is run. As a special case, a CONDITION-NAME of t matches
1734 all errors, even those without the `error' condition name on them
1737 The car of a handler may be a list of condition names
1738 instead of a single condition name.
1740 When a handler handles an error,
1741 control returns to the condition-case and the handler BODY... is executed
1742 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).
1743 VAR may be nil; then you do not get access to the signal information.
1745 The value of the last BODY form is returned from the condition-case.
1746 See also the function `signal' for more info.
1748 Note that at the time the condition handler is invoked, the Lisp stack
1749 and the current catches, condition-cases, and bindings have all been
1750 popped back to the state they were in just before the call to
1751 `condition-case'. This means that resignalling the error from
1752 within the handler will not result in an infinite loop.
1754 If you want to establish an error handler that is called with the
1755 Lisp stack, bindings, etc. as they were when `signal' was called,
1756 rather than when the handler was set, use `call-with-condition-handler'.
1760 /* This function can GC */
1761 Lisp_Object var = XCAR (args);
1762 Lisp_Object bodyform = XCAR (XCDR (args));
1763 Lisp_Object handlers = XCDR (XCDR (args));
1764 return condition_case_3 (bodyform, var, handlers);
1767 DEFUN ("call-with-condition-handler", Fcall_with_condition_handler, 2, MANY, 0, /*
1768 Regain control when an error is signalled, without popping the stack.
1769 Usage looks like (call-with-condition-handler HANDLER FUNCTION &rest ARGS).
1770 This function is similar to `condition-case', but the handler is invoked
1771 with the same environment (Lisp stack, bindings, catches, condition-cases)
1772 that was current when `signal' was called, rather than when the handler
1775 HANDLER should be a function of one argument, which is a cons of the args
1776 \(SIG . DATA) that were passed to `signal'. It is invoked whenever
1777 `signal' is called (this differs from `condition-case', which allows
1778 you to specify which errors are trapped). If the handler function
1779 returns, `signal' continues as if the handler were never invoked.
1780 \(It continues to look for handlers established earlier than this one,
1781 and invokes the standard error-handler if none is found.)
1783 (int nargs, Lisp_Object *args)) /* Note! Args side-effected! */
1785 /* This function can GC */
1786 int speccount = specpdl_depth();
1789 /* #### If there were a way to check that args[0] were a function
1790 which accepted one arg, that should be done here ... */
1792 /* (handler-fun . handler-args) */
1793 tem = noseeum_cons (list1 (args[0]), Vcondition_handlers);
1794 record_unwind_protect (condition_bind_unwind, tem);
1795 Vcondition_handlers = tem;
1797 /* Caller should have GC-protected args */
1798 return unbind_to (speccount, Ffuncall (nargs - 1, args + 1));
1802 condition_type_p (Lisp_Object type, Lisp_Object conditions)
1805 /* (condition-case c # (t c)) catches -all- signals
1806 * Use with caution! */
1810 return !NILP (Fmemq (type, conditions));
1812 for (; CONSP (type); type = XCDR (type))
1813 if (!NILP (Fmemq (XCAR (type), conditions)))
1820 return_from_signal (Lisp_Object value)
1823 /* Most callers are not prepared to handle gc if this
1824 returns. So, since this feature is not very useful,
1826 /* Have called debugger; return value to signaller */
1828 #else /* But the reality is that that stinks, because: */
1829 /* GACK!!! Really want some way for debug-on-quit errors
1830 to be continuable!! */
1831 error ("Returning a value from an error is no longer supported");
1835 extern int in_display;
1838 /************************************************************************/
1839 /* the workhorse error-signaling function */
1840 /************************************************************************/
1842 /* #### This function has not been synched with FSF. It diverges
1846 signal_1 (Lisp_Object sig, Lisp_Object data)
1848 /* This function can GC */
1849 struct gcpro gcpro1, gcpro2;
1850 Lisp_Object conditions;
1851 Lisp_Object handlers;
1852 /* signal_call_debugger() could get called more than once
1853 (once when a call-with-condition-handler is about to
1854 be dealt with, and another when a condition-case handler
1855 is about to be invoked). So make sure the debugger and/or
1856 stack trace aren't done more than once. */
1857 int stack_trace_displayed = 0;
1858 int debugger_entered = 0;
1859 GCPRO2 (conditions, handlers);
1863 /* who knows how much has been initialized? Safest bet is
1864 just to bomb out immediately. */
1865 fprintf (stderr, "Error before initialization is complete!\n");
1869 if (gc_in_progress || in_display)
1870 /* This is one of many reasons why you can't run lisp code from redisplay.
1871 There is no sensible way to handle errors there. */
1874 conditions = Fget (sig, Qerror_conditions, Qnil);
1876 for (handlers = Vcondition_handlers;
1878 handlers = XCDR (handlers))
1880 Lisp_Object handler_fun = XCAR (XCAR (handlers));
1881 Lisp_Object handler_data = XCDR (XCAR (handlers));
1882 Lisp_Object outer_handlers = XCDR (handlers);
1884 if (!UNBOUNDP (handler_fun))
1886 /* call-with-condition-handler */
1888 Lisp_Object all_handlers = Vcondition_handlers;
1889 struct gcpro ngcpro1;
1890 NGCPRO1 (all_handlers);
1891 Vcondition_handlers = outer_handlers;
1893 tem = signal_call_debugger (conditions, sig, data,
1895 &stack_trace_displayed,
1897 if (!UNBOUNDP (tem))
1898 RETURN_NUNGCPRO (return_from_signal (tem));
1900 tem = Fcons (sig, data);
1901 if (NILP (handler_data))
1902 tem = call1 (handler_fun, tem);
1905 /* (This code won't be used (for now?).) */
1906 struct gcpro nngcpro1;
1907 Lisp_Object args[3];
1910 args[0] = handler_fun;
1912 args[2] = handler_data;
1913 nngcpro1.var = args;
1914 tem = Fapply (3, args);
1919 if (!EQ (tem, Qsignal))
1920 return return_from_signal (tem);
1922 /* If handler didn't throw, try another handler */
1923 Vcondition_handlers = all_handlers;
1926 /* It's a condition-case handler */
1928 /* t is used by handlers for all conditions, set up by C code.
1929 * debugger is not called even if debug_on_error */
1930 else if (EQ (handler_data, Qt))
1933 return Fthrow (handlers, Fcons (sig, data));
1935 /* `error' is used similarly to the way `t' is used, but in
1936 addition it invokes the debugger if debug_on_error.
1937 This is normally used for the outer command-loop error
1939 else if (EQ (handler_data, Qerror))
1941 Lisp_Object tem = signal_call_debugger (conditions, sig, data,
1943 &stack_trace_displayed,
1947 if (!UNBOUNDP (tem))
1948 return return_from_signal (tem);
1950 tem = Fcons (sig, data);
1951 return Fthrow (handlers, tem);
1955 /* handler established by real (Lisp) condition-case */
1958 for (h = handler_data; CONSP (h); h = Fcdr (h))
1960 Lisp_Object clause = Fcar (h);
1961 Lisp_Object tem = Fcar (clause);
1963 if (condition_type_p (tem, conditions))
1965 tem = signal_call_debugger (conditions, sig, data,
1967 &stack_trace_displayed,
1970 if (!UNBOUNDP (tem))
1971 return return_from_signal (tem);
1973 /* Doesn't return */
1974 tem = Fcons (Fcons (sig, data), Fcdr (clause));
1975 return Fthrow (handlers, tem);
1981 /* If no handler is present now, try to run the debugger,
1982 and if that fails, throw to top level.
1984 #### The only time that no handler is present is during
1985 temacs or perhaps very early in XEmacs. In both cases,
1986 there is no 'top-level catch. (That's why the
1987 "bomb-out" hack was added.)
1989 #### Fix this horrifitude!
1991 signal_call_debugger (conditions, sig, data, Qnil, 0,
1992 &stack_trace_displayed,
1995 throw_or_bomb_out (Qtop_level, Qt, 1, sig, data); /* Doesn't return */
2000 /****************** Error functions class 1 ******************/
2002 /* Class 1: General functions that signal an error.
2003 These functions take an error type and a list of associated error
2006 /* The simplest external error function: it would be called
2007 signal_continuable_error() in the terminology below, but it's
2010 DEFUN ("signal", Fsignal, 2, 2, 0, /*
2011 Signal a continuable error. Args are ERROR-SYMBOL, and associated DATA.
2012 An error symbol is a symbol defined using `define-error'.
2013 DATA should be a list. Its elements are printed as part of the error message.
2014 If the signal is handled, DATA is made available to the handler.
2015 See also the function `signal-error', and the functions to handle errors:
2016 `condition-case' and `call-with-condition-handler'.
2018 Note that this function can return, if the debugger is invoked and the
2019 user invokes the "return from signal" option.
2021 (error_symbol, data))
2023 /* Fsignal() is one of these functions that's called all the time
2024 with newly-created Lisp objects. We allow this; but we must GC-
2025 protect the objects because all sorts of weird stuff could
2028 struct gcpro gcpro1;
2031 if (!NILP (Vcurrent_error_state))
2033 if (!NILP (Vcurrent_warning_class))
2034 warn_when_safe_lispobj (Vcurrent_warning_class, Qwarning,
2035 Fcons (error_symbol, data));
2036 Fthrow (Qunbound_suspended_errors_tag, Qnil);
2037 abort (); /* Better not get here! */
2039 RETURN_UNGCPRO (signal_1 (error_symbol, data));
2042 /* Signal a non-continuable error. */
2045 signal_error (Lisp_Object sig, Lisp_Object data)
2048 Fsignal (sig, data);
2052 call_with_suspended_errors_1 (Lisp_Object opaque_arg)
2055 Lisp_Object *kludgy_args = (Lisp_Object *) get_opaque_ptr (opaque_arg);
2056 PRIMITIVE_FUNCALL (val, get_opaque_ptr (kludgy_args[0]),
2057 kludgy_args + 2, XINT (kludgy_args[1]));
2062 restore_current_warning_class (Lisp_Object warning_class)
2064 Vcurrent_warning_class = warning_class;
2069 restore_current_error_state (Lisp_Object error_state)
2071 Vcurrent_error_state = error_state;
2075 /* Many functions would like to do one of three things if an error
2078 (1) signal the error, as usual.
2079 (2) silently fail and return some error value.
2080 (3) do as (2) but issue a warning in the process.
2082 Currently there's lots of stuff that passes an Error_behavior
2083 value and calls maybe_signal_error() and other such functions.
2084 This approach is inherently error-prone and broken. A much
2085 more robust and easier approach is to use call_with_suspended_errors().
2086 Wrap this around any function in which you might want errors
2091 call_with_suspended_errors (lisp_fn_t fun, volatile Lisp_Object retval,
2092 Lisp_Object class, Error_behavior errb,
2097 Lisp_Object kludgy_args[22];
2098 Lisp_Object *args = kludgy_args + 2;
2100 Lisp_Object no_error;
2102 assert (SYMBOLP (class)); /* sanity-check */
2103 assert (!NILP (class));
2104 assert (nargs >= 0 && nargs < 20);
2106 /* ERROR_ME means don't trap errors. (However, if errors are
2107 already trapped, we leave them trapped.)
2109 Otherwise, we trap errors, and trap warnings if ERROR_ME_WARN.
2111 If ERROR_ME_NOT, it causes no warnings even if warnings
2112 were previously enabled. However, we never change the
2113 warning class from one to another. */
2114 if (!ERRB_EQ (errb, ERROR_ME))
2116 if (ERRB_EQ (errb, ERROR_ME_NOT)) /* person wants no warnings */
2118 errb = ERROR_ME_NOT;
2124 va_start (vargs, nargs);
2125 for (i = 0; i < nargs; i++)
2126 args[i] = va_arg (vargs, Lisp_Object);
2129 /* If error-checking is not disabled, just call the function.
2130 It's important not to override disabled error-checking with
2131 enabled error-checking. */
2133 if (ERRB_EQ (errb, ERROR_ME))
2136 PRIMITIVE_FUNCALL (val, fun, args, nargs);
2140 speccount = specpdl_depth();
2141 if (NILP (class) || NILP (Vcurrent_warning_class))
2143 /* If we're currently calling for no warnings, then make it so.
2144 If we're currently calling for warnings and we weren't
2145 previously, then set our warning class; otherwise, leave
2146 the existing one alone. */
2147 record_unwind_protect (restore_current_warning_class,
2148 Vcurrent_warning_class);
2149 Vcurrent_warning_class = class;
2151 if (!EQ (Vcurrent_error_state, no_error))
2153 record_unwind_protect (restore_current_error_state,
2154 Vcurrent_error_state);
2155 Vcurrent_error_state = no_error;
2160 Lisp_Object the_retval;
2161 Lisp_Object opaque1 = make_opaque_ptr (kludgy_args);
2162 Lisp_Object opaque2 = make_opaque_ptr ((void *) fun);
2163 struct gcpro gcpro1, gcpro2;
2165 GCPRO2 (opaque1, opaque2);
2166 kludgy_args[0] = opaque2;
2167 kludgy_args[1] = make_int (nargs);
2168 the_retval = internal_catch (Qunbound_suspended_errors_tag,
2169 call_with_suspended_errors_1,
2171 free_opaque_ptr (opaque1);
2172 free_opaque_ptr (opaque2);
2174 /* Use the returned value except in non-local exit, when
2176 /* Some perverse compilers require the perverse cast below. */
2177 return unbind_to (speccount,
2178 threw ? *((Lisp_Object*) &(retval)) : the_retval);
2182 /* Signal a non-continuable error or display a warning or do nothing,
2183 according to ERRB. CLASS is the class of warning and should
2184 refer to what sort of operation is being done (e.g. Qtoolbar,
2185 Qresource, etc.). */
2188 maybe_signal_error (Lisp_Object sig, Lisp_Object data, Lisp_Object class,
2189 Error_behavior errb)
2191 if (ERRB_EQ (errb, ERROR_ME_NOT))
2193 else if (ERRB_EQ (errb, ERROR_ME_WARN))
2194 warn_when_safe_lispobj (class, Qwarning, Fcons (sig, data));
2197 Fsignal (sig, data);
2200 /* Signal a continuable error or display a warning or do nothing,
2201 according to ERRB. */
2204 maybe_signal_continuable_error (Lisp_Object sig, Lisp_Object data,
2205 Lisp_Object class, Error_behavior errb)
2207 if (ERRB_EQ (errb, ERROR_ME_NOT))
2209 else if (ERRB_EQ (errb, ERROR_ME_WARN))
2211 warn_when_safe_lispobj (class, Qwarning, Fcons (sig, data));
2215 return Fsignal (sig, data);
2219 /****************** Error functions class 2 ******************/
2221 /* Class 2: Printf-like functions that signal an error.
2222 These functions signal an error of type Qerror, whose data
2223 is a single string, created using the arguments. */
2225 /* dump an error message; called like printf */
2228 error (CONST char *fmt, ...)
2233 va_start (args, fmt);
2234 obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt), Qnil, -1,
2238 /* Fsignal GC-protects its args */
2239 signal_error (Qerror, list1 (obj));
2243 maybe_error (Lisp_Object class, Error_behavior errb, CONST char *fmt, ...)
2249 if (ERRB_EQ (errb, ERROR_ME_NOT))
2252 va_start (args, fmt);
2253 obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt), Qnil, -1,
2257 /* Fsignal GC-protects its args */
2258 maybe_signal_error (Qerror, list1 (obj), class, errb);
2262 continuable_error (CONST char *fmt, ...)
2267 va_start (args, fmt);
2268 obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt), Qnil, -1,
2272 /* Fsignal GC-protects its args */
2273 return Fsignal (Qerror, list1 (obj));
2277 maybe_continuable_error (Lisp_Object class, Error_behavior errb,
2278 CONST char *fmt, ...)
2284 if (ERRB_EQ (errb, ERROR_ME_NOT))
2287 va_start (args, fmt);
2288 obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt), Qnil, -1,
2292 /* Fsignal GC-protects its args */
2293 return maybe_signal_continuable_error (Qerror, list1 (obj), class, errb);
2297 /****************** Error functions class 3 ******************/
2299 /* Class 3: Signal an error with a string and an associated object.
2300 These functions signal an error of type Qerror, whose data
2301 is two objects, a string and a related Lisp object (usually the object
2302 where the error is occurring). */
2305 signal_simple_error (CONST char *reason, Lisp_Object frob)
2307 signal_error (Qerror, list2 (build_translated_string (reason), frob));
2311 maybe_signal_simple_error (CONST char *reason, Lisp_Object frob,
2312 Lisp_Object class, Error_behavior errb)
2315 if (ERRB_EQ (errb, ERROR_ME_NOT))
2317 maybe_signal_error (Qerror, list2 (build_translated_string (reason), frob),
2322 signal_simple_continuable_error (CONST char *reason, Lisp_Object frob)
2324 return Fsignal (Qerror, list2 (build_translated_string (reason), frob));
2328 maybe_signal_simple_continuable_error (CONST char *reason, Lisp_Object frob,
2329 Lisp_Object class, Error_behavior errb)
2332 if (ERRB_EQ (errb, ERROR_ME_NOT))
2334 return maybe_signal_continuable_error
2335 (Qerror, list2 (build_translated_string (reason),
2336 frob), class, errb);
2340 /****************** Error functions class 4 ******************/
2342 /* Class 4: Printf-like functions that signal an error.
2343 These functions signal an error of type Qerror, whose data
2344 is a two objects, a string (created using the arguments) and a
2349 error_with_frob (Lisp_Object frob, CONST char *fmt, ...)
2354 va_start (args, fmt);
2355 obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt), Qnil, -1,
2359 /* Fsignal GC-protects its args */
2360 signal_error (Qerror, list2 (obj, frob));
2364 maybe_error_with_frob (Lisp_Object frob, Lisp_Object class,
2365 Error_behavior errb, CONST char *fmt, ...)
2371 if (ERRB_EQ (errb, ERROR_ME_NOT))
2374 va_start (args, fmt);
2375 obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt), Qnil, -1,
2379 /* Fsignal GC-protects its args */
2380 maybe_signal_error (Qerror, list2 (obj, frob), class, errb);
2384 continuable_error_with_frob (Lisp_Object frob, CONST char *fmt, ...)
2389 va_start (args, fmt);
2390 obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt), Qnil, -1,
2394 /* Fsignal GC-protects its args */
2395 return Fsignal (Qerror, list2 (obj, frob));
2399 maybe_continuable_error_with_frob (Lisp_Object frob, Lisp_Object class,
2400 Error_behavior errb, CONST char *fmt, ...)
2406 if (ERRB_EQ (errb, ERROR_ME_NOT))
2409 va_start (args, fmt);
2410 obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt), Qnil, -1,
2414 /* Fsignal GC-protects its args */
2415 return maybe_signal_continuable_error (Qerror, list2 (obj, frob),
2420 /****************** Error functions class 5 ******************/
2422 /* Class 5: Signal an error with a string and two associated objects.
2423 These functions signal an error of type Qerror, whose data
2424 is three objects, a string and two related Lisp objects. */
2427 signal_simple_error_2 (CONST char *reason,
2428 Lisp_Object frob0, Lisp_Object frob1)
2430 signal_error (Qerror, list3 (build_translated_string (reason), frob0,
2435 maybe_signal_simple_error_2 (CONST char *reason, Lisp_Object frob0,
2436 Lisp_Object frob1, Lisp_Object class,
2437 Error_behavior errb)
2440 if (ERRB_EQ (errb, ERROR_ME_NOT))
2442 maybe_signal_error (Qerror, list3 (build_translated_string (reason), frob0,
2443 frob1), class, errb);
2448 signal_simple_continuable_error_2 (CONST char *reason, Lisp_Object frob0,
2451 return Fsignal (Qerror, list3 (build_translated_string (reason), frob0,
2456 maybe_signal_simple_continuable_error_2 (CONST char *reason, Lisp_Object frob0,
2457 Lisp_Object frob1, Lisp_Object class,
2458 Error_behavior errb)
2461 if (ERRB_EQ (errb, ERROR_ME_NOT))
2463 return maybe_signal_continuable_error
2464 (Qerror, list3 (build_translated_string (reason), frob0,
2470 /* This is what the QUIT macro calls to signal a quit */
2474 /* This function can GC */
2475 if (EQ (Vquit_flag, Qcritical))
2476 debug_on_quit |= 2; /* set critical bit. */
2478 /* note that this is continuable. */
2479 Fsignal (Qquit, Qnil);
2483 /* Used in core lisp functions for efficiency */
2485 signal_void_function_error (Lisp_Object function)
2487 Fsignal (Qvoid_function, list1 (function));
2491 signal_invalid_function_error (Lisp_Object function)
2493 Fsignal (Qinvalid_function, list1 (function));
2497 signal_wrong_number_of_arguments_error (Lisp_Object function, int nargs)
2499 Fsignal (Qwrong_number_of_arguments, list2 (function, make_int (nargs)));
2502 /* Used in list traversal macros for efficiency. */
2504 signal_malformed_list_error (Lisp_Object list)
2506 Fsignal (Qmalformed_list, list1 (list));
2510 signal_malformed_property_list_error (Lisp_Object list)
2512 Fsignal (Qmalformed_property_list, list1 (list));
2516 signal_circular_list_error (Lisp_Object list)
2518 Fsignal (Qcircular_list, list1 (list));
2522 signal_circular_property_list_error (Lisp_Object list)
2524 Fsignal (Qcircular_property_list, list1 (list));
2527 /************************************************************************/
2529 /************************************************************************/
2531 DEFUN ("commandp", Fcommandp, 1, 1, 0, /*
2532 Return t if FUNCTION makes provisions for interactive calling.
2533 This means it contains a description for how to read arguments to give it.
2534 The value is nil for an invalid function or a symbol with no function
2537 Interactively callable functions include
2539 -- strings and vectors (treated as keyboard macros)
2540 -- lambda-expressions that contain a top-level call to `interactive'
2541 -- autoload definitions made by `autoload' with non-nil fourth argument
2542 (i.e. the interactive flag)
2543 -- compiled-function objects with a non-nil `compiled-function-interactive'
2545 -- subrs (built-in functions) that are interactively callable
2547 Also, a symbol satisfies `commandp' if its function definition does so.
2551 Lisp_Object fun = indirect_function (function, 0);
2553 if (COMPILED_FUNCTIONP (fun))
2554 return XCOMPILED_FUNCTION (fun)->flags.interactivep ? Qt : Qnil;
2556 /* Lists may represent commands. */
2559 Lisp_Object funcar = XCAR (fun);
2560 if (EQ (funcar, Qlambda))
2561 return Fassq (Qinteractive, Fcdr (Fcdr (fun)));
2562 if (EQ (funcar, Qautoload))
2563 return Fcar (Fcdr (Fcdr (Fcdr (fun))));
2568 /* Emacs primitives are interactive if their DEFUN specifies an
2569 interactive spec. */
2571 return XSUBR (fun)->prompt ? Qt : Qnil;
2573 /* Strings and vectors are keyboard macros. */
2574 if (VECTORP (fun) || STRINGP (fun))
2577 /* Everything else (including Qunbound) is not a command. */
2581 DEFUN ("command-execute", Fcommand_execute, 1, 3, 0, /*
2582 Execute CMD as an editor command.
2583 CMD must be an object that satisfies the `commandp' predicate.
2584 Optional second arg RECORD-FLAG is as in `call-interactively'.
2585 The argument KEYS specifies the value to use instead of (this-command-keys)
2586 when reading the arguments.
2588 (cmd, record, keys))
2590 /* This function can GC */
2591 Lisp_Object prefixarg;
2592 Lisp_Object final = cmd;
2593 struct backtrace backtrace;
2594 struct console *con = XCONSOLE (Vselected_console);
2596 prefixarg = con->prefix_arg;
2597 con->prefix_arg = Qnil;
2598 Vcurrent_prefix_arg = prefixarg;
2599 debug_on_next_call = 0; /* #### from FSFmacs; correct? */
2601 if (SYMBOLP (cmd) && !NILP (Fget (cmd, Qdisabled, Qnil)))
2602 return run_hook (Vdisabled_command_hook);
2606 final = indirect_function (cmd, 1);
2607 if (CONSP (final) && EQ (Fcar (final), Qautoload))
2608 do_autoload (final, cmd);
2613 if (CONSP (final) || SUBRP (final) || COMPILED_FUNCTIONP (final))
2615 backtrace.function = &Qcall_interactively;
2616 backtrace.args = &cmd;
2617 backtrace.nargs = 1;
2618 backtrace.evalargs = 0;
2619 backtrace.pdlcount = specpdl_depth();
2620 backtrace.debug_on_exit = 0;
2621 PUSH_BACKTRACE (backtrace);
2623 final = Fcall_interactively (cmd, record, keys);
2625 POP_BACKTRACE (backtrace);
2628 else if (STRINGP (final) || VECTORP (final))
2630 return Fexecute_kbd_macro (final, prefixarg);
2634 Fsignal (Qwrong_type_argument,
2638 : list2 (cmd, final))));
2643 DEFUN ("interactive-p", Finteractive_p, 0, 0, 0, /*
2644 Return t if function in which this appears was called interactively.
2645 This means that the function was called with call-interactively (which
2646 includes being called as the binding of a key)
2647 and input is currently coming from the keyboard (not in keyboard macro).
2651 REGISTER struct backtrace *btp;
2652 REGISTER Lisp_Object fun;
2657 /* Unless the object was compiled, skip the frame of interactive-p itself
2658 (if interpreted) or the frame of byte-code (if called from a compiled
2659 function). Note that *btp->function may be a symbol pointing at a
2660 compiled function. */
2661 btp = backtrace_list;
2665 /* #### FSFmacs does the following instead. I can't figure
2666 out which one is more correct. */
2667 /* If this isn't a byte-compiled function, there may be a frame at
2668 the top for Finteractive_p itself. If so, skip it. */
2669 fun = Findirect_function (*btp->function);
2670 if (SUBRP (fun) && XSUBR (fun) == &Sinteractive_p)
2673 /* If we're running an Emacs 18-style byte-compiled function, there
2674 may be a frame for Fbyte_code. Now, given the strictest
2675 definition, this function isn't really being called
2676 interactively, but because that's the way Emacs 18 always builds
2677 byte-compiled functions, we'll accept it for now. */
2678 if (EQ (*btp->function, Qbyte_code))
2681 /* If this isn't a byte-compiled function, then we may now be
2682 looking at several frames for special forms. Skip past them. */
2684 btp->nargs == UNEVALLED)
2689 if (! (COMPILED_FUNCTIONP (Findirect_function (*btp->function))))
2692 btp && (btp->nargs == UNEVALLED
2693 || EQ (*btp->function, Qbyte_code));
2696 /* btp now points at the frame of the innermost function
2697 that DOES eval its args.
2698 If it is a built-in function (such as load or eval-region)
2700 /* Beats me why this is necessary, but it is */
2701 if (btp && EQ (*btp->function, Qcall_interactively))
2706 fun = Findirect_function (*btp->function);
2709 /* btp points to the frame of a Lisp function that called interactive-p.
2710 Return t if that function was called interactively. */
2711 if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively))
2717 /************************************************************************/
2719 /************************************************************************/
2721 DEFUN ("autoload", Fautoload, 2, 5, 0, /*
2722 Define FUNCTION to autoload from FILE.
2723 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
2724 Third arg DOCSTRING is documentation for the function.
2725 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
2726 Fifth arg TYPE indicates the type of the object:
2727 nil or omitted says FUNCTION is a function,
2728 `keymap' says FUNCTION is really a keymap, and
2729 `macro' or t says FUNCTION is really a macro.
2730 Third through fifth args give info about the real definition.
2731 They default to nil.
2732 If FUNCTION is already defined other than as an autoload,
2733 this does nothing and returns nil.
2735 (function, file, docstring, interactive, type))
2737 /* This function can GC */
2738 CHECK_SYMBOL (function);
2739 CHECK_STRING (file);
2741 /* If function is defined and not as an autoload, don't override */
2743 Lisp_Object f = XSYMBOL (function)->function;
2744 if (!UNBOUNDP (f) && !(CONSP (f) && EQ (XCAR (f), Qautoload)))
2750 /* Attempt to avoid consing identical (string=) pure strings. */
2751 file = Fsymbol_name (Fintern (file, Qnil));
2754 return Ffset (function,
2755 Fpurecopy (Fcons (Qautoload, list4 (file,
2762 un_autoload (Lisp_Object oldqueue)
2764 /* This function can GC */
2765 REGISTER Lisp_Object queue, first, second;
2767 /* Queue to unwind is current value of Vautoload_queue.
2768 oldqueue is the shadowed value to leave in Vautoload_queue. */
2769 queue = Vautoload_queue;
2770 Vautoload_queue = oldqueue;
2771 while (CONSP (queue))
2773 first = XCAR (queue);
2774 second = Fcdr (first);
2775 first = Fcar (first);
2779 Ffset (first, second);
2780 queue = Fcdr (queue);
2786 do_autoload (Lisp_Object fundef,
2787 Lisp_Object funname)
2789 /* This function can GC */
2790 int speccount = specpdl_depth();
2791 Lisp_Object fun = funname;
2792 struct gcpro gcpro1, gcpro2;
2794 CHECK_SYMBOL (funname);
2795 GCPRO2 (fun, funname);
2797 /* Value saved here is to be restored into Vautoload_queue */
2798 record_unwind_protect (un_autoload, Vautoload_queue);
2799 Vautoload_queue = Qt;
2800 call4 (Qload, Fcar (Fcdr (fundef)), Qnil, noninteractive ? Qt : Qnil, Qnil);
2805 /* Save the old autoloads, in case we ever do an unload. */
2806 for (queue = Vautoload_queue; CONSP (queue); queue = XCDR (queue))
2808 Lisp_Object first = XCAR (queue);
2809 Lisp_Object second = Fcdr (first);
2811 first = Fcar (first);
2813 /* Note: This test is subtle. The cdr of an autoload-queue entry
2814 may be an atom if the autoload entry was generated by a defalias
2817 Fput (first, Qautoload, (XCDR (second)));
2821 /* Once loading finishes, don't undo it. */
2822 Vautoload_queue = Qt;
2823 unbind_to (speccount, Qnil);
2825 fun = indirect_function (fun, 0);
2828 if (!NILP (Fequal (fun, fundef)))
2832 && EQ (XCAR (fun), Qautoload)))
2834 error ("Autoloading failed to define function %s",
2835 string_data (XSYMBOL (funname)->name));
2840 /************************************************************************/
2841 /* eval, funcall, apply */
2842 /************************************************************************/
2844 static Lisp_Object funcall_lambda (Lisp_Object fun,
2845 int nargs, Lisp_Object args[]);
2846 static int in_warnings;
2849 in_warnings_restore (Lisp_Object minimus)
2855 DEFUN ("eval", Feval, 1, 1, 0, /*
2856 Evaluate FORM and return its value.
2860 /* This function can GC */
2861 Lisp_Object fun, val, original_fun, original_args;
2863 struct backtrace backtrace;
2865 /* I think this is a pretty safe place to call Lisp code, don't you? */
2866 while (!in_warnings && !NILP (Vpending_warnings))
2868 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
2869 int speccount = specpdl_depth();
2870 Lisp_Object this_warning_cons, this_warning, class, level, messij;
2872 record_unwind_protect (in_warnings_restore, Qnil);
2874 this_warning_cons = Vpending_warnings;
2875 this_warning = XCAR (this_warning_cons);
2876 /* in case an error occurs in the warn function, at least
2877 it won't happen infinitely */
2878 Vpending_warnings = XCDR (Vpending_warnings);
2879 free_cons (XCONS (this_warning_cons));
2880 class = XCAR (this_warning);
2881 level = XCAR (XCDR (this_warning));
2882 messij = XCAR (XCDR (XCDR (this_warning)));
2883 free_list (this_warning);
2885 if (NILP (Vpending_warnings))
2886 Vpending_warnings_tail = Qnil; /* perhaps not strictly necessary,
2889 GCPRO4 (form, class, level, messij);
2890 if (!STRINGP (messij))
2891 messij = Fprin1_to_string (messij, Qnil);
2892 call3 (Qdisplay_warning, class, messij, level);
2894 unbind_to (speccount, Qnil);
2900 return Fsymbol_value (form);
2906 if ((consing_since_gc > gc_cons_threshold) || always_gc)
2908 struct gcpro gcpro1;
2910 garbage_collect_1 ();
2914 if (++lisp_eval_depth > max_lisp_eval_depth)
2916 if (max_lisp_eval_depth < 100)
2917 max_lisp_eval_depth = 100;
2918 if (lisp_eval_depth > max_lisp_eval_depth)
2919 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2922 /* We guaranteed CONSP (form) above */
2923 original_fun = XCAR (form);
2924 original_args = XCDR (form);
2926 GET_EXTERNAL_LIST_LENGTH (original_args, nargs);
2928 backtrace.pdlcount = specpdl_depth();
2929 backtrace.function = &original_fun; /* This also protects them from gc */
2930 backtrace.args = &original_args;
2931 backtrace.nargs = UNEVALLED;
2932 backtrace.evalargs = 1;
2933 backtrace.debug_on_exit = 0;
2934 PUSH_BACKTRACE (backtrace);
2936 if (debug_on_next_call)
2937 do_debug_on_call (Qt);
2939 if (profiling_active)
2940 profile_increase_call_count (original_fun);
2942 /* At this point, only original_fun and original_args
2943 have values that will be used below. */
2945 fun = indirect_function (original_fun, 1);
2949 Lisp_Subr *subr = XSUBR (fun);
2950 int max_args = subr->max_args;
2952 if (nargs < subr->min_args)
2953 goto wrong_number_of_arguments;
2955 if (max_args == UNEVALLED) /* Optimize for the common case */
2957 backtrace.evalargs = 0;
2958 val = (((Lisp_Object (*) (Lisp_Object)) (subr_function (subr)))
2961 else if (nargs <= max_args)
2963 struct gcpro gcpro1;
2964 Lisp_Object args[SUBR_MAX_ARGS];
2965 REGISTER Lisp_Object *p = args;
2971 REGISTER Lisp_Object arg;
2972 LIST_LOOP_2 (arg, original_args)
2979 /* &optional args default to nil. */
2980 while (p - args < max_args)
2983 backtrace.args = args;
2984 backtrace.nargs = nargs;
2986 FUNCALL_SUBR (val, subr, args, max_args);
2990 else if (max_args == MANY)
2992 /* Pass a vector of evaluated arguments */
2993 struct gcpro gcpro1;
2994 Lisp_Object *args = alloca_array (Lisp_Object, nargs);
2995 REGISTER Lisp_Object *p = args;
3001 REGISTER Lisp_Object arg;
3002 LIST_LOOP_2 (arg, original_args)
3009 backtrace.args = args;
3010 backtrace.nargs = nargs;
3012 val = (((Lisp_Object (*) (int, Lisp_Object *)) (subr_function (subr)))
3019 wrong_number_of_arguments:
3020 signal_wrong_number_of_arguments_error (fun, nargs);
3023 else if (COMPILED_FUNCTIONP (fun))
3025 struct gcpro gcpro1;
3026 Lisp_Object *args = alloca_array (Lisp_Object, nargs);
3027 REGISTER Lisp_Object *p = args;
3033 REGISTER Lisp_Object arg;
3034 LIST_LOOP_2 (arg, original_args)
3041 backtrace.args = args;
3042 backtrace.nargs = nargs;
3043 backtrace.evalargs = 0;
3045 val = funcall_compiled_function (fun, nargs, args);
3047 /* Do the debug-on-exit now, while args is still GCPROed. */
3048 if (backtrace.debug_on_exit)
3049 val = do_debug_on_exit (val);
3050 /* Don't do it again when we return to eval. */
3051 backtrace.debug_on_exit = 0;
3055 else if (CONSP (fun))
3057 Lisp_Object funcar = XCAR (fun);
3059 if (EQ (funcar, Qautoload))
3061 do_autoload (fun, original_fun);
3064 else if (EQ (funcar, Qmacro))
3066 val = Feval (apply1 (XCDR (fun), original_args));
3068 else if (EQ (funcar, Qlambda))
3070 struct gcpro gcpro1;
3071 Lisp_Object *args = alloca_array (Lisp_Object, nargs);
3072 REGISTER Lisp_Object *p = args;
3078 REGISTER Lisp_Object arg;
3079 LIST_LOOP_2 (arg, original_args)
3088 backtrace.args = args; /* this also GCPROs `args' */
3089 backtrace.nargs = nargs;
3090 backtrace.evalargs = 0;
3092 val = funcall_lambda (fun, nargs, args);
3094 /* Do the debug-on-exit now, while args is still GCPROed. */
3095 if (backtrace.debug_on_exit)
3096 val = do_debug_on_exit (val);
3097 /* Don't do it again when we return to eval. */
3098 backtrace.debug_on_exit = 0;
3102 goto invalid_function;
3105 else /* ! (SUBRP (fun) || COMPILED_FUNCTIONP (fun) || CONSP (fun)) */
3108 signal_invalid_function_error (fun);
3112 if (backtrace.debug_on_exit)
3113 val = do_debug_on_exit (val);
3114 POP_BACKTRACE (backtrace);
3119 DEFUN ("funcall", Ffuncall, 1, MANY, 0, /*
3120 Call first argument as a function, passing the remaining arguments to it.
3121 Thus, (funcall 'cons 'x 'y) returns (x . y).
3123 (int nargs, Lisp_Object *args))
3125 /* This function can GC */
3128 struct backtrace backtrace;
3129 int fun_nargs = nargs - 1;
3130 Lisp_Object *fun_args = args + 1;
3133 if ((consing_since_gc > gc_cons_threshold) || always_gc)
3134 /* Callers should gcpro lexpr args */
3135 garbage_collect_1 ();
3137 if (++lisp_eval_depth > max_lisp_eval_depth)
3139 if (max_lisp_eval_depth < 100)
3140 max_lisp_eval_depth = 100;
3141 if (lisp_eval_depth > max_lisp_eval_depth)
3142 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
3145 backtrace.pdlcount = specpdl_depth();
3146 backtrace.function = &args[0];
3147 backtrace.args = fun_args;
3148 backtrace.nargs = fun_nargs;
3149 backtrace.evalargs = 0;
3150 backtrace.debug_on_exit = 0;
3151 PUSH_BACKTRACE (backtrace);
3153 if (debug_on_next_call)
3154 do_debug_on_call (Qlambda);
3160 /* It might be useful to place this *after* all the checks. */
3161 if (profiling_active)
3162 profile_increase_call_count (fun);
3164 /* We could call indirect_function directly, but profiling shows
3165 this is worth optimizing by partially unrolling the loop. */
3168 fun = XSYMBOL (fun)->function;
3171 fun = XSYMBOL (fun)->function;
3173 fun = indirect_function (fun, 1);
3179 Lisp_Subr *subr = XSUBR (fun);
3180 int max_args = subr->max_args;
3181 Lisp_Object spacious_args[SUBR_MAX_ARGS];
3183 if (fun_nargs < subr->min_args)
3184 goto wrong_number_of_arguments;
3186 if (fun_nargs == max_args) /* Optimize for the common case */
3189 FUNCALL_SUBR (val, subr, fun_args, max_args);
3191 else if (fun_nargs < max_args)
3193 Lisp_Object *p = spacious_args;
3195 /* Default optionals to nil */
3198 while (p - spacious_args < max_args)
3201 fun_args = spacious_args;
3204 else if (max_args == MANY)
3206 val = ((Lisp_Object (*) (int, Lisp_Object *)) (subr_function (subr)))
3207 (fun_nargs, fun_args);
3209 else if (max_args == UNEVALLED) /* Can't funcall a special form */
3211 goto invalid_function;
3215 wrong_number_of_arguments:
3216 signal_wrong_number_of_arguments_error (fun, fun_nargs);
3219 else if (COMPILED_FUNCTIONP (fun))
3221 val = funcall_compiled_function (fun, fun_nargs, fun_args);
3223 else if (CONSP (fun))
3225 Lisp_Object funcar = XCAR (fun);
3227 if (EQ (funcar, Qlambda))
3229 val = funcall_lambda (fun, fun_nargs, fun_args);
3231 else if (EQ (funcar, Qautoload))
3233 do_autoload (fun, args[0]);
3236 else /* Can't funcall a macro */
3238 goto invalid_function;
3241 else if (UNBOUNDP (fun))
3243 signal_void_function_error (args[0]);
3248 signal_invalid_function_error (fun);
3252 if (backtrace.debug_on_exit)
3253 val = do_debug_on_exit (val);
3254 POP_BACKTRACE (backtrace);
3258 DEFUN ("functionp", Ffunctionp, 1, 1, 0, /*
3259 Return t if OBJECT can be called as a function, else nil.
3260 A function is an object that can be applied to arguments,
3261 using for example `funcall' or `apply'.
3265 if (SYMBOLP (object))
3266 object = indirect_function (object, 0);
3270 COMPILED_FUNCTIONP (object) ||
3272 (EQ (XCAR (object), Qlambda) ||
3273 EQ (XCAR (object), Qautoload))))
3278 function_argcount (Lisp_Object function, int function_min_args_p)
3280 Lisp_Object orig_function = function;
3281 Lisp_Object arglist;
3285 if (SYMBOLP (function))
3286 function = indirect_function (function, 1);
3288 if (SUBRP (function))
3290 return function_min_args_p ?
3291 Fsubr_min_args (function):
3292 Fsubr_max_args (function);
3294 else if (COMPILED_FUNCTIONP (function))
3296 arglist = compiled_function_arglist (XCOMPILED_FUNCTION (function));
3298 else if (CONSP (function))
3300 Lisp_Object funcar = XCAR (function);
3302 if (EQ (funcar, Qmacro))
3304 function = XCDR (function);
3307 else if (EQ (funcar, Qautoload))
3309 do_autoload (function, orig_function);
3312 else if (EQ (funcar, Qlambda))
3314 arglist = Fcar (XCDR (function));
3318 goto invalid_function;
3324 return Fsignal (Qinvalid_function, list1 (function));
3331 EXTERNAL_LIST_LOOP_2 (arg, arglist)
3333 if (EQ (arg, Qand_optional))
3335 if (function_min_args_p)
3338 else if (EQ (arg, Qand_rest))
3340 if (function_min_args_p)
3351 return make_int (argcount);
3355 DEFUN ("function-min-args", Ffunction_min_args, 1, 1, 0, /*
3356 Return the number of arguments a function may be called with.
3357 The function may be any form that can be passed to `funcall',
3358 any special form, or any macro.
3362 return function_argcount (function, 1);
3365 DEFUN ("function-max-args", Ffunction_max_args, 1, 1, 0, /*
3366 Return the number of arguments a function may be called with.
3367 The function may be any form that can be passed to `funcall',
3368 any special form, or any macro.
3369 If the function takes an arbitrary number of arguments or is
3370 a built-in special form, nil is returned.
3374 return function_argcount (function, 0);
3378 DEFUN ("apply", Fapply, 2, MANY, 0, /*
3379 Call FUNCTION with the remaining args, using the last arg as a list of args.
3380 Thus, (apply '+ 1 2 '(3 4)) returns 10.
3382 (int nargs, Lisp_Object *args))
3384 /* This function can GC */
3385 Lisp_Object fun = args[0];
3386 Lisp_Object spread_arg = args [nargs - 1];
3390 GET_EXTERNAL_LIST_LENGTH (spread_arg, numargs);
3393 /* (apply foo 0 1 '()) */
3394 return Ffuncall (nargs - 1, args);
3395 else if (numargs == 1)
3397 /* (apply foo 0 1 '(2)) */
3398 args [nargs - 1] = XCAR (spread_arg);
3399 return Ffuncall (nargs, args);
3402 /* -1 for function, -1 for spread arg */
3403 numargs = nargs - 2 + numargs;
3404 /* +1 for function */
3405 funcall_nargs = 1 + numargs;
3408 fun = indirect_function (fun, 0);
3412 Lisp_Subr *subr = XSUBR (fun);
3413 int max_args = subr->max_args;
3415 if (numargs < subr->min_args
3416 || (max_args >= 0 && max_args < numargs))
3418 /* Let funcall get the error */
3420 else if (max_args > numargs)
3422 /* Avoid having funcall cons up yet another new vector of arguments
3423 by explicitly supplying nil's for optional values */
3424 funcall_nargs += (max_args - numargs);
3427 else if (UNBOUNDP (fun))
3429 /* Let funcall get the error */
3435 Lisp_Object *funcall_args = alloca_array (Lisp_Object, funcall_nargs);
3436 struct gcpro gcpro1;
3438 GCPRO1 (*funcall_args);
3439 gcpro1.nvars = funcall_nargs;
3441 /* Copy in the unspread args */
3442 memcpy (funcall_args, args, (nargs - 1) * sizeof (Lisp_Object));
3443 /* Spread the last arg we got. Its first element goes in
3444 the slot that it used to occupy, hence this value of I. */
3446 !NILP (spread_arg); /* i < 1 + numargs */
3447 i++, spread_arg = XCDR (spread_arg))
3449 funcall_args [i] = XCAR (spread_arg);
3451 /* Supply nil for optional args (to subrs) */
3452 for (; i < funcall_nargs; i++)
3453 funcall_args[i] = Qnil;
3456 RETURN_UNGCPRO (Ffuncall (funcall_nargs, funcall_args));
3461 /* Apply lambda list FUN to the NARGS evaluated arguments in ARGS and
3462 return the result of evaluation. */
3465 funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object args[])
3467 /* This function can GC */
3468 Lisp_Object symbol, arglist, body, tail;
3469 int speccount = specpdl_depth();
3475 goto invalid_function;
3477 arglist = XCAR (tail);
3481 int optional = 0, rest = 0;
3483 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
3485 if (!SYMBOLP (symbol))
3486 goto invalid_function;
3487 if (EQ (symbol, Qand_rest))
3489 else if (EQ (symbol, Qand_optional))
3493 specbind (symbol, Flist (nargs - i, &args[i]));
3497 specbind (symbol, args[i++]);
3499 goto wrong_number_of_arguments;
3501 specbind (symbol, Qnil);
3506 goto wrong_number_of_arguments;
3508 return unbind_to (speccount, Fprogn (body));
3510 wrong_number_of_arguments:
3511 return Fsignal (Qwrong_number_of_arguments, list2 (fun, make_int (nargs)));
3514 return Fsignal (Qinvalid_function, list1 (fun));
3518 /************************************************************************/
3519 /* Run hook variables in various ways. */
3520 /************************************************************************/
3522 DEFUN ("run-hooks", Frun_hooks, 1, MANY, 0, /*
3523 Run each hook in HOOKS. Major mode functions use this.
3524 Each argument should be a symbol, a hook variable.
3525 These symbols are processed in the order specified.
3526 If a hook symbol has a non-nil value, that value may be a function
3527 or a list of functions to be called to run the hook.
3528 If the value is a function, it is called with no arguments.
3529 If it is a list, the elements are called, in order, with no arguments.
3531 To make a hook variable buffer-local, use `make-local-hook',
3532 not `make-local-variable'.
3534 (int nargs, Lisp_Object *args))
3538 for (i = 0; i < nargs; i++)
3539 run_hook_with_args (1, args + i, RUN_HOOKS_TO_COMPLETION);
3544 DEFUN ("run-hook-with-args", Frun_hook_with_args, 1, MANY, 0, /*
3545 Run HOOK with the specified arguments ARGS.
3546 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
3547 value, that value may be a function or a list of functions to be
3548 called to run the hook. If the value is a function, it is called with
3549 the given arguments and its return value is returned. If it is a list
3550 of functions, those functions are called, in order,
3551 with the given arguments ARGS.
3552 It is best not to depend on the value return by `run-hook-with-args',
3555 To make a hook variable buffer-local, use `make-local-hook',
3556 not `make-local-variable'.
3558 (int nargs, Lisp_Object *args))
3560 return run_hook_with_args (nargs, args, RUN_HOOKS_TO_COMPLETION);
3563 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success, 1, MANY, 0, /*
3564 Run HOOK with the specified arguments ARGS.
3565 HOOK should be a symbol, a hook variable. Its value should
3566 be a list of functions. We call those functions, one by one,
3567 passing arguments ARGS to each of them, until one of them
3568 returns a non-nil value. Then we return that value.
3569 If all the functions return nil, we return nil.
3571 To make a hook variable buffer-local, use `make-local-hook',
3572 not `make-local-variable'.
3574 (int nargs, Lisp_Object *args))
3576 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_SUCCESS);
3579 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure, 1, MANY, 0, /*
3580 Run HOOK with the specified arguments ARGS.
3581 HOOK should be a symbol, a hook variable. Its value should
3582 be a list of functions. We call those functions, one by one,
3583 passing arguments ARGS to each of them, until one of them
3584 returns nil. Then we return nil.
3585 If all the functions return non-nil, we return non-nil.
3587 To make a hook variable buffer-local, use `make-local-hook',
3588 not `make-local-variable'.
3590 (int nargs, Lisp_Object *args))
3592 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_FAILURE);
3595 /* ARGS[0] should be a hook symbol.
3596 Call each of the functions in the hook value, passing each of them
3597 as arguments all the rest of ARGS (all NARGS - 1 elements).
3598 COND specifies a condition to test after each call
3599 to decide whether to stop.
3600 The caller (or its caller, etc) must gcpro all of ARGS,
3601 except that it isn't necessary to gcpro ARGS[0]. */
3604 run_hook_with_args_in_buffer (struct buffer *buf, int nargs, Lisp_Object *args,
3605 enum run_hooks_condition cond)
3607 Lisp_Object sym, val, ret;
3609 if (!initialized || preparing_for_armageddon)
3610 /* We need to bail out of here pronto. */
3613 /* Whenever gc_in_progress is true, preparing_for_armageddon
3614 will also be true unless something is really hosed. */
3615 assert (!gc_in_progress);
3618 val = symbol_value_in_buffer (sym, make_buffer (buf));
3619 ret = (cond == RUN_HOOKS_UNTIL_FAILURE ? Qt : Qnil);
3621 if (UNBOUNDP (val) || NILP (val))
3623 else if (!CONSP (val) || EQ (XCAR (val), Qlambda))
3626 return Ffuncall (nargs, args);
3630 struct gcpro gcpro1, gcpro2;
3634 CONSP (val) && ((cond == RUN_HOOKS_TO_COMPLETION)
3635 || (cond == RUN_HOOKS_UNTIL_SUCCESS ? NILP (ret)
3639 if (EQ (XCAR (val), Qt))
3641 /* t indicates this hook has a local binding;
3642 it means to run the global binding too. */
3643 Lisp_Object globals = Fdefault_value (sym);
3645 if ((! CONSP (globals) || EQ (XCAR (globals), Qlambda)) &&
3649 ret = Ffuncall (nargs, args);
3654 CONSP (globals) && ((cond == RUN_HOOKS_TO_COMPLETION)
3655 || (cond == RUN_HOOKS_UNTIL_SUCCESS
3658 globals = XCDR (globals))
3660 args[0] = XCAR (globals);
3661 /* In a global value, t should not occur. If it does, we
3662 must ignore it to avoid an endless loop. */
3663 if (!EQ (args[0], Qt))
3664 ret = Ffuncall (nargs, args);
3670 args[0] = XCAR (val);
3671 ret = Ffuncall (nargs, args);
3681 run_hook_with_args (int nargs, Lisp_Object *args,
3682 enum run_hooks_condition cond)
3684 return run_hook_with_args_in_buffer (current_buffer, nargs, args, cond);
3689 /* From FSF 19.30, not currently used */
3691 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
3692 present value of that symbol.
3693 Call each element of FUNLIST,
3694 passing each of them the rest of ARGS.
3695 The caller (or its caller, etc) must gcpro all of ARGS,
3696 except that it isn't necessary to gcpro ARGS[0]. */
3699 run_hook_list_with_args (Lisp_Object funlist, int nargs, Lisp_Object *args)
3701 Lisp_Object sym = args[0];
3703 struct gcpro gcpro1, gcpro2;
3707 for (val = funlist; CONSP (val); val = XCDR (val))
3709 if (EQ (XCAR (val), Qt))
3711 /* t indicates this hook has a local binding;
3712 it means to run the global binding too. */
3713 Lisp_Object globals;
3715 for (globals = Fdefault_value (sym);
3717 globals = XCDR (globals))
3719 args[0] = XCAR (globals);
3720 /* In a global value, t should not occur. If it does, we
3721 must ignore it to avoid an endless loop. */
3722 if (!EQ (args[0], Qt))
3723 Ffuncall (nargs, args);
3728 args[0] = XCAR (val);
3729 Ffuncall (nargs, args);
3739 va_run_hook_with_args (Lisp_Object hook_var, int nargs, ...)
3741 /* This function can GC */
3742 struct gcpro gcpro1;
3745 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs);
3747 va_start (vargs, nargs);
3748 funcall_args[0] = hook_var;
3749 for (i = 0; i < nargs; i++)
3750 funcall_args[i + 1] = va_arg (vargs, Lisp_Object);
3753 GCPRO1 (*funcall_args);
3754 gcpro1.nvars = nargs + 1;
3755 run_hook_with_args (nargs + 1, funcall_args, RUN_HOOKS_TO_COMPLETION);
3760 va_run_hook_with_args_in_buffer (struct buffer *buf, Lisp_Object hook_var,
3763 /* This function can GC */
3764 struct gcpro gcpro1;
3767 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs);
3769 va_start (vargs, nargs);
3770 funcall_args[0] = hook_var;
3771 for (i = 0; i < nargs; i++)
3772 funcall_args[i + 1] = va_arg (vargs, Lisp_Object);
3775 GCPRO1 (*funcall_args);
3776 gcpro1.nvars = nargs + 1;
3777 run_hook_with_args_in_buffer (buf, nargs + 1, funcall_args,
3778 RUN_HOOKS_TO_COMPLETION);
3783 run_hook (Lisp_Object hook)
3785 Frun_hooks (1, &hook);
3790 /************************************************************************/
3791 /* Front-ends to eval, funcall, apply */
3792 /************************************************************************/
3794 /* Apply fn to arg */
3796 apply1 (Lisp_Object fn, Lisp_Object arg)
3798 /* This function can GC */
3799 struct gcpro gcpro1;
3800 Lisp_Object args[2];
3803 return Ffuncall (1, &fn);
3808 RETURN_UNGCPRO (Fapply (2, args));
3811 /* Call function fn on no arguments */
3813 call0 (Lisp_Object fn)
3815 /* This function can GC */
3816 struct gcpro gcpro1;
3819 RETURN_UNGCPRO (Ffuncall (1, &fn));
3822 /* Call function fn with argument arg0 */
3824 call1 (Lisp_Object fn,
3827 /* This function can GC */
3828 struct gcpro gcpro1;
3829 Lisp_Object args[2];
3834 RETURN_UNGCPRO (Ffuncall (2, args));
3837 /* Call function fn with arguments arg0, arg1 */
3839 call2 (Lisp_Object fn,
3840 Lisp_Object arg0, Lisp_Object arg1)
3842 /* This function can GC */
3843 struct gcpro gcpro1;
3844 Lisp_Object args[3];
3850 RETURN_UNGCPRO (Ffuncall (3, args));
3853 /* Call function fn with arguments arg0, arg1, arg2 */
3855 call3 (Lisp_Object fn,
3856 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2)
3858 /* This function can GC */
3859 struct gcpro gcpro1;
3860 Lisp_Object args[4];
3867 RETURN_UNGCPRO (Ffuncall (4, args));
3870 /* Call function fn with arguments arg0, arg1, arg2, arg3 */
3872 call4 (Lisp_Object fn,
3873 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3876 /* This function can GC */
3877 struct gcpro gcpro1;
3878 Lisp_Object args[5];
3886 RETURN_UNGCPRO (Ffuncall (5, args));
3889 /* Call function fn with arguments arg0, arg1, arg2, arg3, arg4 */
3891 call5 (Lisp_Object fn,
3892 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3893 Lisp_Object arg3, Lisp_Object arg4)
3895 /* This function can GC */
3896 struct gcpro gcpro1;
3897 Lisp_Object args[6];
3906 RETURN_UNGCPRO (Ffuncall (6, args));
3910 call6 (Lisp_Object fn,
3911 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3912 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5)
3914 /* This function can GC */
3915 struct gcpro gcpro1;
3916 Lisp_Object args[7];
3926 RETURN_UNGCPRO (Ffuncall (7, args));
3930 call7 (Lisp_Object fn,
3931 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3932 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5,
3935 /* This function can GC */
3936 struct gcpro gcpro1;
3937 Lisp_Object args[8];
3948 RETURN_UNGCPRO (Ffuncall (8, args));
3952 call8 (Lisp_Object fn,
3953 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3954 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5,
3955 Lisp_Object arg6, Lisp_Object arg7)
3957 /* This function can GC */
3958 struct gcpro gcpro1;
3959 Lisp_Object args[9];
3971 RETURN_UNGCPRO (Ffuncall (9, args));
3975 call0_in_buffer (struct buffer *buf, Lisp_Object fn)
3977 if (current_buffer == buf)
3982 int speccount = specpdl_depth();
3983 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
3984 set_buffer_internal (buf);
3986 unbind_to (speccount, Qnil);
3992 call1_in_buffer (struct buffer *buf, Lisp_Object fn,
3995 if (current_buffer == buf)
3996 return call1 (fn, arg0);
4000 int speccount = specpdl_depth();
4001 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4002 set_buffer_internal (buf);
4003 val = call1 (fn, arg0);
4004 unbind_to (speccount, Qnil);
4010 call2_in_buffer (struct buffer *buf, Lisp_Object fn,
4011 Lisp_Object arg0, Lisp_Object arg1)
4013 if (current_buffer == buf)
4014 return call2 (fn, arg0, arg1);
4018 int speccount = specpdl_depth();
4019 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4020 set_buffer_internal (buf);
4021 val = call2 (fn, arg0, arg1);
4022 unbind_to (speccount, Qnil);
4028 call3_in_buffer (struct buffer *buf, Lisp_Object fn,
4029 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2)
4031 if (current_buffer == buf)
4032 return call3 (fn, arg0, arg1, arg2);
4036 int speccount = specpdl_depth();
4037 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4038 set_buffer_internal (buf);
4039 val = call3 (fn, arg0, arg1, arg2);
4040 unbind_to (speccount, Qnil);
4046 call4_in_buffer (struct buffer *buf, Lisp_Object fn,
4047 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4050 if (current_buffer == buf)
4051 return call4 (fn, arg0, arg1, arg2, arg3);
4055 int speccount = specpdl_depth();
4056 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4057 set_buffer_internal (buf);
4058 val = call4 (fn, arg0, arg1, arg2, arg3);
4059 unbind_to (speccount, Qnil);
4065 eval_in_buffer (struct buffer *buf, Lisp_Object form)
4067 if (current_buffer == buf)
4068 return Feval (form);
4072 int speccount = specpdl_depth();
4073 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4074 set_buffer_internal (buf);
4076 unbind_to (speccount, Qnil);
4082 /************************************************************************/
4083 /* Error-catching front-ends to eval, funcall, apply */
4084 /************************************************************************/
4086 /* Call function fn on no arguments, with condition handler */
4088 call0_with_handler (Lisp_Object handler, Lisp_Object fn)
4090 /* This function can GC */
4091 struct gcpro gcpro1;
4092 Lisp_Object args[2];
4097 RETURN_UNGCPRO (Fcall_with_condition_handler (2, args));
4100 /* Call function fn with argument arg0, with condition handler */
4102 call1_with_handler (Lisp_Object handler, Lisp_Object fn,
4105 /* This function can GC */
4106 struct gcpro gcpro1;
4107 Lisp_Object args[3];
4113 RETURN_UNGCPRO (Fcall_with_condition_handler (3, args));
4117 /* The following functions provide you with error-trapping versions
4118 of the various front-ends above. They take an additional
4119 "warning_string" argument; if non-zero, a warning with this
4120 string and the actual error that occurred will be displayed
4121 in the *Warnings* buffer if an error occurs. In all cases,
4122 QUIT is inhibited while these functions are running, and if
4123 an error occurs, Qunbound is returned instead of the normal
4127 /* #### This stuff needs to catch throws as well. We need to
4128 improve internal_catch() so it can take a "catch anything"
4129 argument similar to Qt or Qerror for condition_case_1(). */
4132 caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg)
4134 if (!NILP (errordata))
4136 Lisp_Object args[2];
4140 char *str = (char *) get_opaque_ptr (arg);
4141 args[0] = build_string (str);
4144 args[0] = build_string ("error");
4145 /* #### This should call
4146 (with-output-to-string (display-error errordata))
4147 but that stuff is all in Lisp currently. */
4148 args[1] = errordata;
4149 warn_when_safe_lispobj
4151 emacs_doprnt_string_lisp ((CONST Bufbyte *) "%s: %s",
4152 Qnil, -1, 2, args));
4158 allow_quit_caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg)
4160 if (CONSP (errordata) && EQ (XCAR (errordata), Qquit))
4161 return Fsignal (Qquit, XCDR (errordata));
4162 return caught_a_squirmer (errordata, arg);
4166 safe_run_hook_caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg)
4168 Lisp_Object hook = Fcar (arg);
4170 /* Clear out the hook. */
4172 return caught_a_squirmer (errordata, arg);
4176 allow_quit_safe_run_hook_caught_a_squirmer (Lisp_Object errordata,
4179 Lisp_Object hook = Fcar (arg);
4181 if (!CONSP (errordata) || !EQ (XCAR (errordata), Qquit))
4182 /* Clear out the hook. */
4184 return allow_quit_caught_a_squirmer (errordata, arg);
4188 catch_them_squirmers_eval_in_buffer (Lisp_Object cons)
4190 return eval_in_buffer (XBUFFER (XCAR (cons)), XCDR (cons));
4194 eval_in_buffer_trapping_errors (CONST char *warning_string,
4195 struct buffer *buf, Lisp_Object form)
4197 int speccount = specpdl_depth();
4202 struct gcpro gcpro1, gcpro2;
4204 XSETBUFFER (buffer, buf);
4206 specbind (Qinhibit_quit, Qt);
4207 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4209 cons = noseeum_cons (buffer, form);
4210 opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil);
4211 GCPRO2 (cons, opaque);
4212 /* Qerror not Qt, so you can get a backtrace */
4213 tem = condition_case_1 (Qerror,
4214 catch_them_squirmers_eval_in_buffer, cons,
4215 caught_a_squirmer, opaque);
4216 free_cons (XCONS (cons));
4217 if (OPAQUEP (opaque))
4218 free_opaque_ptr (opaque);
4221 /* gc_currently_forbidden = 0; */
4222 return unbind_to (speccount, tem);
4226 catch_them_squirmers_run_hook (Lisp_Object hook_symbol)
4228 /* This function can GC */
4229 run_hook (hook_symbol);
4234 run_hook_trapping_errors (CONST char *warning_string, Lisp_Object hook_symbol)
4239 struct gcpro gcpro1;
4241 if (!initialized || preparing_for_armageddon)
4243 tem = find_symbol_value (hook_symbol);
4244 if (NILP (tem) || UNBOUNDP (tem))
4247 speccount = specpdl_depth();
4248 specbind (Qinhibit_quit, Qt);
4250 opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil);
4252 /* Qerror not Qt, so you can get a backtrace */
4253 tem = condition_case_1 (Qerror,
4254 catch_them_squirmers_run_hook, hook_symbol,
4255 caught_a_squirmer, opaque);
4256 if (OPAQUEP (opaque))
4257 free_opaque_ptr (opaque);
4260 return unbind_to (speccount, tem);
4263 /* Same as run_hook_trapping_errors() but also set the hook to nil
4264 if an error occurs. */
4267 safe_run_hook_trapping_errors (CONST char *warning_string,
4268 Lisp_Object hook_symbol,
4271 int speccount = specpdl_depth();
4273 Lisp_Object cons = Qnil;
4274 struct gcpro gcpro1;
4276 if (!initialized || preparing_for_armageddon)
4278 tem = find_symbol_value (hook_symbol);
4279 if (NILP (tem) || UNBOUNDP (tem))
4283 specbind (Qinhibit_quit, Qt);
4285 cons = noseeum_cons (hook_symbol,
4286 warning_string ? make_opaque_ptr (warning_string)
4289 /* Qerror not Qt, so you can get a backtrace */
4290 tem = condition_case_1 (Qerror,
4291 catch_them_squirmers_run_hook,
4294 allow_quit_safe_run_hook_caught_a_squirmer :
4295 safe_run_hook_caught_a_squirmer,
4297 if (OPAQUEP (XCDR (cons)))
4298 free_opaque_ptr (XCDR (cons));
4299 free_cons (XCONS (cons));
4302 return unbind_to (speccount, tem);
4306 catch_them_squirmers_call0 (Lisp_Object function)
4308 /* This function can GC */
4309 return call0 (function);
4313 call0_trapping_errors (CONST char *warning_string, Lisp_Object function)
4317 Lisp_Object opaque = Qnil;
4318 struct gcpro gcpro1, gcpro2;
4320 if (SYMBOLP (function))
4322 tem = XSYMBOL (function)->function;
4323 if (NILP (tem) || UNBOUNDP (tem))
4327 GCPRO2 (opaque, function);
4328 speccount = specpdl_depth();
4329 specbind (Qinhibit_quit, Qt);
4330 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4332 opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil);
4333 /* Qerror not Qt, so you can get a backtrace */
4334 tem = condition_case_1 (Qerror,
4335 catch_them_squirmers_call0, function,
4336 caught_a_squirmer, opaque);
4337 if (OPAQUEP (opaque))
4338 free_opaque_ptr (opaque);
4341 /* gc_currently_forbidden = 0; */
4342 return unbind_to (speccount, tem);
4346 catch_them_squirmers_call1 (Lisp_Object cons)
4348 /* This function can GC */
4349 return call1 (XCAR (cons), XCDR (cons));
4353 catch_them_squirmers_call2 (Lisp_Object cons)
4355 /* This function can GC */
4356 return call2 (XCAR (cons), XCAR (XCDR (cons)), XCAR (XCDR (XCDR (cons))));
4360 call1_trapping_errors (CONST char *warning_string, Lisp_Object function,
4363 int speccount = specpdl_depth();
4365 Lisp_Object cons = Qnil;
4366 Lisp_Object opaque = Qnil;
4367 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
4369 if (SYMBOLP (function))
4371 tem = XSYMBOL (function)->function;
4372 if (NILP (tem) || UNBOUNDP (tem))
4376 GCPRO4 (cons, opaque, function, object);
4378 specbind (Qinhibit_quit, Qt);
4379 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4381 cons = noseeum_cons (function, object);
4382 opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil);
4383 /* Qerror not Qt, so you can get a backtrace */
4384 tem = condition_case_1 (Qerror,
4385 catch_them_squirmers_call1, cons,
4386 caught_a_squirmer, opaque);
4387 if (OPAQUEP (opaque))
4388 free_opaque_ptr (opaque);
4389 free_cons (XCONS (cons));
4392 /* gc_currently_forbidden = 0; */
4393 return unbind_to (speccount, tem);
4397 call2_trapping_errors (CONST char *warning_string, Lisp_Object function,
4398 Lisp_Object object1, Lisp_Object object2)
4400 int speccount = specpdl_depth();
4402 Lisp_Object cons = Qnil;
4403 Lisp_Object opaque = Qnil;
4404 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
4406 if (SYMBOLP (function))
4408 tem = XSYMBOL (function)->function;
4409 if (NILP (tem) || UNBOUNDP (tem))
4413 GCPRO5 (cons, opaque, function, object1, object2);
4414 specbind (Qinhibit_quit, Qt);
4415 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4417 cons = list3 (function, object1, object2);
4418 opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil);
4419 /* Qerror not Qt, so you can get a backtrace */
4420 tem = condition_case_1 (Qerror,
4421 catch_them_squirmers_call2, cons,
4422 caught_a_squirmer, opaque);
4423 if (OPAQUEP (opaque))
4424 free_opaque_ptr (opaque);
4428 /* gc_currently_forbidden = 0; */
4429 return unbind_to (speccount, tem);
4433 /************************************************************************/
4434 /* The special binding stack */
4435 /* Most C code should simply use specbind() and unbind_to(). */
4436 /* When performance is critical, use the macros in backtrace.h. */
4437 /************************************************************************/
4439 #define min_max_specpdl_size 400
4442 grow_specpdl (size_t reserved)
4444 size_t size_needed = specpdl_depth() + reserved;
4445 if (size_needed >= max_specpdl_size)
4447 if (max_specpdl_size < min_max_specpdl_size)
4448 max_specpdl_size = min_max_specpdl_size;
4449 if (size_needed >= max_specpdl_size)
4451 if (!NILP (Vdebug_on_error) ||
4452 !NILP (Vdebug_on_signal))
4453 /* Leave room for some specpdl in the debugger. */
4454 max_specpdl_size = size_needed + 100;
4456 ("Variable binding depth exceeds max-specpdl-size");
4459 while (specpdl_size < size_needed)
4462 if (specpdl_size > max_specpdl_size)
4463 specpdl_size = max_specpdl_size;
4465 XREALLOC_ARRAY (specpdl, struct specbinding, specpdl_size);
4466 specpdl_ptr = specpdl + specpdl_depth();
4470 /* Handle unbinding buffer-local variables */
4472 specbind_unwind_local (Lisp_Object ovalue)
4474 Lisp_Object current = Fcurrent_buffer ();
4475 Lisp_Object symbol = specpdl_ptr->symbol;
4476 struct Lisp_Cons *victim = XCONS (ovalue);
4477 Lisp_Object buf = get_buffer (victim->car, 0);
4478 ovalue = victim->cdr;
4484 /* Deleted buffer -- do nothing */
4486 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buf)) == 0)
4488 /* Was buffer-local when binding was made, now no longer is.
4489 * (kill-local-variable can do this.)
4490 * Do nothing in this case.
4493 else if (EQ (buf, current))
4494 Fset (symbol, ovalue);
4497 /* Urk! Somebody switched buffers */
4498 struct gcpro gcpro1;
4501 Fset (symbol, ovalue);
4502 Fset_buffer (current);
4509 specbind_unwind_wasnt_local (Lisp_Object buffer)
4511 Lisp_Object current = Fcurrent_buffer ();
4512 Lisp_Object symbol = specpdl_ptr->symbol;
4514 buffer = get_buffer (buffer, 0);
4517 /* Deleted buffer -- do nothing */
4519 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buffer)) == 0)
4521 /* Was buffer-local when binding was made, now no longer is.
4522 * (kill-local-variable can do this.)
4523 * Do nothing in this case.
4526 else if (EQ (buffer, current))
4527 Fkill_local_variable (symbol);
4530 /* Urk! Somebody switched buffers */
4531 struct gcpro gcpro1;
4533 Fset_buffer (buffer);
4534 Fkill_local_variable (symbol);
4535 Fset_buffer (current);
4543 specbind (Lisp_Object symbol, Lisp_Object value)
4545 SPECBIND (symbol, value);
4549 specbind_magic (Lisp_Object symbol, Lisp_Object value)
4552 symbol_value_buffer_local_info (symbol, current_buffer);
4554 if (buffer_local == 0)
4556 specpdl_ptr->old_value = find_symbol_value (symbol);
4557 specpdl_ptr->func = 0; /* Handled specially by unbind_to */
4559 else if (buffer_local > 0)
4561 /* Already buffer-local */
4562 specpdl_ptr->old_value = noseeum_cons (Fcurrent_buffer (),
4563 find_symbol_value (symbol));
4564 specpdl_ptr->func = specbind_unwind_local;
4568 /* About to become buffer-local */
4569 specpdl_ptr->old_value = Fcurrent_buffer ();
4570 specpdl_ptr->func = specbind_unwind_wasnt_local;
4573 specpdl_ptr->symbol = symbol;
4575 specpdl_depth_counter++;
4577 Fset (symbol, value);
4581 record_unwind_protect (Lisp_Object (*function) (Lisp_Object arg),
4584 SPECPDL_RESERVE (1);
4585 specpdl_ptr->func = function;
4586 specpdl_ptr->symbol = Qnil;
4587 specpdl_ptr->old_value = arg;
4589 specpdl_depth_counter++;
4592 extern int check_sigio (void);
4594 /* Unwind the stack till specpdl_depth() == COUNT.
4595 VALUE is not used, except that, purely as a convenience to the
4596 caller, it is protected from garbage-protection. */
4598 unbind_to (int count, Lisp_Object value)
4600 UNBIND_TO_GCPRO (count, value);
4604 /* Don't call this directly.
4605 Only for use by UNBIND_TO* macros in backtrace.h */
4607 unbind_to_hairy (int count)
4611 check_quit (); /* make Vquit_flag accurate */
4612 quitf = !NILP (Vquit_flag);
4616 ++specpdl_depth_counter;
4618 while (specpdl_depth_counter != count)
4621 --specpdl_depth_counter;
4623 if (specpdl_ptr->func != 0)
4624 /* An unwind-protect */
4625 (*specpdl_ptr->func) (specpdl_ptr->old_value);
4628 /* We checked symbol for validity when we specbound it,
4629 so only need to call Fset if symbol has magic value. */
4630 struct Lisp_Symbol *sym = XSYMBOL (specpdl_ptr->symbol);
4631 if (!SYMBOL_VALUE_MAGIC_P (sym->value))
4632 sym->value = specpdl_ptr->old_value;
4634 Fset (specpdl_ptr->symbol, specpdl_ptr->old_value);
4638 #ifndef EXCEEDINGLY_QUESTIONABLE_CODE
4639 /* There should never be anything here for us to remove.
4640 If so, it indicates a logic error in Emacs. Catches
4641 should get removed when a throw or signal occurs, or
4642 when a catch or condition-case exits normally. But
4643 it's too dangerous to just remove this code. --ben */
4645 /* Furthermore, this code is not in FSFmacs!!!
4646 Braino on mly's part? */
4647 /* If we're unwound past the pdlcount of a catch frame,
4648 that catch can't possibly still be valid. */
4649 while (catchlist && catchlist->pdlcount > specpdl_depth_counter)
4651 catchlist = catchlist->next;
4652 /* Don't mess with gcprolist, backtrace_list here */
4663 /* Get the value of symbol's global binding, even if that binding is
4664 not now dynamically visible. May return Qunbound or magic values. */
4667 top_level_value (Lisp_Object symbol)
4669 REGISTER struct specbinding *ptr = specpdl;
4671 CHECK_SYMBOL (symbol);
4672 for (; ptr != specpdl_ptr; ptr++)
4674 if (EQ (ptr->symbol, symbol))
4675 return ptr->old_value;
4677 return XSYMBOL (symbol)->value;
4683 top_level_set (Lisp_Object symbol, Lisp_Object newval)
4685 REGISTER struct specbinding *ptr = specpdl;
4687 CHECK_SYMBOL (symbol);
4688 for (; ptr != specpdl_ptr; ptr++)
4690 if (EQ (ptr->symbol, symbol))
4692 ptr->old_value = newval;
4696 return Fset (symbol, newval);
4702 /************************************************************************/
4704 /************************************************************************/
4706 DEFUN ("backtrace-debug", Fbacktrace_debug, 2, 2, 0, /*
4707 Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
4708 The debugger is entered when that frame exits, if the flag is non-nil.
4712 REGISTER struct backtrace *backlist = backtrace_list;
4717 for (i = 0; backlist && i < XINT (level); i++)
4719 backlist = backlist->next;
4723 backlist->debug_on_exit = !NILP (flag);
4729 backtrace_specials (int speccount, int speclimit, Lisp_Object stream)
4731 int printing_bindings = 0;
4733 for (; speccount > speclimit; speccount--)
4735 if (specpdl[speccount - 1].func == 0
4736 || specpdl[speccount - 1].func == specbind_unwind_local
4737 || specpdl[speccount - 1].func == specbind_unwind_wasnt_local)
4739 write_c_string (((!printing_bindings) ? " # bind (" : " "),
4741 Fprin1 (specpdl[speccount - 1].symbol, stream);
4742 printing_bindings = 1;
4746 if (printing_bindings) write_c_string (")\n", stream);
4747 write_c_string (" # (unwind-protect ...)\n", stream);
4748 printing_bindings = 0;
4751 if (printing_bindings) write_c_string (")\n", stream);
4754 DEFUN ("backtrace", Fbacktrace, 0, 2, "", /*
4755 Print a trace of Lisp function calls currently active.
4756 Option arg STREAM specifies the output stream to send the backtrace to,
4757 and defaults to the value of `standard-output'. Optional second arg
4758 DETAILED means show places where currently active variable bindings,
4759 catches, condition-cases, and unwind-protects were made as well as
4764 /* This function can GC */
4765 struct backtrace *backlist = backtrace_list;
4766 struct catchtag *catches = catchlist;
4767 int speccount = specpdl_depth();
4769 int old_nl = print_escape_newlines;
4770 int old_pr = print_readably;
4771 Lisp_Object old_level = Vprint_level;
4772 Lisp_Object oiq = Vinhibit_quit;
4773 struct gcpro gcpro1, gcpro2;
4775 /* We can't allow quits in here because that could cause the values
4776 of print_readably and print_escape_newlines to get screwed up.
4777 Normally we would use a record_unwind_protect but that would
4778 screw up the functioning of this function. */
4781 entering_debugger = 0;
4783 Vprint_level = make_int (3);
4785 print_escape_newlines = 1;
4787 GCPRO2 (stream, old_level);
4790 stream = Vstandard_output;
4791 if (!noninteractive && (NILP (stream) || EQ (stream, Qt)))
4792 stream = Fselected_frame (Qnil);
4796 if (!NILP (detailed) && catches && catches->backlist == backlist)
4798 int catchpdl = catches->pdlcount;
4799 if (specpdl[catchpdl].func == condition_case_unwind
4800 && speccount > catchpdl)
4801 /* This is a condition-case catchpoint */
4802 catchpdl = catchpdl + 1;
4804 backtrace_specials (speccount, catchpdl, stream);
4806 speccount = catches->pdlcount;
4807 if (catchpdl == speccount)
4809 write_c_string (" # (catch ", stream);
4810 Fprin1 (catches->tag, stream);
4811 write_c_string (" ...)\n", stream);
4815 write_c_string (" # (condition-case ... . ", stream);
4816 Fprin1 (Fcdr (Fcar (catches->tag)), stream);
4817 write_c_string (")\n", stream);
4819 catches = catches->next;
4825 if (!NILP (detailed) && backlist->pdlcount < speccount)
4827 backtrace_specials (speccount, backlist->pdlcount, stream);
4828 speccount = backlist->pdlcount;
4830 write_c_string (((backlist->debug_on_exit) ? "* " : " "),
4832 if (backlist->nargs == UNEVALLED)
4834 Fprin1 (Fcons (*backlist->function, *backlist->args), stream);
4835 write_c_string ("\n", stream); /* from FSFmacs 19.30 */
4839 Lisp_Object tem = *backlist->function;
4840 Fprin1 (tem, stream); /* This can QUIT */
4841 write_c_string ("(", stream);
4842 if (backlist->nargs == MANY)
4845 Lisp_Object tail = Qnil;
4846 struct gcpro ngcpro1;
4849 for (tail = *backlist->args, i = 0;
4851 tail = Fcdr (tail), i++)
4853 if (i != 0) write_c_string (" ", stream);
4854 Fprin1 (Fcar (tail), stream);
4861 for (i = 0; i < backlist->nargs; i++)
4863 if (!i && EQ(tem, Qbyte_code)) {
4864 write_c_string("\"...\"", stream);
4867 if (i != 0) write_c_string (" ", stream);
4868 Fprin1 (backlist->args[i], stream);
4872 write_c_string (")\n", stream);
4873 backlist = backlist->next;
4876 Vprint_level = old_level;
4877 print_readably = old_pr;
4878 print_escape_newlines = old_nl;
4880 Vinhibit_quit = oiq;
4885 DEFUN ("backtrace-frame", Fbacktrace_frame, 1, 1, "", /*
4886 Return the function and arguments N frames up from current execution point.
4887 If that frame has not evaluated the arguments yet (or is a special form),
4888 the value is (nil FUNCTION ARG-FORMS...).
4889 If that frame has evaluated its arguments and called its function already,
4890 the value is (t FUNCTION ARG-VALUES...).
4891 A &rest arg is represented as the tail of the list ARG-VALUES.
4892 FUNCTION is whatever was supplied as car of evaluated list,
4893 or a lambda expression for macro calls.
4894 If N is more than the number of frames, the value is nil.
4898 REGISTER struct backtrace *backlist = backtrace_list;
4902 CHECK_NATNUM (nframes);
4904 /* Find the frame requested. */
4905 for (i = XINT (nframes); backlist && (i-- > 0);)
4906 backlist = backlist->next;
4910 if (backlist->nargs == UNEVALLED)
4911 return Fcons (Qnil, Fcons (*backlist->function, *backlist->args));
4914 if (backlist->nargs == MANY)
4915 tem = *backlist->args;
4917 tem = Flist (backlist->nargs, backlist->args);
4919 return Fcons (Qt, Fcons (*backlist->function, tem));
4924 /************************************************************************/
4926 /************************************************************************/
4929 warn_when_safe_lispobj (Lisp_Object class, Lisp_Object level,
4932 obj = list1 (list3 (class, level, obj));
4933 if (NILP (Vpending_warnings))
4934 Vpending_warnings = Vpending_warnings_tail = obj;
4937 Fsetcdr (Vpending_warnings_tail, obj);
4938 Vpending_warnings_tail = obj;
4942 /* #### This should probably accept Lisp objects; but then we have
4943 to make sure that Feval() isn't called, since it might not be safe.
4945 An alternative approach is to just pass some non-string type of
4946 Lisp_Object to warn_when_safe_lispobj(); `prin1-to-string' will
4947 automatically be called when it is safe to do so. */
4950 warn_when_safe (Lisp_Object class, Lisp_Object level, CONST char *fmt, ...)
4955 va_start (args, fmt);
4956 obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (fmt),
4960 warn_when_safe_lispobj (class, level, obj);
4966 /************************************************************************/
4967 /* Initialization */
4968 /************************************************************************/
4973 defsymbol (&Qinhibit_quit, "inhibit-quit");
4974 defsymbol (&Qautoload, "autoload");
4975 defsymbol (&Qdebug_on_error, "debug-on-error");
4976 defsymbol (&Qstack_trace_on_error, "stack-trace-on-error");
4977 defsymbol (&Qdebug_on_signal, "debug-on-signal");
4978 defsymbol (&Qstack_trace_on_signal, "stack-trace-on-signal");
4979 defsymbol (&Qdebugger, "debugger");
4980 defsymbol (&Qmacro, "macro");
4981 defsymbol (&Qand_rest, "&rest");
4982 defsymbol (&Qand_optional, "&optional");
4983 /* Note that the process code also uses Qexit */
4984 defsymbol (&Qexit, "exit");
4985 defsymbol (&Qsetq, "setq");
4986 defsymbol (&Qinteractive, "interactive");
4987 defsymbol (&Qcommandp, "commandp");
4988 defsymbol (&Qdefun, "defun");
4989 defsymbol (&Qprogn, "progn");
4990 defsymbol (&Qvalues, "values");
4991 defsymbol (&Qdisplay_warning, "display-warning");
4992 defsymbol (&Qrun_hooks, "run-hooks");
4993 defsymbol (&Qif, "if");
4998 DEFSUBR_MACRO (Fwhen);
4999 DEFSUBR_MACRO (Funless);
5006 DEFSUBR (Ffunction);
5008 DEFSUBR (Fdefmacro);
5010 DEFSUBR (Fdefconst);
5011 DEFSUBR (Fuser_variable_p);
5015 DEFSUBR (Fmacroexpand_internal);
5018 DEFSUBR (Funwind_protect);
5019 DEFSUBR (Fcondition_case);
5020 DEFSUBR (Fcall_with_condition_handler);
5022 DEFSUBR (Finteractive_p);
5023 DEFSUBR (Fcommandp);
5024 DEFSUBR (Fcommand_execute);
5025 DEFSUBR (Fautoload);
5029 DEFSUBR (Ffunctionp);
5030 DEFSUBR (Ffunction_min_args);
5031 DEFSUBR (Ffunction_max_args);
5032 DEFSUBR (Frun_hooks);
5033 DEFSUBR (Frun_hook_with_args);
5034 DEFSUBR (Frun_hook_with_args_until_success);
5035 DEFSUBR (Frun_hook_with_args_until_failure);
5036 DEFSUBR (Fbacktrace_debug);
5037 DEFSUBR (Fbacktrace);
5038 DEFSUBR (Fbacktrace_frame);
5044 specpdl_ptr = specpdl;
5045 specpdl_depth_counter = 0;
5047 Vcondition_handlers = Qnil;
5050 debug_on_next_call = 0;
5051 lisp_eval_depth = 0;
5052 entering_debugger = 0;
5058 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size /*
5059 Limit on number of Lisp variable bindings & unwind-protects before error.
5062 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth /*
5063 Limit on depth in `eval', `apply' and `funcall' before error.
5064 This limit is to catch infinite recursions for you before they cause
5065 actual stack overflow in C, which would be fatal for Emacs.
5066 You can safely make it considerably larger than its default value,
5067 if that proves inconveniently small.
5070 DEFVAR_LISP ("quit-flag", &Vquit_flag /*
5071 Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
5072 Typing C-G sets `quit-flag' non-nil, regardless of `inhibit-quit'.
5076 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit /*
5077 Non-nil inhibits C-g quitting from happening immediately.
5078 Note that `quit-flag' will still be set by typing C-g,
5079 so a quit will be signalled as soon as `inhibit-quit' is nil.
5080 To prevent this happening, set `quit-flag' to nil
5081 before making `inhibit-quit' nil. The value of `inhibit-quit' is
5082 ignored if a critical quit is requested by typing control-shift-G in
5085 Vinhibit_quit = Qnil;
5087 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error /*
5088 *Non-nil means automatically display a backtrace buffer
5089 after any error that is not handled by a `condition-case'.
5090 If the value is a list, an error only means to display a backtrace
5091 if one of its condition symbols appears in the list.
5092 See also variable `stack-trace-on-signal'.
5094 Vstack_trace_on_error = Qnil;
5096 DEFVAR_LISP ("stack-trace-on-signal", &Vstack_trace_on_signal /*
5097 *Non-nil means automatically display a backtrace buffer
5098 after any error that is signalled, whether or not it is handled by
5100 If the value is a list, an error only means to display a backtrace
5101 if one of its condition symbols appears in the list.
5102 See also variable `stack-trace-on-error'.
5104 Vstack_trace_on_signal = Qnil;
5106 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors /*
5107 *List of errors for which the debugger should not be called.
5108 Each element may be a condition-name or a regexp that matches error messages.
5109 If any element applies to a given error, that error skips the debugger
5110 and just returns to top level.
5111 This overrides the variable `debug-on-error'.
5112 It does not apply to errors handled by `condition-case'.
5114 Vdebug_ignored_errors = Qnil;
5116 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error /*
5117 *Non-nil means enter debugger if an unhandled error is signalled.
5118 The debugger will not be entered if the error is handled by
5120 If the value is a list, an error only means to enter the debugger
5121 if one of its condition symbols appears in the list.
5122 This variable is overridden by `debug-ignored-errors'.
5123 See also variables `debug-on-quit' and `debug-on-signal'.
5125 Vdebug_on_error = Qnil;
5127 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal /*
5128 *Non-nil means enter debugger if an error is signalled.
5129 The debugger will be entered whether or not the error is handled by
5131 If the value is a list, an error only means to enter the debugger
5132 if one of its condition symbols appears in the list.
5133 See also variable `debug-on-quit'.
5135 Vdebug_on_signal = Qnil;
5137 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit /*
5138 *Non-nil means enter debugger if quit is signalled (C-G, for example).
5139 Does not apply if quit is handled by a `condition-case'. Entering the
5140 debugger can also be achieved at any time (for X11 console) by typing
5141 control-shift-G to signal a critical quit.
5145 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call /*
5146 Non-nil means enter debugger before next `eval', `apply' or `funcall'.
5149 DEFVAR_LISP ("debugger", &Vdebugger /*
5150 Function to call to invoke debugger.
5151 If due to frame exit, args are `exit' and the value being returned;
5152 this function's value will be returned instead of that.
5153 If due to error, args are `error' and a list of the args to `signal'.
5154 If due to `apply' or `funcall' entry, one arg, `lambda'.
5155 If due to `eval' entry, one arg, t.
5159 preparing_for_armageddon = 0;
5161 staticpro (&Vpending_warnings);
5162 Vpending_warnings = Qnil;
5163 Vpending_warnings_tail = Qnil; /* no need to protect this */
5167 staticpro (&Vautoload_queue);
5168 Vautoload_queue = Qnil;
5170 staticpro (&Vcondition_handlers);
5172 staticpro (&Vcurrent_warning_class);
5173 Vcurrent_warning_class = Qnil;
5175 staticpro (&Vcurrent_error_state);
5176 Vcurrent_error_state = Qnil; /* errors as normal */
5178 Qunbound_suspended_errors_tag = make_opaque_long (0);
5179 staticpro (&Qunbound_suspended_errors_tag);
5182 specpdl_depth_counter = 0;
5183 specpdl = xnew_array (struct specbinding, specpdl_size);
5184 /* XEmacs change: increase these values. */
5185 max_specpdl_size = 3000;
5186 max_lisp_eval_depth = 500;
5187 #if 0 /* no longer used */