1 /* Evaluator for SXEmacs Lisp interpreter.
2 Copyright (C) 1985-1987, 1992-1994 Free Software Foundation, Inc.
3 Copyright (C) 1995 Sun Microsystems, Inc.
4 Copyright (C) 2000 Ben Wing.
6 This file is part of SXEmacs
8 SXEmacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 SXEmacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with this program. If not, see <http://www.gnu.org/licenses/>. */
22 /* Synched up with: FSF 19.30 (except for Fsignal), Mule 2.0. */
28 #include "backtrace.h"
31 #include "ui/console.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; \
56 /* This is the list of current catches (and also condition-cases).
57 This is a stack: the most recent catch is at the head of the
58 list. Catches are created by declaring a 'struct catchtag'
59 locally, filling the .TAG field in with the tag, and doing
60 a setjmp() on .JMP. Fthrow() will store the value passed
61 to it in .VAL and longjmp() back to .JMP, back to the function
62 that established the catch. This will always be either
63 internal_catch() (catches established internally or through
64 `catch') or condition_case_1 (condition-cases established
65 internally or through `condition-case').
67 The catchtag also records the current position in the
68 call stack (stored in BACKTRACE_LIST), the current position
69 in the specpdl stack (used for variable bindings and
70 unwind-protects), the value of LISP_EVAL_DEPTH, and the
71 current position in the GCPRO stack. All of these are
75 struct catchtag *catchlist;
77 Lisp_Object Qautoload, Qmacro, Qexit;
78 Lisp_Object Qinteractive, Qcommandp, Qdefun, Qprogn, Qvalues;
79 Lisp_Object Vquit_flag, Vinhibit_quit;
80 Lisp_Object Qand_rest, Qand_optional;
81 Lisp_Object Qdebug_on_error, Qstack_trace_on_error;
82 Lisp_Object Qdebug_on_signal, Qstack_trace_on_signal;
83 Lisp_Object Qdebugger;
84 Lisp_Object Qinhibit_quit;
85 Lisp_Object Qrun_hooks;
87 Lisp_Object Qdisplay_warning;
88 Lisp_Object Vpending_warnings, Vpending_warnings_tail;
91 /* Records whether we want errors to occur. This will be a boolean,
92 nil (errors OK) or t (no errors). If t, an error will cause a
93 throw to Qunbound_suspended_errors_tag.
95 See call_with_suspended_errors(). */
96 Lisp_Object Vcurrent_error_state;
98 /* Current warning class when warnings occur, or nil for no warnings.
99 Only meaningful when Vcurrent_error_state is non-nil.
100 See call_with_suspended_errors(). */
101 Lisp_Object Vcurrent_warning_class;
103 /* Special catch tag used in call_with_suspended_errors(). */
104 Lisp_Object Qunbound_suspended_errors_tag;
106 /* Non-nil means record all fset's and provide's, to be undone
107 if the file being autoloaded is not fully loaded.
108 They are recorded by being consed onto the front of Vautoload_queue:
109 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */
110 Lisp_Object Vautoload_queue;
112 /* Current number of specbindings allocated in specpdl. */
115 /* Pointer to beginning of specpdl. */
116 struct specbinding *specpdl;
118 /* Pointer to first unused element in specpdl. */
119 struct specbinding *specpdl_ptr;
121 /* specpdl_ptr - specpdl */
122 int specpdl_depth_counter;
124 /* Maximum size allowed for specpdl allocation */
125 Fixnum max_specpdl_size;
127 /* Depth in Lisp evaluations and function calls. */
128 static int lisp_eval_depth;
130 /* Maximum allowed depth in Lisp evaluations and function calls. */
131 Fixnum max_lisp_eval_depth;
133 /* Nonzero means enter debugger before next function call */
134 static int debug_on_next_call;
136 /* List of conditions (non-nil atom means all) which cause a backtrace
137 if an error is handled by the command loop's error handler. */
138 Lisp_Object Vstack_trace_on_error;
140 /* List of conditions (non-nil atom means all) which enter the debugger
141 if an error is handled by the command loop's error handler. */
142 Lisp_Object Vdebug_on_error;
144 /* List of conditions and regexps specifying error messages which
145 do not enter the debugger even if Vdebug_on_error says they should. */
146 Lisp_Object Vdebug_ignored_errors;
148 /* List of conditions (non-nil atom means all) which cause a backtrace
149 if any error is signalled. */
150 Lisp_Object Vstack_trace_on_signal;
152 /* List of conditions (non-nil atom means all) which enter the debugger
153 if any error is signalled. */
154 Lisp_Object Vdebug_on_signal;
156 /* Nonzero means enter debugger if a quit signal
157 is handled by the command loop's error handler.
159 From lisp, this is a boolean variable and may have the values 0 and 1.
160 But, eval.c temporarily uses the second bit of this variable to indicate
161 that a critical_quit is in progress. The second bit is reset immediately
162 after it is processed in signal_call_debugger(). */
166 /* entering_debugger is basically equivalent */
167 /* The value of num_nonmacro_input_chars as of the last time we
168 started to enter the debugger. If we decide to enter the debugger
169 again when this is still equal to num_nonmacro_input_chars, then we
170 know that the debugger itself has an error, and we should just
171 signal the error instead of entering an infinite loop of debugger
173 int when_entered_debugger;
176 /* Nonzero means we are trying to enter the debugger.
177 This is to prevent recursive attempts.
178 Cleared by the debugger calling Fbacktrace */
179 static int entering_debugger;
181 /* Function to call to invoke the debugger */
182 Lisp_Object Vdebugger;
184 /* Chain of condition handlers currently in effect.
185 The elements of this chain are contained in the stack frames
186 of Fcondition_case and internal_condition_case.
187 When an error is signaled (by calling Fsignal, below),
188 this chain is searched for an element that applies.
190 Each element of this list is one of the following:
192 A list of a handler function and possibly args to pass to
193 the function. This is a handler established with
194 `call-with-condition-handler' (q.v.).
196 A list whose car is Qunbound and whose cdr is Qt.
197 This is a special condition-case handler established
198 by C code with condition_case_1(). All errors are
199 trapped; the debugger is not invoked even if
200 `debug-on-error' was set.
202 A list whose car is Qunbound and whose cdr is Qerror.
203 This is a special condition-case handler established
204 by C code with condition_case_1(). It is like Qt
205 except that the debugger is invoked normally if it is
208 A list whose car is Qunbound and whose cdr is a list
209 of lists (CONDITION-NAME BODY ...) exactly as in
210 `condition-case'. This is a normal `condition-case'
213 Note that in all cases *except* the first, there is a
214 corresponding catch, whose TAG is the value of
215 Vcondition_handlers just after the handler data just
216 described is pushed onto it. The reason is that
217 `condition-case' handlers need to throw back to the
218 place where the handler was installed before invoking
219 it, while `call-with-condition-handler' handlers are
220 invoked in the environment that `signal' was invoked
223 static Lisp_Object Vcondition_handlers;
225 #define DEFEND_AGAINST_THROW_RECURSION
227 #ifdef DEFEND_AGAINST_THROW_RECURSION
228 /* Used for error catching purposes by throw_or_bomb_out */
229 static int throw_level;
232 #ifdef ERROR_CHECK_TYPECHECK
233 void check_error_state_sanity(void);
236 /************************************************************************/
237 /* The subr object type */
238 /************************************************************************/
241 print_subr(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
243 Lisp_Subr *subr = XSUBR(obj);
245 (subr->max_args == UNEVALLED) ? "#<special-form " : "#<subr ";
246 const char *name = subr_name(subr);
247 const char *trailer = subr->prompt ? " (interactive)>" : ">";
250 error("printing unreadable object %s%s%s", header, name,
253 write_c_string(header, printcharfun);
254 write_c_string(name, printcharfun);
255 write_c_string(trailer, printcharfun);
258 static const struct lrecord_description subr_description[] = {
259 {XD_DOC_STRING, offsetof(Lisp_Subr, doc)},
263 DEFINE_BASIC_LRECORD_IMPLEMENTATION("subr", subr,
264 0, print_subr, 0, 0, 0,
265 subr_description, Lisp_Subr);
267 /************************************************************************/
268 /* Entering the debugger */
269 /************************************************************************/
271 /* unwind-protect used by call_debugger() to restore the value of
272 entering_debugger. (We cannot use specbind() because the
273 variable is not Lisp-accessible.) */
275 static Lisp_Object restore_entering_debugger(Lisp_Object arg)
277 entering_debugger = !NILP(arg);
281 /* Actually call the debugger. ARG is a list of args that will be
282 passed to the debugger function, as follows;
284 If due to frame exit, args are `exit' and the value being returned;
285 this function's value will be returned instead of that.
286 If due to error, args are `error' and a list of the args to `signal'.
287 If due to `apply' or `funcall' entry, one arg, `lambda'.
288 If due to `eval' entry, one arg, t.
292 static Lisp_Object call_debugger_259(Lisp_Object arg)
294 return apply1(Vdebugger, arg);
297 /* Call the debugger, doing some encapsulation. We make sure we have
298 some room on the eval and specpdl stacks, and bind entering_debugger
299 to 1 during this call. This is used to trap errors that may occur
300 when entering the debugger (e.g. the value of `debugger' is invalid),
301 so that the debugger will not be recursively entered if debug-on-error
302 is set. (Otherwise, SXEmacs would infinitely recurse, attempting to
303 enter the debugger.) entering_debugger gets reset to 0 as soon
304 as a backtrace is displayed, so that further errors can indeed be
307 We also establish a catch for 'debugger. If the debugger function
308 throws to this instead of returning a value, it means that the user
309 pressed 'c' (pretend like the debugger was never entered). The
310 function then returns Qunbound. (If the user pressed 'r', for
311 return a value, then the debugger function returns normally with
314 The difference between 'c' and 'r' is as follows:
317 No difference. The call proceeds as normal.
319 With 'r', the specified value is returned as the function's
320 return value. With 'c', the value that would normally be
321 returned is returned.
323 With 'r', the specified value is returned as the return
324 value of `signal'. (This is the only time that `signal'
325 can return, instead of making a non-local exit.) With `c',
326 `signal' will continue looking for handlers as if the
327 debugger was never entered, and will probably end up
328 throwing to a handler or to top-level.
331 static Lisp_Object call_debugger(Lisp_Object arg)
337 if (lisp_eval_depth + 20 > max_lisp_eval_depth)
338 max_lisp_eval_depth = lisp_eval_depth + 20;
339 if (specpdl_size + 40 > max_specpdl_size)
340 max_specpdl_size = specpdl_size + 40;
341 debug_on_next_call = 0;
343 speccount = specpdl_depth();
344 record_unwind_protect(restore_entering_debugger,
345 (entering_debugger ? Qt : Qnil));
346 entering_debugger = 1;
347 val = internal_catch(Qdebugger, call_debugger_259, arg, &threw);
349 return unbind_to(speccount, ((threw)
350 ? Qunbound /* Not returning a value */
354 /* Called when debug-on-exit behavior is called for. Enter the debugger
355 with the appropriate args for this. VAL is the exit value that is
356 about to be returned. */
358 static Lisp_Object do_debug_on_exit(Lisp_Object val)
360 /* This is falsified by call_debugger */
361 Lisp_Object v = call_debugger(list2(Qexit, val));
363 return !UNBOUNDP(v) ? v : val;
366 /* Called when debug-on-call behavior is called for. Enter the debugger
367 with the appropriate args for this. VAL is either t for a call
368 through `eval' or 'lambda for a call through `funcall'.
370 #### The differentiation here between EVAL and FUNCALL is bogus.
371 FUNCALL can be defined as
373 (defmacro func (fun &rest args)
374 (cons (eval fun) args))
376 and should be treated as such.
379 static void do_debug_on_call(Lisp_Object code)
381 debug_on_next_call = 0;
382 backtrace_list->debug_on_exit = 1;
383 call_debugger(list1(code));
386 /* LIST is the value of one of the variables `debug-on-error',
387 `debug-on-signal', `stack-trace-on-error', or `stack-trace-on-signal',
388 and CONDITIONS is the list of error conditions associated with
389 the error being signalled. This returns non-nil if LIST
390 matches CONDITIONS. (A nil value for LIST does not match
391 CONDITIONS. A non-list value for LIST does match CONDITIONS.
392 A list matches CONDITIONS when one of the symbols in LIST is the
393 same as one of the symbols in CONDITIONS.) */
395 static int wants_debugger(Lisp_Object list, Lisp_Object conditions)
402 while (CONSP(conditions)) {
403 Lisp_Object this, tail;
404 this = XCAR(conditions);
405 for (tail = list; CONSP(tail); tail = XCDR(tail))
406 if (EQ(XCAR(tail), this))
408 conditions = XCDR(conditions);
413 /* Return 1 if an error with condition-symbols CONDITIONS,
414 and described by SIGNAL-DATA, should skip the debugger
415 according to debugger-ignore-errors. */
417 static int skip_debugger(Lisp_Object conditions, Lisp_Object data)
419 /* This function can GC */
421 int first_string = 1;
422 Lisp_Object error_message = Qnil;
424 for (tail = Vdebug_ignored_errors; CONSP(tail); tail = XCDR(tail)) {
425 if (STRINGP(XCAR(tail))) {
427 error_message = Ferror_message_string(data);
430 if (fast_lisp_string_match(XCAR(tail), error_message) >=
436 for (contail = conditions; CONSP(contail);
437 contail = XCDR(contail))
438 if (EQ(XCAR(tail), XCAR(contail)))
446 /* Actually generate a backtrace on STREAM. */
448 static Lisp_Object backtrace_259(Lisp_Object stream)
450 return Fbacktrace(stream, Qt);
453 /* An error was signaled. Maybe call the debugger, if the `debug-on-error'
454 etc. variables call for this. CONDITIONS is the list of conditions
455 associated with the error being signalled. SIG is the actual error
456 being signalled, and DATA is the associated data (these are exactly
457 the same as the arguments to `signal'). ACTIVE_HANDLERS is the
458 list of error handlers that are to be put in place while the debugger
459 is called. This is generally the remaining handlers that are
460 outside of the innermost handler trapping this error. This way,
461 if the same error occurs inside of the debugger, you usually don't get
462 the debugger entered recursively.
464 This function returns Qunbound if it didn't call the debugger or if
465 the user asked (through 'c') that SXEmacs should pretend like the
466 debugger was never entered. Otherwise, it returns the value
467 that the user specified with `r'. (Note that much of the time,
468 the user will abort with C-], and we will never have a chance to
469 return anything at all.)
471 SIGNAL_VARS_ONLY means we should only look at debug-on-signal
472 and stack-trace-on-signal to control whether we do anything.
473 This is so that debug-on-error doesn't make handled errors
474 cause the debugger to get invoked.
476 STACK_TRACE_DISPLAYED and DEBUGGER_ENTERED are used so that
477 those functions aren't done more than once in a single `signal'
481 signal_call_debugger(Lisp_Object conditions,
482 Lisp_Object sig, Lisp_Object data,
483 Lisp_Object active_handlers,
484 int signal_vars_only,
485 int *stack_trace_displayed, int *debugger_entered)
487 /* This function can GC */
488 Lisp_Object val = Qunbound;
489 Lisp_Object all_handlers = Vcondition_handlers;
490 Lisp_Object temp_data = Qnil;
491 int speccount = specpdl_depth();
492 struct gcpro gcpro1, gcpro2;
493 GCPRO2(all_handlers, temp_data);
495 Vcondition_handlers = active_handlers;
497 temp_data = Fcons(sig, data); /* needed for skip_debugger */
499 if (!entering_debugger && !*stack_trace_displayed && !signal_vars_only
500 && wants_debugger(Vstack_trace_on_error, conditions)
501 && !skip_debugger(conditions, temp_data)) {
502 specbind(Qdebug_on_error, Qnil);
503 specbind(Qstack_trace_on_error, Qnil);
504 specbind(Qdebug_on_signal, Qnil);
505 specbind(Qstack_trace_on_signal, Qnil);
508 internal_with_output_to_temp_buffer(build_string
512 else /* in batch mode, we want this going to stderr. */
514 unbind_to(speccount, Qnil);
515 *stack_trace_displayed = 1;
518 if (!entering_debugger && !*debugger_entered && !signal_vars_only
520 ? debug_on_quit : wants_debugger(Vdebug_on_error, conditions))
521 && !skip_debugger(conditions, temp_data)) {
522 debug_on_quit &= ~2; /* reset critical bit */
523 specbind(Qdebug_on_error, Qnil);
524 specbind(Qstack_trace_on_error, Qnil);
525 specbind(Qdebug_on_signal, Qnil);
526 specbind(Qstack_trace_on_signal, Qnil);
528 val = call_debugger(list2(Qerror, (Fcons(sig, data))));
529 *debugger_entered = 1;
532 if (!entering_debugger && !*stack_trace_displayed
533 && wants_debugger(Vstack_trace_on_signal, conditions)) {
534 specbind(Qdebug_on_error, Qnil);
535 specbind(Qstack_trace_on_error, Qnil);
536 specbind(Qdebug_on_signal, Qnil);
537 specbind(Qstack_trace_on_signal, Qnil);
540 internal_with_output_to_temp_buffer(build_string
544 else /* in batch mode, we want this going to stderr. */
546 unbind_to(speccount, Qnil);
547 *stack_trace_displayed = 1;
550 if (!entering_debugger && !*debugger_entered && (EQ(sig, Qquit)
556 debug_on_quit &= ~2; /* reset critical bit */
557 specbind(Qdebug_on_error, Qnil);
558 specbind(Qstack_trace_on_error, Qnil);
559 specbind(Qdebug_on_signal, Qnil);
560 specbind(Qstack_trace_on_signal, Qnil);
562 val = call_debugger(list2(Qerror, (Fcons(sig, data))));
563 *debugger_entered = 1;
567 Vcondition_handlers = all_handlers;
568 return unbind_to(speccount, val);
571 /************************************************************************/
572 /* The basic special forms */
573 /************************************************************************/
575 /* Except for Fprogn(), the basic special forms below are only called
576 from interpreted code. The byte compiler turns them into bytecodes. */
578 DEFUN("or", For, 0, UNEVALLED, 0, /*
579 Eval args until one of them yields non-nil, then return that value.
580 The remaining args are not evalled at all.
581 If all args return nil, return nil.
585 /* This function can GC */
586 REGISTER Lisp_Object val;
588 LIST_LOOP_2(arg, args) {
589 if (!NILP(val = Feval(arg)))
596 DEFUN("and", Fand, 0, UNEVALLED, 0, /*
597 Eval args until one of them yields nil, then return nil.
598 The remaining args are not evalled at all.
599 If no arg yields nil, return the last arg's value.
603 /* This function can GC */
604 REGISTER Lisp_Object val = Qt;
606 LIST_LOOP_2(arg, args) {
607 if (NILP(val = Feval(arg)))
614 DEFUN("if", Fif, 2, UNEVALLED, 0, /*
615 \(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...
616 Returns the value of THEN or the value of the last of the ELSE's.
617 THEN must be one expression, but ELSE... can be zero or more expressions.
618 If COND yields nil, and there are no ELSE's, the value is nil.
622 /* This function can GC */
623 Lisp_Object condition = XCAR(args);
624 Lisp_Object then_form = XCAR(XCDR(args));
625 Lisp_Object else_forms = XCDR(XCDR(args));
627 if (!NILP(Feval(condition)))
628 return Feval(then_form);
630 return Fprogn(else_forms);
633 /* Macros `when' and `unless' are trivially defined in Lisp,
634 but it helps for bootstrapping to have them ALWAYS defined. */
636 DEFUN("when", Fwhen, 1, MANY, 0, /*
637 \(when COND BODY...): if COND yields non-nil, do BODY, else return nil.
638 BODY can be zero or more expressions. If BODY is nil, return nil.
640 (int nargs, Lisp_Object * args))
642 Lisp_Object cond = args[0];
653 body = Fcons(Qprogn, Flist(nargs - 1, args + 1));
657 return list3(Qif, cond, body);
660 DEFUN("unless", Funless, 1, MANY, 0, /*
661 \(unless COND BODY...): if COND yields nil, do BODY, else return nil.
662 BODY can be zero or more expressions. If BODY is nil, return nil.
664 (int nargs, Lisp_Object * args))
666 Lisp_Object cond = args[0];
667 Lisp_Object body = Flist(nargs - 1, args + 1);
668 return Fcons(Qif, Fcons(cond, Fcons(Qnil, body)));
671 DEFUN("cond", Fcond, 0, UNEVALLED, 0, /*
672 \(cond CLAUSES...): try each clause until one succeeds.
673 Each clause looks like (CONDITION BODY...). CONDITION is evaluated
674 and, if the value is non-nil, this clause succeeds:
675 then the expressions in BODY are evaluated and the last one's
676 value is the value of the cond-form.
677 If no clause succeeds, cond returns nil.
678 If a clause has one element, as in (CONDITION),
679 CONDITION's value if non-nil is returned from the cond-form.
683 /* This function can GC */
684 REGISTER Lisp_Object val;
686 LIST_LOOP_2(clause, args) {
688 if (!NILP(val = Feval(XCAR(clause)))) {
689 if (!NILP(clause = XCDR(clause))) {
690 CHECK_TRUE_LIST(clause);
691 val = Fprogn(clause);
700 DEFUN("progn", Fprogn, 0, UNEVALLED, 0, /*
701 \(progn BODY...): eval BODY forms sequentially and return value of last one.
705 /* This function can GC */
706 /* Caller must provide a true list in ARGS */
707 REGISTER Lisp_Object val = Qnil;
713 LIST_LOOP_2(form, args)
721 /* Fprog1() is the canonical example of a function that must GCPRO a
722 Lisp_Object across calls to Feval(). */
724 DEFUN("prog1", Fprog1, 1, UNEVALLED, 0, /*
725 Similar to `progn', but the value of the first form is returned.
726 \(prog1 FIRST BODY...): All the arguments are evaluated sequentially.
727 The value of FIRST is saved during evaluation of the remaining args,
728 whose values are discarded.
732 /* This function can GC */
733 REGISTER Lisp_Object val;
736 val = Feval(XCAR(args));
741 LIST_LOOP_2(form, XCDR(args))
749 DEFUN("prog2", Fprog2, 2, UNEVALLED, 0, /*
750 Similar to `progn', but the value of the second form is returned.
751 \(prog2 FIRST SECOND BODY...): All the arguments are evaluated sequentially.
752 The value of SECOND is saved during evaluation of the remaining args,
753 whose values are discarded.
757 /* This function can GC */
758 REGISTER Lisp_Object val;
763 val = Feval(XCAR(args));
769 LIST_LOOP_2(form, args)
777 DEFUN("let*", FletX, 1, UNEVALLED, 0, /*
778 \(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.
779 The value of the last form in BODY is returned.
780 Each element of VARLIST is a symbol (which is bound to nil)
781 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
782 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
786 /* This function can GC */
787 Lisp_Object varlist = XCAR(args);
788 Lisp_Object body = XCDR(args);
789 int speccount = specpdl_depth();
791 EXTERNAL_LIST_LOOP_3(var, varlist, tail) {
792 Lisp_Object symbol, value, tem;
794 symbol = var, value = Qnil;
803 value = Feval(XCAR(tem));
804 if (!NILP(XCDR(tem)))
806 ("`let' bindings can have only one value-form",
810 specbind(symbol, value);
812 return unbind_to(speccount, Fprogn(body));
815 DEFUN("let", Flet, 1, UNEVALLED, 0, /*
816 \(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.
817 The value of the last form in BODY is returned.
818 Each element of VARLIST is a symbol (which is bound to nil)
819 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
820 All the VALUEFORMs are evalled before any symbols are bound.
824 /* This function can GC */
825 Lisp_Object varlist = XCAR(args);
826 Lisp_Object body = XCDR(args);
827 int speccount = specpdl_depth();
831 GET_EXTERNAL_LIST_LENGTH(varlist, varcount);
833 /* Make space to hold the values to give the bound variables. */
835 Lisp_Object temps[varcount];
839 memset(temps, 0, sizeof(Lisp_Object)*varcount);
841 /* Compute the values and store them in `temps' */
842 GCPROn(temps, varcount);
845 LIST_LOOP_2(var, varlist) {
846 Lisp_Object *value = &temps[idx++];
857 *value = Feval(XCAR(tem));
859 if (!NILP(XCDR(tem))) {
861 "`let' bindings can "
870 LIST_LOOP_2(var, varlist) {
871 specbind(SYMBOLP(var) ? var : XCAR(var), temps[idx++]);
877 return unbind_to(speccount, Fprogn(body));
880 DEFUN("while", Fwhile, 1, UNEVALLED, 0, /*
881 \(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.
882 The order of execution is thus TEST, BODY, TEST, BODY and so on
883 until TEST returns nil.
887 /* This function can GC */
888 Lisp_Object test = XCAR(args);
889 Lisp_Object body = XCDR(args);
891 while (!NILP(Feval(test))) {
899 DEFUN("setq", Fsetq, 0, UNEVALLED, 0, /*
900 \(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.
901 The symbols SYM are variables; they are literal (not evaluated).
902 The values VAL are expressions; they are evaluated.
903 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
904 The second VAL is not computed until after the first SYM is set, and so on;
905 each VAL can use the new value of variables set earlier in the `setq'.
906 The return value of the `setq' form is the value of the last VAL.
910 /* This function can GC */
911 Lisp_Object symbol, tail, val = Qnil;
915 GET_LIST_LENGTH(args, nargs);
917 if (nargs & 1) /* Odd number of arguments? */
918 Fsignal(Qwrong_number_of_arguments,
919 list2(Qsetq, make_int(nargs)));
923 PROPERTY_LIST_LOOP(tail, symbol, val, args) {
932 DEFUN("quote", Fquote, 1, UNEVALLED, 0, /*
933 Return the argument, without evaluating it. `(quote x)' yields `x'.
940 DEFUN("function", Ffunction, 1, UNEVALLED, 0, /*
941 Like `quote', but preferred for objects which are functions.
942 In byte compilation, `function' causes its argument to be compiled.
943 `quote' cannot do that.
950 /************************************************************************/
951 /* Defining functions/variables */
952 /************************************************************************/
953 static Lisp_Object define_function(Lisp_Object name, Lisp_Object defn)
956 LOADHIST_ATTACH (Fcons (Qdefun, name));
960 DEFUN("defun", Fdefun, 2, UNEVALLED, 0, /*
961 \(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.
962 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
963 See also the function `interactive'.
967 /* This function can GC */
968 return define_function(XCAR(args), Fcons(Qlambda, XCDR(args)));
971 DEFUN("defmacro", Fdefmacro, 2, UNEVALLED, 0, /*
972 \(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.
973 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).
974 When the macro is called, as in (NAME ARGS...),
975 the function (lambda ARGLIST BODY...) is applied to
976 the list ARGS... as it appears in the expression,
977 and the result should be a form to be evaluated instead of the original.
981 /* This function can GC */
982 return define_function(XCAR(args),
983 Fcons(Qmacro, Fcons(Qlambda, XCDR(args))));
986 DEFUN("defvar", Fdefvar, 1, UNEVALLED, 0, /*
987 \(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.
988 You are not required to define a variable in order to use it,
989 but the definition can supply documentation and an initial value
990 in a way that tags can recognize.
992 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is
993 void. (However, when you evaluate a defvar interactively, it acts like a
994 defconst: SYMBOL's value is always set regardless of whether it's currently
996 If SYMBOL is buffer-local, its default value is what is set;
997 buffer-local values are not affected.
998 INITVALUE and DOCSTRING are optional.
999 If DOCSTRING starts with *, this variable is identified as a user option.
1000 This means that M-x set-variable recognizes it.
1001 If INITVALUE is missing, SYMBOL's value is not set.
1003 In lisp-interaction-mode defvar is treated as defconst.
1007 /* This function can GC */
1008 Lisp_Object sym = XCAR(args);
1010 if (!NILP(args = XCDR(args))) {
1011 Lisp_Object val = XCAR(args);
1013 if (NILP(Fdefault_boundp(sym))) {
1014 struct gcpro gcpro1;
1017 Fset_default(sym, val);
1021 if (!NILP(args = XCDR(args))) {
1022 Lisp_Object doc = XCAR(args);
1023 Fput(sym, Qvariable_documentation, doc);
1024 if (!NILP(args = XCDR(args)))
1025 error("too many arguments");
1029 if (!NILP(Vfile_domain))
1030 Fput(sym, Qvariable_domain, Vfile_domain);
1033 LOADHIST_ATTACH(sym);
1037 DEFUN("defconst", Fdefconst, 2, UNEVALLED, 0, /*
1038 \(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant
1040 The intent is that programs do not change this value, but users may.
1041 Always sets the value of SYMBOL to the result of evalling INITVALUE.
1042 If SYMBOL is buffer-local, its default value is what is set;
1043 buffer-local values are not affected.
1044 DOCSTRING is optional.
1045 If DOCSTRING starts with *, this variable is identified as a user option.
1046 This means that M-x set-variable recognizes it.
1048 Note: do not use `defconst' for user options in libraries that are not
1049 normally loaded, since it is useful for users to be able to specify
1050 their own values for such variables before loading the library.
1051 Since `defconst' unconditionally assigns the variable,
1052 it would override the user's choice.
1056 /* This function can GC */
1057 Lisp_Object sym = XCAR(args);
1058 Lisp_Object val = Feval(XCAR(args = XCDR(args)));
1059 struct gcpro gcpro1;
1063 Fset_default(sym, val);
1067 if (!NILP(args = XCDR(args))) {
1068 Lisp_Object doc = XCAR(args);
1069 Fput(sym, Qvariable_documentation, doc);
1070 if (!NILP(args = XCDR(args)))
1071 error("too many arguments");
1074 if (!NILP(Vfile_domain))
1075 Fput(sym, Qvariable_domain, Vfile_domain);
1078 LOADHIST_ATTACH(sym);
1082 DEFUN("user-variable-p", Fuser_variable_p, 1, 1, 0, /*
1083 Return t if VARIABLE is intended to be set and modified by users.
1084 \(The alternative is a variable used internally in a Lisp program.)
1085 Determined by whether the first character of the documentation
1086 for the variable is `*'.
1090 Lisp_Object documentation =
1091 Fget(variable, Qvariable_documentation, Qnil);
1094 ((INTP(documentation) && XINT(documentation) < 0) ||
1095 (STRINGP(documentation) &&
1096 (string_byte(XSTRING(documentation), 0) == '*')) ||
1097 /* If (STRING . INTEGER), a negative integer means a user variable. */
1098 (CONSP(documentation)
1099 && STRINGP(XCAR(documentation))
1100 && INTP(XCDR(documentation))
1101 && XINT(XCDR(documentation)) < 0)) ? Qt : Qnil;
1104 DEFUN("macroexpand-internal", Fmacroexpand_internal, 1, 2, 0, /*
1105 Return result of expanding macros at top level of FORM.
1106 If FORM is not a macro call, it is returned unchanged.
1107 Otherwise, the macro is expanded and the expansion is considered
1108 in place of FORM. When a non-macro-call results, it is returned.
1110 The second optional arg ENVIRONMENT specifies an environment of macro
1111 definitions to shadow the loaded ones for use in file byte-compilation.
1113 (form, environment))
1115 /* This function can GC */
1116 /* With cleanups from Hallvard Furuseth. */
1117 REGISTER Lisp_Object expander, sym, def, tem;
1120 /* Come back here each time we expand a macro call,
1121 in case it expands into another macro call. */
1124 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1125 def = sym = XCAR(form);
1127 /* Trace symbols aliases to other symbols
1128 until we get a symbol that is not an alias. */
1129 while (SYMBOLP(def)) {
1132 tem = Fassq(sym, environment);
1134 def = XSYMBOL(sym)->function;
1140 /* Right now TEM is the result from SYM in ENVIRONMENT,
1141 and if TEM is nil then DEF is SYM's function definition. */
1143 /* SYM is not mentioned in ENVIRONMENT.
1144 Look at its function definition. */
1147 /* Not defined or definition not suitable */
1149 if (EQ(XCAR(def), Qautoload)) {
1150 /* Autoloading function: will it be a macro when loaded? */
1151 tem = Felt(def, make_int(4));
1152 if (EQ(tem, Qt) || EQ(tem, Qmacro)) {
1153 /* Yes, load it and try again. */
1154 /* do_autoload GCPROs both arguments */
1155 do_autoload(def, sym);
1159 } else if (!EQ(XCAR(def), Qmacro))
1162 expander = XCDR(def);
1164 expander = XCDR(tem);
1168 form = apply1(expander, XCDR(form));
1173 /************************************************************************/
1174 /* Non-local exits */
1175 /************************************************************************/
1177 DEFUN("catch", Fcatch, 1, UNEVALLED, 0, /*
1178 \(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.
1179 TAG is evalled to get the tag to use. Then the BODY is executed.
1180 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.
1181 If no throw happens, `catch' returns the value of the last BODY form.
1182 If a throw happens, it specifies the value to return from `catch'.
1186 /* This function can GC */
1187 Lisp_Object tag = Feval(XCAR(args));
1188 Lisp_Object body = XCDR(args);
1189 return internal_catch(tag, Fprogn, body, 0);
1192 /* Set up a catch, then call C function FUNC on argument ARG.
1193 FUNC should return a Lisp_Object.
1194 This is how catches are done from within C code. */
1197 internal_catch(Lisp_Object tag,
1198 Lisp_Object(*func) (Lisp_Object arg),
1199 Lisp_Object arg, int *volatile threw)
1201 /* This structure is made part of the chain `catchlist'. */
1204 /* Fill in the components of c, and put it on the list. */
1208 c.backlist = backtrace_list;
1211 c.handlerlist = handlerlist;
1213 c.lisp_eval_depth = lisp_eval_depth;
1214 c.pdlcount = specpdl_depth();
1216 c.poll_suppress_count = async_timer_suppress_count;
1218 c.gcpro = _get_gcprolist();
1222 if (SETJMP(c.jmp)) {
1223 /* Throw works by a longjmp that comes right here. */
1228 c.val = (*func) (arg);
1232 #ifdef ERROR_CHECK_TYPECHECK
1233 check_error_state_sanity();
1238 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1239 jump to that CATCH, returning VALUE as the value of that catch.
1241 This is the guts Fthrow and Fsignal; they differ only in the way
1242 they choose the catch tag to throw to. A catch tag for a
1243 condition-case form has a TAG of Qnil.
1245 Before each catch is discarded, unbind all special bindings and
1246 execute all unwind-protect clauses made above that catch. Unwind
1247 the handler stack as we go, so that the proper handlers are in
1248 effect for each unwind-protect clause we run. At the end, restore
1249 some static info saved in CATCH, and longjmp to the location
1252 This is used for correct unwinding in Fthrow and Fsignal. */
1254 static void unwind_to_catch(struct catchtag *c, Lisp_Object val)
1258 REGISTER int last_time;
1261 /* Unwind the specbind, catch, and handler stacks back to CATCH
1262 Before each catch is discarded, unbind all special bindings
1263 and execute all unwind-protect clauses made above that catch.
1264 At the end, restore some static info saved in CATCH,
1265 and longjmp to the location specified.
1268 /* Save the value somewhere it will be GC'ed.
1269 (Can't overwrite tag slot because an unwind-protect may
1270 want to throw to this same tag, which isn't yet invalid.) */
1274 /* Restore the polling-suppression count. */
1275 set_poll_suppress_count(catch->poll_suppress_count);
1279 /* #### FSFmacs has the following loop. Is it more correct? */
1281 last_time = catchlist == c;
1283 /* Unwind the specpdl stack, and then restore the proper set of
1285 unbind_to(catchlist->pdlcount, Qnil);
1286 handlerlist = catchlist->handlerlist;
1287 catchlist = catchlist->next;
1288 #ifdef ERROR_CHECK_TYPECHECK
1289 check_error_state_sanity();
1293 #else /* Actual SXEmacs code */
1294 /* Unwind the specpdl stack */
1295 unbind_to(c->pdlcount, Qnil);
1296 catchlist = c->next;
1297 #ifdef ERROR_CHECK_TYPECHECK
1298 check_error_state_sanity();
1302 _set_gcprolist(c->gcpro);
1303 backtrace_list = c->backlist;
1304 lisp_eval_depth = c->lisp_eval_depth;
1306 #ifdef DEFEND_AGAINST_THROW_RECURSION
1312 static DOESNT_RETURN
1313 throw_or_bomb_out(Lisp_Object tag, Lisp_Object val, int bomb_out_p,
1314 Lisp_Object sig, Lisp_Object data)
1316 #ifdef DEFEND_AGAINST_THROW_RECURSION
1317 /* die if we recurse more than is reasonable */
1318 if (++throw_level > 20)
1322 /* If bomb_out_p is t, this is being called from Fsignal as a
1323 "last resort" when there is no handler for this error and
1324 the debugger couldn't be invoked, so we are throwing to
1325 'top-level. If this tag doesn't exist (happens during the
1326 initialization stages) we would get in an infinite recursive
1327 Fsignal/Fthrow loop, so instead we bomb out to the
1328 really-early-error-handler.
1330 Note that in fact the only time that the "last resort"
1331 occurs is when there's no catch for 'top-level -- the
1332 'top-level catch and the catch-all error handler are
1333 established at the same time, in initial_command_loop/
1336 #### Fix this horrifitude!
1340 REGISTER struct catchtag *c;
1343 if (!NILP(tag)) /* #### */
1345 for (c = catchlist; c; c = c->next) {
1346 if (EQ(c->tag, tag))
1347 unwind_to_catch(c, val);
1350 tag = Fsignal(Qno_catch, list2(tag, val));
1352 call1(Qreally_early_error_handler, Fcons(sig, data));
1355 /* can't happen. who cares? - (Sun's compiler does) */
1356 /* throw_level--; */
1357 /* getting tired of compilation warnings */
1361 /* See above, where CATCHLIST is defined, for a description of how
1364 Fthrow() is also called by Fsignal(), to do a non-local jump
1365 back to the appropriate condition-case handler after (maybe)
1366 the debugger is entered. In that case, TAG is the value
1367 of Vcondition_handlers that was in place just after the
1368 condition-case handler was set up. The car of this will be
1369 some data referring to the handler: Its car will be Qunbound
1370 (thus, this tag can never be generated by Lisp code), and
1371 its CDR will be the HANDLERS argument to condition_case_1()
1372 (either Qerror, Qt, or a list of handlers as in `condition-case').
1373 This works fine because Fthrow() does not care what TAG was
1374 passed to it: it just looks up the catch list for something
1375 that is EQ() to TAG. When it finds it, it will longjmp()
1376 back to the place that established the catch (in this case,
1377 condition_case_1). See below for more info.
1380 DEFUN("throw", Fthrow, 2, 2, 0, /*
1381 Throw to the catch for TAG and return VALUE from it.
1382 Both TAG and VALUE are evalled.
1386 throw_or_bomb_out(tag, value, 0, Qnil, Qnil); /* Doesn't return */
1390 DEFUN("unwind-protect", Funwind_protect, 1, UNEVALLED, 0, /*
1391 Do BODYFORM, protecting with UNWINDFORMS.
1392 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).
1393 If BODYFORM completes normally, its value is returned
1394 after executing the UNWINDFORMS.
1395 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1399 /* This function can GC */
1400 int speccount = specpdl_depth();
1402 record_unwind_protect(Fprogn, XCDR(args));
1403 return unbind_to(speccount, Feval(XCAR(args)));
1406 /************************************************************************/
1407 /* Signalling and trapping errors */
1408 /************************************************************************/
1410 static Lisp_Object condition_bind_unwind(Lisp_Object loser)
1413 /* ((handler-fun . handler-args) ... other handlers) */
1414 Lisp_Object tem = XCAR(loser);
1416 while (CONSP(tem)) {
1417 victim = XCONS(tem);
1421 victim = XCONS(loser);
1423 if (EQ(loser, Vcondition_handlers)) /* may have been rebound to some tail */
1424 Vcondition_handlers = victim->cdr;
1430 static Lisp_Object condition_case_unwind(Lisp_Object loser)
1434 /* ((<unbound> . clauses) ... other handlers */
1435 victim = XCONS(XCAR(loser));
1438 victim = XCONS(loser);
1439 if (EQ(loser, Vcondition_handlers)) /* may have been rebound to some tail */
1440 Vcondition_handlers = victim->cdr;
1446 /* Split out from condition_case_3 so that primitive C callers
1447 don't have to cons up a lisp handler form to be evaluated. */
1449 /* Call a function BFUN of one argument BARG, trapping errors as
1450 specified by HANDLERS. If no error occurs that is indicated by
1451 HANDLERS as something to be caught, the return value of this
1452 function is the return value from BFUN. If such an error does
1453 occur, HFUN is called, and its return value becomes the
1454 return value of condition_case_1(). The second argument passed
1455 to HFUN will always be HARG. The first argument depends on
1458 If HANDLERS is Qt, all errors (this includes QUIT, but not
1459 non-local exits with `throw') cause HFUN to be invoked, and VAL
1460 (the first argument to HFUN) is a cons (SIG . DATA) of the
1461 arguments passed to `signal'. The debugger is not invoked even if
1462 `debug-on-error' was set.
1464 A HANDLERS value of Qerror is the same as Qt except that the
1465 debugger is invoked if `debug-on-error' was set.
1467 Otherwise, HANDLERS should be a list of lists (CONDITION-NAME BODY ...)
1468 exactly as in `condition-case', and errors will be trapped
1469 as indicated in HANDLERS. VAL (the first argument to HFUN) will
1470 be a cons whose car is the cons (SIG . DATA) and whose CDR is the
1471 list (BODY ...) from the appropriate slot in HANDLERS.
1473 This function pushes HANDLERS onto the front of Vcondition_handlers
1474 (actually with a Qunbound marker as well -- see Fthrow() above
1475 for why), establishes a catch whose tag is this new value of
1476 Vcondition_handlers, and calls BFUN. When Fsignal() is called,
1477 it calls Fthrow(), setting TAG to this same new value of
1478 Vcondition_handlers and setting VAL to the same thing that will
1479 be passed to HFUN, as above. Fthrow() longjmp()s back to the
1480 jump point we just established, and we in turn just call the
1481 HFUN and return its value.
1483 For a real condition-case, HFUN will always be
1484 run_condition_case_handlers() and HARG is the argument VAR
1485 to condition-case. That function just binds VAR to the cons
1486 (SIG . DATA) that is the CAR of VAL, and calls the handler
1487 (BODY ...) that is the CDR of VAL. Note that before calling
1488 Fthrow(), Fsignal() restored Vcondition_handlers to the value
1489 it had *before* condition_case_1() was called. This maintains
1490 consistency (so that the state of things at exit of
1491 condition_case_1() is the same as at entry), and implies
1492 that the handler can signal the same error again (possibly
1493 after processing of its own), without getting in an infinite
1497 condition_case_1(Lisp_Object handlers,
1498 Lisp_Object(*bfun) (Lisp_Object barg),
1500 Lisp_Object(*hfun) (Lisp_Object val, Lisp_Object harg),
1503 int speccount = specpdl_depth();
1505 struct gcpro gcpro1;
1510 /* Do consing now so out-of-memory error happens up front */
1511 /* (unbound . stuff) is a special condition-case kludge marker
1512 which is known specially by Fsignal.
1513 This is an abomination, but to fix it would require either
1514 making condition_case cons (a union of the conditions of the clauses)
1515 or changing the byte-compiler output (no thanks). */
1516 c.tag = noseeum_cons(noseeum_cons(Qunbound, handlers),
1517 Vcondition_handlers);
1520 c.backlist = backtrace_list;
1523 c.handlerlist = handlerlist;
1525 c.lisp_eval_depth = lisp_eval_depth;
1526 c.pdlcount = specpdl_depth();
1528 c.poll_suppress_count = async_timer_suppress_count;
1530 c.gcpro = _get_gcprolist();
1531 /* #### FSFmacs does the following statement *after* the setjmp(). */
1534 if (SETJMP(c.jmp)) {
1535 /* throw does ungcpro, etc */
1536 return (*hfun) (c.val, harg);
1539 record_unwind_protect(condition_case_unwind, c.tag);
1543 h.handler = handlers;
1545 h.next = handlerlist;
1549 Vcondition_handlers = c.tag;
1551 GCPRO1(harg); /* Somebody has to gc-protect */
1553 c.val = ((*bfun) (barg));
1555 /* The following is *not* true: (ben)
1557 ungcpro, restoring catchlist and condition_handlers are actually
1558 redundant since unbind_to now restores them. But it looks funny not to
1559 have this code here, and it doesn't cost anything, so I'm leaving it. */
1562 #ifdef ERROR_CHECK_TYPECHECK
1563 check_error_state_sanity();
1565 Vcondition_handlers = XCDR(c.tag);
1567 return unbind_to(speccount, c.val);
1570 static Lisp_Object run_condition_case_handlers(Lisp_Object val, Lisp_Object var)
1572 /* This function can GC */
1575 specbind(h.var, c.val);
1576 val = Fprogn(Fcdr(h.chosen_clause));
1578 /* Note that this just undoes the binding of h.var; whoever
1579 longjmp()ed to us unwound the stack to c.pdlcount before
1581 unbind_to(c.pdlcount, Qnil);
1586 CHECK_TRUE_LIST(val);
1588 return Fprogn(Fcdr(val)); /* tail call */
1590 speccount = specpdl_depth();
1591 specbind(var, Fcar(val));
1592 val = Fprogn(Fcdr(val));
1593 return unbind_to(speccount, val);
1597 /* Here for bytecode to call non-consfully. This is exactly like
1598 condition-case except that it takes three arguments rather
1599 than a single list of arguments. */
1601 condition_case_3(Lisp_Object bodyform, Lisp_Object var, Lisp_Object handlers)
1603 /* This function can GC */
1604 EXTERNAL_LIST_LOOP_2(handler, handlers) {
1605 if (NILP(handler)) ;
1606 else if (CONSP(handler)) {
1607 Lisp_Object conditions = XCAR(handler);
1608 /* CONDITIONS must a condition name or a list of condition names */
1609 if (SYMBOLP(conditions)) ;
1611 EXTERNAL_LIST_LOOP_2(condition, conditions)
1612 if (!SYMBOLP(condition))
1613 goto invalid_condition_handler;
1616 invalid_condition_handler:
1617 signal_simple_error("Invalid condition handler",
1624 return condition_case_1(handlers,
1626 run_condition_case_handlers, var);
1629 DEFUN("condition-case", Fcondition_case, 2, UNEVALLED, 0, /*
1630 Regain control when an error is signalled.
1631 Usage looks like (condition-case VAR BODYFORM HANDLERS...).
1632 Executes BODYFORM and returns its value if no error happens.
1633 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1634 where the BODY is made of Lisp expressions.
1636 A handler is applicable to an error if CONDITION-NAME is one of the
1637 error's condition names. If an error happens, the first applicable
1638 handler is run. As a special case, a CONDITION-NAME of t matches
1639 all errors, even those without the `error' condition name on them
1642 The car of a handler may be a list of condition names
1643 instead of a single condition name.
1645 When a handler handles an error,
1646 control returns to the condition-case and the handler BODY... is executed
1647 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).
1648 VAR may be nil; then you do not get access to the signal information.
1650 The value of the last BODY form is returned from the condition-case.
1651 See also the function `signal' for more info.
1653 Note that at the time the condition handler is invoked, the Lisp stack
1654 and the current catches, condition-cases, and bindings have all been
1655 popped back to the state they were in just before the call to
1656 `condition-case'. This means that resignalling the error from
1657 within the handler will not result in an infinite loop.
1659 If you want to establish an error handler that is called with the
1660 Lisp stack, bindings, etc. as they were when `signal' was called,
1661 rather than when the handler was set, use `call-with-condition-handler'.
1665 /* This function can GC */
1666 Lisp_Object var = XCAR(args);
1667 Lisp_Object bodyform = XCAR(XCDR(args));
1668 Lisp_Object handlers = XCDR(XCDR(args));
1669 return condition_case_3(bodyform, var, handlers);
1672 DEFUN("call-with-condition-handler", Fcall_with_condition_handler, 2, MANY, 0, /*
1673 Regain control when an error is signalled, without popping the stack.
1674 Usage looks like (call-with-condition-handler HANDLER FUNCTION &rest ARGS).
1675 This function is similar to `condition-case', but the handler is invoked
1676 with the same environment (Lisp stack, bindings, catches, condition-cases)
1677 that was current when `signal' was called, rather than when the handler
1680 HANDLER should be a function of one argument, which is a cons of the args
1681 \(SIG . DATA) that were passed to `signal'. It is invoked whenever
1682 `signal' is called (this differs from `condition-case', which allows
1683 you to specify which errors are trapped). If the handler function
1684 returns, `signal' continues as if the handler were never invoked.
1685 \(It continues to look for handlers established earlier than this one,
1686 and invokes the standard error-handler if none is found.)
1688 (int nargs, Lisp_Object * args))
1689 { /* Note! Args side-effected! */
1690 /* This function can GC */
1691 int speccount = specpdl_depth();
1694 /* #### If there were a way to check that args[0] were a function
1695 which accepted one arg, that should be done here ... */
1697 /* (handler-fun . handler-args) */
1698 tem = noseeum_cons(list1(args[0]), Vcondition_handlers);
1699 record_unwind_protect(condition_bind_unwind, tem);
1700 Vcondition_handlers = tem;
1702 /* Caller should have GC-protected args */
1703 return unbind_to(speccount, Ffuncall(nargs - 1, args + 1));
1706 static int condition_type_p(Lisp_Object type, Lisp_Object conditions)
1709 /* (condition-case c # (t c)) catches -all- signals
1710 * Use with caution! */
1714 return !NILP(Fmemq(type, conditions));
1716 for (; CONSP(type); type = XCDR(type))
1717 if (!NILP(Fmemq(XCAR(type), conditions)))
1723 static Lisp_Object return_from_signal(Lisp_Object value)
1726 /* Most callers are not prepared to handle gc if this
1727 returns. So, since this feature is not very useful,
1729 /* Have called debugger; return value to signaller */
1731 #else /* But the reality is that that stinks, because: */
1732 /* GACK!!! Really want some way for debug-on-quit errors
1733 to be continuable!! */
1734 error("Returning a value from an error is no longer supported");
1738 extern int in_display;
1740 /************************************************************************/
1741 /* the workhorse error-signaling function */
1742 /************************************************************************/
1744 /* #### This function has not been synched with FSF. It diverges
1747 static Lisp_Object signal_1(Lisp_Object sig, Lisp_Object data)
1749 /* This function can GC */
1750 struct gcpro gcpro1, gcpro2;
1751 Lisp_Object conditions;
1752 Lisp_Object handlers;
1753 /* signal_call_debugger() could get called more than once
1754 (once when a call-with-condition-handler is about to
1755 be dealt with, and another when a condition-case handler
1756 is about to be invoked). So make sure the debugger and/or
1757 stack trace aren't done more than once. */
1758 int stack_trace_displayed = 0;
1759 int debugger_entered = 0;
1760 GCPRO2(conditions, handlers);
1763 /* who knows how much has been initialized? Safest bet is
1764 just to bomb out immediately. */
1765 /* let's not use stderr_out() here, because that does a bunch of
1766 things that might not be safe yet. */
1767 fprintf(stderr, "Error before initialization is complete!\n");
1771 if (gc_in_progress || in_display)
1772 /* This is one of many reasons why you can't run lisp code from redisplay.
1773 There is no sensible way to handle errors there. */
1776 conditions = Fget(sig, Qerror_conditions, Qnil);
1778 for (handlers = Vcondition_handlers;
1779 CONSP(handlers); handlers = XCDR(handlers)) {
1780 Lisp_Object handler_fun = XCAR(XCAR(handlers));
1781 Lisp_Object handler_data = XCDR(XCAR(handlers));
1782 Lisp_Object outer_handlers = XCDR(handlers);
1784 if (!UNBOUNDP(handler_fun)) {
1785 /* call-with-condition-handler */
1787 Lisp_Object all_handlers = Vcondition_handlers;
1788 struct gcpro ngcpro1;
1789 NGCPRO1(all_handlers);
1790 Vcondition_handlers = outer_handlers;
1792 tem = signal_call_debugger(conditions, sig, data,
1794 &stack_trace_displayed,
1797 RETURN_NUNGCPRO(return_from_signal(tem));
1799 tem = Fcons(sig, data);
1800 if (NILP(handler_data))
1801 tem = call1(handler_fun, tem);
1803 /* (This code won't be used (for now?).) */
1804 struct gcpro nngcpro1;
1805 Lisp_Object args[3] = {
1806 handler_fun, tem, handler_data};
1809 tem = Fapply(3, args);
1814 if (!EQ(tem, Qsignal))
1815 return return_from_signal(tem);
1817 /* If handler didn't throw, try another handler */
1818 Vcondition_handlers = all_handlers;
1821 /* It's a condition-case handler */
1823 /* t is used by handlers for all conditions, set up by C code.
1824 * debugger is not called even if debug_on_error */
1825 else if (EQ(handler_data, Qt)) {
1827 return Fthrow(handlers, Fcons(sig, data));
1829 /* `error' is used similarly to the way `t' is used, but in
1830 addition it invokes the debugger if debug_on_error.
1831 This is normally used for the outer command-loop error
1833 else if (EQ(handler_data, Qerror)) {
1835 signal_call_debugger(conditions, sig, data,
1837 &stack_trace_displayed,
1842 return return_from_signal(tem);
1844 tem = Fcons(sig, data);
1845 return Fthrow(handlers, tem);
1847 /* handler established by real (Lisp) condition-case */
1850 for (h = handler_data; CONSP(h); h = Fcdr(h)) {
1851 Lisp_Object clause = Fcar(h);
1852 Lisp_Object tem = Fcar(clause);
1854 if (condition_type_p(tem, conditions)) {
1856 signal_call_debugger(conditions,
1860 &stack_trace_displayed,
1864 return return_from_signal(tem);
1866 /* Doesn't return */
1868 Fcons(Fcons(sig, data),
1870 return Fthrow(handlers, tem);
1876 /* If no handler is present now, try to run the debugger,
1877 and if that fails, throw to top level.
1879 #### The only time that no handler is present is during
1880 temacs or perhaps very early in SXEmacs. In both cases,
1881 there is no 'top-level catch. (That's why the
1882 "bomb-out" hack was added.)
1884 #### Fix this horrifitude!
1886 signal_call_debugger(conditions, sig, data, Qnil, 0,
1887 &stack_trace_displayed, &debugger_entered);
1889 throw_or_bomb_out(Qtop_level, Qt, 1, sig, data); /* Doesn't return */
1893 /****************** Error functions class 1 ******************/
1895 /* Class 1: General functions that signal an error.
1896 These functions take an error type and a list of associated error
1899 /* The simplest external error function: it would be called
1900 signal_continuable_error() in the terminology below, but it's
1903 DEFUN("signal", Fsignal, 2, 2, 0, /*
1904 Signal a continuable error. Args are ERROR-SYMBOL, and associated DATA.
1905 An error symbol is a symbol defined using `define-error'.
1906 DATA should be a list. Its elements are printed as part of the error message.
1907 If the signal is handled, DATA is made available to the handler.
1908 See also the function `signal-error', and the functions to handle errors:
1909 `condition-case' and `call-with-condition-handler'.
1911 Note that this function can return, if the debugger is invoked and the
1912 user invokes the "return from signal" option.
1914 (error_symbol, data))
1916 /* Fsignal() is one of these functions that's called all the time
1917 with newly-created Lisp objects. We allow this; but we must GC-
1918 protect the objects because all sorts of weird stuff could
1921 struct gcpro gcpro1;
1924 if (!NILP(Vcurrent_error_state)) {
1925 if (!NILP(Vcurrent_warning_class))
1926 warn_when_safe_lispobj(Vcurrent_warning_class, Qwarning,
1927 Fcons(error_symbol, data));
1928 Fthrow(Qunbound_suspended_errors_tag, Qnil);
1929 abort(); /* Better not get here! */
1931 RETURN_UNGCPRO(signal_1(error_symbol, data));
1934 /* Signal a non-continuable error. */
1936 DOESNT_RETURN signal_error(Lisp_Object sig, Lisp_Object data)
1942 #ifdef ERROR_CHECK_TYPECHECK
1943 void check_error_state_sanity(void)
1946 int found_error_tag = 0;
1948 for (c = catchlist; c; c = c->next) {
1949 if (EQ(c->tag, Qunbound_suspended_errors_tag)) {
1950 found_error_tag = 1;
1955 assert(found_error_tag || NILP(Vcurrent_error_state));
1959 static Lisp_Object restore_current_warning_class(Lisp_Object warning_class)
1961 Vcurrent_warning_class = warning_class;
1965 static Lisp_Object restore_current_error_state(Lisp_Object error_state)
1967 Vcurrent_error_state = error_state;
1971 static Lisp_Object call_with_suspended_errors_1(Lisp_Object opaque_arg)
1974 Lisp_Object *kludgy_args = (Lisp_Object*)get_opaque_ptr(opaque_arg);
1975 Lisp_Object no_error = kludgy_args[2];
1976 int speccount = specpdl_depth();
1978 if (!EQ(Vcurrent_error_state, no_error)) {
1979 record_unwind_protect(restore_current_error_state,
1980 Vcurrent_error_state);
1981 Vcurrent_error_state = no_error;
1983 PRIMITIVE_FUNCALL(val, get_opaque_ptr(kludgy_args[0]),
1984 kludgy_args + 3, XINT(kludgy_args[1]));
1985 return unbind_to(speccount, val);
1988 /* Many functions would like to do one of three things if an error
1991 (1) signal the error, as usual.
1992 (2) silently fail and return some error value.
1993 (3) do as (2) but issue a warning in the process.
1995 Currently there's lots of stuff that passes an Error_behavior
1996 value and calls maybe_signal_error() and other such functions.
1997 This approach is inherently error-prone and broken. A much
1998 more robust and easier approach is to use call_with_suspended_errors().
1999 Wrap this around any function in which you might want errors
2004 call_with_suspended_errors(lisp_fn_t fun, volatile Lisp_Object retval,
2005 Lisp_Object class, Error_behavior errb,
2010 Lisp_Object kludgy_args[23];
2011 Lisp_Object *args = kludgy_args + 3;
2013 Lisp_Object no_error;
2015 assert(SYMBOLP(class)); /* sanity-check */
2016 assert(!NILP(class));
2017 assert(nargs >= 0 && nargs < 20);
2019 /* ERROR_ME means don't trap errors. (However, if errors are
2020 already trapped, we leave them trapped.)
2022 Otherwise, we trap errors, and trap warnings if ERROR_ME_WARN.
2024 If ERROR_ME_NOT, it causes no warnings even if warnings
2025 were previously enabled. However, we never change the
2026 warning class from one to another. */
2027 if (!ERRB_EQ(errb, ERROR_ME)) {
2028 if (ERRB_EQ(errb, ERROR_ME_NOT)) /* person wants no warnings */
2030 errb = ERROR_ME_NOT;
2035 va_start(vargs, nargs);
2036 for (i = 0; i < nargs; i++)
2037 args[i] = va_arg(vargs, Lisp_Object);
2040 /* If error-checking is not disabled, just call the function.
2041 It's important not to override disabled error-checking with
2042 enabled error-checking. */
2044 if (ERRB_EQ(errb, ERROR_ME)) {
2046 PRIMITIVE_FUNCALL(val, fun, args, nargs);
2050 speccount = specpdl_depth();
2051 if (NILP(class) || NILP(Vcurrent_warning_class)) {
2052 /* If we're currently calling for no warnings, then make it so.
2053 If we're currently calling for warnings and we weren't
2054 previously, then set our warning class; otherwise, leave
2055 the existing one alone. */
2056 record_unwind_protect(restore_current_warning_class,
2057 Vcurrent_warning_class);
2058 Vcurrent_warning_class = class;
2063 Lisp_Object the_retval;
2064 Lisp_Object opaque1 = make_opaque_ptr(kludgy_args);
2065 Lisp_Object opaque2 = make_opaque_ptr((void *)fun);
2066 struct gcpro gcpro1, gcpro2;
2068 GCPRO2(opaque1, opaque2);
2069 kludgy_args[0] = opaque2;
2070 kludgy_args[1] = make_int(nargs);
2071 kludgy_args[2] = no_error;
2072 the_retval = internal_catch(Qunbound_suspended_errors_tag,
2073 call_with_suspended_errors_1,
2075 free_opaque_ptr(opaque1);
2076 free_opaque_ptr(opaque2);
2078 /* Use the returned value except in non-local exit, when
2080 /* Some perverse compilers require the perverse cast below. */
2081 return unbind_to(speccount,
2082 threw ? *((volatile Lisp_Object*)&(retval)) :
2087 /* Signal a non-continuable error or display a warning or do nothing,
2088 according to ERRB. CLASS is the class of warning and should
2089 refer to what sort of operation is being done (e.g. Qtoolbar,
2090 Qresource, etc.). */
2093 maybe_signal_error(Lisp_Object sig, Lisp_Object data, Lisp_Object class,
2094 Error_behavior errb)
2096 if (ERRB_EQ(errb, ERROR_ME_NOT))
2098 else if (ERRB_EQ(errb, ERROR_ME_WARN))
2099 warn_when_safe_lispobj(class, Qwarning, Fcons(sig, data));
2105 /* Signal a continuable error or display a warning or do nothing,
2106 according to ERRB. */
2109 maybe_signal_continuable_error(Lisp_Object sig, Lisp_Object data,
2110 Lisp_Object class, Error_behavior errb)
2112 if (ERRB_EQ(errb, ERROR_ME_NOT))
2114 else if (ERRB_EQ(errb, ERROR_ME_WARN)) {
2115 warn_when_safe_lispobj(class, Qwarning, Fcons(sig, data));
2118 return Fsignal(sig, data);
2121 /****************** Error functions class 2 ******************/
2123 /* Class 2: Printf-like functions that signal an error.
2124 These functions signal an error of a specified type, whose data
2125 is a single string, created using the arguments. */
2127 /* dump an error message; called like printf */
2129 DOESNT_RETURN type_error(Lisp_Object type, const char *fmt, ...)
2134 va_start(args, fmt);
2135 obj = emacs_doprnt_string_va((const Bufbyte *)GETTEXT(fmt), Qnil, -1,
2139 /* Fsignal GC-protects its args */
2140 signal_error(type, list1(obj));
2144 maybe_type_error(Lisp_Object type, Lisp_Object class, Error_behavior errb,
2145 const char *fmt, ...)
2151 if (ERRB_EQ(errb, ERROR_ME_NOT))
2154 va_start(args, fmt);
2155 obj = emacs_doprnt_string_va((const Bufbyte *)GETTEXT(fmt), Qnil, -1,
2159 /* Fsignal GC-protects its args */
2160 maybe_signal_error(type, list1(obj), class, errb);
2163 Lisp_Object continuable_type_error(Lisp_Object type, const char *fmt, ...)
2168 va_start(args, fmt);
2169 obj = emacs_doprnt_string_va((const Bufbyte *)GETTEXT(fmt), Qnil, -1,
2173 /* Fsignal GC-protects its args */
2174 return Fsignal(type, list1(obj));
2178 maybe_continuable_type_error(Lisp_Object type, Lisp_Object class,
2179 Error_behavior errb, const char *fmt, ...)
2185 if (ERRB_EQ(errb, ERROR_ME_NOT))
2188 va_start(args, fmt);
2189 obj = emacs_doprnt_string_va((const Bufbyte *)GETTEXT(fmt), Qnil, -1,
2193 /* Fsignal GC-protects its args */
2194 return maybe_signal_continuable_error(type, list1(obj), class, errb);
2197 /****************** Error functions class 3 ******************/
2199 /* Class 3: Signal an error with a string and an associated object.
2200 These functions signal an error of a specified type, whose data
2201 is two objects, a string and a related Lisp object (usually the object
2202 where the error is occurring). */
2205 signal_type_error(Lisp_Object type, const char *reason, Lisp_Object frob)
2208 signal_error(type, list1(build_translated_string(reason)));
2211 list2(build_translated_string(reason), frob));
2215 maybe_signal_type_error(Lisp_Object type, const char *reason,
2216 Lisp_Object frob, Lisp_Object class,
2217 Error_behavior errb)
2220 if (ERRB_EQ(errb, ERROR_ME_NOT))
2222 maybe_signal_error(type, list2(build_translated_string(reason), frob),
2227 signal_type_continuable_error(Lisp_Object type, const char *reason,
2230 return Fsignal(type, list2(build_translated_string(reason), frob));
2234 maybe_signal_type_continuable_error(Lisp_Object type, const char *reason,
2235 Lisp_Object frob, Lisp_Object class,
2236 Error_behavior errb)
2239 if (ERRB_EQ(errb, ERROR_ME_NOT))
2241 return maybe_signal_continuable_error
2242 (type, list2(build_translated_string(reason), frob), class, errb);
2245 /****************** Error functions class 4 ******************/
2247 /* Class 4: Printf-like functions that signal an error.
2248 These functions signal an error of a specified type, whose data
2249 is a two objects, a string (created using the arguments) and a
2254 type_error_with_frob(Lisp_Object type, Lisp_Object frob, const char *fmt, ...)
2259 va_start(args, fmt);
2260 obj = emacs_doprnt_string_va((const Bufbyte *)GETTEXT(fmt), Qnil, -1,
2264 /* Fsignal GC-protects its args */
2265 signal_error(type, list2(obj, frob));
2269 maybe_type_error_with_frob(Lisp_Object type, Lisp_Object frob,
2270 Lisp_Object class, Error_behavior errb,
2271 const char *fmt, ...)
2277 if (ERRB_EQ(errb, ERROR_ME_NOT))
2280 va_start(args, fmt);
2281 obj = emacs_doprnt_string_va((const Bufbyte *)GETTEXT(fmt), Qnil, -1,
2285 /* Fsignal GC-protects its args */
2286 maybe_signal_error(type, list2(obj, frob), class, errb);
2290 continuable_type_error_with_frob(Lisp_Object type, Lisp_Object frob,
2291 const char *fmt, ...)
2296 va_start(args, fmt);
2297 obj = emacs_doprnt_string_va((const Bufbyte *)GETTEXT(fmt), Qnil, -1,
2301 /* Fsignal GC-protects its args */
2302 return Fsignal(type, list2(obj, frob));
2306 maybe_continuable_type_error_with_frob(Lisp_Object type, Lisp_Object frob,
2307 Lisp_Object class, Error_behavior errb,
2308 const char *fmt, ...)
2314 if (ERRB_EQ(errb, ERROR_ME_NOT))
2317 va_start(args, fmt);
2318 obj = emacs_doprnt_string_va((const Bufbyte *)GETTEXT(fmt), Qnil, -1,
2322 /* Fsignal GC-protects its args */
2323 return maybe_signal_continuable_error(type, list2(obj, frob),
2327 /****************** Error functions class 5 ******************/
2329 /* Class 5: Signal an error with a string and two associated objects.
2330 These functions signal an error of a specified type, whose data
2331 is three objects, a string and two related Lisp objects. */
2334 signal_type_error_2(Lisp_Object type, const char *reason,
2335 Lisp_Object frob0, Lisp_Object frob1)
2337 signal_error(type, list3(build_translated_string(reason), frob0,
2342 maybe_signal_type_error_2(Lisp_Object type, const char *reason,
2343 Lisp_Object frob0, Lisp_Object frob1,
2344 Lisp_Object class, Error_behavior errb)
2347 if (ERRB_EQ(errb, ERROR_ME_NOT))
2349 maybe_signal_error(type, list3(build_translated_string(reason), frob0,
2350 frob1), class, errb);
2354 signal_type_continuable_error_2(Lisp_Object type, const char *reason,
2355 Lisp_Object frob0, Lisp_Object frob1)
2357 return Fsignal(type, list3(build_translated_string(reason), frob0,
2362 maybe_signal_type_continuable_error_2(Lisp_Object type, const char *reason,
2363 Lisp_Object frob0, Lisp_Object frob1,
2364 Lisp_Object class, Error_behavior errb)
2367 if (ERRB_EQ(errb, ERROR_ME_NOT))
2369 return maybe_signal_continuable_error
2370 (type, list3(build_translated_string(reason), frob0,
2371 frob1), class, errb);
2374 /****************** Simple error functions class 2 ******************/
2376 /* Simple class 2: Printf-like functions that signal an error.
2377 These functions signal an error of type Qerror, whose data
2378 is a single string, created using the arguments. */
2380 /* dump an error message; called like printf */
2382 DOESNT_RETURN error(const char *fmt, ...)
2387 va_start(args, fmt);
2388 obj = emacs_doprnt_string_va((const Bufbyte *)GETTEXT(fmt), Qnil, -1,
2392 /* Fsignal GC-protects its args */
2393 signal_error(Qerror, list1(obj));
2396 void maybe_error(Lisp_Object class, Error_behavior errb, const char *fmt, ...)
2402 if (ERRB_EQ(errb, ERROR_ME_NOT))
2405 va_start(args, fmt);
2406 obj = emacs_doprnt_string_va((const Bufbyte *)GETTEXT(fmt), Qnil, -1,
2410 /* Fsignal GC-protects its args */
2411 maybe_signal_error(Qerror, list1(obj), class, errb);
2414 Lisp_Object continuable_error(const char *fmt, ...)
2419 va_start(args, fmt);
2420 obj = emacs_doprnt_string_va((const Bufbyte *)GETTEXT(fmt), Qnil, -1,
2424 /* Fsignal GC-protects its args */
2425 return Fsignal(Qerror, list1(obj));
2429 maybe_continuable_error(Lisp_Object class, Error_behavior errb,
2430 const char *fmt, ...)
2436 if (ERRB_EQ(errb, ERROR_ME_NOT))
2439 va_start(args, fmt);
2440 obj = emacs_doprnt_string_va((const Bufbyte *)GETTEXT(fmt), Qnil, -1,
2444 /* Fsignal GC-protects its args */
2445 return maybe_signal_continuable_error(Qerror, list1(obj), class, errb);
2448 /****************** Simple error functions class 3 ******************/
2450 /* Simple class 3: Signal an error with a string and an associated object.
2451 These functions signal an error of type Qerror, whose data
2452 is two objects, a string and a related Lisp object (usually the object
2453 where the error is occurring). */
2455 DOESNT_RETURN signal_simple_error(const char *reason, Lisp_Object frob)
2457 signal_error(Qerror, list2(build_translated_string(reason), frob));
2461 maybe_signal_simple_error(const char *reason, Lisp_Object frob,
2462 Lisp_Object class, Error_behavior errb)
2465 if (ERRB_EQ(errb, ERROR_ME_NOT))
2467 maybe_signal_error(Qerror, list2(build_translated_string(reason), frob),
2472 signal_simple_continuable_error(const char *reason, Lisp_Object frob)
2474 return Fsignal(Qerror, list2(build_translated_string(reason), frob));
2478 maybe_signal_simple_continuable_error(const char *reason, Lisp_Object frob,
2479 Lisp_Object class, Error_behavior errb)
2482 if (ERRB_EQ(errb, ERROR_ME_NOT))
2484 return maybe_signal_continuable_error
2485 (Qerror, list2(build_translated_string(reason), frob), class, errb);
2488 /****************** Simple error functions class 4 ******************/
2490 /* Simple class 4: Printf-like functions that signal an error.
2491 These functions signal an error of type Qerror, whose data
2492 is a two objects, a string (created using the arguments) and a
2496 DOESNT_RETURN error_with_frob(Lisp_Object frob, const char *fmt, ...)
2501 va_start(args, fmt);
2502 obj = emacs_doprnt_string_va((const Bufbyte *)GETTEXT(fmt), Qnil, -1,
2506 /* Fsignal GC-protects its args */
2507 signal_error(Qerror, list2(obj, frob));
2511 maybe_error_with_frob(Lisp_Object frob, Lisp_Object class,
2512 Error_behavior errb, const char *fmt, ...)
2518 if (ERRB_EQ(errb, ERROR_ME_NOT))
2521 va_start(args, fmt);
2522 obj = emacs_doprnt_string_va((const Bufbyte *)GETTEXT(fmt), Qnil, -1,
2526 /* Fsignal GC-protects its args */
2527 maybe_signal_error(Qerror, list2(obj, frob), class, errb);
2530 Lisp_Object continuable_error_with_frob(Lisp_Object frob, const char *fmt, ...)
2535 va_start(args, fmt);
2536 obj = emacs_doprnt_string_va((const Bufbyte *)GETTEXT(fmt), Qnil, -1,
2540 /* Fsignal GC-protects its args */
2541 return Fsignal(Qerror, list2(obj, frob));
2545 maybe_continuable_error_with_frob(Lisp_Object frob, Lisp_Object class,
2546 Error_behavior errb, const char *fmt, ...)
2552 if (ERRB_EQ(errb, ERROR_ME_NOT))
2555 va_start(args, fmt);
2556 obj = emacs_doprnt_string_va((const Bufbyte *)GETTEXT(fmt), Qnil, -1,
2560 /* Fsignal GC-protects its args */
2561 return maybe_signal_continuable_error(Qerror, list2(obj, frob),
2565 /****************** Simple error functions class 5 ******************/
2567 /* Simple class 5: Signal an error with a string and two associated objects.
2568 These functions signal an error of type Qerror, whose data
2569 is three objects, a string and two related Lisp objects. */
2572 signal_simple_error_2(const char *reason, Lisp_Object frob0, Lisp_Object frob1)
2574 signal_error(Qerror, list3(build_translated_string(reason), frob0,
2579 maybe_signal_simple_error_2(const char *reason, Lisp_Object frob0,
2580 Lisp_Object frob1, Lisp_Object class,
2581 Error_behavior errb)
2584 if (ERRB_EQ(errb, ERROR_ME_NOT))
2586 maybe_signal_error(Qerror, list3(build_translated_string(reason), frob0,
2587 frob1), class, errb);
2591 signal_simple_continuable_error_2(const char *reason, Lisp_Object frob0,
2594 return Fsignal(Qerror, list3(build_translated_string(reason), frob0,
2599 maybe_signal_simple_continuable_error_2(const char *reason, Lisp_Object frob0,
2600 Lisp_Object frob1, Lisp_Object class,
2601 Error_behavior errb)
2604 if (ERRB_EQ(errb, ERROR_ME_NOT))
2606 return maybe_signal_continuable_error
2607 (Qerror, list3(build_translated_string(reason), frob0,
2608 frob1), class, errb);
2611 /* This is what the QUIT macro calls to signal a quit */
2612 void signal_quit(void)
2614 /* This function can GC */
2615 if (EQ(Vquit_flag, Qcritical))
2616 debug_on_quit |= 2; /* set critical bit. */
2618 /* note that this is continuable. */
2619 Fsignal(Qquit, Qnil);
2622 /* Used in core lisp functions for efficiency */
2623 Lisp_Object signal_void_function_error(Lisp_Object function)
2625 return Fsignal(Qvoid_function, list1(function));
2628 Lisp_Object signal_invalid_function_error(Lisp_Object function)
2630 return Fsignal(Qinvalid_function, list1(function));
2634 signal_wrong_number_of_arguments_error(Lisp_Object function, int nargs)
2636 return Fsignal(Qwrong_number_of_arguments,
2637 list2(function, make_int(nargs)));
2640 /* Used in list traversal macros for efficiency. */
2641 DOESNT_RETURN signal_malformed_list_error(Lisp_Object list)
2643 signal_error(Qmalformed_list, list1(list));
2646 DOESNT_RETURN signal_malformed_property_list_error(Lisp_Object list)
2648 signal_error(Qmalformed_property_list, list1(list));
2651 DOESNT_RETURN signal_circular_list_error(Lisp_Object list)
2653 signal_error(Qcircular_list, list1(list));
2656 DOESNT_RETURN signal_circular_property_list_error(Lisp_Object list)
2658 signal_error(Qcircular_property_list, list1(list));
2661 DOESNT_RETURN syntax_error(const char *reason, Lisp_Object frob)
2663 signal_type_error(Qsyntax_error, reason, frob);
2667 syntax_error_2(const char *reason, Lisp_Object frob1, Lisp_Object frob2)
2669 signal_type_error_2(Qsyntax_error, reason, frob1, frob2);
2672 DOESNT_RETURN invalid_argument(const char *reason, Lisp_Object frob)
2674 signal_type_error(Qinvalid_argument, reason, frob);
2678 invalid_argument_2(const char *reason, Lisp_Object frob1, Lisp_Object frob2)
2680 signal_type_error_2(Qinvalid_argument, reason, frob1, frob2);
2683 DOESNT_RETURN invalid_operation(const char *reason, Lisp_Object frob)
2685 signal_type_error(Qinvalid_operation, reason, frob);
2689 invalid_operation_2(const char *reason, Lisp_Object frob1, Lisp_Object frob2)
2691 signal_type_error_2(Qinvalid_operation, reason, frob1, frob2);
2694 DOESNT_RETURN invalid_change(const char *reason, Lisp_Object frob)
2696 signal_type_error(Qinvalid_change, reason, frob);
2700 invalid_change_2(const char *reason, Lisp_Object frob1, Lisp_Object frob2)
2702 signal_type_error_2(Qinvalid_change, reason, frob1, frob2);
2705 /************************************************************************/
2707 /************************************************************************/
2709 DEFUN("commandp", Fcommandp, 1, 1, 0, /*
2710 Return t if FUNCTION makes provisions for interactive calling.
2711 This means it contains a description for how to read arguments to give it.
2712 The value is nil for an invalid function or a symbol with no function
2715 Interactively callable functions include
2717 -- strings and vectors (treated as keyboard macros)
2718 -- lambda-expressions that contain a top-level call to `interactive'
2719 -- autoload definitions made by `autoload' with non-nil fourth argument
2720 (i.e. the interactive flag)
2721 -- compiled-function objects with a non-nil `compiled-function-interactive'
2723 -- subrs (built-in functions) that are interactively callable
2725 Also, a symbol satisfies `commandp' if its function definition does so.
2729 Lisp_Object fun = indirect_function(function, 0);
2731 if (COMPILED_FUNCTIONP(fun))
2732 return XCOMPILED_FUNCTION(fun)->flags.interactivep ? Qt : Qnil;
2734 /* Lists may represent commands. */
2736 Lisp_Object funcar = XCAR(fun);
2737 if (EQ(funcar, Qlambda))
2738 return Fassq(Qinteractive, Fcdr(Fcdr(fun)));
2739 if (EQ(funcar, Qautoload))
2740 return Fcar(Fcdr(Fcdr(Fcdr(fun))));
2745 /* Emacs primitives are interactive if their DEFUN specifies an
2746 interactive spec. */
2748 return XSUBR(fun)->prompt ? Qt : Qnil;
2750 /* Strings and vectors are keyboard macros. */
2751 if (VECTORP(fun) || STRINGP(fun))
2754 /* Everything else (including Qunbound) is not a command. */
2758 DEFUN("command-execute", Fcommand_execute, 1, 3, 0, /*
2759 Execute CMD as an editor command.
2760 CMD must be an object that satisfies the `commandp' predicate.
2761 Optional second arg RECORD-FLAG is as in `call-interactively'.
2762 The argument KEYS specifies the value to use instead of (this-command-keys)
2763 when reading the arguments.
2765 (cmd, record_flag, keys))
2767 /* This function can GC */
2768 Lisp_Object prefixarg;
2769 Lisp_Object final = cmd;
2770 struct backtrace backtrace;
2771 struct console *con = XCONSOLE(Vselected_console);
2773 prefixarg = con->prefix_arg;
2774 con->prefix_arg = Qnil;
2775 Vcurrent_prefix_arg = prefixarg;
2776 debug_on_next_call = 0; /* #### from FSFmacs; correct? */
2778 if (SYMBOLP(cmd) && !NILP(Fget(cmd, Qdisabled, Qnil)))
2779 return run_hook(Vdisabled_command_hook);
2782 final = indirect_function(cmd, 1);
2783 if (CONSP(final) && EQ(Fcar(final), Qautoload)) {
2784 /* do_autoload GCPROs both arguments */
2785 do_autoload(final, cmd);
2790 if (CONSP(final) || SUBRP(final) || COMPILED_FUNCTIONP(final)) {
2791 backtrace.function = &Qcall_interactively;
2792 backtrace.args = &cmd;
2793 backtrace.nargs = 1;
2794 backtrace.evalargs = 0;
2795 backtrace.pdlcount = specpdl_depth();
2796 backtrace.debug_on_exit = 0;
2797 PUSH_BACKTRACE(backtrace);
2799 final = Fcall_interactively(cmd, record_flag, keys);
2801 POP_BACKTRACE(backtrace);
2803 } else if (STRINGP(final) || VECTORP(final)) {
2804 return Fexecute_kbd_macro(final, prefixarg);
2806 Fsignal(Qwrong_type_argument, Fcons(Qcommandp, (EQ(cmd, final)
2814 DEFUN("interactive-p", Finteractive_p, 0, 0, 0, /*
2815 Return t if function in which this appears was called interactively.
2816 This means that the function was called with call-interactively (which
2817 includes being called as the binding of a key)
2818 and input is currently coming from the keyboard (not in keyboard macro).
2822 REGISTER struct backtrace *btp = NULL;
2823 REGISTER Lisp_Object fun = Qnil;
2828 /* Unless the object was compiled, skip the frame of interactive-p itself
2829 (if interpreted) or the frame of byte-code (if called from a compiled
2830 function). Note that *btp->function may be a symbol pointing at a
2831 compiled function. */
2832 btp = backtrace_list;
2836 /* #### FSFmacs does the following instead. I can't figure
2837 out which one is more correct. */
2838 /* If this isn't a byte-compiled function, there may be a frame at
2839 the top for Finteractive_p itself. If so, skip it. */
2840 fun = Findirect_function(*btp->function);
2841 if (SUBRP(fun) && XSUBR(fun) == &Sinteractive_p)
2844 /* If we're running an Emacs 18-style byte-compiled function, there
2845 may be a frame for Fbyte_code. Now, given the strictest
2846 definition, this function isn't really being called
2847 interactively, but because that's the way Emacs 18 always builds
2848 byte-compiled functions, we'll accept it for now. */
2849 if (EQ(*btp->function, Qbyte_code))
2852 /* If this isn't a byte-compiled function, then we may now be
2853 looking at several frames for special forms. Skip past them. */
2854 while (btp && btp->nargs == UNEVALLED)
2859 /* argh, COMPILED_FUNCTIONP evals its argument multiple times,
2860 * so put it into a var first ... gosh I wish all those macros were
2862 fun = Findirect_function(*btp->function);
2863 if (!(COMPILED_FUNCTIONP(fun))) {
2867 btp && (btp->nargs == UNEVALLED
2868 || EQ(*btp->function, Qbyte_code)); btp = btp->next) {
2870 /* btp now points at the frame of the innermost function
2871 that DOES eval its args.
2872 If it is a built-in function (such as load or eval-region)
2874 /* Beats me why this is necessary, but it is */
2875 if (btp && EQ(*btp->function, Qcall_interactively))
2881 fun = Findirect_function(*btp->function);
2884 /* btp points to the frame of a Lisp function that called interactive-p.
2885 Return t if that function was called interactively. */
2886 if (btp && btp->next && EQ(*btp->next->function, Qcall_interactively))
2891 /************************************************************************/
2893 /************************************************************************/
2895 DEFUN("autoload", Fautoload, 2, 5, 0, /*
2896 Define FUNCTION to autoload from FILENAME.
2897 FUNCTION is a symbol; FILENAME is a file name string to pass to `load'.
2898 The remaining optional arguments provide additional info about the
2900 DOCSTRING is documentation for FUNCTION.
2901 INTERACTIVE, if non-nil, says FUNCTION can be called interactively.
2902 TYPE indicates the type of the object:
2903 nil or omitted says FUNCTION is a function,
2904 `keymap' says FUNCTION is really a keymap, and
2905 `macro' or t says FUNCTION is really a macro.
2906 If FUNCTION already has a non-void function definition that is not an
2907 autoload object, this function does nothing and returns nil.
2909 (function, filename, docstring, interactive, type))
2911 /* This function can GC */
2912 CHECK_SYMBOL(function);
2913 CHECK_STRING(filename);
2915 /* If function is defined and not as an autoload, don't override */
2917 Lisp_Object f = XSYMBOL(function)->function;
2918 if (!UNBOUNDP(f) && !(CONSP(f) && EQ(XCAR(f), Qautoload)))
2923 /* Attempt to avoid consing identical (string=) pure strings. */
2924 filename = Fsymbol_name(Fintern(filename, Qnil));
2927 return Ffset(function, Fcons(Qautoload, list4(filename,
2929 interactive, type)));
2932 Lisp_Object un_autoload(Lisp_Object oldqueue)
2934 /* This function can GC */
2935 REGISTER Lisp_Object queue, first, second;
2937 /* Queue to unwind is current value of Vautoload_queue.
2938 oldqueue is the shadowed value to leave in Vautoload_queue. */
2939 queue = Vautoload_queue;
2940 Vautoload_queue = oldqueue;
2941 while (CONSP(queue)) {
2942 first = XCAR(queue);
2943 second = Fcdr(first);
2944 first = Fcar(first);
2948 Ffset(first, second);
2949 queue = Fcdr(queue);
2954 void do_autoload(Lisp_Object fundef, Lisp_Object funname)
2956 /* This function can GC */
2957 int speccount = specpdl_depth();
2958 Lisp_Object fun = funname;
2959 struct gcpro gcpro1, gcpro2, gcpro3;
2961 CHECK_SYMBOL(funname);
2962 GCPRO3(fun, funname, fundef);
2964 /* Value saved here is to be restored into Vautoload_queue */
2965 record_unwind_protect(un_autoload, Vautoload_queue);
2966 Vautoload_queue = Qt;
2967 call4(Qload, Fcar(Fcdr(fundef)), Qnil, noninteractive ? Qt : Qnil,
2973 /* Save the old autoloads, in case we ever do an unload. */
2974 for (queue = Vautoload_queue; CONSP(queue); queue = XCDR(queue)) {
2975 Lisp_Object first = XCAR(queue);
2976 Lisp_Object second = Fcdr(first);
2978 first = Fcar(first);
2980 /* Note: This test is subtle. The cdr of an autoload-queue entry
2981 may be an atom if the autoload entry was generated by a defalias
2984 Fput(first, Qautoload, (XCDR(second)));
2988 /* Once loading finishes, don't undo it. */
2989 Vautoload_queue = Qt;
2990 unbind_to(speccount, Qnil);
2992 fun = indirect_function(fun, 0);
2995 if (!NILP(Fequal(fun, fundef)))
2999 && EQ(XCAR(fun), Qautoload)))
3001 error("Autoloading failed to define function %s",
3002 string_data(XSYMBOL(funname)->name));
3006 /************************************************************************/
3007 /* eval, funcall, apply */
3008 /************************************************************************/
3010 static Lisp_Object funcall_lambda(Lisp_Object fun,
3011 int nargs, Lisp_Object args[]);
3012 static int in_warnings;
3014 static Lisp_Object in_warnings_restore(Lisp_Object minimus)
3020 DEFUN("eval", Feval, 1, 1, 0, /*
3021 Evaluate FORM and return its value.
3025 /* This function can GC */
3026 Lisp_Object fun, val, original_fun, original_args;
3028 struct backtrace backtrace;
3032 return Fsymbol_value(form);
3037 /* I think this is a pretty safe place to call Lisp code, don't you? */
3038 while (!in_warnings && !NILP(Vpending_warnings)) {
3039 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
3040 int speccount = specpdl_depth();
3041 Lisp_Object this_warning_cons, this_warning, class, level,
3044 record_unwind_protect(in_warnings_restore, Qnil);
3046 this_warning_cons = Vpending_warnings;
3047 this_warning = XCAR(this_warning_cons);
3048 /* in case an error occurs in the warn function, at least
3049 it won't happen infinitely */
3050 Vpending_warnings = XCDR(Vpending_warnings);
3051 free_cons(XCONS(this_warning_cons));
3052 class = XCAR(this_warning);
3053 level = XCAR(XCDR(this_warning));
3054 messij = XCAR(XCDR(XCDR(this_warning)));
3055 free_list(this_warning);
3057 if (NILP(Vpending_warnings))
3058 Vpending_warnings_tail = Qnil; /* perhaps not strictly necessary,
3061 GCPRO4(form, class, level, messij);
3062 if (!STRINGP(messij))
3063 messij = Fprin1_to_string(messij, Qnil);
3064 call3(Qdisplay_warning, class, messij, level);
3066 unbind_to(speccount, Qnil);
3070 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3071 if ((consing_since_gc > gc_cons_threshold) || always_gc) {
3072 struct gcpro gcpro1;
3074 garbage_collect_1();
3079 if (++lisp_eval_depth > max_lisp_eval_depth) {
3080 if (max_lisp_eval_depth < 100)
3081 max_lisp_eval_depth = 100;
3082 if (lisp_eval_depth > max_lisp_eval_depth)
3083 error("Lisp nesting exceeds `max-lisp-eval-depth'");
3086 /* We guaranteed CONSP (form) above */
3087 original_fun = XCAR(form);
3088 original_args = XCDR(form);
3090 GET_EXTERNAL_LIST_LENGTH(original_args, nargs);
3092 backtrace.pdlcount = specpdl_depth();
3093 backtrace.function = &original_fun; /* This also protects them from gc */
3094 backtrace.args = &original_args;
3095 backtrace.nargs = UNEVALLED;
3096 backtrace.evalargs = 1;
3097 backtrace.debug_on_exit = 0;
3098 PUSH_BACKTRACE(backtrace);
3100 if (debug_on_next_call)
3101 do_debug_on_call(Qt);
3103 if (profiling_active)
3104 profile_increase_call_count(original_fun);
3106 /* At this point, only original_fun and original_args
3107 have values that will be used below. */
3109 /* Optimise for no indirection. */
3111 if (SYMBOLP (fun) && !EQ (fun, Qunbound)
3112 && (fun = XSYMBOL (fun)->function, SYMBOLP (fun)))
3113 fun = indirect_function(original_fun, 1);
3116 Lisp_Subr *subr = XSUBR(fun);
3117 int max_args = subr->max_args;
3119 if (nargs < subr->min_args)
3120 goto wrong_number_of_arguments;
3122 if (max_args == UNEVALLED) { /* Optimize for the common case */
3123 backtrace.evalargs = 0;
3125 (((Lisp_Object(*)(Lisp_Object)) subr_function(subr))
3127 } else if (nargs <= max_args) {
3128 struct gcpro gcpro1;
3129 Lisp_Object args[SUBR_MAX_ARGS];
3130 REGISTER Lisp_Object *p = args;
3133 memset(args, 0, sizeof(Lisp_Object)*SUBR_MAX_ARGS);
3135 GCPROn(args, countof(args));
3137 LIST_LOOP_2(arg, original_args) {
3141 /* &optional args default to nil. */
3142 while (p - args < max_args)
3145 backtrace.args = args;
3146 backtrace.nargs = nargs;
3148 FUNCALL_SUBR(val, subr, args, max_args);
3151 } else if (max_args == MANY) {
3152 /* Pass a vector of evaluated arguments */
3153 struct gcpro gcpro1;
3154 Lisp_Object args[nargs];
3155 REGISTER Lisp_Object *p = args;
3158 memset(args, 0, sizeof(Lisp_Object)*nargs);
3160 GCPROn(args, nargs);
3162 LIST_LOOP_2(arg, original_args) {
3166 backtrace.args = args;
3167 backtrace.nargs = nargs;
3170 (((Lisp_Object(*)(int, Lisp_Object *))subr_function
3176 wrong_number_of_arguments:
3178 signal_wrong_number_of_arguments_error(original_fun,
3181 } else if (COMPILED_FUNCTIONP(fun)) {
3182 struct gcpro gcpro1;
3183 Lisp_Object args[nargs];
3184 REGISTER Lisp_Object *p = args;
3187 memset(args, 0, sizeof(Lisp_Object)*nargs);
3189 GCPROn(args, nargs);
3191 LIST_LOOP_2(arg, original_args) {
3195 backtrace.args = args;
3196 backtrace.nargs = nargs;
3197 backtrace.evalargs = 0;
3199 val = funcall_compiled_function(fun, nargs, args);
3201 /* Do the debug-on-exit now, while args is still GCPROed. */
3202 if (backtrace.debug_on_exit)
3203 val = do_debug_on_exit(val);
3204 /* Don't do it again when we return to eval. */
3205 backtrace.debug_on_exit = 0;
3208 } else if (CONSP(fun)) {
3209 Lisp_Object funcar = XCAR(fun);
3211 if (EQ(funcar, Qautoload)) {
3212 /* do_autoload GCPROs both arguments */
3213 do_autoload(fun, original_fun);
3215 } else if (EQ(funcar, Qmacro)) {
3216 val = Feval(apply1(XCDR(fun), original_args));
3217 } else if (EQ(funcar, Qlambda)) {
3218 struct gcpro gcpro1;
3219 Lisp_Object args[nargs];
3220 REGISTER Lisp_Object *p = args;
3223 memset(args, 0, sizeof(Lisp_Object)*nargs);
3225 GCPROn(args, nargs);
3227 LIST_LOOP_2(arg, original_args) {
3233 backtrace.args = args; /* this also GCPROs `args' */
3234 backtrace.nargs = nargs;
3235 backtrace.evalargs = 0;
3237 val = funcall_lambda(fun, nargs, args);
3239 /* Do the debug-on-exit now, while args is still GCPROed. */
3240 if (backtrace.debug_on_exit)
3241 val = do_debug_on_exit(val);
3242 /* Don't do it again when we return to eval. */
3243 backtrace.debug_on_exit = 0;
3245 goto invalid_function;
3247 } else if (UNBOUNDP(fun)) {
3248 val = signal_void_function_error(original_fun);
3251 val = signal_invalid_function_error(original_fun);
3255 if (backtrace.debug_on_exit)
3256 val = do_debug_on_exit(val);
3257 POP_BACKTRACE(backtrace);
3262 /* #### Why is Feval so anal about GCPRO, Ffuncall so cavalier? */
3263 DEFUN("funcall", Ffuncall, 1, MANY, 0, /*
3264 Call first argument as a function, passing the remaining arguments to it.
3265 Thus, (funcall 'cons 'x 'y) returns (x . y).
3267 (int nargs, Lisp_Object * args))
3269 /* This function can GC */
3272 struct backtrace backtrace;
3273 int fun_nargs = nargs - 1;
3274 Lisp_Object *fun_args = args + 1;
3277 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3278 if ((consing_since_gc > gc_cons_threshold) || always_gc) {
3279 /* Callers should gcpro lexpr args */
3280 garbage_collect_1();
3284 if (++lisp_eval_depth > max_lisp_eval_depth) {
3285 if (max_lisp_eval_depth < 100)
3286 max_lisp_eval_depth = 100;
3287 if (lisp_eval_depth > max_lisp_eval_depth)
3288 error("Lisp nesting exceeds `max-lisp-eval-depth'");
3291 backtrace.pdlcount = specpdl_depth();
3292 backtrace.function = &args[0];
3293 backtrace.args = fun_args;
3294 backtrace.nargs = fun_nargs;
3295 backtrace.evalargs = 0;
3296 backtrace.debug_on_exit = 0;
3297 PUSH_BACKTRACE(backtrace);
3299 if (debug_on_next_call)
3300 do_debug_on_call(Qlambda);
3306 /* It might be useful to place this *after* all the checks. */
3307 if (profiling_active)
3308 profile_increase_call_count(fun);
3310 /* We could call indirect_function directly, but profiling shows
3311 this is worth optimizing by partially unrolling the loop. */
3313 fun = XSYMBOL(fun)->function;
3315 fun = XSYMBOL(fun)->function;
3317 fun = indirect_function(fun, 1);
3322 Lisp_Subr *subr = XSUBR(fun);
3323 int max_args = subr->max_args;
3324 Lisp_Object spacious_args[SUBR_MAX_ARGS];
3326 if (fun_nargs == max_args) { /* Optimize for the common case */
3329 /* The "extra" braces placate GCC 2.95.4. */
3330 FUNCALL_SUBR(val, subr, fun_args, max_args);
3332 } else if (fun_nargs < subr->min_args) {
3333 goto wrong_number_of_arguments;
3334 } else if (fun_nargs < max_args) {
3335 Lisp_Object *p = spacious_args;
3337 /* Default optionals to nil */
3340 while (p - spacious_args < max_args)
3343 fun_args = spacious_args;
3345 } else if (max_args == MANY) {
3346 val = SUBR_FUNCTION(subr, MANY) (fun_nargs, fun_args);
3347 } else if (max_args == UNEVALLED) { /* Can't funcall a special form */
3348 goto invalid_function;
3350 wrong_number_of_arguments:
3352 signal_wrong_number_of_arguments_error(fun,
3355 } else if (COMPILED_FUNCTIONP(fun)) {
3356 val = funcall_compiled_function(fun, fun_nargs, fun_args);
3357 } else if (CONSP(fun)) {
3358 Lisp_Object funcar = XCAR(fun);
3360 if (EQ(funcar, Qlambda)) {
3361 val = funcall_lambda(fun, fun_nargs, fun_args);
3362 } else if (EQ(funcar, Qautoload)) {
3363 /* do_autoload GCPROs both arguments */
3364 do_autoload(fun, args[0]);
3366 } else { /* Can't funcall a macro */
3368 goto invalid_function;
3370 } else if (UNBOUNDP(fun)) {
3371 val = signal_void_function_error(args[0]);
3374 val = signal_invalid_function_error(fun);
3378 if (backtrace.debug_on_exit)
3379 val = do_debug_on_exit(val);
3380 POP_BACKTRACE(backtrace);
3384 DEFUN("functionp", Ffunctionp, 1, 1, 0, /*
3385 Return t if OBJECT can be called as a function, else nil.
3386 A function is an object that can be applied to arguments,
3387 using for example `funcall' or `apply'.
3391 if (SYMBOLP(object))
3392 object = indirect_function(object, 0);
3396 COMPILED_FUNCTIONP(object) ||
3398 (EQ(XCAR(object), Qlambda) || EQ(XCAR(object), Qautoload))))
3403 function_argcount(Lisp_Object function, int function_min_args_p)
3405 Lisp_Object orig_function = function;
3406 Lisp_Object arglist;
3410 if (SYMBOLP(function))
3411 function = indirect_function(function, 1);
3413 if (SUBRP(function)) {
3414 /* Using return with the ?: operator tickles a DEC CC compiler bug. */
3415 if (function_min_args_p)
3416 return Fsubr_min_args(function);
3418 return Fsubr_max_args(function);
3419 } else if (COMPILED_FUNCTIONP(function)) {
3421 compiled_function_arglist(XCOMPILED_FUNCTION(function));
3422 } else if (CONSP(function)) {
3423 Lisp_Object funcar = XCAR(function);
3425 if (EQ(funcar, Qmacro)) {
3426 function = XCDR(function);
3428 } else if (EQ(funcar, Qautoload)) {
3429 /* do_autoload GCPROs both arguments */
3430 do_autoload(function, orig_function);
3431 function = orig_function;
3433 } else if (EQ(funcar, Qlambda)) {
3434 arglist = Fcar(XCDR(function));
3436 goto invalid_function;
3440 return signal_invalid_function_error(orig_function);
3446 EXTERNAL_LIST_LOOP_2(arg, arglist) {
3447 if (EQ(arg, Qand_optional)) {
3448 if (function_min_args_p)
3450 } else if (EQ(arg, Qand_rest)) {
3451 if (function_min_args_p)
3460 return make_int(argcount);
3464 DEFUN("function-min-args", Ffunction_min_args, 1, 1, 0, /*
3465 Return the number of arguments a function may be called with.
3466 The function may be any form that can be passed to `funcall',
3467 any special form, or any macro.
3471 return function_argcount(function, 1);
3474 DEFUN("function-max-args", Ffunction_max_args, 1, 1, 0, /*
3475 Return the number of arguments a function may be called with.
3476 The function may be any form that can be passed to `funcall',
3477 any special form, or any macro.
3478 If the function takes an arbitrary number of arguments or is
3479 a built-in special form, nil is returned.
3483 return function_argcount(function, 0);
3486 DEFUN("apply", Fapply, 2, MANY, 0, /*
3487 Call FUNCTION with the remaining args, using the last arg as a list of args.
3488 Thus, (apply '+ 1 2 '(3 4)) returns 10.
3490 (int nargs, Lisp_Object * args))
3492 /* This function can GC */
3493 Lisp_Object fun = args[0];
3494 Lisp_Object spread_arg = args[nargs - 1];
3498 GET_EXTERNAL_LIST_LENGTH(spread_arg, numargs);
3501 /* (apply foo 0 1 '()) */
3502 return Ffuncall(nargs - 1, args);
3503 else if (numargs == 1) {
3504 /* (apply foo 0 1 '(2)) */
3505 args[nargs - 1] = XCAR(spread_arg);
3506 return Ffuncall(nargs, args);
3509 /* -1 for function, -1 for spread arg */
3510 numargs = nargs - 2 + numargs;
3511 /* +1 for function */
3512 funcall_nargs = 1 + numargs;
3515 fun = indirect_function(fun, 0);
3518 Lisp_Subr *subr = XSUBR(fun);
3519 int max_args = subr->max_args;
3521 if (numargs < subr->min_args
3522 || (max_args >= 0 && max_args < numargs)) {
3523 /* Let funcall get the error */
3524 } else if (max_args > numargs) {
3525 /* Avoid having funcall cons up yet another new vector of arguments
3526 by explicitly supplying nil's for optional values */
3527 funcall_nargs += (max_args - numargs);
3529 } else if (UNBOUNDP(fun)) {
3530 /* Let funcall get the error */
3536 Lisp_Object funcall_args[funcall_nargs];
3537 struct gcpro gcpro1;
3540 memset(funcall_args, 0, sizeof(Lisp_Object)*funcall_nargs);
3542 GCPROn(funcall_args, funcall_nargs);
3544 /* Copy in the unspread args */
3545 memcpy(funcall_args, args, (nargs - 1) * sizeof(Lisp_Object));
3546 /* Spread the last arg we got. Its first element goes in
3547 the slot that it used to occupy, hence this value of I. */
3548 for (i = nargs - 1; !NILP(spread_arg); /* i < 1 + numargs */
3549 i++, spread_arg = XCDR(spread_arg)) {
3550 funcall_args[i] = XCAR(spread_arg);
3552 /* Supply nil for optional args (to subrs) */
3553 for (; i < funcall_nargs; i++) {
3554 funcall_args[i] = Qnil;
3557 RETURN_UNGCPRO(Ffuncall(funcall_nargs, funcall_args));
3561 /* Apply lambda list FUN to the NARGS evaluated arguments in ARGS and
3562 return the result of evaluation. */
3565 funcall_lambda(Lisp_Object fun, int nargs, Lisp_Object args[])
3567 /* This function can GC */
3568 Lisp_Object arglist, body, tail;
3569 int speccount = specpdl_depth();
3575 goto invalid_function;
3577 arglist = XCAR(tail);
3581 int optional = 0, rest = 0;
3583 EXTERNAL_LIST_LOOP_2(symbol, arglist) {
3584 if (!SYMBOLP(symbol))
3585 goto invalid_function;
3586 if (EQ(symbol, Qand_rest))
3588 else if (EQ(symbol, Qand_optional))
3591 specbind(symbol, Flist(nargs - i, &args[i]));
3593 } else if (i < nargs)
3594 specbind(symbol, args[i++]);
3596 goto wrong_number_of_arguments;
3598 specbind(symbol, Qnil);
3603 goto wrong_number_of_arguments;
3605 return unbind_to(speccount, Fprogn(body));
3607 wrong_number_of_arguments:
3608 return signal_wrong_number_of_arguments_error(fun, nargs);
3611 return signal_invalid_function_error(fun);
3614 /************************************************************************/
3615 /* Run hook variables in various ways. */
3616 /************************************************************************/
3617 int changing_major_mode = 0;
3618 Lisp_Object Qafter_change_major_mode_hook, Vafter_change_major_mode_hook;
3619 Lisp_Object Qafter_change_before_major_mode_hook, Vafter_change_before_major_mode_hook;
3621 Lisp_Object run_hook(Lisp_Object hook);
3623 DEFUN("run-hooks", Frun_hooks, 1, MANY, 0, /*
3624 Run each hook in HOOKS. Major mode functions use this.
3625 Each argument should be a symbol, a hook variable.
3626 These symbols are processed in the order specified.
3627 If a hook symbol has a non-nil value, that value may be a function
3628 or a list of functions to be called to run the hook.
3629 If the value is a function, it is called with no arguments.
3630 If it is a list, the elements are called, in order, with no arguments.
3632 To make a hook variable buffer-local, use `make-local-hook',
3633 not `make-local-variable'.
3635 (int nargs, Lisp_Object * args))
3639 if (changing_major_mode) {
3640 Lisp_Object Qhook = Qafter_change_before_major_mode_hook;
3641 run_hook_with_args( 1, &Qhook,
3642 RUN_HOOKS_TO_COMPLETION);
3645 for (i = 0; i < nargs; i++)
3646 run_hook_with_args(1, args + i, RUN_HOOKS_TO_COMPLETION);
3648 if (changing_major_mode) {
3649 Lisp_Object Qhook = Qafter_change_major_mode_hook;
3650 changing_major_mode = 0;
3651 run_hook_with_args( 1, &Qhook,
3652 RUN_HOOKS_TO_COMPLETION);
3658 DEFUN("run-hook-with-args", Frun_hook_with_args, 1, MANY, 0, /*
3659 Run HOOK with the specified arguments ARGS.
3660 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
3661 value, that value may be a function or a list of functions to be
3662 called to run the hook. If the value is a function, it is called with
3663 the given arguments and its return value is returned. If it is a list
3664 of functions, those functions are called, in order,
3665 with the given arguments ARGS.
3666 It is best not to depend on the value returned by `run-hook-with-args',
3669 To make a hook variable buffer-local, use `make-local-hook',
3670 not `make-local-variable'.
3672 (int nargs, Lisp_Object * args))
3674 return run_hook_with_args(nargs, args, RUN_HOOKS_TO_COMPLETION);
3677 DEFUN("run-hook-with-args-until-success", Frun_hook_with_args_until_success, 1, MANY, 0, /*
3678 Run HOOK with the specified arguments ARGS.
3679 HOOK should be a symbol, a hook variable. Its value should
3680 be a list of functions. We call those functions, one by one,
3681 passing arguments ARGS to each of them, until one of them
3682 returns a non-nil value. Then we return that value.
3683 If all the functions return nil, we return nil.
3685 To make a hook variable buffer-local, use `make-local-hook',
3686 not `make-local-variable'.
3688 (int nargs, Lisp_Object * args))
3690 return run_hook_with_args(nargs, args, RUN_HOOKS_UNTIL_SUCCESS);
3693 DEFUN("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure, 1, MANY, 0, /*
3694 Run HOOK with the specified arguments ARGS.
3695 HOOK should be a symbol, a hook variable. Its value should
3696 be a list of functions. We call those functions, one by one,
3697 passing arguments ARGS to each of them, until one of them
3698 returns nil. Then we return nil.
3699 If all the functions return non-nil, we return non-nil.
3701 To make a hook variable buffer-local, use `make-local-hook',
3702 not `make-local-variable'.
3704 (int nargs, Lisp_Object * args))
3706 return run_hook_with_args(nargs, args, RUN_HOOKS_UNTIL_FAILURE);
3709 Lisp_Object Qcurrent_running_hook, Vcurrent_running_hook;
3711 /* ARGS[0] should be a hook symbol.
3712 Call each of the functions in the hook value, passing each of them
3713 as arguments all the rest of ARGS (all NARGS - 1 elements).
3714 COND specifies a condition to test after each call
3715 to decide whether to stop.
3716 The caller (or its caller, etc) must gcpro all of ARGS,
3717 except that it isn't necessary to gcpro ARGS[0]. */
3720 run_hook_with_args_in_buffer(struct buffer * buf, int nargs, Lisp_Object * args,
3721 enum run_hooks_condition cond)
3723 Lisp_Object sym, val, ret;
3725 if (!initialized || preparing_for_armageddon)
3726 /* We need to bail out of here pronto. */
3729 /* Whenever gc_in_progress is true, preparing_for_armageddon
3730 will also be true unless something is really hosed. */
3731 assert(!gc_in_progress);
3734 val = symbol_value_in_buffer(sym, make_buffer(buf));
3735 ret = (cond == RUN_HOOKS_UNTIL_FAILURE ? Qt : Qnil);
3737 if (UNBOUNDP(val) || NILP(val)) {
3739 } else if (!CONSP(val) || EQ(XCAR(val), Qlambda)) {
3740 Lisp_Object old_running_hook = Qnil;
3741 struct gcpro gcpro1;
3744 GCPRO1(old_running_hook);
3747 old_running_hook = symbol_value_in_buffer(
3748 Qcurrent_running_hook,
3750 Fset(Qcurrent_running_hook,sym);
3751 ret = Ffuncall(nargs, args);
3752 Fset(Qcurrent_running_hook,old_running_hook);
3757 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
3758 Lisp_Object globals = Qnil;
3759 Lisp_Object old_running_hook = Qnil;
3760 GCPRO4(sym, val, globals, old_running_hook);
3762 old_running_hook = symbol_value_in_buffer(
3763 Qcurrent_running_hook,
3765 Fset(Qcurrent_running_hook,sym);
3767 for (; CONSP(val) && ((cond == RUN_HOOKS_TO_COMPLETION)
3769 RUN_HOOKS_UNTIL_SUCCESS ? NILP(ret)
3770 : !NILP(ret))); val = XCDR(val)) {
3771 if (EQ(XCAR(val), Qt)) {
3772 /* t indicates this hook has a local binding;
3773 it means to run the global binding too. */
3774 globals = Fdefault_value(sym);
3776 if ((!CONSP(globals)
3777 || EQ(XCAR(globals), Qlambda))
3778 && !NILP(globals)) {
3780 ret = Ffuncall(nargs, args);
3785 ((cond == RUN_HOOKS_TO_COMPLETION)
3787 RUN_HOOKS_UNTIL_SUCCESS ?
3790 globals = XCDR(globals)) {
3791 args[0] = XCAR(globals);
3792 /* In a global value, t should not occur. If it does, we
3793 must ignore it to avoid an endless loop. */
3794 if (!EQ(args[0], Qt))
3801 args[0] = XCAR(val);
3802 ret = Ffuncall(nargs, args);
3806 Fset(Qcurrent_running_hook,old_running_hook);
3813 run_hook_with_args(int nargs, Lisp_Object * args, enum run_hooks_condition cond)
3815 return run_hook_with_args_in_buffer(current_buffer, nargs, args, cond);
3820 /* From FSF 19.30, not currently used */
3822 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
3823 present value of that symbol.
3824 Call each element of FUNLIST,
3825 passing each of them the rest of ARGS.
3826 The caller (or its caller, etc) must gcpro all of ARGS,
3827 except that it isn't necessary to gcpro ARGS[0]. */
3830 run_hook_list_with_args(Lisp_Object funlist, int nargs, Lisp_Object * args)
3832 Lisp_Object sym = args[0];
3834 struct gcpro gcpro1, gcpro2;
3838 for (val = funlist; CONSP(val); val = XCDR(val)) {
3839 if (EQ(XCAR(val), Qt)) {
3840 /* t indicates this hook has a local binding;
3841 it means to run the global binding too. */
3842 Lisp_Object globals;
3844 for (globals = Fdefault_value(sym);
3845 CONSP(globals); globals = XCDR(globals)) {
3846 args[0] = XCAR(globals);
3847 /* In a global value, t should not occur. If it does, we
3848 must ignore it to avoid an endless loop. */
3849 if (!EQ(args[0], Qt))
3850 Ffuncall(nargs, args);
3853 args[0] = XCAR(val);
3854 Ffuncall(nargs, args);
3863 void va_run_hook_with_args(Lisp_Object hook_var, int nargs, ...)
3865 /* This function can GC */
3866 struct gcpro gcpro1;
3869 Lisp_Object funcall_args[1+nargs];
3871 va_start(vargs, nargs);
3872 funcall_args[0] = hook_var;
3873 for (i = 0; i < nargs; i++) {
3874 funcall_args[i + 1] = va_arg(vargs, Lisp_Object);
3878 GCPROn(funcall_args, 1+nargs);
3879 run_hook_with_args(nargs + 1, funcall_args, RUN_HOOKS_TO_COMPLETION);
3884 va_run_hook_with_args_in_buffer(struct buffer *buf, Lisp_Object hook_var,
3887 /* This function can GC */
3888 struct gcpro gcpro1;
3891 Lisp_Object funcall_args[1+nargs];
3893 va_start(vargs, nargs);
3894 funcall_args[0] = hook_var;
3895 for (i = 0; i < nargs; i++) {
3896 funcall_args[i + 1] = va_arg(vargs, Lisp_Object);
3900 GCPROn(funcall_args, 1+nargs);
3901 run_hook_with_args_in_buffer(buf, nargs + 1, funcall_args,
3902 RUN_HOOKS_TO_COMPLETION);
3906 Lisp_Object run_hook(Lisp_Object hook)
3908 Frun_hooks(1, &hook);
3912 /************************************************************************/
3913 /* Front-ends to eval, funcall, apply */
3914 /************************************************************************/
3916 /* Apply fn to arg */
3917 Lisp_Object apply1(Lisp_Object fn, Lisp_Object arg)
3919 /* This function can GC */
3920 struct gcpro gcpro1;
3921 Lisp_Object args[2];
3924 return Ffuncall(1, &fn);
3928 GCPROn(args, countof(args));
3929 RETURN_UNGCPRO(Fapply(2, args));
3932 /* Call function fn on no arguments */
3933 Lisp_Object call0(Lisp_Object fn)
3935 /* This function can GC */
3936 struct gcpro gcpro1;
3939 RETURN_UNGCPRO(Ffuncall(1, &fn));
3942 /* Call function fn with argument arg0 */
3943 Lisp_Object call1(Lisp_Object fn, Lisp_Object arg0)
3945 /* This function can GC */
3946 struct gcpro gcpro1;
3947 Lisp_Object args[2] = {fn, arg0};
3949 GCPROn(args, countof(args));
3950 RETURN_UNGCPRO(Ffuncall(2, args));
3953 /* Call function fn with arguments arg0, arg1 */
3954 Lisp_Object call2(Lisp_Object fn, Lisp_Object arg0, Lisp_Object arg1)
3956 /* This function can GC */
3957 struct gcpro gcpro1;
3958 Lisp_Object args[3] = {fn, arg0, arg1};
3960 GCPROn(args, countof(args));
3961 RETURN_UNGCPRO(Ffuncall(3, args));
3964 /* Call function fn with arguments arg0, arg1, arg2 */
3966 call3(Lisp_Object fn, Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2)
3968 /* This function can GC */
3969 struct gcpro gcpro1;
3970 Lisp_Object args[4] = {fn, arg0, arg1, arg2};
3972 GCPROn(args, countof(args));
3973 RETURN_UNGCPRO(Ffuncall(4, args));
3976 /* Call function fn with arguments arg0, arg1, arg2, arg3 */
3978 call4(Lisp_Object fn,
3979 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3)
3981 /* This function can GC */
3982 struct gcpro gcpro1;
3983 Lisp_Object args[5] = {fn, arg0, arg1, arg2, arg3};
3985 GCPROn(args, countof(args));
3986 RETURN_UNGCPRO(Ffuncall(5, args));
3989 /* Call function fn with arguments arg0, arg1, arg2, arg3, arg4 */
3991 call5(Lisp_Object fn,
3992 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3993 Lisp_Object arg3, Lisp_Object arg4)
3995 /* This function can GC */
3996 struct gcpro gcpro1;
3997 Lisp_Object args[6] = {fn, arg0, arg1, arg2, arg3, arg4};
3999 GCPROn(args, countof(args));
4000 RETURN_UNGCPRO(Ffuncall(6, args));
4004 call6(Lisp_Object fn,
4005 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4006 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5)
4008 /* This function can GC */
4009 struct gcpro gcpro1;
4010 Lisp_Object args[7] = {fn, arg0, arg1, arg2, arg3, arg4, arg5};
4012 GCPROn(args, countof(args));
4013 RETURN_UNGCPRO(Ffuncall(7, args));
4017 call7(Lisp_Object fn,
4018 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4019 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6)
4021 /* This function can GC */
4022 struct gcpro gcpro1;
4023 Lisp_Object args[8] = {fn, arg0, arg1, arg2, arg3, arg4, arg5, arg6};
4025 GCPROn(args, countof(args));
4026 RETURN_UNGCPRO(Ffuncall(8, args));
4030 call8(Lisp_Object fn,
4031 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4032 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5,
4033 Lisp_Object arg6, Lisp_Object arg7)
4035 /* This function can GC */
4036 struct gcpro gcpro1;
4037 Lisp_Object args[9] = {
4038 fn, arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7};
4040 GCPROn(args, countof(args));
4041 RETURN_UNGCPRO(Ffuncall(9, args));
4044 Lisp_Object call0_in_buffer(struct buffer *buf, Lisp_Object fn)
4046 if (current_buffer == buf) {
4050 int speccount = specpdl_depth();
4051 record_unwind_protect(Fset_buffer, Fcurrent_buffer());
4052 set_buffer_internal(buf);
4054 unbind_to(speccount, Qnil);
4060 call1_in_buffer(struct buffer * buf, Lisp_Object fn, Lisp_Object arg0)
4062 if (current_buffer == buf) {
4063 return call1(fn, arg0);
4066 int speccount = specpdl_depth();
4067 record_unwind_protect(Fset_buffer, Fcurrent_buffer());
4068 set_buffer_internal(buf);
4069 val = call1(fn, arg0);
4070 unbind_to(speccount, Qnil);
4076 call2_in_buffer(struct buffer * buf, Lisp_Object fn,
4077 Lisp_Object arg0, Lisp_Object arg1)
4079 if (current_buffer == buf) {
4080 return call2(fn, arg0, arg1);
4083 int speccount = specpdl_depth();
4084 record_unwind_protect(Fset_buffer, Fcurrent_buffer());
4085 set_buffer_internal(buf);
4086 val = call2(fn, arg0, arg1);
4087 unbind_to(speccount, Qnil);
4093 call3_in_buffer(struct buffer * buf, Lisp_Object fn,
4094 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2)
4096 if (current_buffer == buf) {
4097 return call3(fn, arg0, arg1, arg2);
4100 int speccount = specpdl_depth();
4101 record_unwind_protect(Fset_buffer, Fcurrent_buffer());
4102 set_buffer_internal(buf);
4103 val = call3(fn, arg0, arg1, arg2);
4104 unbind_to(speccount, Qnil);
4110 call4_in_buffer(struct buffer * buf, Lisp_Object fn,
4111 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4114 if (current_buffer == buf) {
4115 return call4(fn, arg0, arg1, arg2, arg3);
4118 int speccount = specpdl_depth();
4119 record_unwind_protect(Fset_buffer, Fcurrent_buffer());
4120 set_buffer_internal(buf);
4121 val = call4(fn, arg0, arg1, arg2, arg3);
4122 unbind_to(speccount, Qnil);
4127 Lisp_Object eval_in_buffer(struct buffer * buf, Lisp_Object form)
4129 if (current_buffer == buf) {
4133 int speccount = specpdl_depth();
4134 record_unwind_protect(Fset_buffer, Fcurrent_buffer());
4135 set_buffer_internal(buf);
4137 unbind_to(speccount, Qnil);
4142 /************************************************************************/
4143 /* Error-catching front-ends to eval, funcall, apply */
4144 /************************************************************************/
4146 /* Call function fn on no arguments, with condition handler */
4147 Lisp_Object call0_with_handler(Lisp_Object handler, Lisp_Object fn)
4149 /* This function can GC */
4150 struct gcpro gcpro1;
4151 Lisp_Object args[2] = {handler, fn};
4153 GCPROn(args, countof(args));
4154 RETURN_UNGCPRO(Fcall_with_condition_handler(2, args));
4157 /* Call function fn with argument arg0, with condition handler */
4159 call1_with_handler(Lisp_Object handler, Lisp_Object fn, Lisp_Object arg0)
4161 /* This function can GC */
4162 struct gcpro gcpro1;
4163 Lisp_Object args[3] = {handler, fn, arg0};
4165 GCPROn(args, countof(args));
4166 RETURN_UNGCPRO(Fcall_with_condition_handler(3, args));
4169 /* The following functions provide you with error-trapping versions
4170 of the various front-ends above. They take an additional
4171 "warning_string" argument; if non-zero, a warning with this
4172 string and the actual error that occurred will be displayed
4173 in the *Warnings* buffer if an error occurs. In all cases,
4174 QUIT is inhibited while these functions are running, and if
4175 an error occurs, Qunbound is returned instead of the normal
4179 /* #### This stuff needs to catch throws as well. We need to
4180 improve internal_catch() so it can take a "catch anything"
4181 argument similar to Qt or Qerror for condition_case_1(). */
4183 static Lisp_Object caught_a_squirmer(Lisp_Object errordata, Lisp_Object arg)
4185 if (!NILP(errordata)) {
4186 Lisp_Object args[2];
4189 char *str = (char *)get_opaque_ptr(arg);
4190 args[0] = build_string(str);
4192 args[0] = build_string("error");
4193 /* #### This should call
4194 (with-output-to-string (display-error errordata))
4195 but that stuff is all in Lisp currently. */
4196 args[1] = errordata;
4197 warn_when_safe_lispobj
4199 emacs_doprnt_string_lisp((const Bufbyte *)"%s: %s",
4200 Qnil, -1, 2, args));
4206 allow_quit_caught_a_squirmer(Lisp_Object errordata, Lisp_Object arg)
4208 if (CONSP(errordata) && EQ(XCAR(errordata), Qquit))
4209 return Fsignal(Qquit, XCDR(errordata));
4210 return caught_a_squirmer(errordata, arg);
4214 safe_run_hook_caught_a_squirmer(Lisp_Object errordata, Lisp_Object arg)
4216 Lisp_Object hook = Fcar(arg);
4218 /* Clear out the hook. */
4220 return caught_a_squirmer(errordata, arg);
4224 allow_quit_safe_run_hook_caught_a_squirmer(Lisp_Object errordata,
4227 Lisp_Object hook = Fcar(arg);
4229 if (!CONSP(errordata) || !EQ(XCAR(errordata), Qquit))
4230 /* Clear out the hook. */
4232 return allow_quit_caught_a_squirmer(errordata, arg);
4235 static Lisp_Object catch_them_squirmers_eval_in_buffer(Lisp_Object cons)
4237 return eval_in_buffer(XBUFFER(XCAR(cons)), XCDR(cons));
4241 eval_in_buffer_trapping_errors(char *warning_string,
4242 struct buffer *buf, Lisp_Object form)
4244 int speccount = specpdl_depth();
4249 struct gcpro gcpro1, gcpro2;
4251 XSETBUFFER(buffer, buf);
4253 specbind(Qinhibit_quit, Qt);
4254 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4256 cons = noseeum_cons(buffer, form);
4257 opaque = warning_string
4258 ? make_opaque_ptr(warning_string)
4260 GCPRO2(cons, opaque);
4261 /* Qerror not Qt, so you can get a backtrace */
4262 tem = condition_case_1(Qerror,
4263 catch_them_squirmers_eval_in_buffer, cons,
4264 caught_a_squirmer, opaque);
4265 free_cons(XCONS(cons));
4266 if (OPAQUE_PTRP(opaque))
4267 free_opaque_ptr(opaque);
4270 /* gc_currently_forbidden = 0; */
4271 return unbind_to(speccount, tem);
4274 static Lisp_Object catch_them_squirmers_run_hook(Lisp_Object hook_symbol)
4276 /* This function can GC */
4277 run_hook(hook_symbol);
4282 run_hook_trapping_errors(char *warning_string, Lisp_Object hook_symbol)
4287 struct gcpro gcpro1;
4289 if (!initialized || preparing_for_armageddon)
4291 tem = find_symbol_value(hook_symbol);
4292 if (NILP(tem) || UNBOUNDP(tem))
4295 speccount = specpdl_depth();
4296 specbind(Qinhibit_quit, Qt);
4298 opaque = warning_string
4299 ? make_opaque_ptr((void*)warning_string)
4302 /* Qerror not Qt, so you can get a backtrace */
4303 tem = condition_case_1(Qerror,
4304 catch_them_squirmers_run_hook, hook_symbol,
4305 caught_a_squirmer, opaque);
4306 if (OPAQUE_PTRP(opaque))
4307 free_opaque_ptr(opaque);
4310 return unbind_to(speccount, tem);
4313 /* Same as run_hook_trapping_errors() but also set the hook to nil
4314 if an error occurs. */
4317 safe_run_hook_trapping_errors(char *warning_string,
4318 Lisp_Object hook_symbol, int allow_quit)
4320 int speccount = specpdl_depth();
4322 Lisp_Object cons = Qnil;
4323 struct gcpro gcpro1;
4325 if (!initialized || preparing_for_armageddon)
4327 tem = find_symbol_value(hook_symbol);
4328 if (NILP(tem) || UNBOUNDP(tem))
4332 specbind(Qinhibit_quit, Qt);
4334 cons = noseeum_cons(hook_symbol,
4336 ? make_opaque_ptr((void*)warning_string)
4339 /* Qerror not Qt, so you can get a backtrace */
4340 tem = condition_case_1(Qerror,
4341 catch_them_squirmers_run_hook,
4344 allow_quit_safe_run_hook_caught_a_squirmer :
4345 safe_run_hook_caught_a_squirmer, cons);
4346 if (OPAQUE_PTRP(XCDR(cons)))
4347 free_opaque_ptr(XCDR(cons));
4348 free_cons(XCONS(cons));
4351 return unbind_to(speccount, tem);
4354 static Lisp_Object catch_them_squirmers_call0(Lisp_Object function)
4356 /* This function can GC */
4357 return call0(function);
4361 call0_trapping_errors(char *warning_string, Lisp_Object function)
4365 Lisp_Object opaque = Qnil;
4366 struct gcpro gcpro1, gcpro2;
4368 if (SYMBOLP(function)) {
4369 tem = XSYMBOL(function)->function;
4370 if (NILP(tem) || UNBOUNDP(tem))
4374 GCPRO2(opaque, function);
4375 speccount = specpdl_depth();
4376 specbind(Qinhibit_quit, Qt);
4377 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4379 opaque = warning_string
4380 ? make_opaque_ptr((void *)warning_string)
4382 /* Qerror not Qt, so you can get a backtrace */
4383 tem = condition_case_1(Qerror,
4384 catch_them_squirmers_call0, function,
4385 caught_a_squirmer, opaque);
4386 if (OPAQUE_PTRP(opaque))
4387 free_opaque_ptr(opaque);
4390 /* gc_currently_forbidden = 0; */
4391 return unbind_to(speccount, tem);
4394 static Lisp_Object catch_them_squirmers_call1(Lisp_Object cons)
4396 /* This function can GC */
4397 return call1(XCAR(cons), XCDR(cons));
4400 static Lisp_Object catch_them_squirmers_call2(Lisp_Object cons)
4402 /* This function can GC */
4403 return call2(XCAR(cons), XCAR(XCDR(cons)), XCAR(XCDR(XCDR(cons))));
4406 static Lisp_Object catch_them_squirmers_call3(Lisp_Object cons)
4408 /* This function can GC */
4409 return call3(XCAR(cons), XCAR(XCDR(cons)), XCAR(XCDR(XCDR(cons))), XCAR(XCDR(XCDR(XCDR(cons)))));
4413 call1_trapping_errors(char *warning_string, Lisp_Object function,
4416 int speccount = specpdl_depth();
4418 Lisp_Object cons = Qnil;
4419 Lisp_Object opaque = Qnil;
4420 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
4422 if (SYMBOLP(function)) {
4423 tem = XSYMBOL(function)->function;
4424 if (NILP(tem) || UNBOUNDP(tem))
4428 GCPRO4(cons, opaque, function, object);
4430 specbind(Qinhibit_quit, Qt);
4431 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4433 cons = noseeum_cons(function, object);
4434 opaque = warning_string
4435 ? make_opaque_ptr((void *)warning_string)
4437 /* Qerror not Qt, so you can get a backtrace */
4438 tem = condition_case_1(Qerror,
4439 catch_them_squirmers_call1, cons,
4440 caught_a_squirmer, opaque);
4441 if (OPAQUE_PTRP(opaque))
4442 free_opaque_ptr(opaque);
4443 free_cons(XCONS(cons));
4446 /* gc_currently_forbidden = 0; */
4447 return unbind_to(speccount, tem);
4451 call2_trapping_errors(char *warning_string, Lisp_Object function,
4452 Lisp_Object object1, Lisp_Object object2)
4454 int speccount = specpdl_depth();
4456 Lisp_Object cons = Qnil;
4457 Lisp_Object opaque = Qnil;
4458 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
4460 if (SYMBOLP(function)) {
4461 tem = XSYMBOL(function)->function;
4462 if (NILP(tem) || UNBOUNDP(tem))
4466 GCPRO5(cons, opaque, function, object1, object2);
4467 specbind(Qinhibit_quit, Qt);
4468 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4470 cons = list3(function, object1, object2);
4471 opaque = warning_string
4472 ? make_opaque_ptr((void *)warning_string)
4474 /* Qerror not Qt, so you can get a backtrace */
4475 tem = condition_case_1(Qerror,
4476 catch_them_squirmers_call2, cons,
4477 caught_a_squirmer, opaque);
4478 if (OPAQUE_PTRP(opaque))
4479 free_opaque_ptr(opaque);
4483 /* gc_currently_forbidden = 0; */
4484 return unbind_to(speccount, tem);
4488 call3_trapping_errors(char *warning_string, Lisp_Object function,
4489 Lisp_Object object1, Lisp_Object object2, Lisp_Object object3)
4491 int speccount = specpdl_depth();
4493 Lisp_Object cons = Qnil;
4494 Lisp_Object opaque = Qnil;
4495 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5, gcpro6;
4497 if (SYMBOLP(function)) {
4498 tem = XSYMBOL(function)->function;
4499 if (NILP(tem) || UNBOUNDP(tem))
4503 GCPRO6(cons, opaque, function, object1, object2, object3);
4504 specbind(Qinhibit_quit, Qt);
4505 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4507 cons = list4(function, object1, object2, object3);
4508 opaque = warning_string
4509 ? make_opaque_ptr((void *)warning_string)
4511 /* Qerror not Qt, so you can get a backtrace */
4512 tem = condition_case_1(Qerror,
4513 catch_them_squirmers_call3, cons,
4514 caught_a_squirmer, opaque);
4515 if (OPAQUE_PTRP(opaque))
4516 free_opaque_ptr(opaque);
4520 /* gc_currently_forbidden = 0; */
4521 return unbind_to(speccount, tem);
4524 /************************************************************************/
4525 /* The special binding stack */
4526 /* Most C code should simply use specbind() and unbind_to(). */
4527 /* When performance is critical, use the macros in backtrace.h. */
4528 /************************************************************************/
4530 #define min_max_specpdl_size 400
4532 void grow_specpdl(EMACS_INT reserved)
4534 EMACS_INT size_needed = specpdl_depth() + reserved;
4535 if (specpdl_size == 0)
4537 if (size_needed >= max_specpdl_size) {
4538 if (max_specpdl_size < min_max_specpdl_size)
4539 max_specpdl_size = min_max_specpdl_size;
4540 if (size_needed >= max_specpdl_size) {
4541 if (!NILP(Vdebug_on_error) || !NILP(Vdebug_on_signal))
4542 /* Leave room for some specpdl in the debugger. */
4543 max_specpdl_size = size_needed + 100;
4545 ("Variable binding depth exceeds max-specpdl-size");
4548 while (specpdl_size < size_needed) {
4550 if (specpdl_size > max_specpdl_size)
4551 specpdl_size = max_specpdl_size;
4553 XREALLOC_ARRAY(specpdl, struct specbinding, specpdl_size);
4554 specpdl_ptr = specpdl + specpdl_depth();
4557 /* Handle unbinding buffer-local variables */
4558 static Lisp_Object specbind_unwind_local(Lisp_Object ovalue)
4560 Lisp_Object current = Fcurrent_buffer();
4561 Lisp_Object symbol = specpdl_ptr->symbol;
4562 Lisp_Cons *victim = XCONS(ovalue);
4563 Lisp_Object buf = emacs_get_buffer(victim->car, 0);
4564 ovalue = victim->cdr;
4569 /* Deleted buffer -- do nothing */
4570 } else if (symbol_value_buffer_local_info(symbol, XBUFFER(buf)) == 0) {
4571 /* Was buffer-local when binding was made, now no longer is.
4572 * (kill-local-variable can do this.)
4573 * Do nothing in this case.
4575 } else if (EQ(buf, current))
4576 Fset(symbol, ovalue);
4578 /* Urk! Somebody switched buffers */
4579 struct gcpro gcpro1;
4582 Fset(symbol, ovalue);
4583 Fset_buffer(current);
4589 static Lisp_Object specbind_unwind_wasnt_local(Lisp_Object buffer)
4591 Lisp_Object current = Fcurrent_buffer();
4592 Lisp_Object symbol = specpdl_ptr->symbol;
4594 buffer = emacs_get_buffer(buffer, 0);
4596 /* Deleted buffer -- do nothing */
4597 } else if (symbol_value_buffer_local_info(symbol, XBUFFER(buffer)) == 0) {
4598 /* Was buffer-local when binding was made, now no longer is.
4599 * (kill-local-variable can do this.)
4600 * Do nothing in this case.
4602 } else if (EQ(buffer, current))
4603 Fkill_local_variable(symbol);
4605 /* Urk! Somebody switched buffers */
4606 struct gcpro gcpro1;
4608 Fset_buffer(buffer);
4609 Fkill_local_variable(symbol);
4610 Fset_buffer(current);
4616 void specbind(Lisp_Object symbol, Lisp_Object value)
4618 SPECBIND(symbol, value);
4621 void specbind_magic(Lisp_Object symbol, Lisp_Object value)
4624 symbol_value_buffer_local_info(symbol, current_buffer);
4626 if (buffer_local == 0) {
4627 specpdl_ptr->old_value = find_symbol_value(symbol);
4628 specpdl_ptr->func = 0; /* Handled specially by unbind_to */
4629 } else if (buffer_local > 0) {
4630 /* Already buffer-local */
4631 specpdl_ptr->old_value = noseeum_cons(Fcurrent_buffer(),
4634 specpdl_ptr->func = specbind_unwind_local;
4636 /* About to become buffer-local */
4637 specpdl_ptr->old_value = Fcurrent_buffer();
4638 specpdl_ptr->func = specbind_unwind_wasnt_local;
4641 specpdl_ptr->symbol = symbol;
4643 specpdl_depth_counter++;
4645 Fset(symbol, value);
4648 /* Note: As long as the unwind-protect exists, its arg is automatically
4652 record_unwind_protect(Lisp_Object(*function) (Lisp_Object arg), Lisp_Object arg)
4655 specpdl_ptr->func = function;
4656 specpdl_ptr->symbol = Qnil;
4657 specpdl_ptr->old_value = arg;
4659 specpdl_depth_counter++;
4662 extern int check_sigio(void);
4664 /* Unwind the stack till specpdl_depth() == COUNT.
4665 VALUE is not used, except that, purely as a convenience to the
4666 caller, it is protected from garbage-protection. */
4667 Lisp_Object unbind_to(int count, Lisp_Object value)
4669 UNBIND_TO_GCPRO(count, value);
4673 /* Don't call this directly.
4674 Only for use by UNBIND_TO* macros in backtrace.h */
4675 void unbind_to_hairy(int count)
4680 ++specpdl_depth_counter;
4682 check_quit(); /* make Vquit_flag accurate */
4683 quitf = !NILP(Vquit_flag);
4686 while (specpdl_depth_counter != count) {
4688 --specpdl_depth_counter;
4690 if (specpdl_ptr->func != 0)
4691 /* An unwind-protect */
4692 (*specpdl_ptr->func) (specpdl_ptr->old_value);
4694 /* We checked symbol for validity when we specbound it,
4695 so only need to call Fset if symbol has magic value. */
4696 Lisp_Symbol *sym = XSYMBOL(specpdl_ptr->symbol);
4697 if (!SYMBOL_VALUE_MAGIC_P(sym->value))
4698 sym->value = specpdl_ptr->old_value;
4700 Fset(specpdl_ptr->symbol,
4701 specpdl_ptr->old_value);
4705 #ifndef EXCEEDINGLY_QUESTIONABLE_CODE
4706 /* There should never be anything here for us to remove.
4707 If so, it indicates a logic error in Emacs. Catches
4708 should get removed when a throw or signal occurs, or
4709 when a catch or condition-case exits normally. But
4710 it's too dangerous to just remove this code. --ben */
4712 /* Furthermore, this code is not in FSFmacs!!!
4713 Braino on mly's part? */
4714 /* If we're unwound past the pdlcount of a catch frame,
4715 that catch can't possibly still be valid. */
4716 while (catchlist && catchlist->pdlcount > specpdl_depth_counter) {
4717 catchlist = catchlist->next;
4718 /* Don't mess with gcprolist, backtrace_list here */
4727 /* Get the value of symbol's global binding, even if that binding is
4728 not now dynamically visible. May return Qunbound or magic values. */
4730 Lisp_Object top_level_value(Lisp_Object symbol)
4732 REGISTER struct specbinding *ptr = specpdl;
4734 CHECK_SYMBOL(symbol);
4735 for (; ptr != specpdl_ptr; ptr++) {
4736 if (EQ(ptr->symbol, symbol))
4737 return ptr->old_value;
4739 return XSYMBOL(symbol)->value;
4744 Lisp_Object top_level_set(Lisp_Object symbol, Lisp_Object newval)
4746 REGISTER struct specbinding *ptr = specpdl;
4748 CHECK_SYMBOL(symbol);
4749 for (; ptr != specpdl_ptr; ptr++) {
4750 if (EQ(ptr->symbol, symbol)) {
4751 ptr->old_value = newval;
4755 return Fset(symbol, newval);
4760 /************************************************************************/
4762 /************************************************************************/
4764 DEFUN("backtrace-debug", Fbacktrace_debug, 2, 2, 0, /*
4765 Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
4766 The debugger is entered when that frame exits, if the flag is non-nil.
4770 REGISTER struct backtrace *backlist = backtrace_list;
4775 for (i = 0; backlist && i < XINT(level); i++) {
4776 backlist = backlist->next;
4780 backlist->debug_on_exit = !NILP(flag);
4785 static void backtrace_specials(int speccount, int speclimit, Lisp_Object stream)
4787 int printing_bindings = 0;
4789 for (; speccount > speclimit; speccount--) {
4790 if (specpdl[speccount - 1].func == 0
4791 || specpdl[speccount - 1].func == specbind_unwind_local
4792 || specpdl[speccount - 1].func ==
4793 specbind_unwind_wasnt_local) {
4794 write_c_string(((!printing_bindings) ? " # bind (" :
4796 Fprin1(specpdl[speccount - 1].symbol, stream);
4797 printing_bindings = 1;
4799 if (printing_bindings)
4800 write_c_string(")\n", stream);
4801 write_c_string(" # (unwind-protect ...)\n", stream);
4802 printing_bindings = 0;
4805 if (printing_bindings)
4806 write_c_string(")\n", stream);
4809 DEFUN("backtrace", Fbacktrace, 0, 2, "", /*
4810 Print a trace of Lisp function calls currently active.
4811 Optional arg STREAM specifies the output stream to send the backtrace to,
4812 and defaults to the value of `standard-output'.
4813 Optional second arg DETAILED non-nil means show places where currently
4814 active variable bindings, catches, condition-cases, and
4815 unwind-protects, as well as function calls, were made.
4819 /* This function can GC */
4820 struct backtrace *backlist = backtrace_list;
4821 struct catchtag *catches = catchlist;
4822 int speccount = specpdl_depth();
4824 int old_nl = print_escape_newlines;
4825 int old_pr = print_readably;
4826 Lisp_Object old_level = Vprint_level;
4827 Lisp_Object oiq = Vinhibit_quit;
4828 struct gcpro gcpro1, gcpro2;
4830 /* We can't allow quits in here because that could cause the values
4831 of print_readably and print_escape_newlines to get screwed up.
4832 Normally we would use a record_unwind_protect but that would
4833 screw up the functioning of this function. */
4836 entering_debugger = 0;
4838 Vprint_level = make_int(3);
4840 print_escape_newlines = 1;
4842 GCPRO2(stream, old_level);
4845 stream = Vstandard_output;
4846 if (!noninteractive && (NILP(stream) || EQ(stream, Qt)))
4847 stream = Fselected_frame(Qnil);
4850 if (!NILP(detailed) && catches && catches->backlist == backlist) {
4851 int catchpdl = catches->pdlcount;
4852 if (speccount > catchpdl
4853 && specpdl[catchpdl].func == condition_case_unwind)
4854 /* This is a condition-case catchpoint */
4855 catchpdl = catchpdl + 1;
4857 backtrace_specials(speccount, catchpdl, stream);
4859 speccount = catches->pdlcount;
4860 if (catchpdl == speccount) {
4861 write_c_string(" # (catch ", stream);
4862 Fprin1(catches->tag, stream);
4863 write_c_string(" ...)\n", stream);
4865 write_c_string(" # (condition-case ... . ",
4867 Fprin1(Fcdr(Fcar(catches->tag)), stream);
4868 write_c_string(")\n", stream);
4870 catches = catches->next;
4871 } else if (!backlist)
4874 if (!NILP(detailed) && backlist->pdlcount < speccount) {
4875 backtrace_specials(speccount,
4876 backlist->pdlcount, stream);
4877 speccount = backlist->pdlcount;
4879 write_c_string(((backlist->
4880 debug_on_exit) ? "* " : " "), stream);
4881 if (backlist->nargs == UNEVALLED) {
4883 (*backlist->function, *backlist->args),
4885 write_c_string("\n", stream); /* from FSFmacs 19.30 */
4887 Lisp_Object tem = *backlist->function;
4888 Fprin1(tem, stream); /* This can QUIT */
4889 write_c_string("(", stream);
4890 if (backlist->nargs == MANY) {
4892 Lisp_Object tail = Qnil;
4893 struct gcpro ngcpro1;
4896 for (tail = *backlist->args, i = 0;
4898 tail = Fcdr(tail), i++) {
4902 Fprin1(Fcar(tail), stream);
4907 for (i = 0; i < backlist->nargs; i++) {
4908 if (!i && EQ(tem, Qbyte_code)) {
4910 ("\"...\"", stream);
4916 Fprin1(backlist->args[i],
4920 write_c_string(")\n", stream);
4922 backlist = backlist->next;
4925 Vprint_level = old_level;
4926 print_readably = old_pr;
4927 print_escape_newlines = old_nl;
4929 Vinhibit_quit = oiq;
4933 DEFUN("backtrace-frame", Fbacktrace_frame, 1, 1, 0, /*
4934 Return the function and arguments NFRAMES up from current execution point.
4935 If that frame has not evaluated the arguments yet (or is a special form),
4936 the value is (nil FUNCTION ARG-FORMS...).
4937 If that frame has evaluated its arguments and called its function already,
4938 the value is (t FUNCTION ARG-VALUES...).
4939 A &rest arg is represented as the tail of the list ARG-VALUES.
4940 FUNCTION is whatever was supplied as car of evaluated list,
4941 or a lambda expression for macro calls.
4942 If NFRAMES is more than the number of frames, the value is nil.
4946 REGISTER struct backtrace *backlist = backtrace_list;
4950 CHECK_NATNUM(nframes);
4952 /* Find the frame requested. */
4953 for (i = XINT(nframes); backlist && (i-- > 0);)
4954 backlist = backlist->next;
4958 if (backlist->nargs == UNEVALLED)
4959 return Fcons(Qnil, Fcons(*backlist->function, *backlist->args));
4961 if (backlist->nargs == MANY)
4962 tem = *backlist->args;
4964 tem = Flist(backlist->nargs, backlist->args);
4966 return Fcons(Qt, Fcons(*backlist->function, tem));
4970 /************************************************************************/
4972 /************************************************************************/
4975 warn_when_safe_lispobj(Lisp_Object class, Lisp_Object level, Lisp_Object obj)
4977 obj = list1(list3(class, level, obj));
4978 if (NILP(Vpending_warnings))
4979 Vpending_warnings = Vpending_warnings_tail = obj;
4981 Fsetcdr(Vpending_warnings_tail, obj);
4982 Vpending_warnings_tail = obj;
4986 /* #### This should probably accept Lisp objects; but then we have
4987 to make sure that Feval() isn't called, since it might not be safe.
4989 An alternative approach is to just pass some non-string type of
4990 Lisp_Object to warn_when_safe_lispobj(); `prin1-to-string' will
4991 automatically be called when it is safe to do so. */
4993 void warn_when_safe(Lisp_Object class, Lisp_Object level, const char *fmt, ...)
4998 va_start(args, fmt);
4999 obj = emacs_doprnt_string_va((const Bufbyte *)GETTEXT(fmt),
5003 warn_when_safe_lispobj(class, level, obj);
5006 /************************************************************************/
5007 /* Initialization */
5008 /************************************************************************/
5010 void syms_of_eval(void)
5012 INIT_LRECORD_IMPLEMENTATION(subr);
5014 defsymbol(&Qinhibit_quit, "inhibit-quit");
5015 defsymbol(&Qautoload, "autoload");
5016 defsymbol(&Qdebug_on_error, "debug-on-error");
5017 defsymbol(&Qstack_trace_on_error, "stack-trace-on-error");
5018 defsymbol(&Qdebug_on_signal, "debug-on-signal");
5019 defsymbol(&Qstack_trace_on_signal, "stack-trace-on-signal");
5020 defsymbol(&Qdebugger, "debugger");
5021 defsymbol(&Qmacro, "macro");
5022 defsymbol(&Qand_rest, "&rest");
5023 defsymbol(&Qand_optional, "&optional");
5024 /* Note that the process code also uses Qexit */
5025 defsymbol(&Qexit, "exit");
5026 defsymbol(&Qsetq, "setq");
5027 defsymbol(&Qinteractive, "interactive");
5028 defsymbol(&Qcommandp, "commandp");
5029 defsymbol(&Qdefun, "defun");
5030 defsymbol(&Qprogn, "progn");
5031 defsymbol(&Qvalues, "values");
5032 defsymbol(&Qdisplay_warning, "display-warning");
5033 defsymbol(&Qrun_hooks, "run-hooks");
5034 defsymbol(&Qafter_change_major_mode_hook, "after-change-major-mode-hook");
5035 defsymbol(&Qafter_change_before_major_mode_hook, "after-change-before-major-mode-hook");
5036 defsymbol(&Qcurrent_running_hook, "current-running-hook");
5037 defsymbol(&Qif, "if");
5042 DEFSUBR_MACRO(Fwhen);
5043 DEFSUBR_MACRO(Funless);
5055 DEFSUBR(Fuser_variable_p);
5059 DEFSUBR(Fmacroexpand_internal);
5062 DEFSUBR(Funwind_protect);
5063 DEFSUBR(Fcondition_case);
5064 DEFSUBR(Fcall_with_condition_handler);
5066 DEFSUBR(Finteractive_p);
5068 DEFSUBR(Fcommand_execute);
5073 DEFSUBR(Ffunctionp);
5074 DEFSUBR(Ffunction_min_args);
5075 DEFSUBR(Ffunction_max_args);
5076 DEFSUBR(Frun_hooks);
5077 DEFSUBR(Frun_hook_with_args);
5078 DEFSUBR(Frun_hook_with_args_until_success);
5079 DEFSUBR(Frun_hook_with_args_until_failure);
5080 DEFSUBR(Fbacktrace_debug);
5081 DEFSUBR(Fbacktrace);
5082 DEFSUBR(Fbacktrace_frame);
5085 void reinit_eval(void)
5087 specpdl_ptr = specpdl;
5088 specpdl_depth_counter = 0;
5090 Vcondition_handlers = Qnil;
5093 debug_on_next_call = 0;
5094 lisp_eval_depth = 0;
5095 entering_debugger = 0;
5096 changing_major_mode = 0;
5099 void reinit_vars_of_eval(void)
5101 preparing_for_armageddon = 0;
5103 Qunbound_suspended_errors_tag =
5104 make_opaque_ptr(&Qunbound_suspended_errors_tag);
5105 staticpro_nodump(&Qunbound_suspended_errors_tag);
5108 specpdl = xnew_array(struct specbinding, specpdl_size);
5109 /* XEmacs change: increase these values. */
5110 max_specpdl_size = 3000;
5111 max_lisp_eval_depth = 1000;
5112 #ifdef DEFEND_AGAINST_THROW_RECURSION
5117 void vars_of_eval(void)
5119 reinit_vars_of_eval();
5121 DEFVAR_INT("max-specpdl-size", &max_specpdl_size /*
5122 Limit on number of Lisp variable bindings & unwind-protects before error.
5125 DEFVAR_INT("max-lisp-eval-depth", &max_lisp_eval_depth /*
5126 Limit on depth in `eval', `apply' and `funcall' before error.
5127 This limit is to catch infinite recursions for you before they cause
5128 actual stack overflow in C, which would be fatal for Emacs.
5129 You can safely make it considerably larger than its default value,
5130 if that proves inconveniently small.
5133 DEFVAR_LISP("quit-flag", &Vquit_flag /*
5134 Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
5135 Typing C-G sets `quit-flag' non-nil, regardless of `inhibit-quit'.
5139 DEFVAR_LISP("inhibit-quit", &Vinhibit_quit /*
5140 Non-nil inhibits C-g quitting from happening immediately.
5141 Note that `quit-flag' will still be set by typing C-g,
5142 so a quit will be signalled as soon as `inhibit-quit' is nil.
5143 To prevent this happening, set `quit-flag' to nil
5144 before making `inhibit-quit' nil. The value of `inhibit-quit' is
5145 ignored if a critical quit is requested by typing control-shift-G in
5148 Vinhibit_quit = Qnil;
5150 DEFVAR_LISP("stack-trace-on-error", &Vstack_trace_on_error /*
5151 *Non-nil means automatically display a backtrace buffer
5152 after any error that is not handled by a `condition-case'.
5153 If the value is a list, an error only means to display a backtrace
5154 if one of its condition symbols appears in the list.
5155 See also variable `stack-trace-on-signal'.
5157 Vstack_trace_on_error = Qnil;
5159 DEFVAR_LISP("stack-trace-on-signal", &Vstack_trace_on_signal /*
5160 *Non-nil means automatically display a backtrace buffer
5161 after any error that is signalled, whether or not it is handled by
5163 If the value is a list, an error only means to display a backtrace
5164 if one of its condition symbols appears in the list.
5165 See also variable `stack-trace-on-error'.
5167 Vstack_trace_on_signal = Qnil;
5169 DEFVAR_LISP("debug-ignored-errors", &Vdebug_ignored_errors /*
5170 *List of errors for which the debugger should not be called.
5171 Each element may be a condition-name or a regexp that matches error messages.
5172 If any element applies to a given error, that error skips the debugger
5173 and just returns to top level.
5174 This overrides the variable `debug-on-error'.
5175 It does not apply to errors handled by `condition-case'.
5177 Vdebug_ignored_errors = Qnil;
5179 DEFVAR_LISP("debug-on-error", &Vdebug_on_error /*
5180 *Non-nil means enter debugger if an unhandled error is signalled.
5181 The debugger will not be entered if the error is handled by
5183 If the value is a list, an error only means to enter the debugger
5184 if one of its condition symbols appears in the list.
5185 This variable is overridden by `debug-ignored-errors'.
5186 See also variables `debug-on-quit' and `debug-on-signal'.
5188 Vdebug_on_error = Qnil;
5190 DEFVAR_LISP("debug-on-signal", &Vdebug_on_signal /*
5191 *Non-nil means enter debugger if an error is signalled.
5192 The debugger will be entered whether or not the error is handled by
5194 If the value is a list, an error only means to enter the debugger
5195 if one of its condition symbols appears in the list.
5196 See also variable `debug-on-quit'.
5198 Vdebug_on_signal = Qnil;
5200 DEFVAR_BOOL("debug-on-quit", &debug_on_quit /*
5201 *Non-nil means enter debugger if quit is signalled (C-G, for example).
5202 Does not apply if quit is handled by a `condition-case'. Entering the
5203 debugger can also be achieved at any time (for X11 console) by typing
5204 control-shift-G to signal a critical quit.
5208 DEFVAR_BOOL("debug-on-next-call", &debug_on_next_call /*
5209 Non-nil means enter debugger before next `eval', `apply' or `funcall'.
5212 DEFVAR_LISP("debugger", &Vdebugger /*
5213 Function to call to invoke debugger.
5214 If due to frame exit, args are `exit' and the value being returned;
5215 this function's value will be returned instead of that.
5216 If due to error, args are `error' and a list of the args to `signal'.
5217 If due to `apply' or `funcall' entry, one arg, `lambda'.
5218 If due to `eval' entry, one arg, t.
5220 DEFVAR_LISP("after-change-major-mode-hook", &Vafter_change_major_mode_hook /*
5221 Normal hook run at the very end of major mode functions.
5223 Vafter_change_major_mode_hook = Qnil;
5225 DEFVAR_LISP("after-change-before-major-mode-hook", &Vafter_change_before_major_mode_hook /*
5226 Normal hook run before a major mode hook is run.
5228 Vafter_change_before_major_mode_hook = Qnil;
5230 DEFVAR_LISP("current-running-hook", &Vcurrent_running_hook /*
5231 Symbol of the current running hook. nil if no hook is running.
5233 Vcurrent_running_hook = Qnil;
5237 staticpro(&Vpending_warnings);
5238 Vpending_warnings = Qnil;
5239 dump_add_root_object(&Vpending_warnings_tail);
5240 Vpending_warnings_tail = Qnil;
5242 staticpro(&Vautoload_queue);
5243 Vautoload_queue = Qnil;
5245 staticpro(&Vcondition_handlers);
5247 staticpro(&Vcurrent_warning_class);
5248 Vcurrent_warning_class = Qnil;
5250 staticpro(&Vcurrent_error_state);
5251 Vcurrent_error_state = Qnil; /* errors as normal */