1 /* Evaluator for XEmacs Lisp interpreter.
2 Copyright (C) 1985-1987, 1992-1994 Free Software Foundation, Inc.
3 Copyright (C) 1995 Sun Microsystems, Inc.
5 This file is part of XEmacs.
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 /* Synched up with: FSF 19.30 (except for Fsignal), Mule 2.0. */
28 #include "backtrace.h"
35 int always_gc; /* Debugging hack */
40 struct backtrace *backtrace_list;
42 /* Note: you must always fill in all of the fields in a backtrace structure
43 before pushing them on the backtrace_list. The profiling code depends
46 #define PUSH_BACKTRACE(bt) do { \
47 (bt).next = backtrace_list; \
48 backtrace_list = &(bt); \
51 #define POP_BACKTRACE(bt) do { \
52 backtrace_list = (bt).next; \
55 /* Macros for calling subrs with an argument list whose length is only
56 known at runtime. See EXFUN and DEFUN for similar hackery. */
59 #define AV_1(av) av[0]
60 #define AV_2(av) AV_1(av), av[1]
61 #define AV_3(av) AV_2(av), av[2]
62 #define AV_4(av) AV_3(av), av[3]
63 #define AV_5(av) AV_4(av), av[4]
64 #define AV_6(av) AV_5(av), av[5]
65 #define AV_7(av) AV_6(av), av[6]
66 #define AV_8(av) AV_7(av), av[7]
68 #define PRIMITIVE_FUNCALL_1(fn, av, ac) \
69 (((Lisp_Object (*)(EXFUN_##ac)) (fn)) (AV_##ac (av)))
71 /* If subrs take more than 8 arguments, more cases need to be added
72 to this switch. (But wait - don't do it - if you really need
73 a SUBR with more than 8 arguments, use max_args == MANY.
74 See the DEFUN macro in lisp.h) */
75 #define PRIMITIVE_FUNCALL(rv, fn, av, ac) do { \
76 void (*PF_fn)(void) = (void (*)(void)) fn; \
77 Lisp_Object *PF_av = (av); \
80 default:rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 0); break; \
81 case 1: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 1); break; \
82 case 2: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 2); break; \
83 case 3: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 3); break; \
84 case 4: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 4); break; \
85 case 5: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 5); break; \
86 case 6: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 6); break; \
87 case 7: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 7); break; \
88 case 8: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 8); break; \
92 #define FUNCALL_SUBR(rv, subr, av, ac) \
93 PRIMITIVE_FUNCALL (rv, subr_function (subr), av, ac);
96 /* This is the list of current catches (and also condition-cases).
97 This is a stack: the most recent catch is at the head of the
98 list. Catches are created by declaring a 'struct catchtag'
99 locally, filling the .TAG field in with the tag, and doing
100 a setjmp() on .JMP. Fthrow() will store the value passed
101 to it in .VAL and longjmp() back to .JMP, back to the function
102 that established the catch. This will always be either
103 internal_catch() (catches established internally or through
104 `catch') or condition_case_1 (condition-cases established
105 internally or through `condition-case').
107 The catchtag also records the current position in the
108 call stack (stored in BACKTRACE_LIST), the current position
109 in the specpdl stack (used for variable bindings and
110 unwind-protects), the value of LISP_EVAL_DEPTH, and the
111 current position in the GCPRO stack. All of these are
112 restored by Fthrow().
115 struct catchtag *catchlist;
117 Lisp_Object Qautoload, Qmacro, Qexit;
118 Lisp_Object Qinteractive, Qcommandp, Qdefun, Qprogn, Qvalues;
119 Lisp_Object Vquit_flag, Vinhibit_quit;
120 Lisp_Object Qand_rest, Qand_optional;
121 Lisp_Object Qdebug_on_error, Qstack_trace_on_error;
122 Lisp_Object Qdebug_on_signal, Qstack_trace_on_signal;
123 Lisp_Object Qdebugger;
124 Lisp_Object Qinhibit_quit;
125 Lisp_Object Qrun_hooks;
127 Lisp_Object Qdisplay_warning;
128 Lisp_Object Vpending_warnings, Vpending_warnings_tail;
131 /* Records whether we want errors to occur. This will be a boolean,
132 nil (errors OK) or t (no errors). If t, an error will cause a
133 throw to Qunbound_suspended_errors_tag.
135 See call_with_suspended_errors(). */
136 Lisp_Object Vcurrent_error_state;
138 /* Current warning class when warnings occur, or nil for no warnings.
139 Only meaningful when Vcurrent_error_state is non-nil.
140 See call_with_suspended_errors(). */
141 Lisp_Object Vcurrent_warning_class;
143 /* Special catch tag used in call_with_suspended_errors(). */
144 Lisp_Object Qunbound_suspended_errors_tag;
146 /* Non-nil means we're going down, so we better not run any hooks
147 or do other non-essential stuff. */
148 int preparing_for_armageddon;
150 /* Non-nil means record all fset's and provide's, to be undone
151 if the file being autoloaded is not fully loaded.
152 They are recorded by being consed onto the front of Vautoload_queue:
153 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */
154 Lisp_Object Vautoload_queue;
156 /* Current number of specbindings allocated in specpdl. */
159 /* Pointer to beginning of specpdl. */
160 struct specbinding *specpdl;
162 /* Pointer to first unused element in specpdl. */
163 struct specbinding *specpdl_ptr;
165 /* specpdl_ptr - specpdl */
166 int specpdl_depth_counter;
168 /* Maximum size allowed for specpdl allocation */
169 int max_specpdl_size;
171 /* Depth in Lisp evaluations and function calls. */
172 static int lisp_eval_depth;
174 /* Maximum allowed depth in Lisp evaluations and function calls. */
175 int max_lisp_eval_depth;
177 /* Nonzero means enter debugger before next function call */
178 static int debug_on_next_call;
180 /* List of conditions (non-nil atom means all) which cause a backtrace
181 if an error is handled by the command loop's error handler. */
182 Lisp_Object Vstack_trace_on_error;
184 /* List of conditions (non-nil atom means all) which enter the debugger
185 if an error is handled by the command loop's error handler. */
186 Lisp_Object Vdebug_on_error;
188 /* List of conditions and regexps specifying error messages which
189 do not enter the debugger even if Vdebug_on_error says they should. */
190 Lisp_Object Vdebug_ignored_errors;
192 /* List of conditions (non-nil atom means all) which cause a backtrace
193 if any error is signalled. */
194 Lisp_Object Vstack_trace_on_signal;
196 /* List of conditions (non-nil atom means all) which enter the debugger
197 if any error is signalled. */
198 Lisp_Object Vdebug_on_signal;
200 /* Nonzero means enter debugger if a quit signal
201 is handled by the command loop's error handler.
203 From lisp, this is a boolean variable and may have the values 0 and 1.
204 But, eval.c temporarily uses the second bit of this variable to indicate
205 that a critical_quit is in progress. The second bit is reset immediately
206 after it is processed in signal_call_debugger(). */
210 /* entering_debugger is basically equivalent */
211 /* The value of num_nonmacro_input_chars as of the last time we
212 started to enter the debugger. If we decide to enter the debugger
213 again when this is still equal to num_nonmacro_input_chars, then we
214 know that the debugger itself has an error, and we should just
215 signal the error instead of entering an infinite loop of debugger
217 int when_entered_debugger;
220 /* Nonzero means we are trying to enter the debugger.
221 This is to prevent recursive attempts.
222 Cleared by the debugger calling Fbacktrace */
223 static int entering_debugger;
225 /* Function to call to invoke the debugger */
226 Lisp_Object Vdebugger;
228 /* Chain of condition handlers currently in effect.
229 The elements of this chain are contained in the stack frames
230 of Fcondition_case and internal_condition_case.
231 When an error is signaled (by calling Fsignal, below),
232 this chain is searched for an element that applies.
234 Each element of this list is one of the following:
236 A list of a handler function and possibly args to pass to
237 the function. This is a handler established with
238 `call-with-condition-handler' (q.v.).
240 A list whose car is Qunbound and whose cdr is Qt.
241 This is a special condition-case handler established
242 by C code with condition_case_1(). All errors are
243 trapped; the debugger is not invoked even if
244 `debug-on-error' was set.
246 A list whose car is Qunbound and whose cdr is Qerror.
247 This is a special condition-case handler established
248 by C code with condition_case_1(). It is like Qt
249 except that the debugger is invoked normally if it is
252 A list whose car is Qunbound and whose cdr is a list
253 of lists (CONDITION-NAME BODY ...) exactly as in
254 `condition-case'. This is a normal `condition-case'
257 Note that in all cases *except* the first, there is a
258 corresponding catch, whose TAG is the value of
259 Vcondition_handlers just after the handler data just
260 described is pushed onto it. The reason is that
261 `condition-case' handlers need to throw back to the
262 place where the handler was installed before invoking
263 it, while `call-with-condition-handler' handlers are
264 invoked in the environment that `signal' was invoked
267 static Lisp_Object Vcondition_handlers;
270 #define DEFEND_AGAINST_THROW_RECURSION
272 #ifdef DEFEND_AGAINST_THROW_RECURSION
273 /* Used for error catching purposes by throw_or_bomb_out */
274 static int throw_level;
277 #ifdef ERROR_CHECK_TYPECHECK
278 void check_error_state_sanity (void);
282 /************************************************************************/
283 /* The subr object type */
284 /************************************************************************/
287 print_subr (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
289 Lisp_Subr *subr = XSUBR (obj);
291 (subr->max_args == UNEVALLED) ? "#<special-form " : "#<subr ";
292 const char *name = subr_name (subr);
293 const char *trailer = subr->prompt ? " (interactive)>" : ">";
296 error ("printing unreadable object %s%s%s", header, name, trailer);
298 write_c_string (header, printcharfun);
299 write_c_string (name, printcharfun);
300 write_c_string (trailer, printcharfun);
303 static const struct lrecord_description subr_description[] = {
304 { XD_DOC_STRING, offsetof (Lisp_Subr, doc) },
308 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("subr", subr,
309 0, print_subr, 0, 0, 0,
313 /************************************************************************/
314 /* Entering the debugger */
315 /************************************************************************/
317 /* unwind-protect used by call_debugger() to restore the value of
318 entering_debugger. (We cannot use specbind() because the
319 variable is not Lisp-accessible.) */
322 restore_entering_debugger (Lisp_Object arg)
324 entering_debugger = ! NILP (arg);
328 /* Actually call the debugger. ARG is a list of args that will be
329 passed to the debugger function, as follows;
331 If due to frame exit, args are `exit' and the value being returned;
332 this function's value will be returned instead of that.
333 If due to error, args are `error' and a list of the args to `signal'.
334 If due to `apply' or `funcall' entry, one arg, `lambda'.
335 If due to `eval' entry, one arg, t.
340 call_debugger_259 (Lisp_Object arg)
342 return apply1 (Vdebugger, arg);
345 /* Call the debugger, doing some encapsulation. We make sure we have
346 some room on the eval and specpdl stacks, and bind entering_debugger
347 to 1 during this call. This is used to trap errors that may occur
348 when entering the debugger (e.g. the value of `debugger' is invalid),
349 so that the debugger will not be recursively entered if debug-on-error
350 is set. (Otherwise, XEmacs would infinitely recurse, attempting to
351 enter the debugger.) entering_debugger gets reset to 0 as soon
352 as a backtrace is displayed, so that further errors can indeed be
355 We also establish a catch for 'debugger. If the debugger function
356 throws to this instead of returning a value, it means that the user
357 pressed 'c' (pretend like the debugger was never entered). The
358 function then returns Qunbound. (If the user pressed 'r', for
359 return a value, then the debugger function returns normally with
362 The difference between 'c' and 'r' is as follows:
365 No difference. The call proceeds as normal.
367 With 'r', the specified value is returned as the function's
368 return value. With 'c', the value that would normally be
369 returned is returned.
371 With 'r', the specified value is returned as the return
372 value of `signal'. (This is the only time that `signal'
373 can return, instead of making a non-local exit.) With `c',
374 `signal' will continue looking for handlers as if the
375 debugger was never entered, and will probably end up
376 throwing to a handler or to top-level.
380 call_debugger (Lisp_Object arg)
386 if (lisp_eval_depth + 20 > max_lisp_eval_depth)
387 max_lisp_eval_depth = lisp_eval_depth + 20;
388 if (specpdl_size + 40 > max_specpdl_size)
389 max_specpdl_size = specpdl_size + 40;
390 debug_on_next_call = 0;
392 speccount = specpdl_depth();
393 record_unwind_protect (restore_entering_debugger,
394 (entering_debugger ? Qt : Qnil));
395 entering_debugger = 1;
396 val = internal_catch (Qdebugger, call_debugger_259, arg, &threw);
398 return unbind_to (speccount, ((threw)
399 ? Qunbound /* Not returning a value */
403 /* Called when debug-on-exit behavior is called for. Enter the debugger
404 with the appropriate args for this. VAL is the exit value that is
405 about to be returned. */
408 do_debug_on_exit (Lisp_Object val)
410 /* This is falsified by call_debugger */
411 Lisp_Object v = call_debugger (list2 (Qexit, val));
413 return !UNBOUNDP (v) ? v : val;
416 /* Called when debug-on-call behavior is called for. Enter the debugger
417 with the appropriate args for this. VAL is either t for a call
418 through `eval' or 'lambda for a call through `funcall'.
420 #### The differentiation here between EVAL and FUNCALL is bogus.
421 FUNCALL can be defined as
423 (defmacro func (fun &rest args)
424 (cons (eval fun) args))
426 and should be treated as such.
430 do_debug_on_call (Lisp_Object code)
432 debug_on_next_call = 0;
433 backtrace_list->debug_on_exit = 1;
434 call_debugger (list1 (code));
437 /* LIST is the value of one of the variables `debug-on-error',
438 `debug-on-signal', `stack-trace-on-error', or `stack-trace-on-signal',
439 and CONDITIONS is the list of error conditions associated with
440 the error being signalled. This returns non-nil if LIST
441 matches CONDITIONS. (A nil value for LIST does not match
442 CONDITIONS. A non-list value for LIST does match CONDITIONS.
443 A list matches CONDITIONS when one of the symbols in LIST is the
444 same as one of the symbols in CONDITIONS.) */
447 wants_debugger (Lisp_Object list, Lisp_Object conditions)
454 while (CONSP (conditions))
456 Lisp_Object this, tail;
457 this = XCAR (conditions);
458 for (tail = list; CONSP (tail); tail = XCDR (tail))
459 if (EQ (XCAR (tail), this))
461 conditions = XCDR (conditions);
467 /* Return 1 if an error with condition-symbols CONDITIONS,
468 and described by SIGNAL-DATA, should skip the debugger
469 according to debugger-ignore-errors. */
472 skip_debugger (Lisp_Object conditions, Lisp_Object data)
474 /* This function can GC */
476 int first_string = 1;
477 Lisp_Object error_message = Qnil;
479 for (tail = Vdebug_ignored_errors; CONSP (tail); tail = XCDR (tail))
481 if (STRINGP (XCAR (tail)))
485 error_message = Ferror_message_string (data);
488 if (fast_lisp_string_match (XCAR (tail), error_message) >= 0)
495 for (contail = conditions; CONSP (contail); contail = XCDR (contail))
496 if (EQ (XCAR (tail), XCAR (contail)))
504 /* Actually generate a backtrace on STREAM. */
507 backtrace_259 (Lisp_Object stream)
509 return Fbacktrace (stream, Qt);
512 /* An error was signaled. Maybe call the debugger, if the `debug-on-error'
513 etc. variables call for this. CONDITIONS is the list of conditions
514 associated with the error being signalled. SIG is the actual error
515 being signalled, and DATA is the associated data (these are exactly
516 the same as the arguments to `signal'). ACTIVE_HANDLERS is the
517 list of error handlers that are to be put in place while the debugger
518 is called. This is generally the remaining handlers that are
519 outside of the innermost handler trapping this error. This way,
520 if the same error occurs inside of the debugger, you usually don't get
521 the debugger entered recursively.
523 This function returns Qunbound if it didn't call the debugger or if
524 the user asked (through 'c') that XEmacs should pretend like the
525 debugger was never entered. Otherwise, it returns the value
526 that the user specified with `r'. (Note that much of the time,
527 the user will abort with C-], and we will never have a chance to
528 return anything at all.)
530 SIGNAL_VARS_ONLY means we should only look at debug-on-signal
531 and stack-trace-on-signal to control whether we do anything.
532 This is so that debug-on-error doesn't make handled errors
533 cause the debugger to get invoked.
535 STACK_TRACE_DISPLAYED and DEBUGGER_ENTERED are used so that
536 those functions aren't done more than once in a single `signal'
540 signal_call_debugger (Lisp_Object conditions,
541 Lisp_Object sig, Lisp_Object data,
542 Lisp_Object active_handlers,
543 int signal_vars_only,
544 int *stack_trace_displayed,
545 int *debugger_entered)
547 /* This function can GC */
548 Lisp_Object val = Qunbound;
549 Lisp_Object all_handlers = Vcondition_handlers;
550 Lisp_Object temp_data = Qnil;
551 int speccount = specpdl_depth();
552 struct gcpro gcpro1, gcpro2;
553 GCPRO2 (all_handlers, temp_data);
555 Vcondition_handlers = active_handlers;
557 temp_data = Fcons (sig, data); /* needed for skip_debugger */
559 if (!entering_debugger && !*stack_trace_displayed && !signal_vars_only
560 && wants_debugger (Vstack_trace_on_error, conditions)
561 && !skip_debugger (conditions, temp_data))
563 specbind (Qdebug_on_error, Qnil);
564 specbind (Qstack_trace_on_error, Qnil);
565 specbind (Qdebug_on_signal, Qnil);
566 specbind (Qstack_trace_on_signal, Qnil);
568 internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
572 unbind_to (speccount, Qnil);
573 *stack_trace_displayed = 1;
576 if (!entering_debugger && !*debugger_entered && !signal_vars_only
579 : wants_debugger (Vdebug_on_error, conditions))
580 && !skip_debugger (conditions, temp_data))
582 debug_on_quit &= ~2; /* reset critical bit */
583 specbind (Qdebug_on_error, Qnil);
584 specbind (Qstack_trace_on_error, Qnil);
585 specbind (Qdebug_on_signal, Qnil);
586 specbind (Qstack_trace_on_signal, Qnil);
588 val = call_debugger (list2 (Qerror, (Fcons (sig, data))));
589 *debugger_entered = 1;
592 if (!entering_debugger && !*stack_trace_displayed
593 && wants_debugger (Vstack_trace_on_signal, conditions))
595 specbind (Qdebug_on_error, Qnil);
596 specbind (Qstack_trace_on_error, Qnil);
597 specbind (Qdebug_on_signal, Qnil);
598 specbind (Qstack_trace_on_signal, Qnil);
600 internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
604 unbind_to (speccount, Qnil);
605 *stack_trace_displayed = 1;
608 if (!entering_debugger && !*debugger_entered
611 : wants_debugger (Vdebug_on_signal, conditions)))
613 debug_on_quit &= ~2; /* reset critical bit */
614 specbind (Qdebug_on_error, Qnil);
615 specbind (Qstack_trace_on_error, Qnil);
616 specbind (Qdebug_on_signal, Qnil);
617 specbind (Qstack_trace_on_signal, Qnil);
619 val = call_debugger (list2 (Qerror, (Fcons (sig, data))));
620 *debugger_entered = 1;
624 Vcondition_handlers = all_handlers;
625 return unbind_to (speccount, val);
629 /************************************************************************/
630 /* The basic special forms */
631 /************************************************************************/
633 /* Except for Fprogn(), the basic special forms below are only called
634 from interpreted code. The byte compiler turns them into bytecodes. */
636 DEFUN ("or", For, 0, UNEVALLED, 0, /*
637 Eval args until one of them yields non-nil, then return that value.
638 The remaining args are not evalled at all.
639 If all args return nil, return nil.
643 /* This function can GC */
644 REGISTER Lisp_Object arg, val;
646 LIST_LOOP_2 (arg, args)
648 if (!NILP (val = Feval (arg)))
655 DEFUN ("and", Fand, 0, UNEVALLED, 0, /*
656 Eval args until one of them yields nil, then return nil.
657 The remaining args are not evalled at all.
658 If no arg yields nil, return the last arg's value.
662 /* This function can GC */
663 REGISTER Lisp_Object arg, val = Qt;
665 LIST_LOOP_2 (arg, args)
667 if (NILP (val = Feval (arg)))
674 DEFUN ("if", Fif, 2, UNEVALLED, 0, /*
675 \(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...
676 Returns the value of THEN or the value of the last of the ELSE's.
677 THEN must be one expression, but ELSE... can be zero or more expressions.
678 If COND yields nil, and there are no ELSE's, the value is nil.
682 /* This function can GC */
683 Lisp_Object condition = XCAR (args);
684 Lisp_Object then_form = XCAR (XCDR (args));
685 Lisp_Object else_forms = XCDR (XCDR (args));
687 if (!NILP (Feval (condition)))
688 return Feval (then_form);
690 return Fprogn (else_forms);
693 /* Macros `when' and `unless' are trivially defined in Lisp,
694 but it helps for bootstrapping to have them ALWAYS defined. */
696 DEFUN ("when", Fwhen, 1, MANY, 0, /*
697 \(when COND BODY...): if COND yields non-nil, do BODY, else return nil.
698 BODY can be zero or more expressions. If BODY is nil, return nil.
700 (int nargs, Lisp_Object *args))
702 Lisp_Object cond = args[0];
707 case 1: body = Qnil; break;
708 case 2: body = args[1]; break;
709 default: body = Fcons (Qprogn, Flist (nargs-1, args+1)); break;
712 return list3 (Qif, cond, body);
715 DEFUN ("unless", Funless, 1, MANY, 0, /*
716 \(unless COND BODY...): if COND yields nil, do BODY, else return nil.
717 BODY can be zero or more expressions. If BODY is nil, return nil.
719 (int nargs, Lisp_Object *args))
721 Lisp_Object cond = args[0];
722 Lisp_Object body = Flist (nargs-1, args+1);
723 return Fcons (Qif, Fcons (cond, Fcons (Qnil, body)));
726 DEFUN ("cond", Fcond, 0, UNEVALLED, 0, /*
727 (cond CLAUSES...): try each clause until one succeeds.
728 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
729 and, if the value is non-nil, this clause succeeds:
730 then the expressions in BODY are evaluated and the last one's
731 value is the value of the cond-form.
732 If no clause succeeds, cond returns nil.
733 If a clause has one element, as in (CONDITION),
734 CONDITION's value if non-nil is returned from the cond-form.
738 /* This function can GC */
739 REGISTER Lisp_Object val, clause;
741 LIST_LOOP_2 (clause, args)
744 if (!NILP (val = Feval (XCAR (clause))))
746 if (!NILP (clause = XCDR (clause)))
748 CHECK_TRUE_LIST (clause);
749 val = Fprogn (clause);
758 DEFUN ("progn", Fprogn, 0, UNEVALLED, 0, /*
759 \(progn BODY...): eval BODY forms sequentially and return value of last one.
763 /* This function can GC */
764 /* Caller must provide a true list in ARGS */
765 REGISTER Lisp_Object form, val = Qnil;
771 LIST_LOOP_2 (form, args)
779 /* Fprog1() is the canonical example of a function that must GCPRO a
780 Lisp_Object across calls to Feval(). */
782 DEFUN ("prog1", Fprog1, 1, UNEVALLED, 0, /*
783 Similar to `progn', but the value of the first form is returned.
784 \(prog1 FIRST BODY...): All the arguments are evaluated sequentially.
785 The value of FIRST is saved during evaluation of the remaining args,
786 whose values are discarded.
790 /* This function can GC */
791 REGISTER Lisp_Object val, form;
794 val = Feval (XCAR (args));
799 LIST_LOOP_2 (form, XCDR (args))
807 DEFUN ("prog2", Fprog2, 2, UNEVALLED, 0, /*
808 Similar to `progn', but the value of the second form is returned.
809 \(prog2 FIRST SECOND BODY...): All the arguments are evaluated sequentially.
810 The value of SECOND is saved during evaluation of the remaining args,
811 whose values are discarded.
815 /* This function can GC */
816 REGISTER Lisp_Object val, form, tail;
821 val = Feval (XCAR (args));
826 LIST_LOOP_3 (form, args, tail)
833 DEFUN ("let*", FletX, 1, UNEVALLED, 0, /*
834 \(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.
835 The value of the last form in BODY is returned.
836 Each element of VARLIST is a symbol (which is bound to nil)
837 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
838 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
842 /* This function can GC */
843 Lisp_Object var, tail;
844 Lisp_Object varlist = XCAR (args);
845 Lisp_Object body = XCDR (args);
846 int speccount = specpdl_depth();
848 EXTERNAL_LIST_LOOP_3 (var, varlist, tail)
850 Lisp_Object symbol, value, tem;
852 symbol = var, value = Qnil;
863 value = Feval (XCAR (tem));
864 if (!NILP (XCDR (tem)))
866 ("`let' bindings can have only one value-form", var);
869 specbind (symbol, value);
871 return unbind_to (speccount, Fprogn (body));
874 DEFUN ("let", Flet, 1, UNEVALLED, 0, /*
875 \(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.
876 The value of the last form in BODY is returned.
877 Each element of VARLIST is a symbol (which is bound to nil)
878 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
879 All the VALUEFORMs are evalled before any symbols are bound.
883 /* This function can GC */
884 Lisp_Object var, tail;
885 Lisp_Object varlist = XCAR (args);
886 Lisp_Object body = XCDR (args);
887 int speccount = specpdl_depth();
892 /* Make space to hold the values to give the bound variables. */
895 GET_EXTERNAL_LIST_LENGTH (varlist, varcount);
896 temps = alloca_array (Lisp_Object, varcount);
899 /* Compute the values and store them in `temps' */
904 LIST_LOOP_3 (var, varlist, tail)
906 Lisp_Object *value = &temps[idx++];
919 *value = Feval (XCAR (tem));
922 if (!NILP (XCDR (tem)))
924 ("`let' bindings can have only one value-form", var);
930 LIST_LOOP_3 (var, varlist, tail)
932 specbind (SYMBOLP (var) ? var : XCAR (var), temps[idx++]);
937 return unbind_to (speccount, Fprogn (body));
940 DEFUN ("while", Fwhile, 1, UNEVALLED, 0, /*
941 \(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.
942 The order of execution is thus TEST, BODY, TEST, BODY and so on
943 until TEST returns nil.
947 /* This function can GC */
948 Lisp_Object test = XCAR (args);
949 Lisp_Object body = XCDR (args);
951 while (!NILP (Feval (test)))
960 DEFUN ("setq", Fsetq, 0, UNEVALLED, 0, /*
961 \(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.
962 The symbols SYM are variables; they are literal (not evaluated).
963 The values VAL are expressions; they are evaluated.
964 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
965 The second VAL is not computed until after the first SYM is set, and so on;
966 each VAL can use the new value of variables set earlier in the `setq'.
967 The return value of the `setq' form is the value of the last VAL.
971 /* This function can GC */
972 Lisp_Object symbol, tail, val = Qnil;
976 GET_LIST_LENGTH (args, nargs);
978 if (nargs & 1) /* Odd number of arguments? */
979 Fsignal (Qwrong_number_of_arguments, list2 (Qsetq, make_int (nargs)));
983 PROPERTY_LIST_LOOP (tail, symbol, val, args)
993 DEFUN ("quote", Fquote, 1, UNEVALLED, 0, /*
994 Return the argument, without evaluating it. `(quote x)' yields `x'.
1001 DEFUN ("function", Ffunction, 1, UNEVALLED, 0, /*
1002 Like `quote', but preferred for objects which are functions.
1003 In byte compilation, `function' causes its argument to be compiled.
1004 `quote' cannot do that.
1012 /************************************************************************/
1013 /* Defining functions/variables */
1014 /************************************************************************/
1016 define_function (Lisp_Object name, Lisp_Object defn)
1019 LOADHIST_ATTACH (name);
1023 DEFUN ("defun", Fdefun, 2, UNEVALLED, 0, /*
1024 \(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.
1025 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
1026 See also the function `interactive'.
1030 /* This function can GC */
1031 return define_function (XCAR (args),
1032 Fcons (Qlambda, XCDR (args)));
1035 DEFUN ("defmacro", Fdefmacro, 2, UNEVALLED, 0, /*
1036 \(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.
1037 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).
1038 When the macro is called, as in (NAME ARGS...),
1039 the function (lambda ARGLIST BODY...) is applied to
1040 the list ARGS... as it appears in the expression,
1041 and the result should be a form to be evaluated instead of the original.
1045 /* This function can GC */
1046 return define_function (XCAR (args),
1047 Fcons (Qmacro, Fcons (Qlambda, XCDR (args))));
1050 DEFUN ("defvar", Fdefvar, 1, UNEVALLED, 0, /*
1051 \(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.
1052 You are not required to define a variable in order to use it,
1053 but the definition can supply documentation and an initial value
1054 in a way that tags can recognize.
1056 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is
1057 void. (However, when you evaluate a defvar interactively, it acts like a
1058 defconst: SYMBOL's value is always set regardless of whether it's currently
1060 If SYMBOL is buffer-local, its default value is what is set;
1061 buffer-local values are not affected.
1062 INITVALUE and DOCSTRING are optional.
1063 If DOCSTRING starts with *, this variable is identified as a user option.
1064 This means that M-x set-variable and M-x edit-options recognize it.
1065 If INITVALUE is missing, SYMBOL's value is not set.
1067 In lisp-interaction-mode defvar is treated as defconst.
1071 /* This function can GC */
1072 Lisp_Object sym = XCAR (args);
1074 if (!NILP (args = XCDR (args)))
1076 Lisp_Object val = XCAR (args);
1078 if (NILP (Fdefault_boundp (sym)))
1080 struct gcpro gcpro1;
1083 Fset_default (sym, val);
1087 if (!NILP (args = XCDR (args)))
1089 Lisp_Object doc = XCAR (args);
1090 Fput (sym, Qvariable_documentation, doc);
1091 if (!NILP (args = XCDR (args)))
1092 error ("too many arguments");
1097 if (!NILP (Vfile_domain))
1098 Fput (sym, Qvariable_domain, Vfile_domain);
1101 LOADHIST_ATTACH (sym);
1105 DEFUN ("defconst", Fdefconst, 2, UNEVALLED, 0, /*
1106 \(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant
1108 The intent is that programs do not change this value, but users may.
1109 Always sets the value of SYMBOL to the result of evalling INITVALUE.
1110 If SYMBOL is buffer-local, its default value is what is set;
1111 buffer-local values are not affected.
1112 DOCSTRING is optional.
1113 If DOCSTRING starts with *, this variable is identified as a user option.
1114 This means that M-x set-variable and M-x edit-options recognize it.
1116 Note: do not use `defconst' for user options in libraries that are not
1117 normally loaded, since it is useful for users to be able to specify
1118 their own values for such variables before loading the library.
1119 Since `defconst' unconditionally assigns the variable,
1120 it would override the user's choice.
1124 /* This function can GC */
1125 Lisp_Object sym = XCAR (args);
1126 Lisp_Object val = Feval (XCAR (args = XCDR (args)));
1127 struct gcpro gcpro1;
1131 Fset_default (sym, val);
1135 if (!NILP (args = XCDR (args)))
1137 Lisp_Object doc = XCAR (args);
1138 Fput (sym, Qvariable_documentation, doc);
1139 if (!NILP (args = XCDR (args)))
1140 error ("too many arguments");
1144 if (!NILP (Vfile_domain))
1145 Fput (sym, Qvariable_domain, Vfile_domain);
1148 LOADHIST_ATTACH (sym);
1152 DEFUN ("user-variable-p", Fuser_variable_p, 1, 1, 0, /*
1153 Return t if VARIABLE is intended to be set and modified by users.
1154 \(The alternative is a variable used internally in a Lisp program.)
1155 Determined by whether the first character of the documentation
1156 for the variable is `*'.
1160 Lisp_Object documentation = Fget (variable, Qvariable_documentation, Qnil);
1163 ((INTP (documentation) && XINT (documentation) < 0) ||
1165 (STRINGP (documentation) &&
1166 (string_byte (XSTRING (documentation), 0) == '*')) ||
1168 /* If (STRING . INTEGER), a negative integer means a user variable. */
1169 (CONSP (documentation)
1170 && STRINGP (XCAR (documentation))
1171 && INTP (XCDR (documentation))
1172 && XINT (XCDR (documentation)) < 0)) ?
1176 DEFUN ("macroexpand-internal", Fmacroexpand_internal, 1, 2, 0, /*
1177 Return result of expanding macros at top level of FORM.
1178 If FORM is not a macro call, it is returned unchanged.
1179 Otherwise, the macro is expanded and the expansion is considered
1180 in place of FORM. When a non-macro-call results, it is returned.
1182 The second optional arg ENVIRONMENT species an environment of macro
1183 definitions to shadow the loaded ones for use in file byte-compilation.
1187 /* This function can GC */
1188 /* With cleanups from Hallvard Furuseth. */
1189 REGISTER Lisp_Object expander, sym, def, tem;
1193 /* Come back here each time we expand a macro call,
1194 in case it expands into another macro call. */
1197 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1198 def = sym = XCAR (form);
1200 /* Trace symbols aliases to other symbols
1201 until we get a symbol that is not an alias. */
1202 while (SYMBOLP (def))
1206 tem = Fassq (sym, env);
1209 def = XSYMBOL (sym)->function;
1210 if (!UNBOUNDP (def))
1215 /* Right now TEM is the result from SYM in ENV,
1216 and if TEM is nil then DEF is SYM's function definition. */
1219 /* SYM is not mentioned in ENV.
1220 Look at its function definition. */
1223 /* Not defined or definition not suitable */
1225 if (EQ (XCAR (def), Qautoload))
1227 /* Autoloading function: will it be a macro when loaded? */
1228 tem = Felt (def, make_int (4));
1229 if (EQ (tem, Qt) || EQ (tem, Qmacro))
1231 /* Yes, load it and try again. */
1232 do_autoload (def, sym);
1238 else if (!EQ (XCAR (def), Qmacro))
1240 else expander = XCDR (def);
1244 expander = XCDR (tem);
1245 if (NILP (expander))
1248 form = apply1 (expander, XCDR (form));
1254 /************************************************************************/
1255 /* Non-local exits */
1256 /************************************************************************/
1258 DEFUN ("catch", Fcatch, 1, UNEVALLED, 0, /*
1259 \(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.
1260 TAG is evalled to get the tag to use. Then the BODY is executed.
1261 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.
1262 If no throw happens, `catch' returns the value of the last BODY form.
1263 If a throw happens, it specifies the value to return from `catch'.
1267 /* This function can GC */
1268 Lisp_Object tag = Feval (XCAR (args));
1269 Lisp_Object body = XCDR (args);
1270 return internal_catch (tag, Fprogn, body, 0);
1273 /* Set up a catch, then call C function FUNC on argument ARG.
1274 FUNC should return a Lisp_Object.
1275 This is how catches are done from within C code. */
1278 internal_catch (Lisp_Object tag,
1279 Lisp_Object (*func) (Lisp_Object arg),
1281 int * volatile threw)
1283 /* This structure is made part of the chain `catchlist'. */
1286 /* Fill in the components of c, and put it on the list. */
1290 c.backlist = backtrace_list;
1293 c.handlerlist = handlerlist;
1295 c.lisp_eval_depth = lisp_eval_depth;
1296 c.pdlcount = specpdl_depth();
1298 c.poll_suppress_count = async_timer_suppress_count;
1300 c.gcpro = gcprolist;
1306 /* Throw works by a longjmp that comes right here. */
1307 if (threw) *threw = 1;
1310 c.val = (*func) (arg);
1311 if (threw) *threw = 0;
1313 #ifdef ERROR_CHECK_TYPECHECK
1314 check_error_state_sanity ();
1320 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1321 jump to that CATCH, returning VALUE as the value of that catch.
1323 This is the guts Fthrow and Fsignal; they differ only in the way
1324 they choose the catch tag to throw to. A catch tag for a
1325 condition-case form has a TAG of Qnil.
1327 Before each catch is discarded, unbind all special bindings and
1328 execute all unwind-protect clauses made above that catch. Unwind
1329 the handler stack as we go, so that the proper handlers are in
1330 effect for each unwind-protect clause we run. At the end, restore
1331 some static info saved in CATCH, and longjmp to the location
1334 This is used for correct unwinding in Fthrow and Fsignal. */
1337 unwind_to_catch (struct catchtag *c, Lisp_Object val)
1341 REGISTER int last_time;
1344 /* Unwind the specbind, catch, and handler stacks back to CATCH
1345 Before each catch is discarded, unbind all special bindings
1346 and execute all unwind-protect clauses made above that catch.
1347 At the end, restore some static info saved in CATCH,
1348 and longjmp to the location specified.
1351 /* Save the value somewhere it will be GC'ed.
1352 (Can't overwrite tag slot because an unwind-protect may
1353 want to throw to this same tag, which isn't yet invalid.) */
1357 /* Restore the polling-suppression count. */
1358 set_poll_suppress_count (catch->poll_suppress_count);
1362 /* #### FSFmacs has the following loop. Is it more correct? */
1365 last_time = catchlist == c;
1367 /* Unwind the specpdl stack, and then restore the proper set of
1369 unbind_to (catchlist->pdlcount, Qnil);
1370 handlerlist = catchlist->handlerlist;
1371 catchlist = catchlist->next;
1372 #ifdef ERROR_CHECK_TYPECHECK
1373 check_error_state_sanity ();
1376 while (! last_time);
1377 #else /* Actual XEmacs code */
1378 /* Unwind the specpdl stack */
1379 unbind_to (c->pdlcount, Qnil);
1380 catchlist = c->next;
1381 #ifdef ERROR_CHECK_TYPECHECK
1382 check_error_state_sanity ();
1386 gcprolist = c->gcpro;
1387 backtrace_list = c->backlist;
1388 lisp_eval_depth = c->lisp_eval_depth;
1390 #ifdef DEFEND_AGAINST_THROW_RECURSION
1393 LONGJMP (c->jmp, 1);
1396 static DOESNT_RETURN
1397 throw_or_bomb_out (Lisp_Object tag, Lisp_Object val, int bomb_out_p,
1398 Lisp_Object sig, Lisp_Object data)
1400 #ifdef DEFEND_AGAINST_THROW_RECURSION
1401 /* die if we recurse more than is reasonable */
1402 if (++throw_level > 20)
1406 /* If bomb_out_p is t, this is being called from Fsignal as a
1407 "last resort" when there is no handler for this error and
1408 the debugger couldn't be invoked, so we are throwing to
1409 'top-level. If this tag doesn't exist (happens during the
1410 initialization stages) we would get in an infinite recursive
1411 Fsignal/Fthrow loop, so instead we bomb out to the
1412 really-early-error-handler.
1414 Note that in fact the only time that the "last resort"
1415 occurs is when there's no catch for 'top-level -- the
1416 'top-level catch and the catch-all error handler are
1417 established at the same time, in initial_command_loop/
1420 #### Fix this horrifitude!
1425 REGISTER struct catchtag *c;
1428 if (!NILP (tag)) /* #### */
1430 for (c = catchlist; c; c = c->next)
1432 if (EQ (c->tag, tag))
1433 unwind_to_catch (c, val);
1436 tag = Fsignal (Qno_catch, list2 (tag, val));
1438 call1 (Qreally_early_error_handler, Fcons (sig, data));
1441 /* can't happen. who cares? - (Sun's compiler does) */
1442 /* throw_level--; */
1443 /* getting tired of compilation warnings */
1447 /* See above, where CATCHLIST is defined, for a description of how
1450 Fthrow() is also called by Fsignal(), to do a non-local jump
1451 back to the appropriate condition-case handler after (maybe)
1452 the debugger is entered. In that case, TAG is the value
1453 of Vcondition_handlers that was in place just after the
1454 condition-case handler was set up. The car of this will be
1455 some data referring to the handler: Its car will be Qunbound
1456 (thus, this tag can never be generated by Lisp code), and
1457 its CDR will be the HANDLERS argument to condition_case_1()
1458 (either Qerror, Qt, or a list of handlers as in `condition-case').
1459 This works fine because Fthrow() does not care what TAG was
1460 passed to it: it just looks up the catch list for something
1461 that is EQ() to TAG. When it finds it, it will longjmp()
1462 back to the place that established the catch (in this case,
1463 condition_case_1). See below for more info.
1466 DEFUN ("throw", Fthrow, 2, 2, 0, /*
1467 \(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.
1468 Both TAG and VALUE are evalled.
1472 throw_or_bomb_out (tag, val, 0, Qnil, Qnil); /* Doesn't return */
1476 DEFUN ("unwind-protect", Funwind_protect, 1, UNEVALLED, 0, /*
1477 Do BODYFORM, protecting with UNWINDFORMS.
1478 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).
1479 If BODYFORM completes normally, its value is returned
1480 after executing the UNWINDFORMS.
1481 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1485 /* This function can GC */
1486 int speccount = specpdl_depth();
1488 record_unwind_protect (Fprogn, XCDR (args));
1489 return unbind_to (speccount, Feval (XCAR (args)));
1493 /************************************************************************/
1494 /* Signalling and trapping errors */
1495 /************************************************************************/
1498 condition_bind_unwind (Lisp_Object loser)
1501 /* ((handler-fun . handler-args) ... other handlers) */
1502 Lisp_Object tem = XCAR (loser);
1506 victim = XCONS (tem);
1510 victim = XCONS (loser);
1512 if (EQ (loser, Vcondition_handlers)) /* may have been rebound to some tail */
1513 Vcondition_handlers = victim->cdr;
1520 condition_case_unwind (Lisp_Object loser)
1524 /* ((<unbound> . clauses) ... other handlers */
1525 victim = XCONS (XCAR (loser));
1528 victim = XCONS (loser);
1529 if (EQ (loser, Vcondition_handlers)) /* may have been rebound to some tail */
1530 Vcondition_handlers = victim->cdr;
1536 /* Split out from condition_case_3 so that primitive C callers
1537 don't have to cons up a lisp handler form to be evaluated. */
1539 /* Call a function BFUN of one argument BARG, trapping errors as
1540 specified by HANDLERS. If no error occurs that is indicated by
1541 HANDLERS as something to be caught, the return value of this
1542 function is the return value from BFUN. If such an error does
1543 occur, HFUN is called, and its return value becomes the
1544 return value of condition_case_1(). The second argument passed
1545 to HFUN will always be HARG. The first argument depends on
1548 If HANDLERS is Qt, all errors (this includes QUIT, but not
1549 non-local exits with `throw') cause HFUN to be invoked, and VAL
1550 (the first argument to HFUN) is a cons (SIG . DATA) of the
1551 arguments passed to `signal'. The debugger is not invoked even if
1552 `debug-on-error' was set.
1554 A HANDLERS value of Qerror is the same as Qt except that the
1555 debugger is invoked if `debug-on-error' was set.
1557 Otherwise, HANDLERS should be a list of lists (CONDITION-NAME BODY ...)
1558 exactly as in `condition-case', and errors will be trapped
1559 as indicated in HANDLERS. VAL (the first argument to HFUN) will
1560 be a cons whose car is the cons (SIG . DATA) and whose CDR is the
1561 list (BODY ...) from the appropriate slot in HANDLERS.
1563 This function pushes HANDLERS onto the front of Vcondition_handlers
1564 (actually with a Qunbound marker as well -- see Fthrow() above
1565 for why), establishes a catch whose tag is this new value of
1566 Vcondition_handlers, and calls BFUN. When Fsignal() is called,
1567 it calls Fthrow(), setting TAG to this same new value of
1568 Vcondition_handlers and setting VAL to the same thing that will
1569 be passed to HFUN, as above. Fthrow() longjmp()s back to the
1570 jump point we just established, and we in turn just call the
1571 HFUN and return its value.
1573 For a real condition-case, HFUN will always be
1574 run_condition_case_handlers() and HARG is the argument VAR
1575 to condition-case. That function just binds VAR to the cons
1576 (SIG . DATA) that is the CAR of VAL, and calls the handler
1577 (BODY ...) that is the CDR of VAL. Note that before calling
1578 Fthrow(), Fsignal() restored Vcondition_handlers to the value
1579 it had *before* condition_case_1() was called. This maintains
1580 consistency (so that the state of things at exit of
1581 condition_case_1() is the same as at entry), and implies
1582 that the handler can signal the same error again (possibly
1583 after processing of its own), without getting in an infinite
1587 condition_case_1 (Lisp_Object handlers,
1588 Lisp_Object (*bfun) (Lisp_Object barg),
1590 Lisp_Object (*hfun) (Lisp_Object val, Lisp_Object harg),
1593 int speccount = specpdl_depth();
1595 struct gcpro gcpro1;
1600 /* Do consing now so out-of-memory error happens up front */
1601 /* (unbound . stuff) is a special condition-case kludge marker
1602 which is known specially by Fsignal.
1603 This is an abomination, but to fix it would require either
1604 making condition_case cons (a union of the conditions of the clauses)
1605 or changing the byte-compiler output (no thanks). */
1606 c.tag = noseeum_cons (noseeum_cons (Qunbound, handlers),
1607 Vcondition_handlers);
1610 c.backlist = backtrace_list;
1613 c.handlerlist = handlerlist;
1615 c.lisp_eval_depth = lisp_eval_depth;
1616 c.pdlcount = specpdl_depth();
1618 c.poll_suppress_count = async_timer_suppress_count;
1620 c.gcpro = gcprolist;
1621 /* #### FSFmacs does the following statement *after* the setjmp(). */
1626 /* throw does ungcpro, etc */
1627 return (*hfun) (c.val, harg);
1630 record_unwind_protect (condition_case_unwind, c.tag);
1634 h.handler = handlers;
1636 h.next = handlerlist;
1640 Vcondition_handlers = c.tag;
1642 GCPRO1 (harg); /* Somebody has to gc-protect */
1644 c.val = ((*bfun) (barg));
1646 /* The following is *not* true: (ben)
1648 ungcpro, restoring catchlist and condition_handlers are actually
1649 redundant since unbind_to now restores them. But it looks funny not to
1650 have this code here, and it doesn't cost anything, so I'm leaving it.*/
1653 #ifdef ERROR_CHECK_TYPECHECK
1654 check_error_state_sanity ();
1656 Vcondition_handlers = XCDR (c.tag);
1658 return unbind_to (speccount, c.val);
1662 run_condition_case_handlers (Lisp_Object val, Lisp_Object var)
1664 /* This function can GC */
1667 specbind (h.var, c.val);
1668 val = Fprogn (Fcdr (h.chosen_clause));
1670 /* Note that this just undoes the binding of h.var; whoever
1671 longjmp()ed to us unwound the stack to c.pdlcount before
1673 unbind_to (c.pdlcount, Qnil);
1678 CHECK_TRUE_LIST (val);
1680 return Fprogn (Fcdr (val)); /* tail call */
1682 speccount = specpdl_depth();
1683 specbind (var, Fcar (val));
1684 val = Fprogn (Fcdr (val));
1685 return unbind_to (speccount, val);
1689 /* Here for bytecode to call non-consfully. This is exactly like
1690 condition-case except that it takes three arguments rather
1691 than a single list of arguments. */
1693 condition_case_3 (Lisp_Object bodyform, Lisp_Object var, Lisp_Object handlers)
1695 /* This function can GC */
1696 Lisp_Object handler;
1698 EXTERNAL_LIST_LOOP_2 (handler, handlers)
1702 else if (CONSP (handler))
1704 Lisp_Object conditions = XCAR (handler);
1705 /* CONDITIONS must a condition name or a list of condition names */
1706 if (SYMBOLP (conditions))
1710 Lisp_Object condition;
1711 EXTERNAL_LIST_LOOP_2 (condition, conditions)
1712 if (!SYMBOLP (condition))
1713 goto invalid_condition_handler;
1718 invalid_condition_handler:
1719 signal_simple_error ("Invalid condition handler", handler);
1725 return condition_case_1 (handlers,
1727 run_condition_case_handlers,
1731 DEFUN ("condition-case", Fcondition_case, 2, UNEVALLED, 0, /*
1732 Regain control when an error is signalled.
1733 Usage looks like (condition-case VAR BODYFORM HANDLERS...).
1734 Executes BODYFORM and returns its value if no error happens.
1735 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1736 where the BODY is made of Lisp expressions.
1738 A handler is applicable to an error if CONDITION-NAME is one of the
1739 error's condition names. If an error happens, the first applicable
1740 handler is run. As a special case, a CONDITION-NAME of t matches
1741 all errors, even those without the `error' condition name on them
1744 The car of a handler may be a list of condition names
1745 instead of a single condition name.
1747 When a handler handles an error,
1748 control returns to the condition-case and the handler BODY... is executed
1749 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).
1750 VAR may be nil; then you do not get access to the signal information.
1752 The value of the last BODY form is returned from the condition-case.
1753 See also the function `signal' for more info.
1755 Note that at the time the condition handler is invoked, the Lisp stack
1756 and the current catches, condition-cases, and bindings have all been
1757 popped back to the state they were in just before the call to
1758 `condition-case'. This means that resignalling the error from
1759 within the handler will not result in an infinite loop.
1761 If you want to establish an error handler that is called with the
1762 Lisp stack, bindings, etc. as they were when `signal' was called,
1763 rather than when the handler was set, use `call-with-condition-handler'.
1767 /* This function can GC */
1768 Lisp_Object var = XCAR (args);
1769 Lisp_Object bodyform = XCAR (XCDR (args));
1770 Lisp_Object handlers = XCDR (XCDR (args));
1771 return condition_case_3 (bodyform, var, handlers);
1774 DEFUN ("call-with-condition-handler", Fcall_with_condition_handler, 2, MANY, 0, /*
1775 Regain control when an error is signalled, without popping the stack.
1776 Usage looks like (call-with-condition-handler HANDLER FUNCTION &rest ARGS).
1777 This function is similar to `condition-case', but the handler is invoked
1778 with the same environment (Lisp stack, bindings, catches, condition-cases)
1779 that was current when `signal' was called, rather than when the handler
1782 HANDLER should be a function of one argument, which is a cons of the args
1783 \(SIG . DATA) that were passed to `signal'. It is invoked whenever
1784 `signal' is called (this differs from `condition-case', which allows
1785 you to specify which errors are trapped). If the handler function
1786 returns, `signal' continues as if the handler were never invoked.
1787 \(It continues to look for handlers established earlier than this one,
1788 and invokes the standard error-handler if none is found.)
1790 (int nargs, Lisp_Object *args)) /* Note! Args side-effected! */
1792 /* This function can GC */
1793 int speccount = specpdl_depth();
1796 /* #### If there were a way to check that args[0] were a function
1797 which accepted one arg, that should be done here ... */
1799 /* (handler-fun . handler-args) */
1800 tem = noseeum_cons (list1 (args[0]), Vcondition_handlers);
1801 record_unwind_protect (condition_bind_unwind, tem);
1802 Vcondition_handlers = tem;
1804 /* Caller should have GC-protected args */
1805 return unbind_to (speccount, Ffuncall (nargs - 1, args + 1));
1809 condition_type_p (Lisp_Object type, Lisp_Object conditions)
1812 /* (condition-case c # (t c)) catches -all- signals
1813 * Use with caution! */
1817 return !NILP (Fmemq (type, conditions));
1819 for (; CONSP (type); type = XCDR (type))
1820 if (!NILP (Fmemq (XCAR (type), conditions)))
1827 return_from_signal (Lisp_Object value)
1830 /* Most callers are not prepared to handle gc if this
1831 returns. So, since this feature is not very useful,
1833 /* Have called debugger; return value to signaller */
1835 #else /* But the reality is that that stinks, because: */
1836 /* GACK!!! Really want some way for debug-on-quit errors
1837 to be continuable!! */
1838 error ("Returning a value from an error is no longer supported");
1842 extern int in_display;
1845 /************************************************************************/
1846 /* the workhorse error-signaling function */
1847 /************************************************************************/
1849 /* #### This function has not been synched with FSF. It diverges
1853 signal_1 (Lisp_Object sig, Lisp_Object data)
1855 /* This function can GC */
1856 struct gcpro gcpro1, gcpro2;
1857 Lisp_Object conditions;
1858 Lisp_Object handlers;
1859 /* signal_call_debugger() could get called more than once
1860 (once when a call-with-condition-handler is about to
1861 be dealt with, and another when a condition-case handler
1862 is about to be invoked). So make sure the debugger and/or
1863 stack trace aren't done more than once. */
1864 int stack_trace_displayed = 0;
1865 int debugger_entered = 0;
1866 GCPRO2 (conditions, handlers);
1870 /* who knows how much has been initialized? Safest bet is
1871 just to bomb out immediately. */
1872 /* let's not use stderr_out() here, because that does a bunch of
1873 things that might not be safe yet. */
1874 fprintf (stderr, "Error before initialization is complete!\n");
1878 if (gc_in_progress || in_display)
1879 /* This is one of many reasons why you can't run lisp code from redisplay.
1880 There is no sensible way to handle errors there. */
1883 conditions = Fget (sig, Qerror_conditions, Qnil);
1885 for (handlers = Vcondition_handlers;
1887 handlers = XCDR (handlers))
1889 Lisp_Object handler_fun = XCAR (XCAR (handlers));
1890 Lisp_Object handler_data = XCDR (XCAR (handlers));
1891 Lisp_Object outer_handlers = XCDR (handlers);
1893 if (!UNBOUNDP (handler_fun))
1895 /* call-with-condition-handler */
1897 Lisp_Object all_handlers = Vcondition_handlers;
1898 struct gcpro ngcpro1;
1899 NGCPRO1 (all_handlers);
1900 Vcondition_handlers = outer_handlers;
1902 tem = signal_call_debugger (conditions, sig, data,
1904 &stack_trace_displayed,
1906 if (!UNBOUNDP (tem))
1907 RETURN_NUNGCPRO (return_from_signal (tem));
1909 tem = Fcons (sig, data);
1910 if (NILP (handler_data))
1911 tem = call1 (handler_fun, tem);
1914 /* (This code won't be used (for now?).) */
1915 struct gcpro nngcpro1;
1916 Lisp_Object args[3];
1919 args[0] = handler_fun;
1921 args[2] = handler_data;
1922 nngcpro1.var = args;
1923 tem = Fapply (3, args);
1928 if (!EQ (tem, Qsignal))
1929 return return_from_signal (tem);
1931 /* If handler didn't throw, try another handler */
1932 Vcondition_handlers = all_handlers;
1935 /* It's a condition-case handler */
1937 /* t is used by handlers for all conditions, set up by C code.
1938 * debugger is not called even if debug_on_error */
1939 else if (EQ (handler_data, Qt))
1942 return Fthrow (handlers, Fcons (sig, data));
1944 /* `error' is used similarly to the way `t' is used, but in
1945 addition it invokes the debugger if debug_on_error.
1946 This is normally used for the outer command-loop error
1948 else if (EQ (handler_data, Qerror))
1950 Lisp_Object tem = signal_call_debugger (conditions, sig, data,
1952 &stack_trace_displayed,
1956 if (!UNBOUNDP (tem))
1957 return return_from_signal (tem);
1959 tem = Fcons (sig, data);
1960 return Fthrow (handlers, tem);
1964 /* handler established by real (Lisp) condition-case */
1967 for (h = handler_data; CONSP (h); h = Fcdr (h))
1969 Lisp_Object clause = Fcar (h);
1970 Lisp_Object tem = Fcar (clause);
1972 if (condition_type_p (tem, conditions))
1974 tem = signal_call_debugger (conditions, sig, data,
1976 &stack_trace_displayed,
1979 if (!UNBOUNDP (tem))
1980 return return_from_signal (tem);
1982 /* Doesn't return */
1983 tem = Fcons (Fcons (sig, data), Fcdr (clause));
1984 return Fthrow (handlers, tem);
1990 /* If no handler is present now, try to run the debugger,
1991 and if that fails, throw to top level.
1993 #### The only time that no handler is present is during
1994 temacs or perhaps very early in XEmacs. In both cases,
1995 there is no 'top-level catch. (That's why the
1996 "bomb-out" hack was added.)
1998 #### Fix this horrifitude!
2000 signal_call_debugger (conditions, sig, data, Qnil, 0,
2001 &stack_trace_displayed,
2004 throw_or_bomb_out (Qtop_level, Qt, 1, sig, data); /* Doesn't return */
2009 /****************** Error functions class 1 ******************/
2011 /* Class 1: General functions that signal an error.
2012 These functions take an error type and a list of associated error
2015 /* The simplest external error function: it would be called
2016 signal_continuable_error() in the terminology below, but it's
2019 DEFUN ("signal", Fsignal, 2, 2, 0, /*
2020 Signal a continuable error. Args are ERROR-SYMBOL, and associated DATA.
2021 An error symbol is a symbol defined using `define-error'.
2022 DATA should be a list. Its elements are printed as part of the error message.
2023 If the signal is handled, DATA is made available to the handler.
2024 See also the function `signal-error', and the functions to handle errors:
2025 `condition-case' and `call-with-condition-handler'.
2027 Note that this function can return, if the debugger is invoked and the
2028 user invokes the "return from signal" option.
2030 (error_symbol, data))
2032 /* Fsignal() is one of these functions that's called all the time
2033 with newly-created Lisp objects. We allow this; but we must GC-
2034 protect the objects because all sorts of weird stuff could
2037 struct gcpro gcpro1;
2040 if (!NILP (Vcurrent_error_state))
2042 if (!NILP (Vcurrent_warning_class))
2043 warn_when_safe_lispobj (Vcurrent_warning_class, Qwarning,
2044 Fcons (error_symbol, data));
2045 Fthrow (Qunbound_suspended_errors_tag, Qnil);
2046 abort (); /* Better not get here! */
2048 RETURN_UNGCPRO (signal_1 (error_symbol, data));
2051 /* Signal a non-continuable error. */
2054 signal_error (Lisp_Object sig, Lisp_Object data)
2057 Fsignal (sig, data);
2059 #ifdef ERROR_CHECK_TYPECHECK
2061 check_error_state_sanity (void)
2064 int found_error_tag = 0;
2066 for (c = catchlist; c; c = c->next)
2068 if (EQ (c->tag, Qunbound_suspended_errors_tag))
2070 found_error_tag = 1;
2075 assert (found_error_tag || NILP (Vcurrent_error_state));
2080 restore_current_warning_class (Lisp_Object warning_class)
2082 Vcurrent_warning_class = warning_class;
2087 restore_current_error_state (Lisp_Object error_state)
2089 Vcurrent_error_state = error_state;
2094 call_with_suspended_errors_1 (Lisp_Object opaque_arg)
2097 Lisp_Object *kludgy_args = (Lisp_Object *) get_opaque_ptr (opaque_arg);
2098 Lisp_Object no_error = kludgy_args[2];
2099 int speccount = specpdl_depth ();
2101 if (!EQ (Vcurrent_error_state, no_error))
2103 record_unwind_protect (restore_current_error_state,
2104 Vcurrent_error_state);
2105 Vcurrent_error_state = no_error;
2107 PRIMITIVE_FUNCALL (val, get_opaque_ptr (kludgy_args[0]),
2108 kludgy_args + 3, XINT (kludgy_args[1]));
2109 return unbind_to (speccount, val);
2112 /* Many functions would like to do one of three things if an error
2115 (1) signal the error, as usual.
2116 (2) silently fail and return some error value.
2117 (3) do as (2) but issue a warning in the process.
2119 Currently there's lots of stuff that passes an Error_behavior
2120 value and calls maybe_signal_error() and other such functions.
2121 This approach is inherently error-prone and broken. A much
2122 more robust and easier approach is to use call_with_suspended_errors().
2123 Wrap this around any function in which you might want errors
2128 call_with_suspended_errors (lisp_fn_t fun, volatile Lisp_Object retval,
2129 Lisp_Object class, Error_behavior errb,
2134 Lisp_Object kludgy_args[23];
2135 Lisp_Object *args = kludgy_args + 3;
2137 Lisp_Object no_error;
2139 assert (SYMBOLP (class)); /* sanity-check */
2140 assert (!NILP (class));
2141 assert (nargs >= 0 && nargs < 20);
2143 /* ERROR_ME means don't trap errors. (However, if errors are
2144 already trapped, we leave them trapped.)
2146 Otherwise, we trap errors, and trap warnings if ERROR_ME_WARN.
2148 If ERROR_ME_NOT, it causes no warnings even if warnings
2149 were previously enabled. However, we never change the
2150 warning class from one to another. */
2151 if (!ERRB_EQ (errb, ERROR_ME))
2153 if (ERRB_EQ (errb, ERROR_ME_NOT)) /* person wants no warnings */
2155 errb = ERROR_ME_NOT;
2161 va_start (vargs, nargs);
2162 for (i = 0; i < nargs; i++)
2163 args[i] = va_arg (vargs, Lisp_Object);
2166 /* If error-checking is not disabled, just call the function.
2167 It's important not to override disabled error-checking with
2168 enabled error-checking. */
2170 if (ERRB_EQ (errb, ERROR_ME))
2173 PRIMITIVE_FUNCALL (val, fun, args, nargs);
2177 speccount = specpdl_depth ();
2178 if (NILP (class) || NILP (Vcurrent_warning_class))
2180 /* If we're currently calling for no warnings, then make it so.
2181 If we're currently calling for warnings and we weren't
2182 previously, then set our warning class; otherwise, leave
2183 the existing one alone. */
2184 record_unwind_protect (restore_current_warning_class,
2185 Vcurrent_warning_class);
2186 Vcurrent_warning_class = class;
2191 Lisp_Object the_retval;
2192 Lisp_Object opaque1 = make_opaque_ptr (kludgy_args);
2193 Lisp_Object opaque2 = make_opaque_ptr ((void *) fun);
2194 struct gcpro gcpro1, gcpro2;
2196 GCPRO2 (opaque1, opaque2);
2197 kludgy_args[0] = opaque2;
2198 kludgy_args[1] = make_int (nargs);
2199 kludgy_args[2] = no_error;
2200 the_retval = internal_catch (Qunbound_suspended_errors_tag,
2201 call_with_suspended_errors_1,
2203 free_opaque_ptr (opaque1);
2204 free_opaque_ptr (opaque2);
2206 /* Use the returned value except in non-local exit, when
2208 /* Some perverse compilers require the perverse cast below. */
2209 return unbind_to (speccount,
2210 threw ? *((Lisp_Object*) &(retval)) : the_retval);
2214 /* Signal a non-continuable error or display a warning or do nothing,
2215 according to ERRB. CLASS is the class of warning and should
2216 refer to what sort of operation is being done (e.g. Qtoolbar,
2217 Qresource, etc.). */
2220 maybe_signal_error (Lisp_Object sig, Lisp_Object data, Lisp_Object class,
2221 Error_behavior errb)
2223 if (ERRB_EQ (errb, ERROR_ME_NOT))
2225 else if (ERRB_EQ (errb, ERROR_ME_WARN))
2226 warn_when_safe_lispobj (class, Qwarning, Fcons (sig, data));
2229 Fsignal (sig, data);
2232 /* Signal a continuable error or display a warning or do nothing,
2233 according to ERRB. */
2236 maybe_signal_continuable_error (Lisp_Object sig, Lisp_Object data,
2237 Lisp_Object class, Error_behavior errb)
2239 if (ERRB_EQ (errb, ERROR_ME_NOT))
2241 else if (ERRB_EQ (errb, ERROR_ME_WARN))
2243 warn_when_safe_lispobj (class, Qwarning, Fcons (sig, data));
2247 return Fsignal (sig, data);
2251 /****************** Error functions class 2 ******************/
2253 /* Class 2: Printf-like functions that signal an error.
2254 These functions signal an error of type Qerror, whose data
2255 is a single string, created using the arguments. */
2257 /* dump an error message; called like printf */
2260 error (const char *fmt, ...)
2265 va_start (args, fmt);
2266 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2270 /* Fsignal GC-protects its args */
2271 signal_error (Qerror, list1 (obj));
2275 maybe_error (Lisp_Object class, Error_behavior errb, const char *fmt, ...)
2281 if (ERRB_EQ (errb, ERROR_ME_NOT))
2284 va_start (args, fmt);
2285 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2289 /* Fsignal GC-protects its args */
2290 maybe_signal_error (Qerror, list1 (obj), class, errb);
2294 continuable_error (const char *fmt, ...)
2299 va_start (args, fmt);
2300 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2304 /* Fsignal GC-protects its args */
2305 return Fsignal (Qerror, list1 (obj));
2309 maybe_continuable_error (Lisp_Object class, Error_behavior errb,
2310 const char *fmt, ...)
2316 if (ERRB_EQ (errb, ERROR_ME_NOT))
2319 va_start (args, fmt);
2320 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2324 /* Fsignal GC-protects its args */
2325 return maybe_signal_continuable_error (Qerror, list1 (obj), class, errb);
2329 /****************** Error functions class 3 ******************/
2331 /* Class 3: Signal an error with a string and an associated object.
2332 These functions signal an error of type Qerror, whose data
2333 is two objects, a string and a related Lisp object (usually the object
2334 where the error is occurring). */
2337 signal_simple_error (const char *reason, Lisp_Object frob)
2339 signal_error (Qerror, list2 (build_translated_string (reason), frob));
2343 maybe_signal_simple_error (const char *reason, Lisp_Object frob,
2344 Lisp_Object class, Error_behavior errb)
2347 if (ERRB_EQ (errb, ERROR_ME_NOT))
2349 maybe_signal_error (Qerror, list2 (build_translated_string (reason), frob),
2354 signal_simple_continuable_error (const char *reason, Lisp_Object frob)
2356 return Fsignal (Qerror, list2 (build_translated_string (reason), frob));
2360 maybe_signal_simple_continuable_error (const char *reason, Lisp_Object frob,
2361 Lisp_Object class, Error_behavior errb)
2364 if (ERRB_EQ (errb, ERROR_ME_NOT))
2366 return maybe_signal_continuable_error
2367 (Qerror, list2 (build_translated_string (reason),
2368 frob), class, errb);
2372 /****************** Error functions class 4 ******************/
2374 /* Class 4: Printf-like functions that signal an error.
2375 These functions signal an error of type Qerror, whose data
2376 is a two objects, a string (created using the arguments) and a
2381 error_with_frob (Lisp_Object frob, const char *fmt, ...)
2386 va_start (args, fmt);
2387 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2391 /* Fsignal GC-protects its args */
2392 signal_error (Qerror, list2 (obj, frob));
2396 maybe_error_with_frob (Lisp_Object frob, Lisp_Object class,
2397 Error_behavior errb, const char *fmt, ...)
2403 if (ERRB_EQ (errb, ERROR_ME_NOT))
2406 va_start (args, fmt);
2407 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2411 /* Fsignal GC-protects its args */
2412 maybe_signal_error (Qerror, list2 (obj, frob), class, errb);
2416 continuable_error_with_frob (Lisp_Object frob, const char *fmt, ...)
2421 va_start (args, fmt);
2422 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2426 /* Fsignal GC-protects its args */
2427 return Fsignal (Qerror, list2 (obj, frob));
2431 maybe_continuable_error_with_frob (Lisp_Object frob, Lisp_Object class,
2432 Error_behavior errb, const char *fmt, ...)
2438 if (ERRB_EQ (errb, ERROR_ME_NOT))
2441 va_start (args, fmt);
2442 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2446 /* Fsignal GC-protects its args */
2447 return maybe_signal_continuable_error (Qerror, list2 (obj, frob),
2452 /****************** Error functions class 5 ******************/
2454 /* Class 5: Signal an error with a string and two associated objects.
2455 These functions signal an error of type Qerror, whose data
2456 is three objects, a string and two related Lisp objects. */
2459 signal_simple_error_2 (const char *reason,
2460 Lisp_Object frob0, Lisp_Object frob1)
2462 signal_error (Qerror, list3 (build_translated_string (reason), frob0,
2467 maybe_signal_simple_error_2 (const char *reason, Lisp_Object frob0,
2468 Lisp_Object frob1, Lisp_Object class,
2469 Error_behavior errb)
2472 if (ERRB_EQ (errb, ERROR_ME_NOT))
2474 maybe_signal_error (Qerror, list3 (build_translated_string (reason), frob0,
2475 frob1), class, errb);
2480 signal_simple_continuable_error_2 (const char *reason, Lisp_Object frob0,
2483 return Fsignal (Qerror, list3 (build_translated_string (reason), frob0,
2488 maybe_signal_simple_continuable_error_2 (const char *reason, Lisp_Object frob0,
2489 Lisp_Object frob1, Lisp_Object class,
2490 Error_behavior errb)
2493 if (ERRB_EQ (errb, ERROR_ME_NOT))
2495 return maybe_signal_continuable_error
2496 (Qerror, list3 (build_translated_string (reason), frob0,
2502 /* This is what the QUIT macro calls to signal a quit */
2506 /* This function can GC */
2507 if (EQ (Vquit_flag, Qcritical))
2508 debug_on_quit |= 2; /* set critical bit. */
2510 /* note that this is continuable. */
2511 Fsignal (Qquit, Qnil);
2515 /* Used in core lisp functions for efficiency */
2517 signal_void_function_error (Lisp_Object function)
2519 return Fsignal (Qvoid_function, list1 (function));
2523 signal_invalid_function_error (Lisp_Object function)
2525 return Fsignal (Qinvalid_function, list1 (function));
2529 signal_wrong_number_of_arguments_error (Lisp_Object function, int nargs)
2531 return Fsignal (Qwrong_number_of_arguments,
2532 list2 (function, make_int (nargs)));
2535 /* Used in list traversal macros for efficiency. */
2537 signal_malformed_list_error (Lisp_Object list)
2539 signal_error (Qmalformed_list, list1 (list));
2543 signal_malformed_property_list_error (Lisp_Object list)
2545 signal_error (Qmalformed_property_list, list1 (list));
2549 signal_circular_list_error (Lisp_Object list)
2551 signal_error (Qcircular_list, list1 (list));
2555 signal_circular_property_list_error (Lisp_Object list)
2557 signal_error (Qcircular_property_list, list1 (list));
2560 /************************************************************************/
2562 /************************************************************************/
2564 DEFUN ("commandp", Fcommandp, 1, 1, 0, /*
2565 Return t if FUNCTION makes provisions for interactive calling.
2566 This means it contains a description for how to read arguments to give it.
2567 The value is nil for an invalid function or a symbol with no function
2570 Interactively callable functions include
2572 -- strings and vectors (treated as keyboard macros)
2573 -- lambda-expressions that contain a top-level call to `interactive'
2574 -- autoload definitions made by `autoload' with non-nil fourth argument
2575 (i.e. the interactive flag)
2576 -- compiled-function objects with a non-nil `compiled-function-interactive'
2578 -- subrs (built-in functions) that are interactively callable
2580 Also, a symbol satisfies `commandp' if its function definition does so.
2584 Lisp_Object fun = indirect_function (function, 0);
2586 if (COMPILED_FUNCTIONP (fun))
2587 return XCOMPILED_FUNCTION (fun)->flags.interactivep ? Qt : Qnil;
2589 /* Lists may represent commands. */
2592 Lisp_Object funcar = XCAR (fun);
2593 if (EQ (funcar, Qlambda))
2594 return Fassq (Qinteractive, Fcdr (Fcdr (fun)));
2595 if (EQ (funcar, Qautoload))
2596 return Fcar (Fcdr (Fcdr (Fcdr (fun))));
2601 /* Emacs primitives are interactive if their DEFUN specifies an
2602 interactive spec. */
2604 return XSUBR (fun)->prompt ? Qt : Qnil;
2606 /* Strings and vectors are keyboard macros. */
2607 if (VECTORP (fun) || STRINGP (fun))
2610 /* Everything else (including Qunbound) is not a command. */
2614 DEFUN ("command-execute", Fcommand_execute, 1, 3, 0, /*
2615 Execute CMD as an editor command.
2616 CMD must be an object that satisfies the `commandp' predicate.
2617 Optional second arg RECORD-FLAG is as in `call-interactively'.
2618 The argument KEYS specifies the value to use instead of (this-command-keys)
2619 when reading the arguments.
2621 (cmd, record, keys))
2623 /* This function can GC */
2624 Lisp_Object prefixarg;
2625 Lisp_Object final = cmd;
2626 struct backtrace backtrace;
2627 struct console *con = XCONSOLE (Vselected_console);
2629 prefixarg = con->prefix_arg;
2630 con->prefix_arg = Qnil;
2631 Vcurrent_prefix_arg = prefixarg;
2632 debug_on_next_call = 0; /* #### from FSFmacs; correct? */
2634 if (SYMBOLP (cmd) && !NILP (Fget (cmd, Qdisabled, Qnil)))
2635 return run_hook (Vdisabled_command_hook);
2639 final = indirect_function (cmd, 1);
2640 if (CONSP (final) && EQ (Fcar (final), Qautoload))
2641 do_autoload (final, cmd);
2646 if (CONSP (final) || SUBRP (final) || COMPILED_FUNCTIONP (final))
2648 backtrace.function = &Qcall_interactively;
2649 backtrace.args = &cmd;
2650 backtrace.nargs = 1;
2651 backtrace.evalargs = 0;
2652 backtrace.pdlcount = specpdl_depth();
2653 backtrace.debug_on_exit = 0;
2654 PUSH_BACKTRACE (backtrace);
2656 final = Fcall_interactively (cmd, record, keys);
2658 POP_BACKTRACE (backtrace);
2661 else if (STRINGP (final) || VECTORP (final))
2663 return Fexecute_kbd_macro (final, prefixarg);
2667 Fsignal (Qwrong_type_argument,
2671 : list2 (cmd, final))));
2676 DEFUN ("interactive-p", Finteractive_p, 0, 0, 0, /*
2677 Return t if function in which this appears was called interactively.
2678 This means that the function was called with call-interactively (which
2679 includes being called as the binding of a key)
2680 and input is currently coming from the keyboard (not in keyboard macro).
2684 REGISTER struct backtrace *btp;
2685 REGISTER Lisp_Object fun;
2690 /* Unless the object was compiled, skip the frame of interactive-p itself
2691 (if interpreted) or the frame of byte-code (if called from a compiled
2692 function). Note that *btp->function may be a symbol pointing at a
2693 compiled function. */
2694 btp = backtrace_list;
2698 /* #### FSFmacs does the following instead. I can't figure
2699 out which one is more correct. */
2700 /* If this isn't a byte-compiled function, there may be a frame at
2701 the top for Finteractive_p itself. If so, skip it. */
2702 fun = Findirect_function (*btp->function);
2703 if (SUBRP (fun) && XSUBR (fun) == &Sinteractive_p)
2706 /* If we're running an Emacs 18-style byte-compiled function, there
2707 may be a frame for Fbyte_code. Now, given the strictest
2708 definition, this function isn't really being called
2709 interactively, but because that's the way Emacs 18 always builds
2710 byte-compiled functions, we'll accept it for now. */
2711 if (EQ (*btp->function, Qbyte_code))
2714 /* If this isn't a byte-compiled function, then we may now be
2715 looking at several frames for special forms. Skip past them. */
2717 btp->nargs == UNEVALLED)
2722 if (! (COMPILED_FUNCTIONP (Findirect_function (*btp->function))))
2725 btp && (btp->nargs == UNEVALLED
2726 || EQ (*btp->function, Qbyte_code));
2729 /* btp now points at the frame of the innermost function
2730 that DOES eval its args.
2731 If it is a built-in function (such as load or eval-region)
2733 /* Beats me why this is necessary, but it is */
2734 if (btp && EQ (*btp->function, Qcall_interactively))
2739 fun = Findirect_function (*btp->function);
2742 /* btp points to the frame of a Lisp function that called interactive-p.
2743 Return t if that function was called interactively. */
2744 if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively))
2750 /************************************************************************/
2752 /************************************************************************/
2754 DEFUN ("autoload", Fautoload, 2, 5, 0, /*
2755 Define FUNCTION to autoload from FILE.
2756 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
2757 Third arg DOCSTRING is documentation for the function.
2758 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
2759 Fifth arg TYPE indicates the type of the object:
2760 nil or omitted says FUNCTION is a function,
2761 `keymap' says FUNCTION is really a keymap, and
2762 `macro' or t says FUNCTION is really a macro.
2763 Third through fifth args give info about the real definition.
2764 They default to nil.
2765 If FUNCTION is already defined other than as an autoload,
2766 this does nothing and returns nil.
2768 (function, file, docstring, interactive, type))
2770 /* This function can GC */
2771 CHECK_SYMBOL (function);
2772 CHECK_STRING (file);
2774 /* If function is defined and not as an autoload, don't override */
2776 Lisp_Object f = XSYMBOL (function)->function;
2777 if (!UNBOUNDP (f) && !(CONSP (f) && EQ (XCAR (f), Qautoload)))
2783 /* Attempt to avoid consing identical (string=) pure strings. */
2784 file = Fsymbol_name (Fintern (file, Qnil));
2787 return Ffset (function, Fcons (Qautoload, list4 (file,
2794 un_autoload (Lisp_Object oldqueue)
2796 /* This function can GC */
2797 REGISTER Lisp_Object queue, first, second;
2799 /* Queue to unwind is current value of Vautoload_queue.
2800 oldqueue is the shadowed value to leave in Vautoload_queue. */
2801 queue = Vautoload_queue;
2802 Vautoload_queue = oldqueue;
2803 while (CONSP (queue))
2805 first = XCAR (queue);
2806 second = Fcdr (first);
2807 first = Fcar (first);
2811 Ffset (first, second);
2812 queue = Fcdr (queue);
2818 do_autoload (Lisp_Object fundef,
2819 Lisp_Object funname)
2821 /* This function can GC */
2822 int speccount = specpdl_depth();
2823 Lisp_Object fun = funname;
2824 struct gcpro gcpro1, gcpro2;
2826 CHECK_SYMBOL (funname);
2827 GCPRO2 (fun, funname);
2829 /* Value saved here is to be restored into Vautoload_queue */
2830 record_unwind_protect (un_autoload, Vautoload_queue);
2831 Vautoload_queue = Qt;
2832 call4 (Qload, Fcar (Fcdr (fundef)), Qnil, noninteractive ? Qt : Qnil, Qnil);
2837 /* Save the old autoloads, in case we ever do an unload. */
2838 for (queue = Vautoload_queue; CONSP (queue); queue = XCDR (queue))
2840 Lisp_Object first = XCAR (queue);
2841 Lisp_Object second = Fcdr (first);
2843 first = Fcar (first);
2845 /* Note: This test is subtle. The cdr of an autoload-queue entry
2846 may be an atom if the autoload entry was generated by a defalias
2849 Fput (first, Qautoload, (XCDR (second)));
2853 /* Once loading finishes, don't undo it. */
2854 Vautoload_queue = Qt;
2855 unbind_to (speccount, Qnil);
2857 fun = indirect_function (fun, 0);
2860 if (!NILP (Fequal (fun, fundef)))
2864 && EQ (XCAR (fun), Qautoload)))
2866 error ("Autoloading failed to define function %s",
2867 string_data (XSYMBOL (funname)->name));
2872 /************************************************************************/
2873 /* eval, funcall, apply */
2874 /************************************************************************/
2876 static Lisp_Object funcall_lambda (Lisp_Object fun,
2877 int nargs, Lisp_Object args[]);
2878 static int in_warnings;
2881 in_warnings_restore (Lisp_Object minimus)
2887 DEFUN ("eval", Feval, 1, 1, 0, /*
2888 Evaluate FORM and return its value.
2892 /* This function can GC */
2893 Lisp_Object fun, val, original_fun, original_args;
2895 struct backtrace backtrace;
2897 /* I think this is a pretty safe place to call Lisp code, don't you? */
2898 while (!in_warnings && !NILP (Vpending_warnings))
2900 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
2901 int speccount = specpdl_depth();
2902 Lisp_Object this_warning_cons, this_warning, class, level, messij;
2904 record_unwind_protect (in_warnings_restore, Qnil);
2906 this_warning_cons = Vpending_warnings;
2907 this_warning = XCAR (this_warning_cons);
2908 /* in case an error occurs in the warn function, at least
2909 it won't happen infinitely */
2910 Vpending_warnings = XCDR (Vpending_warnings);
2911 free_cons (XCONS (this_warning_cons));
2912 class = XCAR (this_warning);
2913 level = XCAR (XCDR (this_warning));
2914 messij = XCAR (XCDR (XCDR (this_warning)));
2915 free_list (this_warning);
2917 if (NILP (Vpending_warnings))
2918 Vpending_warnings_tail = Qnil; /* perhaps not strictly necessary,
2921 GCPRO4 (form, class, level, messij);
2922 if (!STRINGP (messij))
2923 messij = Fprin1_to_string (messij, Qnil);
2924 call3 (Qdisplay_warning, class, messij, level);
2926 unbind_to (speccount, Qnil);
2932 return Fsymbol_value (form);
2938 if ((consing_since_gc > gc_cons_threshold) || always_gc)
2940 struct gcpro gcpro1;
2942 garbage_collect_1 ();
2946 if (++lisp_eval_depth > max_lisp_eval_depth)
2948 if (max_lisp_eval_depth < 100)
2949 max_lisp_eval_depth = 100;
2950 if (lisp_eval_depth > max_lisp_eval_depth)
2951 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2954 /* We guaranteed CONSP (form) above */
2955 original_fun = XCAR (form);
2956 original_args = XCDR (form);
2958 GET_EXTERNAL_LIST_LENGTH (original_args, nargs);
2960 backtrace.pdlcount = specpdl_depth();
2961 backtrace.function = &original_fun; /* This also protects them from gc */
2962 backtrace.args = &original_args;
2963 backtrace.nargs = UNEVALLED;
2964 backtrace.evalargs = 1;
2965 backtrace.debug_on_exit = 0;
2966 PUSH_BACKTRACE (backtrace);
2968 if (debug_on_next_call)
2969 do_debug_on_call (Qt);
2971 if (profiling_active)
2972 profile_increase_call_count (original_fun);
2974 /* At this point, only original_fun and original_args
2975 have values that will be used below. */
2977 fun = indirect_function (original_fun, 1);
2981 Lisp_Subr *subr = XSUBR (fun);
2982 int max_args = subr->max_args;
2984 if (nargs < subr->min_args)
2985 goto wrong_number_of_arguments;
2987 if (max_args == UNEVALLED) /* Optimize for the common case */
2989 backtrace.evalargs = 0;
2990 val = (((Lisp_Object (*) (Lisp_Object)) subr_function (subr))
2993 else if (nargs <= max_args)
2995 struct gcpro gcpro1;
2996 Lisp_Object args[SUBR_MAX_ARGS];
2997 REGISTER Lisp_Object *p = args;
3003 REGISTER Lisp_Object arg;
3004 LIST_LOOP_2 (arg, original_args)
3011 /* &optional args default to nil. */
3012 while (p - args < max_args)
3015 backtrace.args = args;
3016 backtrace.nargs = nargs;
3018 FUNCALL_SUBR (val, subr, args, max_args);
3022 else if (max_args == MANY)
3024 /* Pass a vector of evaluated arguments */
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;
3044 val = (((Lisp_Object (*) (int, Lisp_Object *)) subr_function (subr))
3051 wrong_number_of_arguments:
3052 val = signal_wrong_number_of_arguments_error (original_fun, nargs);
3055 else if (COMPILED_FUNCTIONP (fun))
3057 struct gcpro gcpro1;
3058 Lisp_Object *args = alloca_array (Lisp_Object, nargs);
3059 REGISTER Lisp_Object *p = args;
3065 REGISTER Lisp_Object arg;
3066 LIST_LOOP_2 (arg, original_args)
3073 backtrace.args = args;
3074 backtrace.nargs = nargs;
3075 backtrace.evalargs = 0;
3077 val = funcall_compiled_function (fun, nargs, args);
3079 /* Do the debug-on-exit now, while args is still GCPROed. */
3080 if (backtrace.debug_on_exit)
3081 val = do_debug_on_exit (val);
3082 /* Don't do it again when we return to eval. */
3083 backtrace.debug_on_exit = 0;
3087 else if (CONSP (fun))
3089 Lisp_Object funcar = XCAR (fun);
3091 if (EQ (funcar, Qautoload))
3093 do_autoload (fun, original_fun);
3096 else if (EQ (funcar, Qmacro))
3098 val = Feval (apply1 (XCDR (fun), original_args));
3100 else if (EQ (funcar, Qlambda))
3102 struct gcpro gcpro1;
3103 Lisp_Object *args = alloca_array (Lisp_Object, nargs);
3104 REGISTER Lisp_Object *p = args;
3110 REGISTER Lisp_Object arg;
3111 LIST_LOOP_2 (arg, original_args)
3120 backtrace.args = args; /* this also GCPROs `args' */
3121 backtrace.nargs = nargs;
3122 backtrace.evalargs = 0;
3124 val = funcall_lambda (fun, nargs, args);
3126 /* Do the debug-on-exit now, while args is still GCPROed. */
3127 if (backtrace.debug_on_exit)
3128 val = do_debug_on_exit (val);
3129 /* Don't do it again when we return to eval. */
3130 backtrace.debug_on_exit = 0;
3134 goto invalid_function;
3137 else /* ! (SUBRP (fun) || COMPILED_FUNCTIONP (fun) || CONSP (fun)) */
3140 val = signal_invalid_function_error (fun);
3144 if (backtrace.debug_on_exit)
3145 val = do_debug_on_exit (val);
3146 POP_BACKTRACE (backtrace);
3151 DEFUN ("funcall", Ffuncall, 1, MANY, 0, /*
3152 Call first argument as a function, passing the remaining arguments to it.
3153 Thus, (funcall 'cons 'x 'y) returns (x . y).
3155 (int nargs, Lisp_Object *args))
3157 /* This function can GC */
3160 struct backtrace backtrace;
3161 int fun_nargs = nargs - 1;
3162 Lisp_Object *fun_args = args + 1;
3165 if ((consing_since_gc > gc_cons_threshold) || always_gc)
3166 /* Callers should gcpro lexpr args */
3167 garbage_collect_1 ();
3169 if (++lisp_eval_depth > max_lisp_eval_depth)
3171 if (max_lisp_eval_depth < 100)
3172 max_lisp_eval_depth = 100;
3173 if (lisp_eval_depth > max_lisp_eval_depth)
3174 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
3177 backtrace.pdlcount = specpdl_depth();
3178 backtrace.function = &args[0];
3179 backtrace.args = fun_args;
3180 backtrace.nargs = fun_nargs;
3181 backtrace.evalargs = 0;
3182 backtrace.debug_on_exit = 0;
3183 PUSH_BACKTRACE (backtrace);
3185 if (debug_on_next_call)
3186 do_debug_on_call (Qlambda);
3192 /* It might be useful to place this *after* all the checks. */
3193 if (profiling_active)
3194 profile_increase_call_count (fun);
3196 /* We could call indirect_function directly, but profiling shows
3197 this is worth optimizing by partially unrolling the loop. */
3200 fun = XSYMBOL (fun)->function;
3203 fun = XSYMBOL (fun)->function;
3205 fun = indirect_function (fun, 1);
3211 Lisp_Subr *subr = XSUBR (fun);
3212 int max_args = subr->max_args;
3213 Lisp_Object spacious_args[SUBR_MAX_ARGS];
3215 if (fun_nargs == max_args) /* Optimize for the common case */
3218 FUNCALL_SUBR (val, subr, fun_args, max_args);
3220 else if (fun_nargs < subr->min_args)
3222 goto wrong_number_of_arguments;
3224 else if (fun_nargs < max_args)
3226 Lisp_Object *p = spacious_args;
3228 /* Default optionals to nil */
3231 while (p - spacious_args < max_args)
3234 fun_args = spacious_args;
3237 else if (max_args == MANY)
3239 val = SUBR_FUNCTION (subr, MANY) (fun_nargs, fun_args);
3241 else if (max_args == UNEVALLED) /* Can't funcall a special form */
3243 goto invalid_function;
3247 wrong_number_of_arguments:
3248 val = signal_wrong_number_of_arguments_error (fun, fun_nargs);
3251 else if (COMPILED_FUNCTIONP (fun))
3253 val = funcall_compiled_function (fun, fun_nargs, fun_args);
3255 else if (CONSP (fun))
3257 Lisp_Object funcar = XCAR (fun);
3259 if (EQ (funcar, Qlambda))
3261 val = funcall_lambda (fun, fun_nargs, fun_args);
3263 else if (EQ (funcar, Qautoload))
3265 do_autoload (fun, args[0]);
3268 else /* Can't funcall a macro */
3270 goto invalid_function;
3273 else if (UNBOUNDP (fun))
3275 val = signal_void_function_error (args[0]);
3280 val = signal_invalid_function_error (fun);
3284 if (backtrace.debug_on_exit)
3285 val = do_debug_on_exit (val);
3286 POP_BACKTRACE (backtrace);
3290 DEFUN ("functionp", Ffunctionp, 1, 1, 0, /*
3291 Return t if OBJECT can be called as a function, else nil.
3292 A function is an object that can be applied to arguments,
3293 using for example `funcall' or `apply'.
3297 if (SYMBOLP (object))
3298 object = indirect_function (object, 0);
3302 COMPILED_FUNCTIONP (object) ||
3304 (EQ (XCAR (object), Qlambda) ||
3305 EQ (XCAR (object), Qautoload))))
3310 function_argcount (Lisp_Object function, int function_min_args_p)
3312 Lisp_Object orig_function = function;
3313 Lisp_Object arglist;
3317 if (SYMBOLP (function))
3318 function = indirect_function (function, 1);
3320 if (SUBRP (function))
3322 return function_min_args_p ?
3323 Fsubr_min_args (function):
3324 Fsubr_max_args (function);
3326 else if (COMPILED_FUNCTIONP (function))
3328 arglist = compiled_function_arglist (XCOMPILED_FUNCTION (function));
3330 else if (CONSP (function))
3332 Lisp_Object funcar = XCAR (function);
3334 if (EQ (funcar, Qmacro))
3336 function = XCDR (function);
3339 else if (EQ (funcar, Qautoload))
3341 do_autoload (function, orig_function);
3344 else if (EQ (funcar, Qlambda))
3346 arglist = Fcar (XCDR (function));
3350 goto invalid_function;
3356 return signal_invalid_function_error (function);
3363 EXTERNAL_LIST_LOOP_2 (arg, arglist)
3365 if (EQ (arg, Qand_optional))
3367 if (function_min_args_p)
3370 else if (EQ (arg, Qand_rest))
3372 if (function_min_args_p)
3383 return make_int (argcount);
3387 DEFUN ("function-min-args", Ffunction_min_args, 1, 1, 0, /*
3388 Return the number of arguments a function may be called with.
3389 The function may be any form that can be passed to `funcall',
3390 any special form, or any macro.
3394 return function_argcount (function, 1);
3397 DEFUN ("function-max-args", Ffunction_max_args, 1, 1, 0, /*
3398 Return the number of arguments a function may be called with.
3399 The function may be any form that can be passed to `funcall',
3400 any special form, or any macro.
3401 If the function takes an arbitrary number of arguments or is
3402 a built-in special form, nil is returned.
3406 return function_argcount (function, 0);
3410 DEFUN ("apply", Fapply, 2, MANY, 0, /*
3411 Call FUNCTION with the remaining args, using the last arg as a list of args.
3412 Thus, (apply '+ 1 2 '(3 4)) returns 10.
3414 (int nargs, Lisp_Object *args))
3416 /* This function can GC */
3417 Lisp_Object fun = args[0];
3418 Lisp_Object spread_arg = args [nargs - 1];
3422 GET_EXTERNAL_LIST_LENGTH (spread_arg, numargs);
3425 /* (apply foo 0 1 '()) */
3426 return Ffuncall (nargs - 1, args);
3427 else if (numargs == 1)
3429 /* (apply foo 0 1 '(2)) */
3430 args [nargs - 1] = XCAR (spread_arg);
3431 return Ffuncall (nargs, args);
3434 /* -1 for function, -1 for spread arg */
3435 numargs = nargs - 2 + numargs;
3436 /* +1 for function */
3437 funcall_nargs = 1 + numargs;
3440 fun = indirect_function (fun, 0);
3444 Lisp_Subr *subr = XSUBR (fun);
3445 int max_args = subr->max_args;
3447 if (numargs < subr->min_args
3448 || (max_args >= 0 && max_args < numargs))
3450 /* Let funcall get the error */
3452 else if (max_args > numargs)
3454 /* Avoid having funcall cons up yet another new vector of arguments
3455 by explicitly supplying nil's for optional values */
3456 funcall_nargs += (max_args - numargs);
3459 else if (UNBOUNDP (fun))
3461 /* Let funcall get the error */
3467 Lisp_Object *funcall_args = alloca_array (Lisp_Object, funcall_nargs);
3468 struct gcpro gcpro1;
3470 GCPRO1 (*funcall_args);
3471 gcpro1.nvars = funcall_nargs;
3473 /* Copy in the unspread args */
3474 memcpy (funcall_args, args, (nargs - 1) * sizeof (Lisp_Object));
3475 /* Spread the last arg we got. Its first element goes in
3476 the slot that it used to occupy, hence this value of I. */
3478 !NILP (spread_arg); /* i < 1 + numargs */
3479 i++, spread_arg = XCDR (spread_arg))
3481 funcall_args [i] = XCAR (spread_arg);
3483 /* Supply nil for optional args (to subrs) */
3484 for (; i < funcall_nargs; i++)
3485 funcall_args[i] = Qnil;
3488 RETURN_UNGCPRO (Ffuncall (funcall_nargs, funcall_args));
3493 /* Apply lambda list FUN to the NARGS evaluated arguments in ARGS and
3494 return the result of evaluation. */
3497 funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object args[])
3499 /* This function can GC */
3500 Lisp_Object symbol, arglist, body, tail;
3501 int speccount = specpdl_depth();
3507 goto invalid_function;
3509 arglist = XCAR (tail);
3513 int optional = 0, rest = 0;
3515 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
3517 if (!SYMBOLP (symbol))
3518 goto invalid_function;
3519 if (EQ (symbol, Qand_rest))
3521 else if (EQ (symbol, Qand_optional))
3525 specbind (symbol, Flist (nargs - i, &args[i]));
3529 specbind (symbol, args[i++]);
3531 goto wrong_number_of_arguments;
3533 specbind (symbol, Qnil);
3538 goto wrong_number_of_arguments;
3540 return unbind_to (speccount, Fprogn (body));
3542 wrong_number_of_arguments:
3543 return signal_wrong_number_of_arguments_error (fun, nargs);
3546 return signal_invalid_function_error (fun);
3550 /************************************************************************/
3551 /* Run hook variables in various ways. */
3552 /************************************************************************/
3554 DEFUN ("run-hooks", Frun_hooks, 1, MANY, 0, /*
3555 Run each hook in HOOKS. Major mode functions use this.
3556 Each argument should be a symbol, a hook variable.
3557 These symbols are processed in the order specified.
3558 If a hook symbol has a non-nil value, that value may be a function
3559 or a list of functions to be called to run the hook.
3560 If the value is a function, it is called with no arguments.
3561 If it is a list, the elements are called, in order, with no arguments.
3563 To make a hook variable buffer-local, use `make-local-hook',
3564 not `make-local-variable'.
3566 (int nargs, Lisp_Object *args))
3570 for (i = 0; i < nargs; i++)
3571 run_hook_with_args (1, args + i, RUN_HOOKS_TO_COMPLETION);
3576 DEFUN ("run-hook-with-args", Frun_hook_with_args, 1, MANY, 0, /*
3577 Run HOOK with the specified arguments ARGS.
3578 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
3579 value, that value may be a function or a list of functions to be
3580 called to run the hook. If the value is a function, it is called with
3581 the given arguments and its return value is returned. If it is a list
3582 of functions, those functions are called, in order,
3583 with the given arguments ARGS.
3584 It is best not to depend on the value return by `run-hook-with-args',
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_TO_COMPLETION);
3595 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success, 1, MANY, 0, /*
3596 Run HOOK with the specified arguments ARGS.
3597 HOOK should be a symbol, a hook variable. Its value should
3598 be a list of functions. We call those functions, one by one,
3599 passing arguments ARGS to each of them, until one of them
3600 returns a non-nil value. Then we return that value.
3601 If all the functions return nil, we return nil.
3603 To make a hook variable buffer-local, use `make-local-hook',
3604 not `make-local-variable'.
3606 (int nargs, Lisp_Object *args))
3608 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_SUCCESS);
3611 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure, 1, MANY, 0, /*
3612 Run HOOK with the specified arguments ARGS.
3613 HOOK should be a symbol, a hook variable. Its value should
3614 be a list of functions. We call those functions, one by one,
3615 passing arguments ARGS to each of them, until one of them
3616 returns nil. Then we return nil.
3617 If all the functions return non-nil, we return non-nil.
3619 To make a hook variable buffer-local, use `make-local-hook',
3620 not `make-local-variable'.
3622 (int nargs, Lisp_Object *args))
3624 return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_FAILURE);
3627 /* ARGS[0] should be a hook symbol.
3628 Call each of the functions in the hook value, passing each of them
3629 as arguments all the rest of ARGS (all NARGS - 1 elements).
3630 COND specifies a condition to test after each call
3631 to decide whether to stop.
3632 The caller (or its caller, etc) must gcpro all of ARGS,
3633 except that it isn't necessary to gcpro ARGS[0]. */
3636 run_hook_with_args_in_buffer (struct buffer *buf, int nargs, Lisp_Object *args,
3637 enum run_hooks_condition cond)
3639 Lisp_Object sym, val, ret;
3641 if (!initialized || preparing_for_armageddon)
3642 /* We need to bail out of here pronto. */
3645 /* Whenever gc_in_progress is true, preparing_for_armageddon
3646 will also be true unless something is really hosed. */
3647 assert (!gc_in_progress);
3650 val = symbol_value_in_buffer (sym, make_buffer (buf));
3651 ret = (cond == RUN_HOOKS_UNTIL_FAILURE ? Qt : Qnil);
3653 if (UNBOUNDP (val) || NILP (val))
3655 else if (!CONSP (val) || EQ (XCAR (val), Qlambda))
3658 return Ffuncall (nargs, args);
3662 struct gcpro gcpro1, gcpro2, gcpro3;
3663 Lisp_Object globals = Qnil;
3664 GCPRO3 (sym, val, globals);
3667 CONSP (val) && ((cond == RUN_HOOKS_TO_COMPLETION)
3668 || (cond == RUN_HOOKS_UNTIL_SUCCESS ? NILP (ret)
3672 if (EQ (XCAR (val), Qt))
3674 /* t indicates this hook has a local binding;
3675 it means to run the global binding too. */
3676 globals = Fdefault_value (sym);
3678 if ((! CONSP (globals) || EQ (XCAR (globals), Qlambda)) &&
3682 ret = Ffuncall (nargs, args);
3687 CONSP (globals) && ((cond == RUN_HOOKS_TO_COMPLETION)
3688 || (cond == RUN_HOOKS_UNTIL_SUCCESS
3691 globals = XCDR (globals))
3693 args[0] = XCAR (globals);
3694 /* In a global value, t should not occur. If it does, we
3695 must ignore it to avoid an endless loop. */
3696 if (!EQ (args[0], Qt))
3697 ret = Ffuncall (nargs, args);
3703 args[0] = XCAR (val);
3704 ret = Ffuncall (nargs, args);
3714 run_hook_with_args (int nargs, Lisp_Object *args,
3715 enum run_hooks_condition cond)
3717 return run_hook_with_args_in_buffer (current_buffer, nargs, args, cond);
3722 /* From FSF 19.30, not currently used */
3724 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
3725 present value of that symbol.
3726 Call each element of FUNLIST,
3727 passing each of them the rest of ARGS.
3728 The caller (or its caller, etc) must gcpro all of ARGS,
3729 except that it isn't necessary to gcpro ARGS[0]. */
3732 run_hook_list_with_args (Lisp_Object funlist, int nargs, Lisp_Object *args)
3734 Lisp_Object sym = args[0];
3736 struct gcpro gcpro1, gcpro2;
3740 for (val = funlist; CONSP (val); val = XCDR (val))
3742 if (EQ (XCAR (val), Qt))
3744 /* t indicates this hook has a local binding;
3745 it means to run the global binding too. */
3746 Lisp_Object globals;
3748 for (globals = Fdefault_value (sym);
3750 globals = XCDR (globals))
3752 args[0] = XCAR (globals);
3753 /* In a global value, t should not occur. If it does, we
3754 must ignore it to avoid an endless loop. */
3755 if (!EQ (args[0], Qt))
3756 Ffuncall (nargs, args);
3761 args[0] = XCAR (val);
3762 Ffuncall (nargs, args);
3772 va_run_hook_with_args (Lisp_Object hook_var, int nargs, ...)
3774 /* This function can GC */
3775 struct gcpro gcpro1;
3778 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs);
3780 va_start (vargs, nargs);
3781 funcall_args[0] = hook_var;
3782 for (i = 0; i < nargs; i++)
3783 funcall_args[i + 1] = va_arg (vargs, Lisp_Object);
3786 GCPRO1 (*funcall_args);
3787 gcpro1.nvars = nargs + 1;
3788 run_hook_with_args (nargs + 1, funcall_args, RUN_HOOKS_TO_COMPLETION);
3793 va_run_hook_with_args_in_buffer (struct buffer *buf, Lisp_Object hook_var,
3796 /* This function can GC */
3797 struct gcpro gcpro1;
3800 Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs);
3802 va_start (vargs, nargs);
3803 funcall_args[0] = hook_var;
3804 for (i = 0; i < nargs; i++)
3805 funcall_args[i + 1] = va_arg (vargs, Lisp_Object);
3808 GCPRO1 (*funcall_args);
3809 gcpro1.nvars = nargs + 1;
3810 run_hook_with_args_in_buffer (buf, nargs + 1, funcall_args,
3811 RUN_HOOKS_TO_COMPLETION);
3816 run_hook (Lisp_Object hook)
3818 Frun_hooks (1, &hook);
3823 /************************************************************************/
3824 /* Front-ends to eval, funcall, apply */
3825 /************************************************************************/
3827 /* Apply fn to arg */
3829 apply1 (Lisp_Object fn, Lisp_Object arg)
3831 /* This function can GC */
3832 struct gcpro gcpro1;
3833 Lisp_Object args[2];
3836 return Ffuncall (1, &fn);
3841 RETURN_UNGCPRO (Fapply (2, args));
3844 /* Call function fn on no arguments */
3846 call0 (Lisp_Object fn)
3848 /* This function can GC */
3849 struct gcpro gcpro1;
3852 RETURN_UNGCPRO (Ffuncall (1, &fn));
3855 /* Call function fn with argument arg0 */
3857 call1 (Lisp_Object fn,
3860 /* This function can GC */
3861 struct gcpro gcpro1;
3862 Lisp_Object args[2];
3867 RETURN_UNGCPRO (Ffuncall (2, args));
3870 /* Call function fn with arguments arg0, arg1 */
3872 call2 (Lisp_Object fn,
3873 Lisp_Object arg0, Lisp_Object arg1)
3875 /* This function can GC */
3876 struct gcpro gcpro1;
3877 Lisp_Object args[3];
3883 RETURN_UNGCPRO (Ffuncall (3, args));
3886 /* Call function fn with arguments arg0, arg1, arg2 */
3888 call3 (Lisp_Object fn,
3889 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2)
3891 /* This function can GC */
3892 struct gcpro gcpro1;
3893 Lisp_Object args[4];
3900 RETURN_UNGCPRO (Ffuncall (4, args));
3903 /* Call function fn with arguments arg0, arg1, arg2, arg3 */
3905 call4 (Lisp_Object fn,
3906 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3909 /* This function can GC */
3910 struct gcpro gcpro1;
3911 Lisp_Object args[5];
3919 RETURN_UNGCPRO (Ffuncall (5, args));
3922 /* Call function fn with arguments arg0, arg1, arg2, arg3, arg4 */
3924 call5 (Lisp_Object fn,
3925 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3926 Lisp_Object arg3, Lisp_Object arg4)
3928 /* This function can GC */
3929 struct gcpro gcpro1;
3930 Lisp_Object args[6];
3939 RETURN_UNGCPRO (Ffuncall (6, args));
3943 call6 (Lisp_Object fn,
3944 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3945 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5)
3947 /* This function can GC */
3948 struct gcpro gcpro1;
3949 Lisp_Object args[7];
3959 RETURN_UNGCPRO (Ffuncall (7, args));
3963 call7 (Lisp_Object fn,
3964 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3965 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5,
3968 /* This function can GC */
3969 struct gcpro gcpro1;
3970 Lisp_Object args[8];
3981 RETURN_UNGCPRO (Ffuncall (8, args));
3985 call8 (Lisp_Object fn,
3986 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3987 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5,
3988 Lisp_Object arg6, Lisp_Object arg7)
3990 /* This function can GC */
3991 struct gcpro gcpro1;
3992 Lisp_Object args[9];
4004 RETURN_UNGCPRO (Ffuncall (9, args));
4008 call0_in_buffer (struct buffer *buf, Lisp_Object fn)
4010 if (current_buffer == buf)
4015 int speccount = specpdl_depth();
4016 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4017 set_buffer_internal (buf);
4019 unbind_to (speccount, Qnil);
4025 call1_in_buffer (struct buffer *buf, Lisp_Object fn,
4028 if (current_buffer == buf)
4029 return call1 (fn, arg0);
4033 int speccount = specpdl_depth();
4034 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4035 set_buffer_internal (buf);
4036 val = call1 (fn, arg0);
4037 unbind_to (speccount, Qnil);
4043 call2_in_buffer (struct buffer *buf, Lisp_Object fn,
4044 Lisp_Object arg0, Lisp_Object arg1)
4046 if (current_buffer == buf)
4047 return call2 (fn, arg0, arg1);
4051 int speccount = specpdl_depth();
4052 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4053 set_buffer_internal (buf);
4054 val = call2 (fn, arg0, arg1);
4055 unbind_to (speccount, Qnil);
4061 call3_in_buffer (struct buffer *buf, Lisp_Object fn,
4062 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2)
4064 if (current_buffer == buf)
4065 return call3 (fn, arg0, arg1, arg2);
4069 int speccount = specpdl_depth();
4070 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4071 set_buffer_internal (buf);
4072 val = call3 (fn, arg0, arg1, arg2);
4073 unbind_to (speccount, Qnil);
4079 call4_in_buffer (struct buffer *buf, Lisp_Object fn,
4080 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4083 if (current_buffer == buf)
4084 return call4 (fn, arg0, arg1, arg2, arg3);
4088 int speccount = specpdl_depth();
4089 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4090 set_buffer_internal (buf);
4091 val = call4 (fn, arg0, arg1, arg2, arg3);
4092 unbind_to (speccount, Qnil);
4098 eval_in_buffer (struct buffer *buf, Lisp_Object form)
4100 if (current_buffer == buf)
4101 return Feval (form);
4105 int speccount = specpdl_depth();
4106 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4107 set_buffer_internal (buf);
4109 unbind_to (speccount, Qnil);
4115 /************************************************************************/
4116 /* Error-catching front-ends to eval, funcall, apply */
4117 /************************************************************************/
4119 /* Call function fn on no arguments, with condition handler */
4121 call0_with_handler (Lisp_Object handler, Lisp_Object fn)
4123 /* This function can GC */
4124 struct gcpro gcpro1;
4125 Lisp_Object args[2];
4130 RETURN_UNGCPRO (Fcall_with_condition_handler (2, args));
4133 /* Call function fn with argument arg0, with condition handler */
4135 call1_with_handler (Lisp_Object handler, Lisp_Object fn,
4138 /* This function can GC */
4139 struct gcpro gcpro1;
4140 Lisp_Object args[3];
4146 RETURN_UNGCPRO (Fcall_with_condition_handler (3, args));
4150 /* The following functions provide you with error-trapping versions
4151 of the various front-ends above. They take an additional
4152 "warning_string" argument; if non-zero, a warning with this
4153 string and the actual error that occurred will be displayed
4154 in the *Warnings* buffer if an error occurs. In all cases,
4155 QUIT is inhibited while these functions are running, and if
4156 an error occurs, Qunbound is returned instead of the normal
4160 /* #### This stuff needs to catch throws as well. We need to
4161 improve internal_catch() so it can take a "catch anything"
4162 argument similar to Qt or Qerror for condition_case_1(). */
4165 caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg)
4167 if (!NILP (errordata))
4169 Lisp_Object args[2];
4173 char *str = (char *) get_opaque_ptr (arg);
4174 args[0] = build_string (str);
4177 args[0] = build_string ("error");
4178 /* #### This should call
4179 (with-output-to-string (display-error errordata))
4180 but that stuff is all in Lisp currently. */
4181 args[1] = errordata;
4182 warn_when_safe_lispobj
4184 emacs_doprnt_string_lisp ((const Bufbyte *) "%s: %s",
4185 Qnil, -1, 2, args));
4191 allow_quit_caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg)
4193 if (CONSP (errordata) && EQ (XCAR (errordata), Qquit))
4194 return Fsignal (Qquit, XCDR (errordata));
4195 return caught_a_squirmer (errordata, arg);
4199 safe_run_hook_caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg)
4201 Lisp_Object hook = Fcar (arg);
4203 /* Clear out the hook. */
4205 return caught_a_squirmer (errordata, arg);
4209 allow_quit_safe_run_hook_caught_a_squirmer (Lisp_Object errordata,
4212 Lisp_Object hook = Fcar (arg);
4214 if (!CONSP (errordata) || !EQ (XCAR (errordata), Qquit))
4215 /* Clear out the hook. */
4217 return allow_quit_caught_a_squirmer (errordata, arg);
4221 catch_them_squirmers_eval_in_buffer (Lisp_Object cons)
4223 return eval_in_buffer (XBUFFER (XCAR (cons)), XCDR (cons));
4227 eval_in_buffer_trapping_errors (const char *warning_string,
4228 struct buffer *buf, Lisp_Object form)
4230 int speccount = specpdl_depth();
4235 struct gcpro gcpro1, gcpro2;
4237 XSETBUFFER (buffer, buf);
4239 specbind (Qinhibit_quit, Qt);
4240 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4242 cons = noseeum_cons (buffer, form);
4243 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
4244 GCPRO2 (cons, opaque);
4245 /* Qerror not Qt, so you can get a backtrace */
4246 tem = condition_case_1 (Qerror,
4247 catch_them_squirmers_eval_in_buffer, cons,
4248 caught_a_squirmer, opaque);
4249 free_cons (XCONS (cons));
4250 if (OPAQUE_PTRP (opaque))
4251 free_opaque_ptr (opaque);
4254 /* gc_currently_forbidden = 0; */
4255 return unbind_to (speccount, tem);
4259 catch_them_squirmers_run_hook (Lisp_Object hook_symbol)
4261 /* This function can GC */
4262 run_hook (hook_symbol);
4267 run_hook_trapping_errors (const char *warning_string, Lisp_Object hook_symbol)
4272 struct gcpro gcpro1;
4274 if (!initialized || preparing_for_armageddon)
4276 tem = find_symbol_value (hook_symbol);
4277 if (NILP (tem) || UNBOUNDP (tem))
4280 speccount = specpdl_depth();
4281 specbind (Qinhibit_quit, Qt);
4283 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
4285 /* Qerror not Qt, so you can get a backtrace */
4286 tem = condition_case_1 (Qerror,
4287 catch_them_squirmers_run_hook, hook_symbol,
4288 caught_a_squirmer, opaque);
4289 if (OPAQUE_PTRP (opaque))
4290 free_opaque_ptr (opaque);
4293 return unbind_to (speccount, tem);
4296 /* Same as run_hook_trapping_errors() but also set the hook to nil
4297 if an error occurs. */
4300 safe_run_hook_trapping_errors (const char *warning_string,
4301 Lisp_Object hook_symbol,
4304 int speccount = specpdl_depth();
4306 Lisp_Object cons = Qnil;
4307 struct gcpro gcpro1;
4309 if (!initialized || preparing_for_armageddon)
4311 tem = find_symbol_value (hook_symbol);
4312 if (NILP (tem) || UNBOUNDP (tem))
4316 specbind (Qinhibit_quit, Qt);
4318 cons = noseeum_cons (hook_symbol,
4319 warning_string ? make_opaque_ptr ((void *)warning_string)
4322 /* Qerror not Qt, so you can get a backtrace */
4323 tem = condition_case_1 (Qerror,
4324 catch_them_squirmers_run_hook,
4327 allow_quit_safe_run_hook_caught_a_squirmer :
4328 safe_run_hook_caught_a_squirmer,
4330 if (OPAQUE_PTRP (XCDR (cons)))
4331 free_opaque_ptr (XCDR (cons));
4332 free_cons (XCONS (cons));
4335 return unbind_to (speccount, tem);
4339 catch_them_squirmers_call0 (Lisp_Object function)
4341 /* This function can GC */
4342 return call0 (function);
4346 call0_trapping_errors (const char *warning_string, Lisp_Object function)
4350 Lisp_Object opaque = Qnil;
4351 struct gcpro gcpro1, gcpro2;
4353 if (SYMBOLP (function))
4355 tem = XSYMBOL (function)->function;
4356 if (NILP (tem) || UNBOUNDP (tem))
4360 GCPRO2 (opaque, function);
4361 speccount = specpdl_depth();
4362 specbind (Qinhibit_quit, Qt);
4363 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4365 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
4366 /* Qerror not Qt, so you can get a backtrace */
4367 tem = condition_case_1 (Qerror,
4368 catch_them_squirmers_call0, function,
4369 caught_a_squirmer, opaque);
4370 if (OPAQUE_PTRP (opaque))
4371 free_opaque_ptr (opaque);
4374 /* gc_currently_forbidden = 0; */
4375 return unbind_to (speccount, tem);
4379 catch_them_squirmers_call1 (Lisp_Object cons)
4381 /* This function can GC */
4382 return call1 (XCAR (cons), XCDR (cons));
4386 catch_them_squirmers_call2 (Lisp_Object cons)
4388 /* This function can GC */
4389 return call2 (XCAR (cons), XCAR (XCDR (cons)), XCAR (XCDR (XCDR (cons))));
4393 call1_trapping_errors (const char *warning_string, Lisp_Object function,
4396 int speccount = specpdl_depth();
4398 Lisp_Object cons = Qnil;
4399 Lisp_Object opaque = Qnil;
4400 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
4402 if (SYMBOLP (function))
4404 tem = XSYMBOL (function)->function;
4405 if (NILP (tem) || UNBOUNDP (tem))
4409 GCPRO4 (cons, opaque, function, object);
4411 specbind (Qinhibit_quit, Qt);
4412 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4414 cons = noseeum_cons (function, object);
4415 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
4416 /* Qerror not Qt, so you can get a backtrace */
4417 tem = condition_case_1 (Qerror,
4418 catch_them_squirmers_call1, cons,
4419 caught_a_squirmer, opaque);
4420 if (OPAQUE_PTRP (opaque))
4421 free_opaque_ptr (opaque);
4422 free_cons (XCONS (cons));
4425 /* gc_currently_forbidden = 0; */
4426 return unbind_to (speccount, tem);
4430 call2_trapping_errors (const char *warning_string, Lisp_Object function,
4431 Lisp_Object object1, Lisp_Object object2)
4433 int speccount = specpdl_depth();
4435 Lisp_Object cons = Qnil;
4436 Lisp_Object opaque = Qnil;
4437 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
4439 if (SYMBOLP (function))
4441 tem = XSYMBOL (function)->function;
4442 if (NILP (tem) || UNBOUNDP (tem))
4446 GCPRO5 (cons, opaque, function, object1, object2);
4447 specbind (Qinhibit_quit, Qt);
4448 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4450 cons = list3 (function, object1, object2);
4451 opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
4452 /* Qerror not Qt, so you can get a backtrace */
4453 tem = condition_case_1 (Qerror,
4454 catch_them_squirmers_call2, cons,
4455 caught_a_squirmer, opaque);
4456 if (OPAQUE_PTRP (opaque))
4457 free_opaque_ptr (opaque);
4461 /* gc_currently_forbidden = 0; */
4462 return unbind_to (speccount, tem);
4466 /************************************************************************/
4467 /* The special binding stack */
4468 /* Most C code should simply use specbind() and unbind_to(). */
4469 /* When performance is critical, use the macros in backtrace.h. */
4470 /************************************************************************/
4472 #define min_max_specpdl_size 400
4475 grow_specpdl (size_t reserved)
4477 size_t size_needed = specpdl_depth() + reserved;
4478 if (size_needed >= max_specpdl_size)
4480 if (max_specpdl_size < min_max_specpdl_size)
4481 max_specpdl_size = min_max_specpdl_size;
4482 if (size_needed >= max_specpdl_size)
4484 if (!NILP (Vdebug_on_error) ||
4485 !NILP (Vdebug_on_signal))
4486 /* Leave room for some specpdl in the debugger. */
4487 max_specpdl_size = size_needed + 100;
4489 ("Variable binding depth exceeds max-specpdl-size");
4492 while (specpdl_size < size_needed)
4495 if (specpdl_size > max_specpdl_size)
4496 specpdl_size = max_specpdl_size;
4498 XREALLOC_ARRAY (specpdl, struct specbinding, specpdl_size);
4499 specpdl_ptr = specpdl + specpdl_depth();
4503 /* Handle unbinding buffer-local variables */
4505 specbind_unwind_local (Lisp_Object ovalue)
4507 Lisp_Object current = Fcurrent_buffer ();
4508 Lisp_Object symbol = specpdl_ptr->symbol;
4509 Lisp_Cons *victim = XCONS (ovalue);
4510 Lisp_Object buf = get_buffer (victim->car, 0);
4511 ovalue = victim->cdr;
4517 /* Deleted buffer -- do nothing */
4519 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buf)) == 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 (buf, current))
4527 Fset (symbol, ovalue);
4530 /* Urk! Somebody switched buffers */
4531 struct gcpro gcpro1;
4534 Fset (symbol, ovalue);
4535 Fset_buffer (current);
4542 specbind_unwind_wasnt_local (Lisp_Object buffer)
4544 Lisp_Object current = Fcurrent_buffer ();
4545 Lisp_Object symbol = specpdl_ptr->symbol;
4547 buffer = get_buffer (buffer, 0);
4550 /* Deleted buffer -- do nothing */
4552 else if (symbol_value_buffer_local_info (symbol, XBUFFER (buffer)) == 0)
4554 /* Was buffer-local when binding was made, now no longer is.
4555 * (kill-local-variable can do this.)
4556 * Do nothing in this case.
4559 else if (EQ (buffer, current))
4560 Fkill_local_variable (symbol);
4563 /* Urk! Somebody switched buffers */
4564 struct gcpro gcpro1;
4566 Fset_buffer (buffer);
4567 Fkill_local_variable (symbol);
4568 Fset_buffer (current);
4576 specbind (Lisp_Object symbol, Lisp_Object value)
4578 SPECBIND (symbol, value);
4582 specbind_magic (Lisp_Object symbol, Lisp_Object value)
4585 symbol_value_buffer_local_info (symbol, current_buffer);
4587 if (buffer_local == 0)
4589 specpdl_ptr->old_value = find_symbol_value (symbol);
4590 specpdl_ptr->func = 0; /* Handled specially by unbind_to */
4592 else if (buffer_local > 0)
4594 /* Already buffer-local */
4595 specpdl_ptr->old_value = noseeum_cons (Fcurrent_buffer (),
4596 find_symbol_value (symbol));
4597 specpdl_ptr->func = specbind_unwind_local;
4601 /* About to become buffer-local */
4602 specpdl_ptr->old_value = Fcurrent_buffer ();
4603 specpdl_ptr->func = specbind_unwind_wasnt_local;
4606 specpdl_ptr->symbol = symbol;
4608 specpdl_depth_counter++;
4610 Fset (symbol, value);
4614 record_unwind_protect (Lisp_Object (*function) (Lisp_Object arg),
4617 SPECPDL_RESERVE (1);
4618 specpdl_ptr->func = function;
4619 specpdl_ptr->symbol = Qnil;
4620 specpdl_ptr->old_value = arg;
4622 specpdl_depth_counter++;
4625 extern int check_sigio (void);
4627 /* Unwind the stack till specpdl_depth() == COUNT.
4628 VALUE is not used, except that, purely as a convenience to the
4629 caller, it is protected from garbage-protection. */
4631 unbind_to (int count, Lisp_Object value)
4633 UNBIND_TO_GCPRO (count, value);
4637 /* Don't call this directly.
4638 Only for use by UNBIND_TO* macros in backtrace.h */
4640 unbind_to_hairy (int count)
4645 ++specpdl_depth_counter;
4647 check_quit (); /* make Vquit_flag accurate */
4648 quitf = !NILP (Vquit_flag);
4651 while (specpdl_depth_counter != count)
4654 --specpdl_depth_counter;
4656 if (specpdl_ptr->func != 0)
4657 /* An unwind-protect */
4658 (*specpdl_ptr->func) (specpdl_ptr->old_value);
4661 /* We checked symbol for validity when we specbound it,
4662 so only need to call Fset if symbol has magic value. */
4663 Lisp_Symbol *sym = XSYMBOL (specpdl_ptr->symbol);
4664 if (!SYMBOL_VALUE_MAGIC_P (sym->value))
4665 sym->value = specpdl_ptr->old_value;
4667 Fset (specpdl_ptr->symbol, specpdl_ptr->old_value);
4671 #ifndef EXCEEDINGLY_QUESTIONABLE_CODE
4672 /* There should never be anything here for us to remove.
4673 If so, it indicates a logic error in Emacs. Catches
4674 should get removed when a throw or signal occurs, or
4675 when a catch or condition-case exits normally. But
4676 it's too dangerous to just remove this code. --ben */
4678 /* Furthermore, this code is not in FSFmacs!!!
4679 Braino on mly's part? */
4680 /* If we're unwound past the pdlcount of a catch frame,
4681 that catch can't possibly still be valid. */
4682 while (catchlist && catchlist->pdlcount > specpdl_depth_counter)
4684 catchlist = catchlist->next;
4685 /* Don't mess with gcprolist, backtrace_list here */
4696 /* Get the value of symbol's global binding, even if that binding is
4697 not now dynamically visible. May return Qunbound or magic values. */
4700 top_level_value (Lisp_Object symbol)
4702 REGISTER struct specbinding *ptr = specpdl;
4704 CHECK_SYMBOL (symbol);
4705 for (; ptr != specpdl_ptr; ptr++)
4707 if (EQ (ptr->symbol, symbol))
4708 return ptr->old_value;
4710 return XSYMBOL (symbol)->value;
4716 top_level_set (Lisp_Object symbol, Lisp_Object newval)
4718 REGISTER struct specbinding *ptr = specpdl;
4720 CHECK_SYMBOL (symbol);
4721 for (; ptr != specpdl_ptr; ptr++)
4723 if (EQ (ptr->symbol, symbol))
4725 ptr->old_value = newval;
4729 return Fset (symbol, newval);
4735 /************************************************************************/
4737 /************************************************************************/
4739 DEFUN ("backtrace-debug", Fbacktrace_debug, 2, 2, 0, /*
4740 Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
4741 The debugger is entered when that frame exits, if the flag is non-nil.
4745 REGISTER struct backtrace *backlist = backtrace_list;
4750 for (i = 0; backlist && i < XINT (level); i++)
4752 backlist = backlist->next;
4756 backlist->debug_on_exit = !NILP (flag);
4762 backtrace_specials (int speccount, int speclimit, Lisp_Object stream)
4764 int printing_bindings = 0;
4766 for (; speccount > speclimit; speccount--)
4768 if (specpdl[speccount - 1].func == 0
4769 || specpdl[speccount - 1].func == specbind_unwind_local
4770 || specpdl[speccount - 1].func == specbind_unwind_wasnt_local)
4772 write_c_string (((!printing_bindings) ? " # bind (" : " "),
4774 Fprin1 (specpdl[speccount - 1].symbol, stream);
4775 printing_bindings = 1;
4779 if (printing_bindings) write_c_string (")\n", stream);
4780 write_c_string (" # (unwind-protect ...)\n", stream);
4781 printing_bindings = 0;
4784 if (printing_bindings) write_c_string (")\n", stream);
4787 DEFUN ("backtrace", Fbacktrace, 0, 2, "", /*
4788 Print a trace of Lisp function calls currently active.
4789 Optional arg STREAM specifies the output stream to send the backtrace to,
4790 and defaults to the value of `standard-output'. Optional second arg
4791 DETAILED means show places where currently active variable bindings,
4792 catches, condition-cases, and unwind-protects were made as well as
4797 /* This function can GC */
4798 struct backtrace *backlist = backtrace_list;
4799 struct catchtag *catches = catchlist;
4800 int speccount = specpdl_depth();
4802 int old_nl = print_escape_newlines;
4803 int old_pr = print_readably;
4804 Lisp_Object old_level = Vprint_level;
4805 Lisp_Object oiq = Vinhibit_quit;
4806 struct gcpro gcpro1, gcpro2;
4808 /* We can't allow quits in here because that could cause the values
4809 of print_readably and print_escape_newlines to get screwed up.
4810 Normally we would use a record_unwind_protect but that would
4811 screw up the functioning of this function. */
4814 entering_debugger = 0;
4816 Vprint_level = make_int (3);
4818 print_escape_newlines = 1;
4820 GCPRO2 (stream, old_level);
4823 stream = Vstandard_output;
4824 if (!noninteractive && (NILP (stream) || EQ (stream, Qt)))
4825 stream = Fselected_frame (Qnil);
4829 if (!NILP (detailed) && catches && catches->backlist == backlist)
4831 int catchpdl = catches->pdlcount;
4832 if (speccount > catchpdl
4833 && specpdl[catchpdl].func == condition_case_unwind)
4834 /* This is a condition-case catchpoint */
4835 catchpdl = catchpdl + 1;
4837 backtrace_specials (speccount, catchpdl, stream);
4839 speccount = catches->pdlcount;
4840 if (catchpdl == speccount)
4842 write_c_string (" # (catch ", stream);
4843 Fprin1 (catches->tag, stream);
4844 write_c_string (" ...)\n", stream);
4848 write_c_string (" # (condition-case ... . ", stream);
4849 Fprin1 (Fcdr (Fcar (catches->tag)), stream);
4850 write_c_string (")\n", stream);
4852 catches = catches->next;
4858 if (!NILP (detailed) && backlist->pdlcount < speccount)
4860 backtrace_specials (speccount, backlist->pdlcount, stream);
4861 speccount = backlist->pdlcount;
4863 write_c_string (((backlist->debug_on_exit) ? "* " : " "),
4865 if (backlist->nargs == UNEVALLED)
4867 Fprin1 (Fcons (*backlist->function, *backlist->args), stream);
4868 write_c_string ("\n", stream); /* from FSFmacs 19.30 */
4872 Lisp_Object tem = *backlist->function;
4873 Fprin1 (tem, stream); /* This can QUIT */
4874 write_c_string ("(", stream);
4875 if (backlist->nargs == MANY)
4878 Lisp_Object tail = Qnil;
4879 struct gcpro ngcpro1;
4882 for (tail = *backlist->args, i = 0;
4884 tail = Fcdr (tail), i++)
4886 if (i != 0) write_c_string (" ", stream);
4887 Fprin1 (Fcar (tail), stream);
4894 for (i = 0; i < backlist->nargs; i++)
4896 if (!i && EQ(tem, Qbyte_code)) {
4897 write_c_string("\"...\"", stream);
4900 if (i != 0) write_c_string (" ", stream);
4901 Fprin1 (backlist->args[i], stream);
4905 write_c_string (")\n", stream);
4906 backlist = backlist->next;
4909 Vprint_level = old_level;
4910 print_readably = old_pr;
4911 print_escape_newlines = old_nl;
4913 Vinhibit_quit = oiq;
4918 DEFUN ("backtrace-frame", Fbacktrace_frame, 1, 1, "", /*
4919 Return the function and arguments N frames up from current execution point.
4920 If that frame has not evaluated the arguments yet (or is a special form),
4921 the value is (nil FUNCTION ARG-FORMS...).
4922 If that frame has evaluated its arguments and called its function already,
4923 the value is (t FUNCTION ARG-VALUES...).
4924 A &rest arg is represented as the tail of the list ARG-VALUES.
4925 FUNCTION is whatever was supplied as car of evaluated list,
4926 or a lambda expression for macro calls.
4927 If N is more than the number of frames, the value is nil.
4931 REGISTER struct backtrace *backlist = backtrace_list;
4935 CHECK_NATNUM (nframes);
4937 /* Find the frame requested. */
4938 for (i = XINT (nframes); backlist && (i-- > 0);)
4939 backlist = backlist->next;
4943 if (backlist->nargs == UNEVALLED)
4944 return Fcons (Qnil, Fcons (*backlist->function, *backlist->args));
4947 if (backlist->nargs == MANY)
4948 tem = *backlist->args;
4950 tem = Flist (backlist->nargs, backlist->args);
4952 return Fcons (Qt, Fcons (*backlist->function, tem));
4957 /************************************************************************/
4959 /************************************************************************/
4962 warn_when_safe_lispobj (Lisp_Object class, Lisp_Object level,
4965 obj = list1 (list3 (class, level, obj));
4966 if (NILP (Vpending_warnings))
4967 Vpending_warnings = Vpending_warnings_tail = obj;
4970 Fsetcdr (Vpending_warnings_tail, obj);
4971 Vpending_warnings_tail = obj;
4975 /* #### This should probably accept Lisp objects; but then we have
4976 to make sure that Feval() isn't called, since it might not be safe.
4978 An alternative approach is to just pass some non-string type of
4979 Lisp_Object to warn_when_safe_lispobj(); `prin1-to-string' will
4980 automatically be called when it is safe to do so. */
4983 warn_when_safe (Lisp_Object class, Lisp_Object level, const char *fmt, ...)
4988 va_start (args, fmt);
4989 obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt),
4993 warn_when_safe_lispobj (class, level, obj);
4999 /************************************************************************/
5000 /* Initialization */
5001 /************************************************************************/
5006 INIT_LRECORD_IMPLEMENTATION (subr);
5008 defsymbol (&Qinhibit_quit, "inhibit-quit");
5009 defsymbol (&Qautoload, "autoload");
5010 defsymbol (&Qdebug_on_error, "debug-on-error");
5011 defsymbol (&Qstack_trace_on_error, "stack-trace-on-error");
5012 defsymbol (&Qdebug_on_signal, "debug-on-signal");
5013 defsymbol (&Qstack_trace_on_signal, "stack-trace-on-signal");
5014 defsymbol (&Qdebugger, "debugger");
5015 defsymbol (&Qmacro, "macro");
5016 defsymbol (&Qand_rest, "&rest");
5017 defsymbol (&Qand_optional, "&optional");
5018 /* Note that the process code also uses Qexit */
5019 defsymbol (&Qexit, "exit");
5020 defsymbol (&Qsetq, "setq");
5021 defsymbol (&Qinteractive, "interactive");
5022 defsymbol (&Qcommandp, "commandp");
5023 defsymbol (&Qdefun, "defun");
5024 defsymbol (&Qprogn, "progn");
5025 defsymbol (&Qvalues, "values");
5026 defsymbol (&Qdisplay_warning, "display-warning");
5027 defsymbol (&Qrun_hooks, "run-hooks");
5028 defsymbol (&Qif, "if");
5033 DEFSUBR_MACRO (Fwhen);
5034 DEFSUBR_MACRO (Funless);
5041 DEFSUBR (Ffunction);
5043 DEFSUBR (Fdefmacro);
5045 DEFSUBR (Fdefconst);
5046 DEFSUBR (Fuser_variable_p);
5050 DEFSUBR (Fmacroexpand_internal);
5053 DEFSUBR (Funwind_protect);
5054 DEFSUBR (Fcondition_case);
5055 DEFSUBR (Fcall_with_condition_handler);
5057 DEFSUBR (Finteractive_p);
5058 DEFSUBR (Fcommandp);
5059 DEFSUBR (Fcommand_execute);
5060 DEFSUBR (Fautoload);
5064 DEFSUBR (Ffunctionp);
5065 DEFSUBR (Ffunction_min_args);
5066 DEFSUBR (Ffunction_max_args);
5067 DEFSUBR (Frun_hooks);
5068 DEFSUBR (Frun_hook_with_args);
5069 DEFSUBR (Frun_hook_with_args_until_success);
5070 DEFSUBR (Frun_hook_with_args_until_failure);
5071 DEFSUBR (Fbacktrace_debug);
5072 DEFSUBR (Fbacktrace);
5073 DEFSUBR (Fbacktrace_frame);
5079 specpdl_ptr = specpdl;
5080 specpdl_depth_counter = 0;
5082 Vcondition_handlers = Qnil;
5085 debug_on_next_call = 0;
5086 lisp_eval_depth = 0;
5087 entering_debugger = 0;
5091 reinit_vars_of_eval (void)
5093 preparing_for_armageddon = 0;
5095 Qunbound_suspended_errors_tag = make_opaque_ptr (&Qunbound_suspended_errors_tag);
5096 staticpro_nodump (&Qunbound_suspended_errors_tag);
5099 specpdl = xnew_array (struct specbinding, specpdl_size);
5100 /* XEmacs change: increase these values. */
5101 max_specpdl_size = 3000;
5102 max_lisp_eval_depth = 500;
5103 #ifdef DEFEND_AGAINST_THROW_RECURSION
5111 reinit_vars_of_eval ();
5113 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size /*
5114 Limit on number of Lisp variable bindings & unwind-protects before error.
5117 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth /*
5118 Limit on depth in `eval', `apply' and `funcall' before error.
5119 This limit is to catch infinite recursions for you before they cause
5120 actual stack overflow in C, which would be fatal for Emacs.
5121 You can safely make it considerably larger than its default value,
5122 if that proves inconveniently small.
5125 DEFVAR_LISP ("quit-flag", &Vquit_flag /*
5126 Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
5127 Typing C-G sets `quit-flag' non-nil, regardless of `inhibit-quit'.
5131 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit /*
5132 Non-nil inhibits C-g quitting from happening immediately.
5133 Note that `quit-flag' will still be set by typing C-g,
5134 so a quit will be signalled as soon as `inhibit-quit' is nil.
5135 To prevent this happening, set `quit-flag' to nil
5136 before making `inhibit-quit' nil. The value of `inhibit-quit' is
5137 ignored if a critical quit is requested by typing control-shift-G in
5140 Vinhibit_quit = Qnil;
5142 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error /*
5143 *Non-nil means automatically display a backtrace buffer
5144 after any error that is not handled by a `condition-case'.
5145 If the value is a list, an error only means to display a backtrace
5146 if one of its condition symbols appears in the list.
5147 See also variable `stack-trace-on-signal'.
5149 Vstack_trace_on_error = Qnil;
5151 DEFVAR_LISP ("stack-trace-on-signal", &Vstack_trace_on_signal /*
5152 *Non-nil means automatically display a backtrace buffer
5153 after any error that is signalled, whether or not it is handled by
5155 If the value is a list, an error only means to display a backtrace
5156 if one of its condition symbols appears in the list.
5157 See also variable `stack-trace-on-error'.
5159 Vstack_trace_on_signal = Qnil;
5161 DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors /*
5162 *List of errors for which the debugger should not be called.
5163 Each element may be a condition-name or a regexp that matches error messages.
5164 If any element applies to a given error, that error skips the debugger
5165 and just returns to top level.
5166 This overrides the variable `debug-on-error'.
5167 It does not apply to errors handled by `condition-case'.
5169 Vdebug_ignored_errors = Qnil;
5171 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error /*
5172 *Non-nil means enter debugger if an unhandled error is signalled.
5173 The debugger will not be entered if the error is handled by
5175 If the value is a list, an error only means to enter the debugger
5176 if one of its condition symbols appears in the list.
5177 This variable is overridden by `debug-ignored-errors'.
5178 See also variables `debug-on-quit' and `debug-on-signal'.
5180 Vdebug_on_error = Qnil;
5182 DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal /*
5183 *Non-nil means enter debugger if an error is signalled.
5184 The debugger will be entered whether or not the error is handled by
5186 If the value is a list, an error only means to enter the debugger
5187 if one of its condition symbols appears in the list.
5188 See also variable `debug-on-quit'.
5190 Vdebug_on_signal = Qnil;
5192 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit /*
5193 *Non-nil means enter debugger if quit is signalled (C-G, for example).
5194 Does not apply if quit is handled by a `condition-case'. Entering the
5195 debugger can also be achieved at any time (for X11 console) by typing
5196 control-shift-G to signal a critical quit.
5200 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call /*
5201 Non-nil means enter debugger before next `eval', `apply' or `funcall'.
5204 DEFVAR_LISP ("debugger", &Vdebugger /*
5205 Function to call to invoke debugger.
5206 If due to frame exit, args are `exit' and the value being returned;
5207 this function's value will be returned instead of that.
5208 If due to error, args are `error' and a list of the args to `signal'.
5209 If due to `apply' or `funcall' entry, one arg, `lambda'.
5210 If due to `eval' entry, one arg, t.
5214 staticpro (&Vpending_warnings);
5215 Vpending_warnings = Qnil;
5216 pdump_wire (&Vpending_warnings_tail);
5217 Vpending_warnings_tail = Qnil;
5219 staticpro (&Vautoload_queue);
5220 Vautoload_queue = Qnil;
5222 staticpro (&Vcondition_handlers);
5224 staticpro (&Vcurrent_warning_class);
5225 Vcurrent_warning_class = Qnil;
5227 staticpro (&Vcurrent_error_state);
5228 Vcurrent_error_state = Qnil; /* errors as normal */