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;
2823 REGISTER Lisp_Object fun;
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))
2880 fun = Findirect_function(*btp->function);
2883 /* btp points to the frame of a Lisp function that called interactive-p.
2884 Return t if that function was called interactively. */
2885 if (btp && btp->next && EQ(*btp->next->function, Qcall_interactively))
2890 /************************************************************************/
2892 /************************************************************************/
2894 DEFUN("autoload", Fautoload, 2, 5, 0, /*
2895 Define FUNCTION to autoload from FILENAME.
2896 FUNCTION is a symbol; FILENAME is a file name string to pass to `load'.
2897 The remaining optional arguments provide additional info about the
2899 DOCSTRING is documentation for FUNCTION.
2900 INTERACTIVE, if non-nil, says FUNCTION can be called interactively.
2901 TYPE indicates the type of the object:
2902 nil or omitted says FUNCTION is a function,
2903 `keymap' says FUNCTION is really a keymap, and
2904 `macro' or t says FUNCTION is really a macro.
2905 If FUNCTION already has a non-void function definition that is not an
2906 autoload object, this function does nothing and returns nil.
2908 (function, filename, docstring, interactive, type))
2910 /* This function can GC */
2911 CHECK_SYMBOL(function);
2912 CHECK_STRING(filename);
2914 /* If function is defined and not as an autoload, don't override */
2916 Lisp_Object f = XSYMBOL(function)->function;
2917 if (!UNBOUNDP(f) && !(CONSP(f) && EQ(XCAR(f), Qautoload)))
2922 /* Attempt to avoid consing identical (string=) pure strings. */
2923 filename = Fsymbol_name(Fintern(filename, Qnil));
2926 return Ffset(function, Fcons(Qautoload, list4(filename,
2928 interactive, type)));
2931 Lisp_Object un_autoload(Lisp_Object oldqueue)
2933 /* This function can GC */
2934 REGISTER Lisp_Object queue, first, second;
2936 /* Queue to unwind is current value of Vautoload_queue.
2937 oldqueue is the shadowed value to leave in Vautoload_queue. */
2938 queue = Vautoload_queue;
2939 Vautoload_queue = oldqueue;
2940 while (CONSP(queue)) {
2941 first = XCAR(queue);
2942 second = Fcdr(first);
2943 first = Fcar(first);
2947 Ffset(first, second);
2948 queue = Fcdr(queue);
2953 void do_autoload(Lisp_Object fundef, Lisp_Object funname)
2955 /* This function can GC */
2956 int speccount = specpdl_depth();
2957 Lisp_Object fun = funname;
2958 struct gcpro gcpro1, gcpro2, gcpro3;
2960 CHECK_SYMBOL(funname);
2961 GCPRO3(fun, funname, fundef);
2963 /* Value saved here is to be restored into Vautoload_queue */
2964 record_unwind_protect(un_autoload, Vautoload_queue);
2965 Vautoload_queue = Qt;
2966 call4(Qload, Fcar(Fcdr(fundef)), Qnil, noninteractive ? Qt : Qnil,
2972 /* Save the old autoloads, in case we ever do an unload. */
2973 for (queue = Vautoload_queue; CONSP(queue); queue = XCDR(queue)) {
2974 Lisp_Object first = XCAR(queue);
2975 Lisp_Object second = Fcdr(first);
2977 first = Fcar(first);
2979 /* Note: This test is subtle. The cdr of an autoload-queue entry
2980 may be an atom if the autoload entry was generated by a defalias
2983 Fput(first, Qautoload, (XCDR(second)));
2987 /* Once loading finishes, don't undo it. */
2988 Vautoload_queue = Qt;
2989 unbind_to(speccount, Qnil);
2991 fun = indirect_function(fun, 0);
2994 if (!NILP(Fequal(fun, fundef)))
2998 && EQ(XCAR(fun), Qautoload)))
3000 error("Autoloading failed to define function %s",
3001 string_data(XSYMBOL(funname)->name));
3005 /************************************************************************/
3006 /* eval, funcall, apply */
3007 /************************************************************************/
3009 static Lisp_Object funcall_lambda(Lisp_Object fun,
3010 int nargs, Lisp_Object args[]);
3011 static int in_warnings;
3013 static Lisp_Object in_warnings_restore(Lisp_Object minimus)
3019 DEFUN("eval", Feval, 1, 1, 0, /*
3020 Evaluate FORM and return its value.
3024 /* This function can GC */
3025 Lisp_Object fun, val, original_fun, original_args;
3027 struct backtrace backtrace;
3031 return Fsymbol_value(form);
3036 /* I think this is a pretty safe place to call Lisp code, don't you? */
3037 while (!in_warnings && !NILP(Vpending_warnings)) {
3038 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
3039 int speccount = specpdl_depth();
3040 Lisp_Object this_warning_cons, this_warning, class, level,
3043 record_unwind_protect(in_warnings_restore, Qnil);
3045 this_warning_cons = Vpending_warnings;
3046 this_warning = XCAR(this_warning_cons);
3047 /* in case an error occurs in the warn function, at least
3048 it won't happen infinitely */
3049 Vpending_warnings = XCDR(Vpending_warnings);
3050 free_cons(XCONS(this_warning_cons));
3051 class = XCAR(this_warning);
3052 level = XCAR(XCDR(this_warning));
3053 messij = XCAR(XCDR(XCDR(this_warning)));
3054 free_list(this_warning);
3056 if (NILP(Vpending_warnings))
3057 Vpending_warnings_tail = Qnil; /* perhaps not strictly necessary,
3060 GCPRO4(form, class, level, messij);
3061 if (!STRINGP(messij))
3062 messij = Fprin1_to_string(messij, Qnil);
3063 call3(Qdisplay_warning, class, messij, level);
3065 unbind_to(speccount, Qnil);
3069 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3070 if ((consing_since_gc > gc_cons_threshold) || always_gc) {
3071 struct gcpro gcpro1;
3073 garbage_collect_1();
3078 if (++lisp_eval_depth > max_lisp_eval_depth) {
3079 if (max_lisp_eval_depth < 100)
3080 max_lisp_eval_depth = 100;
3081 if (lisp_eval_depth > max_lisp_eval_depth)
3082 error("Lisp nesting exceeds `max-lisp-eval-depth'");
3085 /* We guaranteed CONSP (form) above */
3086 original_fun = XCAR(form);
3087 original_args = XCDR(form);
3089 GET_EXTERNAL_LIST_LENGTH(original_args, nargs);
3091 backtrace.pdlcount = specpdl_depth();
3092 backtrace.function = &original_fun; /* This also protects them from gc */
3093 backtrace.args = &original_args;
3094 backtrace.nargs = UNEVALLED;
3095 backtrace.evalargs = 1;
3096 backtrace.debug_on_exit = 0;
3097 PUSH_BACKTRACE(backtrace);
3099 if (debug_on_next_call)
3100 do_debug_on_call(Qt);
3102 if (profiling_active)
3103 profile_increase_call_count(original_fun);
3105 /* At this point, only original_fun and original_args
3106 have values that will be used below. */
3108 /* Optimise for no indirection. */
3110 if (SYMBOLP (fun) && !EQ (fun, Qunbound)
3111 && (fun = XSYMBOL (fun)->function, SYMBOLP (fun)))
3112 fun = indirect_function(original_fun, 1);
3115 Lisp_Subr *subr = XSUBR(fun);
3116 int max_args = subr->max_args;
3118 if (nargs < subr->min_args)
3119 goto wrong_number_of_arguments;
3121 if (max_args == UNEVALLED) { /* Optimize for the common case */
3122 backtrace.evalargs = 0;
3124 (((Lisp_Object(*)(Lisp_Object)) subr_function(subr))
3126 } else if (nargs <= max_args) {
3127 struct gcpro gcpro1;
3128 Lisp_Object args[SUBR_MAX_ARGS];
3129 REGISTER Lisp_Object *p = args;
3132 memset(args, 0, sizeof(Lisp_Object)*SUBR_MAX_ARGS);
3134 GCPROn(args, countof(args));
3136 LIST_LOOP_2(arg, original_args) {
3140 /* &optional args default to nil. */
3141 while (p - args < max_args)
3144 backtrace.args = args;
3145 backtrace.nargs = nargs;
3147 FUNCALL_SUBR(val, subr, args, max_args);
3150 } else if (max_args == MANY) {
3151 /* Pass a vector of evaluated arguments */
3152 struct gcpro gcpro1;
3153 Lisp_Object args[nargs];
3154 REGISTER Lisp_Object *p = args;
3157 memset(args, 0, sizeof(Lisp_Object)*nargs);
3159 GCPROn(args, nargs);
3161 LIST_LOOP_2(arg, original_args) {
3165 backtrace.args = args;
3166 backtrace.nargs = nargs;
3169 (((Lisp_Object(*)(int, Lisp_Object *))subr_function
3175 wrong_number_of_arguments:
3177 signal_wrong_number_of_arguments_error(original_fun,
3180 } else if (COMPILED_FUNCTIONP(fun)) {
3181 struct gcpro gcpro1;
3182 Lisp_Object args[nargs];
3183 REGISTER Lisp_Object *p = args;
3186 memset(args, 0, sizeof(Lisp_Object)*nargs);
3188 GCPROn(args, nargs);
3190 LIST_LOOP_2(arg, original_args) {
3194 backtrace.args = args;
3195 backtrace.nargs = nargs;
3196 backtrace.evalargs = 0;
3198 val = funcall_compiled_function(fun, nargs, args);
3200 /* Do the debug-on-exit now, while args is still GCPROed. */
3201 if (backtrace.debug_on_exit)
3202 val = do_debug_on_exit(val);
3203 /* Don't do it again when we return to eval. */
3204 backtrace.debug_on_exit = 0;
3207 } else if (CONSP(fun)) {
3208 Lisp_Object funcar = XCAR(fun);
3210 if (EQ(funcar, Qautoload)) {
3211 /* do_autoload GCPROs both arguments */
3212 do_autoload(fun, original_fun);
3214 } else if (EQ(funcar, Qmacro)) {
3215 val = Feval(apply1(XCDR(fun), original_args));
3216 } else if (EQ(funcar, Qlambda)) {
3217 struct gcpro gcpro1;
3218 Lisp_Object args[nargs];
3219 REGISTER Lisp_Object *p = args;
3222 memset(args, 0, sizeof(Lisp_Object)*nargs);
3224 GCPROn(args, nargs);
3226 LIST_LOOP_2(arg, original_args) {
3232 backtrace.args = args; /* this also GCPROs `args' */
3233 backtrace.nargs = nargs;
3234 backtrace.evalargs = 0;
3236 val = funcall_lambda(fun, nargs, args);
3238 /* Do the debug-on-exit now, while args is still GCPROed. */
3239 if (backtrace.debug_on_exit)
3240 val = do_debug_on_exit(val);
3241 /* Don't do it again when we return to eval. */
3242 backtrace.debug_on_exit = 0;
3244 goto invalid_function;
3246 } else if (UNBOUNDP(fun)) {
3247 val = signal_void_function_error(original_fun);
3250 val = signal_invalid_function_error(original_fun);
3254 if (backtrace.debug_on_exit)
3255 val = do_debug_on_exit(val);
3256 POP_BACKTRACE(backtrace);
3261 /* #### Why is Feval so anal about GCPRO, Ffuncall so cavalier? */
3262 DEFUN("funcall", Ffuncall, 1, MANY, 0, /*
3263 Call first argument as a function, passing the remaining arguments to it.
3264 Thus, (funcall 'cons 'x 'y) returns (x . y).
3266 (int nargs, Lisp_Object * args))
3268 /* This function can GC */
3271 struct backtrace backtrace;
3272 int fun_nargs = nargs - 1;
3273 Lisp_Object *fun_args = args + 1;
3276 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
3277 if ((consing_since_gc > gc_cons_threshold) || always_gc) {
3278 /* Callers should gcpro lexpr args */
3279 garbage_collect_1();
3283 if (++lisp_eval_depth > max_lisp_eval_depth) {
3284 if (max_lisp_eval_depth < 100)
3285 max_lisp_eval_depth = 100;
3286 if (lisp_eval_depth > max_lisp_eval_depth)
3287 error("Lisp nesting exceeds `max-lisp-eval-depth'");
3290 backtrace.pdlcount = specpdl_depth();
3291 backtrace.function = &args[0];
3292 backtrace.args = fun_args;
3293 backtrace.nargs = fun_nargs;
3294 backtrace.evalargs = 0;
3295 backtrace.debug_on_exit = 0;
3296 PUSH_BACKTRACE(backtrace);
3298 if (debug_on_next_call)
3299 do_debug_on_call(Qlambda);
3305 /* It might be useful to place this *after* all the checks. */
3306 if (profiling_active)
3307 profile_increase_call_count(fun);
3309 /* We could call indirect_function directly, but profiling shows
3310 this is worth optimizing by partially unrolling the loop. */
3312 fun = XSYMBOL(fun)->function;
3314 fun = XSYMBOL(fun)->function;
3316 fun = indirect_function(fun, 1);
3321 Lisp_Subr *subr = XSUBR(fun);
3322 int max_args = subr->max_args;
3323 Lisp_Object spacious_args[SUBR_MAX_ARGS];
3325 if (fun_nargs == max_args) { /* Optimize for the common case */
3328 /* The "extra" braces placate GCC 2.95.4. */
3329 FUNCALL_SUBR(val, subr, fun_args, max_args);
3331 } else if (fun_nargs < subr->min_args) {
3332 goto wrong_number_of_arguments;
3333 } else if (fun_nargs < max_args) {
3334 Lisp_Object *p = spacious_args;
3336 /* Default optionals to nil */
3339 while (p - spacious_args < max_args)
3342 fun_args = spacious_args;
3344 } else if (max_args == MANY) {
3345 val = SUBR_FUNCTION(subr, MANY) (fun_nargs, fun_args);
3346 } else if (max_args == UNEVALLED) { /* Can't funcall a special form */
3347 goto invalid_function;
3349 wrong_number_of_arguments:
3351 signal_wrong_number_of_arguments_error(fun,
3354 } else if (COMPILED_FUNCTIONP(fun)) {
3355 val = funcall_compiled_function(fun, fun_nargs, fun_args);
3356 } else if (CONSP(fun)) {
3357 Lisp_Object funcar = XCAR(fun);
3359 if (EQ(funcar, Qlambda)) {
3360 val = funcall_lambda(fun, fun_nargs, fun_args);
3361 } else if (EQ(funcar, Qautoload)) {
3362 /* do_autoload GCPROs both arguments */
3363 do_autoload(fun, args[0]);
3365 } else { /* Can't funcall a macro */
3367 goto invalid_function;
3369 } else if (UNBOUNDP(fun)) {
3370 val = signal_void_function_error(args[0]);
3373 val = signal_invalid_function_error(fun);
3377 if (backtrace.debug_on_exit)
3378 val = do_debug_on_exit(val);
3379 POP_BACKTRACE(backtrace);
3383 DEFUN("functionp", Ffunctionp, 1, 1, 0, /*
3384 Return t if OBJECT can be called as a function, else nil.
3385 A function is an object that can be applied to arguments,
3386 using for example `funcall' or `apply'.
3390 if (SYMBOLP(object))
3391 object = indirect_function(object, 0);
3395 COMPILED_FUNCTIONP(object) ||
3397 (EQ(XCAR(object), Qlambda) || EQ(XCAR(object), Qautoload))))
3402 function_argcount(Lisp_Object function, int function_min_args_p)
3404 Lisp_Object orig_function = function;
3405 Lisp_Object arglist;
3409 if (SYMBOLP(function))
3410 function = indirect_function(function, 1);
3412 if (SUBRP(function)) {
3413 /* Using return with the ?: operator tickles a DEC CC compiler bug. */
3414 if (function_min_args_p)
3415 return Fsubr_min_args(function);
3417 return Fsubr_max_args(function);
3418 } else if (COMPILED_FUNCTIONP(function)) {
3420 compiled_function_arglist(XCOMPILED_FUNCTION(function));
3421 } else if (CONSP(function)) {
3422 Lisp_Object funcar = XCAR(function);
3424 if (EQ(funcar, Qmacro)) {
3425 function = XCDR(function);
3427 } else if (EQ(funcar, Qautoload)) {
3428 /* do_autoload GCPROs both arguments */
3429 do_autoload(function, orig_function);
3430 function = orig_function;
3432 } else if (EQ(funcar, Qlambda)) {
3433 arglist = Fcar(XCDR(function));
3435 goto invalid_function;
3439 return signal_invalid_function_error(orig_function);
3445 EXTERNAL_LIST_LOOP_2(arg, arglist) {
3446 if (EQ(arg, Qand_optional)) {
3447 if (function_min_args_p)
3449 } else if (EQ(arg, Qand_rest)) {
3450 if (function_min_args_p)
3459 return make_int(argcount);
3463 DEFUN("function-min-args", Ffunction_min_args, 1, 1, 0, /*
3464 Return the number of arguments a function may be called with.
3465 The function may be any form that can be passed to `funcall',
3466 any special form, or any macro.
3470 return function_argcount(function, 1);
3473 DEFUN("function-max-args", Ffunction_max_args, 1, 1, 0, /*
3474 Return the number of arguments a function may be called with.
3475 The function may be any form that can be passed to `funcall',
3476 any special form, or any macro.
3477 If the function takes an arbitrary number of arguments or is
3478 a built-in special form, nil is returned.
3482 return function_argcount(function, 0);
3485 DEFUN("apply", Fapply, 2, MANY, 0, /*
3486 Call FUNCTION with the remaining args, using the last arg as a list of args.
3487 Thus, (apply '+ 1 2 '(3 4)) returns 10.
3489 (int nargs, Lisp_Object * args))
3491 /* This function can GC */
3492 Lisp_Object fun = args[0];
3493 Lisp_Object spread_arg = args[nargs - 1];
3497 GET_EXTERNAL_LIST_LENGTH(spread_arg, numargs);
3500 /* (apply foo 0 1 '()) */
3501 return Ffuncall(nargs - 1, args);
3502 else if (numargs == 1) {
3503 /* (apply foo 0 1 '(2)) */
3504 args[nargs - 1] = XCAR(spread_arg);
3505 return Ffuncall(nargs, args);
3508 /* -1 for function, -1 for spread arg */
3509 numargs = nargs - 2 + numargs;
3510 /* +1 for function */
3511 funcall_nargs = 1 + numargs;
3514 fun = indirect_function(fun, 0);
3517 Lisp_Subr *subr = XSUBR(fun);
3518 int max_args = subr->max_args;
3520 if (numargs < subr->min_args
3521 || (max_args >= 0 && max_args < numargs)) {
3522 /* Let funcall get the error */
3523 } else if (max_args > numargs) {
3524 /* Avoid having funcall cons up yet another new vector of arguments
3525 by explicitly supplying nil's for optional values */
3526 funcall_nargs += (max_args - numargs);
3528 } else if (UNBOUNDP(fun)) {
3529 /* Let funcall get the error */
3535 Lisp_Object funcall_args[funcall_nargs];
3536 struct gcpro gcpro1;
3539 memset(funcall_args, 0, sizeof(Lisp_Object)*funcall_nargs);
3541 GCPROn(funcall_args, funcall_nargs);
3543 /* Copy in the unspread args */
3544 memcpy(funcall_args, args, (nargs - 1) * sizeof(Lisp_Object));
3545 /* Spread the last arg we got. Its first element goes in
3546 the slot that it used to occupy, hence this value of I. */
3547 for (i = nargs - 1; !NILP(spread_arg); /* i < 1 + numargs */
3548 i++, spread_arg = XCDR(spread_arg)) {
3549 funcall_args[i] = XCAR(spread_arg);
3551 /* Supply nil for optional args (to subrs) */
3552 for (; i < funcall_nargs; i++) {
3553 funcall_args[i] = Qnil;
3556 RETURN_UNGCPRO(Ffuncall(funcall_nargs, funcall_args));
3560 /* Apply lambda list FUN to the NARGS evaluated arguments in ARGS and
3561 return the result of evaluation. */
3564 funcall_lambda(Lisp_Object fun, int nargs, Lisp_Object args[])
3566 /* This function can GC */
3567 Lisp_Object arglist, body, tail;
3568 int speccount = specpdl_depth();
3574 goto invalid_function;
3576 arglist = XCAR(tail);
3580 int optional = 0, rest = 0;
3582 EXTERNAL_LIST_LOOP_2(symbol, arglist) {
3583 if (!SYMBOLP(symbol))
3584 goto invalid_function;
3585 if (EQ(symbol, Qand_rest))
3587 else if (EQ(symbol, Qand_optional))
3590 specbind(symbol, Flist(nargs - i, &args[i]));
3592 } else if (i < nargs)
3593 specbind(symbol, args[i++]);
3595 goto wrong_number_of_arguments;
3597 specbind(symbol, Qnil);
3602 goto wrong_number_of_arguments;
3604 return unbind_to(speccount, Fprogn(body));
3606 wrong_number_of_arguments:
3607 return signal_wrong_number_of_arguments_error(fun, nargs);
3610 return signal_invalid_function_error(fun);
3613 /************************************************************************/
3614 /* Run hook variables in various ways. */
3615 /************************************************************************/
3616 int changing_major_mode = 0;
3617 Lisp_Object Qafter_change_major_mode_hook, Vafter_change_major_mode_hook;
3618 Lisp_Object Qafter_change_before_major_mode_hook, Vafter_change_before_major_mode_hook;
3620 Lisp_Object run_hook(Lisp_Object hook);
3622 DEFUN("run-hooks", Frun_hooks, 1, MANY, 0, /*
3623 Run each hook in HOOKS. Major mode functions use this.
3624 Each argument should be a symbol, a hook variable.
3625 These symbols are processed in the order specified.
3626 If a hook symbol has a non-nil value, that value may be a function
3627 or a list of functions to be called to run the hook.
3628 If the value is a function, it is called with no arguments.
3629 If it is a list, the elements are called, in order, with no arguments.
3631 To make a hook variable buffer-local, use `make-local-hook',
3632 not `make-local-variable'.
3634 (int nargs, Lisp_Object * args))
3638 if (changing_major_mode) {
3639 Lisp_Object Qhook = Qafter_change_before_major_mode_hook;
3640 run_hook_with_args( 1, &Qhook,
3641 RUN_HOOKS_TO_COMPLETION);
3644 for (i = 0; i < nargs; i++)
3645 run_hook_with_args(1, args + i, RUN_HOOKS_TO_COMPLETION);
3647 if (changing_major_mode) {
3648 Lisp_Object Qhook = Qafter_change_major_mode_hook;
3649 changing_major_mode = 0;
3650 run_hook_with_args( 1, &Qhook,
3651 RUN_HOOKS_TO_COMPLETION);
3657 DEFUN("run-hook-with-args", Frun_hook_with_args, 1, MANY, 0, /*
3658 Run HOOK with the specified arguments ARGS.
3659 HOOK should be a symbol, a hook variable. If HOOK has a non-nil
3660 value, that value may be a function or a list of functions to be
3661 called to run the hook. If the value is a function, it is called with
3662 the given arguments and its return value is returned. If it is a list
3663 of functions, those functions are called, in order,
3664 with the given arguments ARGS.
3665 It is best not to depend on the value returned by `run-hook-with-args',
3668 To make a hook variable buffer-local, use `make-local-hook',
3669 not `make-local-variable'.
3671 (int nargs, Lisp_Object * args))
3673 return run_hook_with_args(nargs, args, RUN_HOOKS_TO_COMPLETION);
3676 DEFUN("run-hook-with-args-until-success", Frun_hook_with_args_until_success, 1, MANY, 0, /*
3677 Run HOOK with the specified arguments ARGS.
3678 HOOK should be a symbol, a hook variable. Its value should
3679 be a list of functions. We call those functions, one by one,
3680 passing arguments ARGS to each of them, until one of them
3681 returns a non-nil value. Then we return that value.
3682 If all the functions return nil, we return nil.
3684 To make a hook variable buffer-local, use `make-local-hook',
3685 not `make-local-variable'.
3687 (int nargs, Lisp_Object * args))
3689 return run_hook_with_args(nargs, args, RUN_HOOKS_UNTIL_SUCCESS);
3692 DEFUN("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure, 1, MANY, 0, /*
3693 Run HOOK with the specified arguments ARGS.
3694 HOOK should be a symbol, a hook variable. Its value should
3695 be a list of functions. We call those functions, one by one,
3696 passing arguments ARGS to each of them, until one of them
3697 returns nil. Then we return nil.
3698 If all the functions return non-nil, we return non-nil.
3700 To make a hook variable buffer-local, use `make-local-hook',
3701 not `make-local-variable'.
3703 (int nargs, Lisp_Object * args))
3705 return run_hook_with_args(nargs, args, RUN_HOOKS_UNTIL_FAILURE);
3708 Lisp_Object Qcurrent_running_hook, Vcurrent_running_hook;
3710 /* ARGS[0] should be a hook symbol.
3711 Call each of the functions in the hook value, passing each of them
3712 as arguments all the rest of ARGS (all NARGS - 1 elements).
3713 COND specifies a condition to test after each call
3714 to decide whether to stop.
3715 The caller (or its caller, etc) must gcpro all of ARGS,
3716 except that it isn't necessary to gcpro ARGS[0]. */
3719 run_hook_with_args_in_buffer(struct buffer * buf, int nargs, Lisp_Object * args,
3720 enum run_hooks_condition cond)
3722 Lisp_Object sym, val, ret;
3724 if (!initialized || preparing_for_armageddon)
3725 /* We need to bail out of here pronto. */
3728 /* Whenever gc_in_progress is true, preparing_for_armageddon
3729 will also be true unless something is really hosed. */
3730 assert(!gc_in_progress);
3733 val = symbol_value_in_buffer(sym, make_buffer(buf));
3734 ret = (cond == RUN_HOOKS_UNTIL_FAILURE ? Qt : Qnil);
3736 if (UNBOUNDP(val) || NILP(val)) {
3738 } else if (!CONSP(val) || EQ(XCAR(val), Qlambda)) {
3739 Lisp_Object old_running_hook = Qnil;
3740 struct gcpro gcpro1;
3743 GCPRO1(old_running_hook);
3746 old_running_hook = symbol_value_in_buffer(
3747 Qcurrent_running_hook,
3749 Fset(Qcurrent_running_hook,sym);
3750 ret = Ffuncall(nargs, args);
3751 Fset(Qcurrent_running_hook,old_running_hook);
3756 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
3757 Lisp_Object globals = Qnil;
3758 Lisp_Object old_running_hook = Qnil;
3759 GCPRO4(sym, val, globals, old_running_hook);
3761 old_running_hook = symbol_value_in_buffer(
3762 Qcurrent_running_hook,
3764 Fset(Qcurrent_running_hook,sym);
3766 for (; CONSP(val) && ((cond == RUN_HOOKS_TO_COMPLETION)
3768 RUN_HOOKS_UNTIL_SUCCESS ? NILP(ret)
3769 : !NILP(ret))); val = XCDR(val)) {
3770 if (EQ(XCAR(val), Qt)) {
3771 /* t indicates this hook has a local binding;
3772 it means to run the global binding too. */
3773 globals = Fdefault_value(sym);
3775 if ((!CONSP(globals)
3776 || EQ(XCAR(globals), Qlambda))
3777 && !NILP(globals)) {
3779 ret = Ffuncall(nargs, args);
3784 ((cond == RUN_HOOKS_TO_COMPLETION)
3786 RUN_HOOKS_UNTIL_SUCCESS ?
3789 globals = XCDR(globals)) {
3790 args[0] = XCAR(globals);
3791 /* In a global value, t should not occur. If it does, we
3792 must ignore it to avoid an endless loop. */
3793 if (!EQ(args[0], Qt))
3800 args[0] = XCAR(val);
3801 ret = Ffuncall(nargs, args);
3805 Fset(Qcurrent_running_hook,old_running_hook);
3812 run_hook_with_args(int nargs, Lisp_Object * args, enum run_hooks_condition cond)
3814 return run_hook_with_args_in_buffer(current_buffer, nargs, args, cond);
3819 /* From FSF 19.30, not currently used */
3821 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
3822 present value of that symbol.
3823 Call each element of FUNLIST,
3824 passing each of them the rest of ARGS.
3825 The caller (or its caller, etc) must gcpro all of ARGS,
3826 except that it isn't necessary to gcpro ARGS[0]. */
3829 run_hook_list_with_args(Lisp_Object funlist, int nargs, Lisp_Object * args)
3831 Lisp_Object sym = args[0];
3833 struct gcpro gcpro1, gcpro2;
3837 for (val = funlist; CONSP(val); val = XCDR(val)) {
3838 if (EQ(XCAR(val), Qt)) {
3839 /* t indicates this hook has a local binding;
3840 it means to run the global binding too. */
3841 Lisp_Object globals;
3843 for (globals = Fdefault_value(sym);
3844 CONSP(globals); globals = XCDR(globals)) {
3845 args[0] = XCAR(globals);
3846 /* In a global value, t should not occur. If it does, we
3847 must ignore it to avoid an endless loop. */
3848 if (!EQ(args[0], Qt))
3849 Ffuncall(nargs, args);
3852 args[0] = XCAR(val);
3853 Ffuncall(nargs, args);
3862 void va_run_hook_with_args(Lisp_Object hook_var, int nargs, ...)
3864 /* This function can GC */
3865 struct gcpro gcpro1;
3868 Lisp_Object funcall_args[1+nargs];
3870 va_start(vargs, nargs);
3871 funcall_args[0] = hook_var;
3872 for (i = 0; i < nargs; i++) {
3873 funcall_args[i + 1] = va_arg(vargs, Lisp_Object);
3877 GCPROn(funcall_args, 1+nargs);
3878 run_hook_with_args(nargs + 1, funcall_args, RUN_HOOKS_TO_COMPLETION);
3883 va_run_hook_with_args_in_buffer(struct buffer *buf, Lisp_Object hook_var,
3886 /* This function can GC */
3887 struct gcpro gcpro1;
3890 Lisp_Object funcall_args[1+nargs];
3892 va_start(vargs, nargs);
3893 funcall_args[0] = hook_var;
3894 for (i = 0; i < nargs; i++) {
3895 funcall_args[i + 1] = va_arg(vargs, Lisp_Object);
3899 GCPROn(funcall_args, 1+nargs);
3900 run_hook_with_args_in_buffer(buf, nargs + 1, funcall_args,
3901 RUN_HOOKS_TO_COMPLETION);
3905 Lisp_Object run_hook(Lisp_Object hook)
3907 Frun_hooks(1, &hook);
3911 /************************************************************************/
3912 /* Front-ends to eval, funcall, apply */
3913 /************************************************************************/
3915 /* Apply fn to arg */
3916 Lisp_Object apply1(Lisp_Object fn, Lisp_Object arg)
3918 /* This function can GC */
3919 struct gcpro gcpro1;
3920 Lisp_Object args[2];
3923 return Ffuncall(1, &fn);
3927 GCPROn(args, countof(args));
3928 RETURN_UNGCPRO(Fapply(2, args));
3931 /* Call function fn on no arguments */
3932 Lisp_Object call0(Lisp_Object fn)
3934 /* This function can GC */
3935 struct gcpro gcpro1;
3938 RETURN_UNGCPRO(Ffuncall(1, &fn));
3941 /* Call function fn with argument arg0 */
3942 Lisp_Object call1(Lisp_Object fn, Lisp_Object arg0)
3944 /* This function can GC */
3945 struct gcpro gcpro1;
3946 Lisp_Object args[2] = {fn, arg0};
3948 GCPROn(args, countof(args));
3949 RETURN_UNGCPRO(Ffuncall(2, args));
3952 /* Call function fn with arguments arg0, arg1 */
3953 Lisp_Object call2(Lisp_Object fn, Lisp_Object arg0, Lisp_Object arg1)
3955 /* This function can GC */
3956 struct gcpro gcpro1;
3957 Lisp_Object args[3] = {fn, arg0, arg1};
3959 GCPROn(args, countof(args));
3960 RETURN_UNGCPRO(Ffuncall(3, args));
3963 /* Call function fn with arguments arg0, arg1, arg2 */
3965 call3(Lisp_Object fn, Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2)
3967 /* This function can GC */
3968 struct gcpro gcpro1;
3969 Lisp_Object args[4] = {fn, arg0, arg1, arg2};
3971 GCPROn(args, countof(args));
3972 RETURN_UNGCPRO(Ffuncall(4, args));
3975 /* Call function fn with arguments arg0, arg1, arg2, arg3 */
3977 call4(Lisp_Object fn,
3978 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3)
3980 /* This function can GC */
3981 struct gcpro gcpro1;
3982 Lisp_Object args[5] = {fn, arg0, arg1, arg2, arg3};
3984 GCPROn(args, countof(args));
3985 RETURN_UNGCPRO(Ffuncall(5, args));
3988 /* Call function fn with arguments arg0, arg1, arg2, arg3, arg4 */
3990 call5(Lisp_Object fn,
3991 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
3992 Lisp_Object arg3, Lisp_Object arg4)
3994 /* This function can GC */
3995 struct gcpro gcpro1;
3996 Lisp_Object args[6] = {fn, arg0, arg1, arg2, arg3, arg4};
3998 GCPROn(args, countof(args));
3999 RETURN_UNGCPRO(Ffuncall(6, args));
4003 call6(Lisp_Object fn,
4004 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4005 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5)
4007 /* This function can GC */
4008 struct gcpro gcpro1;
4009 Lisp_Object args[7] = {fn, arg0, arg1, arg2, arg3, arg4, arg5};
4011 GCPROn(args, countof(args));
4012 RETURN_UNGCPRO(Ffuncall(7, args));
4016 call7(Lisp_Object fn,
4017 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4018 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5, Lisp_Object arg6)
4020 /* This function can GC */
4021 struct gcpro gcpro1;
4022 Lisp_Object args[8] = {fn, arg0, arg1, arg2, arg3, arg4, arg5, arg6};
4024 GCPROn(args, countof(args));
4025 RETURN_UNGCPRO(Ffuncall(8, args));
4029 call8(Lisp_Object fn,
4030 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4031 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5,
4032 Lisp_Object arg6, Lisp_Object arg7)
4034 /* This function can GC */
4035 struct gcpro gcpro1;
4036 Lisp_Object args[9] = {
4037 fn, arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7};
4039 GCPROn(args, countof(args));
4040 RETURN_UNGCPRO(Ffuncall(9, args));
4043 Lisp_Object call0_in_buffer(struct buffer *buf, Lisp_Object fn)
4045 if (current_buffer == buf) {
4049 int speccount = specpdl_depth();
4050 record_unwind_protect(Fset_buffer, Fcurrent_buffer());
4051 set_buffer_internal(buf);
4053 unbind_to(speccount, Qnil);
4059 call1_in_buffer(struct buffer * buf, Lisp_Object fn, Lisp_Object arg0)
4061 if (current_buffer == buf) {
4062 return call1(fn, arg0);
4065 int speccount = specpdl_depth();
4066 record_unwind_protect(Fset_buffer, Fcurrent_buffer());
4067 set_buffer_internal(buf);
4068 val = call1(fn, arg0);
4069 unbind_to(speccount, Qnil);
4075 call2_in_buffer(struct buffer * buf, Lisp_Object fn,
4076 Lisp_Object arg0, Lisp_Object arg1)
4078 if (current_buffer == buf) {
4079 return call2(fn, arg0, arg1);
4082 int speccount = specpdl_depth();
4083 record_unwind_protect(Fset_buffer, Fcurrent_buffer());
4084 set_buffer_internal(buf);
4085 val = call2(fn, arg0, arg1);
4086 unbind_to(speccount, Qnil);
4092 call3_in_buffer(struct buffer * buf, Lisp_Object fn,
4093 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2)
4095 if (current_buffer == buf) {
4096 return call3(fn, arg0, arg1, arg2);
4099 int speccount = specpdl_depth();
4100 record_unwind_protect(Fset_buffer, Fcurrent_buffer());
4101 set_buffer_internal(buf);
4102 val = call3(fn, arg0, arg1, arg2);
4103 unbind_to(speccount, Qnil);
4109 call4_in_buffer(struct buffer * buf, Lisp_Object fn,
4110 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4113 if (current_buffer == buf) {
4114 return call4(fn, arg0, arg1, arg2, arg3);
4117 int speccount = specpdl_depth();
4118 record_unwind_protect(Fset_buffer, Fcurrent_buffer());
4119 set_buffer_internal(buf);
4120 val = call4(fn, arg0, arg1, arg2, arg3);
4121 unbind_to(speccount, Qnil);
4126 Lisp_Object eval_in_buffer(struct buffer * buf, Lisp_Object form)
4128 if (current_buffer == buf) {
4132 int speccount = specpdl_depth();
4133 record_unwind_protect(Fset_buffer, Fcurrent_buffer());
4134 set_buffer_internal(buf);
4136 unbind_to(speccount, Qnil);
4141 /************************************************************************/
4142 /* Error-catching front-ends to eval, funcall, apply */
4143 /************************************************************************/
4145 /* Call function fn on no arguments, with condition handler */
4146 Lisp_Object call0_with_handler(Lisp_Object handler, Lisp_Object fn)
4148 /* This function can GC */
4149 struct gcpro gcpro1;
4150 Lisp_Object args[2] = {handler, fn};
4152 GCPROn(args, countof(args));
4153 RETURN_UNGCPRO(Fcall_with_condition_handler(2, args));
4156 /* Call function fn with argument arg0, with condition handler */
4158 call1_with_handler(Lisp_Object handler, Lisp_Object fn, Lisp_Object arg0)
4160 /* This function can GC */
4161 struct gcpro gcpro1;
4162 Lisp_Object args[3] = {handler, fn, arg0};
4164 GCPROn(args, countof(args));
4165 RETURN_UNGCPRO(Fcall_with_condition_handler(3, args));
4168 /* The following functions provide you with error-trapping versions
4169 of the various front-ends above. They take an additional
4170 "warning_string" argument; if non-zero, a warning with this
4171 string and the actual error that occurred will be displayed
4172 in the *Warnings* buffer if an error occurs. In all cases,
4173 QUIT is inhibited while these functions are running, and if
4174 an error occurs, Qunbound is returned instead of the normal
4178 /* #### This stuff needs to catch throws as well. We need to
4179 improve internal_catch() so it can take a "catch anything"
4180 argument similar to Qt or Qerror for condition_case_1(). */
4182 static Lisp_Object caught_a_squirmer(Lisp_Object errordata, Lisp_Object arg)
4184 if (!NILP(errordata)) {
4185 Lisp_Object args[2];
4188 char *str = (char *)get_opaque_ptr(arg);
4189 args[0] = build_string(str);
4191 args[0] = build_string("error");
4192 /* #### This should call
4193 (with-output-to-string (display-error errordata))
4194 but that stuff is all in Lisp currently. */
4195 args[1] = errordata;
4196 warn_when_safe_lispobj
4198 emacs_doprnt_string_lisp((const Bufbyte *)"%s: %s",
4199 Qnil, -1, 2, args));
4205 allow_quit_caught_a_squirmer(Lisp_Object errordata, Lisp_Object arg)
4207 if (CONSP(errordata) && EQ(XCAR(errordata), Qquit))
4208 return Fsignal(Qquit, XCDR(errordata));
4209 return caught_a_squirmer(errordata, arg);
4213 safe_run_hook_caught_a_squirmer(Lisp_Object errordata, Lisp_Object arg)
4215 Lisp_Object hook = Fcar(arg);
4217 /* Clear out the hook. */
4219 return caught_a_squirmer(errordata, arg);
4223 allow_quit_safe_run_hook_caught_a_squirmer(Lisp_Object errordata,
4226 Lisp_Object hook = Fcar(arg);
4228 if (!CONSP(errordata) || !EQ(XCAR(errordata), Qquit))
4229 /* Clear out the hook. */
4231 return allow_quit_caught_a_squirmer(errordata, arg);
4234 static Lisp_Object catch_them_squirmers_eval_in_buffer(Lisp_Object cons)
4236 return eval_in_buffer(XBUFFER(XCAR(cons)), XCDR(cons));
4240 eval_in_buffer_trapping_errors(char *warning_string,
4241 struct buffer *buf, Lisp_Object form)
4243 int speccount = specpdl_depth();
4248 struct gcpro gcpro1, gcpro2;
4250 XSETBUFFER(buffer, buf);
4252 specbind(Qinhibit_quit, Qt);
4253 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4255 cons = noseeum_cons(buffer, form);
4256 opaque = warning_string
4257 ? make_opaque_ptr(warning_string)
4259 GCPRO2(cons, opaque);
4260 /* Qerror not Qt, so you can get a backtrace */
4261 tem = condition_case_1(Qerror,
4262 catch_them_squirmers_eval_in_buffer, cons,
4263 caught_a_squirmer, opaque);
4264 free_cons(XCONS(cons));
4265 if (OPAQUE_PTRP(opaque))
4266 free_opaque_ptr(opaque);
4269 /* gc_currently_forbidden = 0; */
4270 return unbind_to(speccount, tem);
4273 static Lisp_Object catch_them_squirmers_run_hook(Lisp_Object hook_symbol)
4275 /* This function can GC */
4276 run_hook(hook_symbol);
4281 run_hook_trapping_errors(char *warning_string, Lisp_Object hook_symbol)
4286 struct gcpro gcpro1;
4288 if (!initialized || preparing_for_armageddon)
4290 tem = find_symbol_value(hook_symbol);
4291 if (NILP(tem) || UNBOUNDP(tem))
4294 speccount = specpdl_depth();
4295 specbind(Qinhibit_quit, Qt);
4297 opaque = warning_string
4298 ? make_opaque_ptr((void*)warning_string)
4301 /* Qerror not Qt, so you can get a backtrace */
4302 tem = condition_case_1(Qerror,
4303 catch_them_squirmers_run_hook, hook_symbol,
4304 caught_a_squirmer, opaque);
4305 if (OPAQUE_PTRP(opaque))
4306 free_opaque_ptr(opaque);
4309 return unbind_to(speccount, tem);
4312 /* Same as run_hook_trapping_errors() but also set the hook to nil
4313 if an error occurs. */
4316 safe_run_hook_trapping_errors(char *warning_string,
4317 Lisp_Object hook_symbol, int allow_quit)
4319 int speccount = specpdl_depth();
4321 Lisp_Object cons = Qnil;
4322 struct gcpro gcpro1;
4324 if (!initialized || preparing_for_armageddon)
4326 tem = find_symbol_value(hook_symbol);
4327 if (NILP(tem) || UNBOUNDP(tem))
4331 specbind(Qinhibit_quit, Qt);
4333 cons = noseeum_cons(hook_symbol,
4335 ? make_opaque_ptr((void*)warning_string)
4338 /* Qerror not Qt, so you can get a backtrace */
4339 tem = condition_case_1(Qerror,
4340 catch_them_squirmers_run_hook,
4343 allow_quit_safe_run_hook_caught_a_squirmer :
4344 safe_run_hook_caught_a_squirmer, cons);
4345 if (OPAQUE_PTRP(XCDR(cons)))
4346 free_opaque_ptr(XCDR(cons));
4347 free_cons(XCONS(cons));
4350 return unbind_to(speccount, tem);
4353 static Lisp_Object catch_them_squirmers_call0(Lisp_Object function)
4355 /* This function can GC */
4356 return call0(function);
4360 call0_trapping_errors(char *warning_string, Lisp_Object function)
4364 Lisp_Object opaque = Qnil;
4365 struct gcpro gcpro1, gcpro2;
4367 if (SYMBOLP(function)) {
4368 tem = XSYMBOL(function)->function;
4369 if (NILP(tem) || UNBOUNDP(tem))
4373 GCPRO2(opaque, function);
4374 speccount = specpdl_depth();
4375 specbind(Qinhibit_quit, Qt);
4376 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4378 opaque = warning_string
4379 ? make_opaque_ptr((void *)warning_string)
4381 /* Qerror not Qt, so you can get a backtrace */
4382 tem = condition_case_1(Qerror,
4383 catch_them_squirmers_call0, function,
4384 caught_a_squirmer, opaque);
4385 if (OPAQUE_PTRP(opaque))
4386 free_opaque_ptr(opaque);
4389 /* gc_currently_forbidden = 0; */
4390 return unbind_to(speccount, tem);
4393 static Lisp_Object catch_them_squirmers_call1(Lisp_Object cons)
4395 /* This function can GC */
4396 return call1(XCAR(cons), XCDR(cons));
4399 static Lisp_Object catch_them_squirmers_call2(Lisp_Object cons)
4401 /* This function can GC */
4402 return call2(XCAR(cons), XCAR(XCDR(cons)), XCAR(XCDR(XCDR(cons))));
4405 static Lisp_Object catch_them_squirmers_call3(Lisp_Object cons)
4407 /* This function can GC */
4408 return call3(XCAR(cons), XCAR(XCDR(cons)), XCAR(XCDR(XCDR(cons))), XCAR(XCDR(XCDR(XCDR(cons)))));
4412 call1_trapping_errors(char *warning_string, Lisp_Object function,
4415 int speccount = specpdl_depth();
4417 Lisp_Object cons = Qnil;
4418 Lisp_Object opaque = Qnil;
4419 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
4421 if (SYMBOLP(function)) {
4422 tem = XSYMBOL(function)->function;
4423 if (NILP(tem) || UNBOUNDP(tem))
4427 GCPRO4(cons, opaque, function, object);
4429 specbind(Qinhibit_quit, Qt);
4430 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4432 cons = noseeum_cons(function, object);
4433 opaque = warning_string
4434 ? make_opaque_ptr((void *)warning_string)
4436 /* Qerror not Qt, so you can get a backtrace */
4437 tem = condition_case_1(Qerror,
4438 catch_them_squirmers_call1, cons,
4439 caught_a_squirmer, opaque);
4440 if (OPAQUE_PTRP(opaque))
4441 free_opaque_ptr(opaque);
4442 free_cons(XCONS(cons));
4445 /* gc_currently_forbidden = 0; */
4446 return unbind_to(speccount, tem);
4450 call2_trapping_errors(char *warning_string, Lisp_Object function,
4451 Lisp_Object object1, Lisp_Object object2)
4453 int speccount = specpdl_depth();
4455 Lisp_Object cons = Qnil;
4456 Lisp_Object opaque = Qnil;
4457 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
4459 if (SYMBOLP(function)) {
4460 tem = XSYMBOL(function)->function;
4461 if (NILP(tem) || UNBOUNDP(tem))
4465 GCPRO5(cons, opaque, function, object1, object2);
4466 specbind(Qinhibit_quit, Qt);
4467 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4469 cons = list3(function, object1, object2);
4470 opaque = warning_string
4471 ? make_opaque_ptr((void *)warning_string)
4473 /* Qerror not Qt, so you can get a backtrace */
4474 tem = condition_case_1(Qerror,
4475 catch_them_squirmers_call2, cons,
4476 caught_a_squirmer, opaque);
4477 if (OPAQUE_PTRP(opaque))
4478 free_opaque_ptr(opaque);
4482 /* gc_currently_forbidden = 0; */
4483 return unbind_to(speccount, tem);
4487 call3_trapping_errors(char *warning_string, Lisp_Object function,
4488 Lisp_Object object1, Lisp_Object object2, Lisp_Object object3)
4490 int speccount = specpdl_depth();
4492 Lisp_Object cons = Qnil;
4493 Lisp_Object opaque = Qnil;
4494 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5, gcpro6;
4496 if (SYMBOLP(function)) {
4497 tem = XSYMBOL(function)->function;
4498 if (NILP(tem) || UNBOUNDP(tem))
4502 GCPRO6(cons, opaque, function, object1, object2, object3);
4503 specbind(Qinhibit_quit, Qt);
4504 /* gc_currently_forbidden = 1; Currently no reason to do this; */
4506 cons = list4(function, object1, object2, object3);
4507 opaque = warning_string
4508 ? make_opaque_ptr((void *)warning_string)
4510 /* Qerror not Qt, so you can get a backtrace */
4511 tem = condition_case_1(Qerror,
4512 catch_them_squirmers_call3, cons,
4513 caught_a_squirmer, opaque);
4514 if (OPAQUE_PTRP(opaque))
4515 free_opaque_ptr(opaque);
4519 /* gc_currently_forbidden = 0; */
4520 return unbind_to(speccount, tem);
4523 /************************************************************************/
4524 /* The special binding stack */
4525 /* Most C code should simply use specbind() and unbind_to(). */
4526 /* When performance is critical, use the macros in backtrace.h. */
4527 /************************************************************************/
4529 #define min_max_specpdl_size 400
4531 void grow_specpdl(EMACS_INT reserved)
4533 EMACS_INT size_needed = specpdl_depth() + reserved;
4534 if (size_needed >= max_specpdl_size) {
4535 if (max_specpdl_size < min_max_specpdl_size)
4536 max_specpdl_size = min_max_specpdl_size;
4537 if (size_needed >= max_specpdl_size) {
4538 if (!NILP(Vdebug_on_error) || !NILP(Vdebug_on_signal))
4539 /* Leave room for some specpdl in the debugger. */
4540 max_specpdl_size = size_needed + 100;
4542 ("Variable binding depth exceeds max-specpdl-size");
4545 while (specpdl_size < size_needed) {
4547 if (specpdl_size > max_specpdl_size)
4548 specpdl_size = max_specpdl_size;
4550 XREALLOC_ARRAY(specpdl, struct specbinding, specpdl_size);
4551 specpdl_ptr = specpdl + specpdl_depth();
4554 /* Handle unbinding buffer-local variables */
4555 static Lisp_Object specbind_unwind_local(Lisp_Object ovalue)
4557 Lisp_Object current = Fcurrent_buffer();
4558 Lisp_Object symbol = specpdl_ptr->symbol;
4559 Lisp_Cons *victim = XCONS(ovalue);
4560 Lisp_Object buf = emacs_get_buffer(victim->car, 0);
4561 ovalue = victim->cdr;
4566 /* Deleted buffer -- do nothing */
4567 } else if (symbol_value_buffer_local_info(symbol, XBUFFER(buf)) == 0) {
4568 /* Was buffer-local when binding was made, now no longer is.
4569 * (kill-local-variable can do this.)
4570 * Do nothing in this case.
4572 } else if (EQ(buf, current))
4573 Fset(symbol, ovalue);
4575 /* Urk! Somebody switched buffers */
4576 struct gcpro gcpro1;
4579 Fset(symbol, ovalue);
4580 Fset_buffer(current);
4586 static Lisp_Object specbind_unwind_wasnt_local(Lisp_Object buffer)
4588 Lisp_Object current = Fcurrent_buffer();
4589 Lisp_Object symbol = specpdl_ptr->symbol;
4591 buffer = emacs_get_buffer(buffer, 0);
4593 /* Deleted buffer -- do nothing */
4594 } else if (symbol_value_buffer_local_info(symbol, XBUFFER(buffer)) == 0) {
4595 /* Was buffer-local when binding was made, now no longer is.
4596 * (kill-local-variable can do this.)
4597 * Do nothing in this case.
4599 } else if (EQ(buffer, current))
4600 Fkill_local_variable(symbol);
4602 /* Urk! Somebody switched buffers */
4603 struct gcpro gcpro1;
4605 Fset_buffer(buffer);
4606 Fkill_local_variable(symbol);
4607 Fset_buffer(current);
4613 void specbind(Lisp_Object symbol, Lisp_Object value)
4615 SPECBIND(symbol, value);
4618 void specbind_magic(Lisp_Object symbol, Lisp_Object value)
4621 symbol_value_buffer_local_info(symbol, current_buffer);
4623 if (buffer_local == 0) {
4624 specpdl_ptr->old_value = find_symbol_value(symbol);
4625 specpdl_ptr->func = 0; /* Handled specially by unbind_to */
4626 } else if (buffer_local > 0) {
4627 /* Already buffer-local */
4628 specpdl_ptr->old_value = noseeum_cons(Fcurrent_buffer(),
4631 specpdl_ptr->func = specbind_unwind_local;
4633 /* About to become buffer-local */
4634 specpdl_ptr->old_value = Fcurrent_buffer();
4635 specpdl_ptr->func = specbind_unwind_wasnt_local;
4638 specpdl_ptr->symbol = symbol;
4640 specpdl_depth_counter++;
4642 Fset(symbol, value);
4645 /* Note: As long as the unwind-protect exists, its arg is automatically
4649 record_unwind_protect(Lisp_Object(*function) (Lisp_Object arg), Lisp_Object arg)
4652 specpdl_ptr->func = function;
4653 specpdl_ptr->symbol = Qnil;
4654 specpdl_ptr->old_value = arg;
4656 specpdl_depth_counter++;
4659 extern int check_sigio(void);
4661 /* Unwind the stack till specpdl_depth() == COUNT.
4662 VALUE is not used, except that, purely as a convenience to the
4663 caller, it is protected from garbage-protection. */
4664 Lisp_Object unbind_to(int count, Lisp_Object value)
4666 UNBIND_TO_GCPRO(count, value);
4670 /* Don't call this directly.
4671 Only for use by UNBIND_TO* macros in backtrace.h */
4672 void unbind_to_hairy(int count)
4677 ++specpdl_depth_counter;
4679 check_quit(); /* make Vquit_flag accurate */
4680 quitf = !NILP(Vquit_flag);
4683 while (specpdl_depth_counter != count) {
4685 --specpdl_depth_counter;
4687 if (specpdl_ptr->func != 0)
4688 /* An unwind-protect */
4689 (*specpdl_ptr->func) (specpdl_ptr->old_value);
4691 /* We checked symbol for validity when we specbound it,
4692 so only need to call Fset if symbol has magic value. */
4693 Lisp_Symbol *sym = XSYMBOL(specpdl_ptr->symbol);
4694 if (!SYMBOL_VALUE_MAGIC_P(sym->value))
4695 sym->value = specpdl_ptr->old_value;
4697 Fset(specpdl_ptr->symbol,
4698 specpdl_ptr->old_value);
4702 #ifndef EXCEEDINGLY_QUESTIONABLE_CODE
4703 /* There should never be anything here for us to remove.
4704 If so, it indicates a logic error in Emacs. Catches
4705 should get removed when a throw or signal occurs, or
4706 when a catch or condition-case exits normally. But
4707 it's too dangerous to just remove this code. --ben */
4709 /* Furthermore, this code is not in FSFmacs!!!
4710 Braino on mly's part? */
4711 /* If we're unwound past the pdlcount of a catch frame,
4712 that catch can't possibly still be valid. */
4713 while (catchlist && catchlist->pdlcount > specpdl_depth_counter) {
4714 catchlist = catchlist->next;
4715 /* Don't mess with gcprolist, backtrace_list here */
4724 /* Get the value of symbol's global binding, even if that binding is
4725 not now dynamically visible. May return Qunbound or magic values. */
4727 Lisp_Object top_level_value(Lisp_Object symbol)
4729 REGISTER struct specbinding *ptr = specpdl;
4731 CHECK_SYMBOL(symbol);
4732 for (; ptr != specpdl_ptr; ptr++) {
4733 if (EQ(ptr->symbol, symbol))
4734 return ptr->old_value;
4736 return XSYMBOL(symbol)->value;
4741 Lisp_Object top_level_set(Lisp_Object symbol, Lisp_Object newval)
4743 REGISTER struct specbinding *ptr = specpdl;
4745 CHECK_SYMBOL(symbol);
4746 for (; ptr != specpdl_ptr; ptr++) {
4747 if (EQ(ptr->symbol, symbol)) {
4748 ptr->old_value = newval;
4752 return Fset(symbol, newval);
4757 /************************************************************************/
4759 /************************************************************************/
4761 DEFUN("backtrace-debug", Fbacktrace_debug, 2, 2, 0, /*
4762 Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
4763 The debugger is entered when that frame exits, if the flag is non-nil.
4767 REGISTER struct backtrace *backlist = backtrace_list;
4772 for (i = 0; backlist && i < XINT(level); i++) {
4773 backlist = backlist->next;
4777 backlist->debug_on_exit = !NILP(flag);
4782 static void backtrace_specials(int speccount, int speclimit, Lisp_Object stream)
4784 int printing_bindings = 0;
4786 for (; speccount > speclimit; speccount--) {
4787 if (specpdl[speccount - 1].func == 0
4788 || specpdl[speccount - 1].func == specbind_unwind_local
4789 || specpdl[speccount - 1].func ==
4790 specbind_unwind_wasnt_local) {
4791 write_c_string(((!printing_bindings) ? " # bind (" :
4793 Fprin1(specpdl[speccount - 1].symbol, stream);
4794 printing_bindings = 1;
4796 if (printing_bindings)
4797 write_c_string(")\n", stream);
4798 write_c_string(" # (unwind-protect ...)\n", stream);
4799 printing_bindings = 0;
4802 if (printing_bindings)
4803 write_c_string(")\n", stream);
4806 DEFUN("backtrace", Fbacktrace, 0, 2, "", /*
4807 Print a trace of Lisp function calls currently active.
4808 Optional arg STREAM specifies the output stream to send the backtrace to,
4809 and defaults to the value of `standard-output'.
4810 Optional second arg DETAILED non-nil means show places where currently
4811 active variable bindings, catches, condition-cases, and
4812 unwind-protects, as well as function calls, were made.
4816 /* This function can GC */
4817 struct backtrace *backlist = backtrace_list;
4818 struct catchtag *catches = catchlist;
4819 int speccount = specpdl_depth();
4821 int old_nl = print_escape_newlines;
4822 int old_pr = print_readably;
4823 Lisp_Object old_level = Vprint_level;
4824 Lisp_Object oiq = Vinhibit_quit;
4825 struct gcpro gcpro1, gcpro2;
4827 /* We can't allow quits in here because that could cause the values
4828 of print_readably and print_escape_newlines to get screwed up.
4829 Normally we would use a record_unwind_protect but that would
4830 screw up the functioning of this function. */
4833 entering_debugger = 0;
4835 Vprint_level = make_int(3);
4837 print_escape_newlines = 1;
4839 GCPRO2(stream, old_level);
4842 stream = Vstandard_output;
4843 if (!noninteractive && (NILP(stream) || EQ(stream, Qt)))
4844 stream = Fselected_frame(Qnil);
4847 if (!NILP(detailed) && catches && catches->backlist == backlist) {
4848 int catchpdl = catches->pdlcount;
4849 if (speccount > catchpdl
4850 && specpdl[catchpdl].func == condition_case_unwind)
4851 /* This is a condition-case catchpoint */
4852 catchpdl = catchpdl + 1;
4854 backtrace_specials(speccount, catchpdl, stream);
4856 speccount = catches->pdlcount;
4857 if (catchpdl == speccount) {
4858 write_c_string(" # (catch ", stream);
4859 Fprin1(catches->tag, stream);
4860 write_c_string(" ...)\n", stream);
4862 write_c_string(" # (condition-case ... . ",
4864 Fprin1(Fcdr(Fcar(catches->tag)), stream);
4865 write_c_string(")\n", stream);
4867 catches = catches->next;
4868 } else if (!backlist)
4871 if (!NILP(detailed) && backlist->pdlcount < speccount) {
4872 backtrace_specials(speccount,
4873 backlist->pdlcount, stream);
4874 speccount = backlist->pdlcount;
4876 write_c_string(((backlist->
4877 debug_on_exit) ? "* " : " "), stream);
4878 if (backlist->nargs == UNEVALLED) {
4880 (*backlist->function, *backlist->args),
4882 write_c_string("\n", stream); /* from FSFmacs 19.30 */
4884 Lisp_Object tem = *backlist->function;
4885 Fprin1(tem, stream); /* This can QUIT */
4886 write_c_string("(", stream);
4887 if (backlist->nargs == MANY) {
4889 Lisp_Object tail = Qnil;
4890 struct gcpro ngcpro1;
4893 for (tail = *backlist->args, i = 0;
4895 tail = Fcdr(tail), i++) {
4899 Fprin1(Fcar(tail), stream);
4904 for (i = 0; i < backlist->nargs; i++) {
4905 if (!i && EQ(tem, Qbyte_code)) {
4907 ("\"...\"", stream);
4913 Fprin1(backlist->args[i],
4917 write_c_string(")\n", stream);
4919 backlist = backlist->next;
4922 Vprint_level = old_level;
4923 print_readably = old_pr;
4924 print_escape_newlines = old_nl;
4926 Vinhibit_quit = oiq;
4930 DEFUN("backtrace-frame", Fbacktrace_frame, 1, 1, 0, /*
4931 Return the function and arguments NFRAMES up from current execution point.
4932 If that frame has not evaluated the arguments yet (or is a special form),
4933 the value is (nil FUNCTION ARG-FORMS...).
4934 If that frame has evaluated its arguments and called its function already,
4935 the value is (t FUNCTION ARG-VALUES...).
4936 A &rest arg is represented as the tail of the list ARG-VALUES.
4937 FUNCTION is whatever was supplied as car of evaluated list,
4938 or a lambda expression for macro calls.
4939 If NFRAMES is more than the number of frames, the value is nil.
4943 REGISTER struct backtrace *backlist = backtrace_list;
4947 CHECK_NATNUM(nframes);
4949 /* Find the frame requested. */
4950 for (i = XINT(nframes); backlist && (i-- > 0);)
4951 backlist = backlist->next;
4955 if (backlist->nargs == UNEVALLED)
4956 return Fcons(Qnil, Fcons(*backlist->function, *backlist->args));
4958 if (backlist->nargs == MANY)
4959 tem = *backlist->args;
4961 tem = Flist(backlist->nargs, backlist->args);
4963 return Fcons(Qt, Fcons(*backlist->function, tem));
4967 /************************************************************************/
4969 /************************************************************************/
4972 warn_when_safe_lispobj(Lisp_Object class, Lisp_Object level, Lisp_Object obj)
4974 obj = list1(list3(class, level, obj));
4975 if (NILP(Vpending_warnings))
4976 Vpending_warnings = Vpending_warnings_tail = obj;
4978 Fsetcdr(Vpending_warnings_tail, obj);
4979 Vpending_warnings_tail = obj;
4983 /* #### This should probably accept Lisp objects; but then we have
4984 to make sure that Feval() isn't called, since it might not be safe.
4986 An alternative approach is to just pass some non-string type of
4987 Lisp_Object to warn_when_safe_lispobj(); `prin1-to-string' will
4988 automatically be called when it is safe to do so. */
4990 void warn_when_safe(Lisp_Object class, Lisp_Object level, const char *fmt, ...)
4995 va_start(args, fmt);
4996 obj = emacs_doprnt_string_va((const Bufbyte *)GETTEXT(fmt),
5000 warn_when_safe_lispobj(class, level, obj);
5003 /************************************************************************/
5004 /* Initialization */
5005 /************************************************************************/
5007 void syms_of_eval(void)
5009 INIT_LRECORD_IMPLEMENTATION(subr);
5011 defsymbol(&Qinhibit_quit, "inhibit-quit");
5012 defsymbol(&Qautoload, "autoload");
5013 defsymbol(&Qdebug_on_error, "debug-on-error");
5014 defsymbol(&Qstack_trace_on_error, "stack-trace-on-error");
5015 defsymbol(&Qdebug_on_signal, "debug-on-signal");
5016 defsymbol(&Qstack_trace_on_signal, "stack-trace-on-signal");
5017 defsymbol(&Qdebugger, "debugger");
5018 defsymbol(&Qmacro, "macro");
5019 defsymbol(&Qand_rest, "&rest");
5020 defsymbol(&Qand_optional, "&optional");
5021 /* Note that the process code also uses Qexit */
5022 defsymbol(&Qexit, "exit");
5023 defsymbol(&Qsetq, "setq");
5024 defsymbol(&Qinteractive, "interactive");
5025 defsymbol(&Qcommandp, "commandp");
5026 defsymbol(&Qdefun, "defun");
5027 defsymbol(&Qprogn, "progn");
5028 defsymbol(&Qvalues, "values");
5029 defsymbol(&Qdisplay_warning, "display-warning");
5030 defsymbol(&Qrun_hooks, "run-hooks");
5031 defsymbol(&Qafter_change_major_mode_hook, "after-change-major-mode-hook");
5032 defsymbol(&Qafter_change_before_major_mode_hook, "after-change-before-major-mode-hook");
5033 defsymbol(&Qcurrent_running_hook, "current-running-hook");
5034 defsymbol(&Qif, "if");
5039 DEFSUBR_MACRO(Fwhen);
5040 DEFSUBR_MACRO(Funless);
5052 DEFSUBR(Fuser_variable_p);
5056 DEFSUBR(Fmacroexpand_internal);
5059 DEFSUBR(Funwind_protect);
5060 DEFSUBR(Fcondition_case);
5061 DEFSUBR(Fcall_with_condition_handler);
5063 DEFSUBR(Finteractive_p);
5065 DEFSUBR(Fcommand_execute);
5070 DEFSUBR(Ffunctionp);
5071 DEFSUBR(Ffunction_min_args);
5072 DEFSUBR(Ffunction_max_args);
5073 DEFSUBR(Frun_hooks);
5074 DEFSUBR(Frun_hook_with_args);
5075 DEFSUBR(Frun_hook_with_args_until_success);
5076 DEFSUBR(Frun_hook_with_args_until_failure);
5077 DEFSUBR(Fbacktrace_debug);
5078 DEFSUBR(Fbacktrace);
5079 DEFSUBR(Fbacktrace_frame);
5082 void reinit_eval(void)
5084 specpdl_ptr = specpdl;
5085 specpdl_depth_counter = 0;
5087 Vcondition_handlers = Qnil;
5090 debug_on_next_call = 0;
5091 lisp_eval_depth = 0;
5092 entering_debugger = 0;
5093 changing_major_mode = 0;
5096 void reinit_vars_of_eval(void)
5098 preparing_for_armageddon = 0;
5100 Qunbound_suspended_errors_tag =
5101 make_opaque_ptr(&Qunbound_suspended_errors_tag);
5102 staticpro_nodump(&Qunbound_suspended_errors_tag);
5105 specpdl = xnew_array(struct specbinding, specpdl_size);
5106 /* XEmacs change: increase these values. */
5107 max_specpdl_size = 3000;
5108 max_lisp_eval_depth = 1000;
5109 #ifdef DEFEND_AGAINST_THROW_RECURSION
5114 void vars_of_eval(void)
5116 reinit_vars_of_eval();
5118 DEFVAR_INT("max-specpdl-size", &max_specpdl_size /*
5119 Limit on number of Lisp variable bindings & unwind-protects before error.
5122 DEFVAR_INT("max-lisp-eval-depth", &max_lisp_eval_depth /*
5123 Limit on depth in `eval', `apply' and `funcall' before error.
5124 This limit is to catch infinite recursions for you before they cause
5125 actual stack overflow in C, which would be fatal for Emacs.
5126 You can safely make it considerably larger than its default value,
5127 if that proves inconveniently small.
5130 DEFVAR_LISP("quit-flag", &Vquit_flag /*
5131 Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
5132 Typing C-G sets `quit-flag' non-nil, regardless of `inhibit-quit'.
5136 DEFVAR_LISP("inhibit-quit", &Vinhibit_quit /*
5137 Non-nil inhibits C-g quitting from happening immediately.
5138 Note that `quit-flag' will still be set by typing C-g,
5139 so a quit will be signalled as soon as `inhibit-quit' is nil.
5140 To prevent this happening, set `quit-flag' to nil
5141 before making `inhibit-quit' nil. The value of `inhibit-quit' is
5142 ignored if a critical quit is requested by typing control-shift-G in
5145 Vinhibit_quit = Qnil;
5147 DEFVAR_LISP("stack-trace-on-error", &Vstack_trace_on_error /*
5148 *Non-nil means automatically display a backtrace buffer
5149 after any error that is not handled by a `condition-case'.
5150 If the value is a list, an error only means to display a backtrace
5151 if one of its condition symbols appears in the list.
5152 See also variable `stack-trace-on-signal'.
5154 Vstack_trace_on_error = Qnil;
5156 DEFVAR_LISP("stack-trace-on-signal", &Vstack_trace_on_signal /*
5157 *Non-nil means automatically display a backtrace buffer
5158 after any error that is signalled, whether or not it is handled by
5160 If the value is a list, an error only means to display a backtrace
5161 if one of its condition symbols appears in the list.
5162 See also variable `stack-trace-on-error'.
5164 Vstack_trace_on_signal = Qnil;
5166 DEFVAR_LISP("debug-ignored-errors", &Vdebug_ignored_errors /*
5167 *List of errors for which the debugger should not be called.
5168 Each element may be a condition-name or a regexp that matches error messages.
5169 If any element applies to a given error, that error skips the debugger
5170 and just returns to top level.
5171 This overrides the variable `debug-on-error'.
5172 It does not apply to errors handled by `condition-case'.
5174 Vdebug_ignored_errors = Qnil;
5176 DEFVAR_LISP("debug-on-error", &Vdebug_on_error /*
5177 *Non-nil means enter debugger if an unhandled error is signalled.
5178 The debugger will not be entered if the error is handled by
5180 If the value is a list, an error only means to enter the debugger
5181 if one of its condition symbols appears in the list.
5182 This variable is overridden by `debug-ignored-errors'.
5183 See also variables `debug-on-quit' and `debug-on-signal'.
5185 Vdebug_on_error = Qnil;
5187 DEFVAR_LISP("debug-on-signal", &Vdebug_on_signal /*
5188 *Non-nil means enter debugger if an error is signalled.
5189 The debugger will be entered whether or not the error is handled by
5191 If the value is a list, an error only means to enter the debugger
5192 if one of its condition symbols appears in the list.
5193 See also variable `debug-on-quit'.
5195 Vdebug_on_signal = Qnil;
5197 DEFVAR_BOOL("debug-on-quit", &debug_on_quit /*
5198 *Non-nil means enter debugger if quit is signalled (C-G, for example).
5199 Does not apply if quit is handled by a `condition-case'. Entering the
5200 debugger can also be achieved at any time (for X11 console) by typing
5201 control-shift-G to signal a critical quit.
5205 DEFVAR_BOOL("debug-on-next-call", &debug_on_next_call /*
5206 Non-nil means enter debugger before next `eval', `apply' or `funcall'.
5209 DEFVAR_LISP("debugger", &Vdebugger /*
5210 Function to call to invoke debugger.
5211 If due to frame exit, args are `exit' and the value being returned;
5212 this function's value will be returned instead of that.
5213 If due to error, args are `error' and a list of the args to `signal'.
5214 If due to `apply' or `funcall' entry, one arg, `lambda'.
5215 If due to `eval' entry, one arg, t.
5217 DEFVAR_LISP("after-change-major-mode-hook", &Vafter_change_major_mode_hook /*
5218 Normal hook run at the very end of major mode functions.
5220 Vafter_change_major_mode_hook = Qnil;
5222 DEFVAR_LISP("after-change-before-major-mode-hook", &Vafter_change_before_major_mode_hook /*
5223 Normal hook run before a major mode hook is run.
5225 Vafter_change_before_major_mode_hook = Qnil;
5227 DEFVAR_LISP("current-running-hook", &Vcurrent_running_hook /*
5228 Symbol of the current running hook. nil if no hook is running.
5230 Vcurrent_running_hook = Qnil;
5234 staticpro(&Vpending_warnings);
5235 Vpending_warnings = Qnil;
5236 dump_add_root_object(&Vpending_warnings_tail);
5237 Vpending_warnings_tail = Qnil;
5239 staticpro(&Vautoload_queue);
5240 Vautoload_queue = Qnil;
5242 staticpro(&Vcondition_handlers);
5244 staticpro(&Vcurrent_warning_class);
5245 Vcurrent_warning_class = Qnil;
5247 staticpro(&Vcurrent_error_state);
5248 Vcurrent_error_state = Qnil; /* errors as normal */