update.
[chise/xemacs-chise.git.1] / src / eval.c
1 /* Evaluator for XEmacs 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.
5
6 This file is part of XEmacs.
7
8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
11 later version.
12
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with XEmacs; see the file COPYING.  If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA.  */
22
23 /* Synched up with: FSF 19.30 (except for Fsignal), Mule 2.0. */
24
25 #include <config.h>
26 #include "lisp.h"
27
28 #include "commands.h"
29 #include "backtrace.h"
30 #include "bytecode.h"
31 #include "buffer.h"
32 #include "console.h"
33 #include "opaque.h"
34
35 #ifdef ERROR_CHECK_GC
36 int always_gc;                  /* Debugging hack */
37 #else
38 #define always_gc 0
39 #endif
40
41 struct backtrace *backtrace_list;
42
43 /* Note: you must always fill in all of the fields in a backtrace structure
44    before pushing them on the backtrace_list.  The profiling code depends
45    on this. */
46
47 #define PUSH_BACKTRACE(bt) do {         \
48   (bt).next = backtrace_list;           \
49   backtrace_list = &(bt);               \
50 } while (0)
51
52 #define POP_BACKTRACE(bt) do {          \
53   backtrace_list = (bt).next;           \
54 } while (0)
55
56 /* Macros for calling subrs with an argument list whose length is only
57    known at runtime.  See EXFUN and DEFUN for similar hackery.  */
58
59 #define AV_0(av)
60 #define AV_1(av) av[0]
61 #define AV_2(av) AV_1(av), av[1]
62 #define AV_3(av) AV_2(av), av[2]
63 #define AV_4(av) AV_3(av), av[3]
64 #define AV_5(av) AV_4(av), av[4]
65 #define AV_6(av) AV_5(av), av[5]
66 #define AV_7(av) AV_6(av), av[6]
67 #define AV_8(av) AV_7(av), av[7]
68
69 #define PRIMITIVE_FUNCALL_1(fn, av, ac) \
70   (((Lisp_Object (*)(EXFUN_##ac)) (fn)) (AV_##ac (av)))
71
72 /* If subrs take more than 8 arguments, more cases need to be added
73    to this switch.  (But wait - don't do it - if you really need
74    a SUBR with more than 8 arguments, use max_args == MANY.
75    See the DEFUN macro in lisp.h)  */
76 #define PRIMITIVE_FUNCALL(rv, fn, av, ac) do {                  \
77   void (*PF_fn)(void) = (void (*)(void)) fn;                    \
78   Lisp_Object *PF_av = (av);                                    \
79   switch (ac)                                                   \
80     {                                                           \
81     default:rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 0); break;   \
82     case 1: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 1); break;   \
83     case 2: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 2); break;   \
84     case 3: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 3); break;   \
85     case 4: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 4); break;   \
86     case 5: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 5); break;   \
87     case 6: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 6); break;   \
88     case 7: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 7); break;   \
89     case 8: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 8); break;   \
90     }                                                           \
91 } while (0)
92
93 #define FUNCALL_SUBR(rv, subr, av, ac) \
94         PRIMITIVE_FUNCALL (rv, subr_function (subr), av, ac);
95
96
97 /* This is the list of current catches (and also condition-cases).
98    This is a stack: the most recent catch is at the head of the
99    list.  Catches are created by declaring a 'struct catchtag'
100    locally, filling the .TAG field in with the tag, and doing
101    a setjmp() on .JMP.  Fthrow() will store the value passed
102    to it in .VAL and longjmp() back to .JMP, back to the function
103    that established the catch.  This will always be either
104    internal_catch() (catches established internally or through
105    `catch') or condition_case_1 (condition-cases established
106    internally or through `condition-case').
107
108    The catchtag also records the current position in the
109    call stack (stored in BACKTRACE_LIST), the current position
110    in the specpdl stack (used for variable bindings and
111    unwind-protects), the value of LISP_EVAL_DEPTH, and the
112    current position in the GCPRO stack.  All of these are
113    restored by Fthrow().
114    */
115
116 struct catchtag *catchlist;
117
118 Lisp_Object Qautoload, Qmacro, Qexit;
119 Lisp_Object Qinteractive, Qcommandp, Qdefun, Qprogn, Qvalues;
120 Lisp_Object Vquit_flag, Vinhibit_quit;
121 Lisp_Object Qand_rest, Qand_optional;
122 Lisp_Object Qdebug_on_error, Qstack_trace_on_error;
123 Lisp_Object Qdebug_on_signal, Qstack_trace_on_signal;
124 Lisp_Object Qdebugger;
125 Lisp_Object Qinhibit_quit;
126 Lisp_Object Qrun_hooks;
127 Lisp_Object Qsetq;
128 Lisp_Object Qdisplay_warning;
129 Lisp_Object Vpending_warnings, Vpending_warnings_tail;
130 Lisp_Object Qif;
131
132 /* Records whether we want errors to occur.  This will be a boolean,
133    nil (errors OK) or t (no errors).  If t, an error will cause a
134    throw to Qunbound_suspended_errors_tag.
135
136    See call_with_suspended_errors(). */
137 Lisp_Object Vcurrent_error_state;
138
139 /* Current warning class when warnings occur, or nil for no warnings.
140    Only meaningful when Vcurrent_error_state is non-nil.
141    See call_with_suspended_errors(). */
142 Lisp_Object Vcurrent_warning_class;
143
144 /* Special catch tag used in call_with_suspended_errors(). */
145 Lisp_Object Qunbound_suspended_errors_tag;
146
147 /* Non-nil means record all fset's and provide's, to be undone
148    if the file being autoloaded is not fully loaded.
149    They are recorded by being consed onto the front of Vautoload_queue:
150    (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide.  */
151 Lisp_Object Vautoload_queue;
152
153 /* Current number of specbindings allocated in specpdl.  */
154 int specpdl_size;
155
156 /* Pointer to beginning of specpdl.  */
157 struct specbinding *specpdl;
158
159 /* Pointer to first unused element in specpdl.  */
160 struct specbinding *specpdl_ptr;
161
162 /* specpdl_ptr - specpdl */
163 int specpdl_depth_counter;
164
165 /* Maximum size allowed for specpdl allocation */
166 Fixnum max_specpdl_size;
167
168 /* Depth in Lisp evaluations and function calls.  */
169 static int lisp_eval_depth;
170
171 /* Maximum allowed depth in Lisp evaluations and function calls.  */
172 Fixnum max_lisp_eval_depth;
173
174 /* Nonzero means enter debugger before next function call */
175 static int debug_on_next_call;
176
177 /* List of conditions (non-nil atom means all) which cause a backtrace
178    if an error is handled by the command loop's error handler.  */
179 Lisp_Object Vstack_trace_on_error;
180
181 /* List of conditions (non-nil atom means all) which enter the debugger
182    if an error is handled by the command loop's error handler.  */
183 Lisp_Object Vdebug_on_error;
184
185 /* List of conditions and regexps specifying error messages which
186    do not enter the debugger even if Vdebug_on_error says they should.  */
187 Lisp_Object Vdebug_ignored_errors;
188
189 /* List of conditions (non-nil atom means all) which cause a backtrace
190    if any error is signalled.  */
191 Lisp_Object Vstack_trace_on_signal;
192
193 /* List of conditions (non-nil atom means all) which enter the debugger
194    if any error is signalled.  */
195 Lisp_Object Vdebug_on_signal;
196
197 /* Nonzero means enter debugger if a quit signal
198    is handled by the command loop's error handler.
199
200    From lisp, this is a boolean variable and may have the values 0 and 1.
201    But, eval.c temporarily uses the second bit of this variable to indicate
202    that a critical_quit is in progress.  The second bit is reset immediately
203    after it is processed in signal_call_debugger().  */
204 int debug_on_quit;
205
206 #if 0 /* FSFmacs */
207 /* entering_debugger is basically equivalent */
208 /* The value of num_nonmacro_input_chars as of the last time we
209    started to enter the debugger.  If we decide to enter the debugger
210    again when this is still equal to num_nonmacro_input_chars, then we
211    know that the debugger itself has an error, and we should just
212    signal the error instead of entering an infinite loop of debugger
213    invocations.  */
214 int when_entered_debugger;
215 #endif
216
217 /* Nonzero means we are trying to enter the debugger.
218    This is to prevent recursive attempts.
219    Cleared by the debugger calling Fbacktrace */
220 static int entering_debugger;
221
222 /* Function to call to invoke the debugger */
223 Lisp_Object Vdebugger;
224
225 /* Chain of condition handlers currently in effect.
226    The elements of this chain are contained in the stack frames
227    of Fcondition_case and internal_condition_case.
228    When an error is signaled (by calling Fsignal, below),
229    this chain is searched for an element that applies.
230
231    Each element of this list is one of the following:
232
233    A list of a handler function and possibly args to pass to
234    the function.  This is a handler established with
235    `call-with-condition-handler' (q.v.).
236
237    A list whose car is Qunbound and whose cdr is Qt.
238    This is a special condition-case handler established
239    by C code with condition_case_1().  All errors are
240    trapped; the debugger is not invoked even if
241    `debug-on-error' was set.
242
243    A list whose car is Qunbound and whose cdr is Qerror.
244    This is a special condition-case handler established
245    by C code with condition_case_1().  It is like Qt
246    except that the debugger is invoked normally if it is
247    called for.
248
249    A list whose car is Qunbound and whose cdr is a list
250    of lists (CONDITION-NAME BODY ...) exactly as in
251    `condition-case'.  This is a normal `condition-case'
252    handler.
253
254    Note that in all cases *except* the first, there is a
255    corresponding catch, whose TAG is the value of
256    Vcondition_handlers just after the handler data just
257    described is pushed onto it.  The reason is that
258    `condition-case' handlers need to throw back to the
259    place where the handler was installed before invoking
260    it, while `call-with-condition-handler' handlers are
261    invoked in the environment that `signal' was invoked
262    in.
263 */
264 static Lisp_Object Vcondition_handlers;
265
266
267 #define DEFEND_AGAINST_THROW_RECURSION
268
269 #ifdef DEFEND_AGAINST_THROW_RECURSION
270 /* Used for error catching purposes by throw_or_bomb_out */
271 static int throw_level;
272 #endif
273
274 #ifdef ERROR_CHECK_TYPECHECK
275 void check_error_state_sanity (void);
276 #endif
277
278 \f
279 /************************************************************************/
280 /*                      The subr object type                            */
281 /************************************************************************/
282
283 static void
284 print_subr (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
285 {
286   Lisp_Subr *subr = XSUBR (obj);
287   const char *header =
288     (subr->max_args == UNEVALLED) ? "#<special-form " : "#<subr ";
289   const char *name = subr_name (subr);
290   const char *trailer = subr->prompt ? " (interactive)>" : ">";
291
292   if (print_readably)
293     error ("printing unreadable object %s%s%s", header, name, trailer);
294
295   write_c_string (header,  printcharfun);
296   write_c_string (name,    printcharfun);
297   write_c_string (trailer, printcharfun);
298 }
299
300 static const struct lrecord_description subr_description[] = {
301   { XD_DOC_STRING, offsetof (Lisp_Subr, doc) },
302   { XD_END }
303 };
304
305 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("subr", subr,
306                                      0, print_subr, 0, 0, 0,
307                                      subr_description,
308                                      Lisp_Subr);
309 \f
310 /************************************************************************/
311 /*                       Entering the debugger                          */
312 /************************************************************************/
313
314 /* unwind-protect used by call_debugger() to restore the value of
315    entering_debugger. (We cannot use specbind() because the
316    variable is not Lisp-accessible.) */
317
318 static Lisp_Object
319 restore_entering_debugger (Lisp_Object arg)
320 {
321   entering_debugger = ! NILP (arg);
322   return arg;
323 }
324
325 /* Actually call the debugger.  ARG is a list of args that will be
326    passed to the debugger function, as follows;
327
328 If due to frame exit, args are `exit' and the value being returned;
329  this function's value will be returned instead of that.
330 If due to error, args are `error' and a list of the args to `signal'.
331 If due to `apply' or `funcall' entry, one arg, `lambda'.
332 If due to `eval' entry, one arg, t.
333
334 */
335
336 static Lisp_Object
337 call_debugger_259 (Lisp_Object arg)
338 {
339   return apply1 (Vdebugger, arg);
340 }
341
342 /* Call the debugger, doing some encapsulation.  We make sure we have
343    some room on the eval and specpdl stacks, and bind entering_debugger
344    to 1 during this call.  This is used to trap errors that may occur
345    when entering the debugger (e.g. the value of `debugger' is invalid),
346    so that the debugger will not be recursively entered if debug-on-error
347    is set. (Otherwise, XEmacs would infinitely recurse, attempting to
348    enter the debugger.) entering_debugger gets reset to 0 as soon
349    as a backtrace is displayed, so that further errors can indeed be
350    handled normally.
351
352    We also establish a catch for 'debugger.  If the debugger function
353    throws to this instead of returning a value, it means that the user
354    pressed 'c' (pretend like the debugger was never entered).  The
355    function then returns Qunbound. (If the user pressed 'r', for
356    return a value, then the debugger function returns normally with
357    this value.)
358
359    The difference between 'c' and 'r' is as follows:
360
361    debug-on-call:
362      No difference.  The call proceeds as normal.
363    debug-on-exit:
364      With 'r', the specified value is returned as the function's
365      return value.  With 'c', the value that would normally be
366      returned is returned.
367    signal:
368      With 'r', the specified value is returned as the return
369      value of `signal'. (This is the only time that `signal'
370      can return, instead of making a non-local exit.) With `c',
371      `signal' will continue looking for handlers as if the
372      debugger was never entered, and will probably end up
373      throwing to a handler or to top-level.
374 */
375
376 static Lisp_Object
377 call_debugger (Lisp_Object arg)
378 {
379   int threw;
380   Lisp_Object val;
381   int speccount;
382
383   if (lisp_eval_depth + 20 > max_lisp_eval_depth)
384     max_lisp_eval_depth = lisp_eval_depth + 20;
385   if (specpdl_size + 40 > max_specpdl_size)
386     max_specpdl_size = specpdl_size + 40;
387   debug_on_next_call = 0;
388
389   speccount = specpdl_depth();
390   record_unwind_protect (restore_entering_debugger,
391                          (entering_debugger ? Qt : Qnil));
392   entering_debugger = 1;
393   val = internal_catch (Qdebugger, call_debugger_259, arg, &threw);
394
395   return unbind_to (speccount, ((threw)
396                                 ? Qunbound /* Not returning a value */
397                                 : val));
398 }
399
400 /* Called when debug-on-exit behavior is called for.  Enter the debugger
401    with the appropriate args for this.  VAL is the exit value that is
402    about to be returned. */
403
404 static Lisp_Object
405 do_debug_on_exit (Lisp_Object val)
406 {
407   /* This is falsified by call_debugger */
408   Lisp_Object v = call_debugger (list2 (Qexit, val));
409
410   return !UNBOUNDP (v) ? v : val;
411 }
412
413 /* Called when debug-on-call behavior is called for.  Enter the debugger
414    with the appropriate args for this.  VAL is either t for a call
415    through `eval' or 'lambda for a call through `funcall'.
416
417    #### The differentiation here between EVAL and FUNCALL is bogus.
418    FUNCALL can be defined as
419
420    (defmacro func (fun &rest args)
421      (cons (eval fun) args))
422
423    and should be treated as such.
424  */
425
426 static void
427 do_debug_on_call (Lisp_Object code)
428 {
429   debug_on_next_call = 0;
430   backtrace_list->debug_on_exit = 1;
431   call_debugger (list1 (code));
432 }
433
434 /* LIST is the value of one of the variables `debug-on-error',
435    `debug-on-signal', `stack-trace-on-error', or `stack-trace-on-signal',
436    and CONDITIONS is the list of error conditions associated with
437    the error being signalled.  This returns non-nil if LIST
438    matches CONDITIONS. (A nil value for LIST does not match
439    CONDITIONS.  A non-list value for LIST does match CONDITIONS.
440    A list matches CONDITIONS when one of the symbols in LIST is the
441    same as one of the symbols in CONDITIONS.) */
442
443 static int
444 wants_debugger (Lisp_Object list, Lisp_Object conditions)
445 {
446   if (NILP (list))
447     return 0;
448   if (! CONSP (list))
449     return 1;
450
451   while (CONSP (conditions))
452     {
453       Lisp_Object this, tail;
454       this = XCAR (conditions);
455       for (tail = list; CONSP (tail); tail = XCDR (tail))
456         if (EQ (XCAR (tail), this))
457           return 1;
458       conditions = XCDR (conditions);
459     }
460   return 0;
461 }
462
463
464 /* Return 1 if an error with condition-symbols CONDITIONS,
465    and described by SIGNAL-DATA, should skip the debugger
466    according to debugger-ignore-errors.  */
467
468 static int
469 skip_debugger (Lisp_Object conditions, Lisp_Object data)
470 {
471   /* This function can GC */
472   Lisp_Object tail;
473   int first_string = 1;
474   Lisp_Object error_message = Qnil;
475
476   for (tail = Vdebug_ignored_errors; CONSP (tail); tail = XCDR (tail))
477     {
478       if (STRINGP (XCAR (tail)))
479         {
480           if (first_string)
481             {
482               error_message = Ferror_message_string (data);
483               first_string = 0;
484             }
485           if (fast_lisp_string_match (XCAR (tail), error_message) >= 0)
486             return 1;
487         }
488       else
489         {
490           Lisp_Object contail;
491
492           for (contail = conditions; CONSP (contail); contail = XCDR (contail))
493             if (EQ (XCAR (tail), XCAR (contail)))
494               return 1;
495         }
496     }
497
498   return 0;
499 }
500
501 /* Actually generate a backtrace on STREAM. */
502
503 static Lisp_Object
504 backtrace_259 (Lisp_Object stream)
505 {
506   return Fbacktrace (stream, Qt);
507 }
508
509 /* An error was signaled.  Maybe call the debugger, if the `debug-on-error'
510    etc. variables call for this.  CONDITIONS is the list of conditions
511    associated with the error being signalled.  SIG is the actual error
512    being signalled, and DATA is the associated data (these are exactly
513    the same as the arguments to `signal').  ACTIVE_HANDLERS is the
514    list of error handlers that are to be put in place while the debugger
515    is called.  This is generally the remaining handlers that are
516    outside of the innermost handler trapping this error.  This way,
517    if the same error occurs inside of the debugger, you usually don't get
518    the debugger entered recursively.
519
520    This function returns Qunbound if it didn't call the debugger or if
521    the user asked (through 'c') that XEmacs should pretend like the
522    debugger was never entered.  Otherwise, it returns the value
523    that the user specified with `r'. (Note that much of the time,
524    the user will abort with C-], and we will never have a chance to
525    return anything at all.)
526
527    SIGNAL_VARS_ONLY means we should only look at debug-on-signal
528    and stack-trace-on-signal to control whether we do anything.
529    This is so that debug-on-error doesn't make handled errors
530    cause the debugger to get invoked.
531
532    STACK_TRACE_DISPLAYED and DEBUGGER_ENTERED are used so that
533    those functions aren't done more than once in a single `signal'
534    session. */
535
536 static Lisp_Object
537 signal_call_debugger (Lisp_Object conditions,
538                       Lisp_Object sig, Lisp_Object data,
539                       Lisp_Object active_handlers,
540                       int signal_vars_only,
541                       int *stack_trace_displayed,
542                       int *debugger_entered)
543 {
544   /* This function can GC */
545   Lisp_Object val = Qunbound;
546   Lisp_Object all_handlers = Vcondition_handlers;
547   Lisp_Object temp_data = Qnil;
548   int speccount = specpdl_depth();
549   struct gcpro gcpro1, gcpro2;
550   GCPRO2 (all_handlers, temp_data);
551
552   Vcondition_handlers = active_handlers;
553
554   temp_data = Fcons (sig, data); /* needed for skip_debugger */
555
556   if (!entering_debugger && !*stack_trace_displayed && !signal_vars_only
557       && wants_debugger (Vstack_trace_on_error, conditions)
558       && !skip_debugger (conditions, temp_data))
559     {
560       specbind (Qdebug_on_error,        Qnil);
561       specbind (Qstack_trace_on_error,  Qnil);
562       specbind (Qdebug_on_signal,       Qnil);
563       specbind (Qstack_trace_on_signal, Qnil);
564
565       if (!noninteractive)
566         internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
567                                              backtrace_259,
568                                              Qnil,
569                                              Qnil);
570       else /* in batch mode, we want this going to stderr. */
571         backtrace_259 (Qnil);
572       unbind_to (speccount, Qnil);
573       *stack_trace_displayed = 1;
574     }
575
576   if (!entering_debugger && !*debugger_entered && !signal_vars_only
577       && (EQ (sig, Qquit)
578           ? debug_on_quit
579           : wants_debugger (Vdebug_on_error, conditions))
580       && !skip_debugger (conditions, temp_data))
581     {
582       debug_on_quit &= ~2;      /* reset critical bit */
583       specbind (Qdebug_on_error,        Qnil);
584       specbind (Qstack_trace_on_error,  Qnil);
585       specbind (Qdebug_on_signal,       Qnil);
586       specbind (Qstack_trace_on_signal, Qnil);
587
588       val = call_debugger (list2 (Qerror, (Fcons (sig, data))));
589       *debugger_entered = 1;
590     }
591
592   if (!entering_debugger && !*stack_trace_displayed
593       && wants_debugger (Vstack_trace_on_signal, conditions))
594     {
595       specbind (Qdebug_on_error,        Qnil);
596       specbind (Qstack_trace_on_error,  Qnil);
597       specbind (Qdebug_on_signal,       Qnil);
598       specbind (Qstack_trace_on_signal, Qnil);
599
600       if (!noninteractive)
601         internal_with_output_to_temp_buffer (build_string ("*Backtrace*"),
602                                              backtrace_259,
603                                              Qnil,
604                                              Qnil);
605       else /* in batch mode, we want this going to stderr. */
606         backtrace_259 (Qnil);
607       unbind_to (speccount, Qnil);
608       *stack_trace_displayed = 1;
609     }
610
611   if (!entering_debugger && !*debugger_entered
612       && (EQ (sig, Qquit)
613           ? debug_on_quit
614           : wants_debugger (Vdebug_on_signal, conditions)))
615     {
616       debug_on_quit &= ~2;      /* reset critical bit */
617       specbind (Qdebug_on_error,        Qnil);
618       specbind (Qstack_trace_on_error,  Qnil);
619       specbind (Qdebug_on_signal,       Qnil);
620       specbind (Qstack_trace_on_signal, Qnil);
621
622       val = call_debugger (list2 (Qerror, (Fcons (sig, data))));
623       *debugger_entered = 1;
624     }
625
626   UNGCPRO;
627   Vcondition_handlers = all_handlers;
628   return unbind_to (speccount, val);
629 }
630
631 \f
632 /************************************************************************/
633 /*                     The basic special forms                          */
634 /************************************************************************/
635
636 /* Except for Fprogn(), the basic special forms below are only called
637    from interpreted code.  The byte compiler turns them into bytecodes. */
638
639 DEFUN ("or", For, 0, UNEVALLED, 0, /*
640 Eval args until one of them yields non-nil, then return that value.
641 The remaining args are not evalled at all.
642 If all args return nil, return nil.
643 */
644        (args))
645 {
646   /* This function can GC */
647   REGISTER Lisp_Object val;
648
649   LIST_LOOP_2 (arg, args)
650     {
651       if (!NILP (val = Feval (arg)))
652         return val;
653     }
654
655   return Qnil;
656 }
657
658 DEFUN ("and", Fand, 0, UNEVALLED, 0, /*
659 Eval args until one of them yields nil, then return nil.
660 The remaining args are not evalled at all.
661 If no arg yields nil, return the last arg's value.
662 */
663        (args))
664 {
665   /* This function can GC */
666   REGISTER Lisp_Object val = Qt;
667
668   LIST_LOOP_2 (arg, args)
669     {
670       if (NILP (val = Feval (arg)))
671         return val;
672     }
673
674   return val;
675 }
676
677 DEFUN ("if", Fif, 2, UNEVALLED, 0, /*
678 \(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...
679 Returns the value of THEN or the value of the last of the ELSE's.
680 THEN must be one expression, but ELSE... can be zero or more expressions.
681 If COND yields nil, and there are no ELSE's, the value is nil.
682 */
683        (args))
684 {
685   /* This function can GC */
686   Lisp_Object condition  = XCAR (args);
687   Lisp_Object then_form  = XCAR (XCDR (args));
688   Lisp_Object else_forms = XCDR (XCDR (args));
689
690   if (!NILP (Feval (condition)))
691     return Feval (then_form);
692   else
693     return Fprogn (else_forms);
694 }
695
696 /* Macros `when' and `unless' are trivially defined in Lisp,
697    but it helps for bootstrapping to have them ALWAYS defined. */
698
699 DEFUN ("when", Fwhen, 1, MANY, 0, /*
700 \(when COND BODY...): if COND yields non-nil, do BODY, else return nil.
701 BODY can be zero or more expressions.  If BODY is nil, return nil.
702 */
703        (int nargs, Lisp_Object *args))
704 {
705   Lisp_Object cond = args[0];
706   Lisp_Object body;
707
708   switch (nargs)
709     {
710     case 1:  body = Qnil; break;
711     case 2:  body = args[1]; break;
712     default: body = Fcons (Qprogn, Flist (nargs-1, args+1)); break;
713     }
714
715   return list3 (Qif, cond, body);
716 }
717
718 DEFUN ("unless", Funless, 1, MANY, 0, /*
719 \(unless COND BODY...): if COND yields nil, do BODY, else return nil.
720 BODY can be zero or more expressions.  If BODY is nil, return nil.
721 */
722        (int nargs, Lisp_Object *args))
723 {
724   Lisp_Object cond = args[0];
725   Lisp_Object body = Flist (nargs-1, args+1);
726   return Fcons (Qif, Fcons (cond, Fcons (Qnil, body)));
727 }
728
729 DEFUN ("cond", Fcond, 0, UNEVALLED, 0, /*
730 \(cond CLAUSES...): try each clause until one succeeds.
731 Each clause looks like (CONDITION BODY...).  CONDITION is evaluated
732 and, if the value is non-nil, this clause succeeds:
733 then the expressions in BODY are evaluated and the last one's
734 value is the value of the cond-form.
735 If no clause succeeds, cond returns nil.
736 If a clause has one element, as in (CONDITION),
737 CONDITION's value if non-nil is returned from the cond-form.
738 */
739        (args))
740 {
741   /* This function can GC */
742   REGISTER Lisp_Object val;
743
744   LIST_LOOP_2 (clause, args)
745     {
746       CHECK_CONS (clause);
747       if (!NILP (val = Feval (XCAR (clause))))
748         {
749           if (!NILP (clause = XCDR (clause)))
750             {
751               CHECK_TRUE_LIST (clause);
752               val = Fprogn (clause);
753             }
754           return val;
755         }
756     }
757
758   return Qnil;
759 }
760
761 DEFUN ("progn", Fprogn, 0, UNEVALLED, 0, /*
762 \(progn BODY...): eval BODY forms sequentially and return value of last one.
763 */
764        (args))
765 {
766   /* This function can GC */
767   /* Caller must provide a true list in ARGS */
768   REGISTER Lisp_Object val = Qnil;
769   struct gcpro gcpro1;
770
771   GCPRO1 (args);
772
773   {
774     LIST_LOOP_2 (form, args)
775       val = Feval (form);
776   }
777
778   UNGCPRO;
779   return val;
780 }
781
782 /* Fprog1() is the canonical example of a function that must GCPRO a
783    Lisp_Object across calls to Feval(). */
784
785 DEFUN ("prog1", Fprog1, 1, UNEVALLED, 0, /*
786 Similar to `progn', but the value of the first form is returned.
787 \(prog1 FIRST BODY...): All the arguments are evaluated sequentially.
788 The value of FIRST is saved during evaluation of the remaining args,
789 whose values are discarded.
790 */
791        (args))
792 {
793   /* This function can GC */
794   REGISTER Lisp_Object val;
795   struct gcpro gcpro1;
796
797   val = Feval (XCAR (args));
798
799   GCPRO1 (val);
800
801   {
802     LIST_LOOP_2 (form, XCDR (args))
803       Feval (form);
804   }
805
806   UNGCPRO;
807   return val;
808 }
809
810 DEFUN ("prog2", Fprog2, 2, UNEVALLED, 0, /*
811 Similar to `progn', but the value of the second form is returned.
812 \(prog2 FIRST SECOND BODY...): All the arguments are evaluated sequentially.
813 The value of SECOND is saved during evaluation of the remaining args,
814 whose values are discarded.
815 */
816        (args))
817 {
818   /* This function can GC */
819   REGISTER Lisp_Object val;
820   struct gcpro gcpro1;
821
822   Feval (XCAR (args));
823   args = XCDR (args);
824   val = Feval (XCAR (args));
825   args = XCDR (args);
826
827   GCPRO1 (val);
828
829   {
830     LIST_LOOP_2 (form, args)
831       Feval (form);
832   }
833
834   UNGCPRO;
835   return val;
836 }
837
838 DEFUN ("let*", FletX, 1, UNEVALLED, 0, /*
839 \(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.
840 The value of the last form in BODY is returned.
841 Each element of VARLIST is a symbol (which is bound to nil)
842 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
843 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
844 */
845        (args))
846 {
847   /* This function can GC */
848   Lisp_Object varlist = XCAR (args);
849   Lisp_Object body    = XCDR (args);
850   int speccount = specpdl_depth();
851
852   EXTERNAL_LIST_LOOP_3 (var, varlist, tail)
853     {
854       Lisp_Object symbol, value, tem;
855       if (SYMBOLP (var))
856         symbol = var, value = Qnil;
857       else
858         {
859           CHECK_CONS (var);
860           symbol = XCAR (var);
861           tem    = XCDR (var);
862           if (NILP (tem))
863             value = Qnil;
864           else
865             {
866               CHECK_CONS (tem);
867               value = Feval (XCAR (tem));
868               if (!NILP (XCDR (tem)))
869                 signal_simple_error
870                   ("`let' bindings can have only one value-form", var);
871             }
872         }
873       specbind (symbol, value);
874     }
875   return unbind_to (speccount, Fprogn (body));
876 }
877
878 DEFUN ("let", Flet, 1, UNEVALLED, 0, /*
879 \(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.
880 The value of the last form in BODY is returned.
881 Each element of VARLIST is a symbol (which is bound to nil)
882 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
883 All the VALUEFORMs are evalled before any symbols are bound.
884 */
885        (args))
886 {
887   /* This function can GC */
888   Lisp_Object varlist = XCAR (args);
889   Lisp_Object body    = XCDR (args);
890   int speccount = specpdl_depth();
891   Lisp_Object *temps;
892   int idx;
893   struct gcpro gcpro1;
894
895   /* Make space to hold the values to give the bound variables. */
896   {
897     int varcount;
898     GET_EXTERNAL_LIST_LENGTH (varlist, varcount);
899     temps = alloca_array (Lisp_Object, varcount);
900   }
901
902   /* Compute the values and store them in `temps' */
903   GCPRO1 (*temps);
904   gcpro1.nvars = 0;
905
906   idx = 0;
907   {
908     LIST_LOOP_2 (var, varlist)
909       {
910         Lisp_Object *value = &temps[idx++];
911         if (SYMBOLP (var))
912           *value = Qnil;
913         else
914           {
915             Lisp_Object tem;
916             CHECK_CONS (var);
917             tem = XCDR (var);
918             if (NILP (tem))
919               *value = Qnil;
920             else
921               {
922                 CHECK_CONS (tem);
923                 *value = Feval (XCAR (tem));
924                 gcpro1.nvars = idx;
925
926                 if (!NILP (XCDR (tem)))
927                   signal_simple_error
928                     ("`let' bindings can have only one value-form", var);
929               }
930           }
931       }
932   }
933
934   idx = 0;
935   {
936     LIST_LOOP_2 (var, varlist)
937       {
938         specbind (SYMBOLP (var) ? var : XCAR (var), temps[idx++]);
939       }
940   }
941
942   UNGCPRO;
943
944   return unbind_to (speccount, Fprogn (body));
945 }
946
947 DEFUN ("while", Fwhile, 1, UNEVALLED, 0, /*
948 \(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.
949 The order of execution is thus TEST, BODY, TEST, BODY and so on
950 until TEST returns nil.
951 */
952        (args))
953 {
954   /* This function can GC */
955   Lisp_Object test = XCAR (args);
956   Lisp_Object body = XCDR (args);
957
958   while (!NILP (Feval (test)))
959     {
960       QUIT;
961       Fprogn (body);
962     }
963
964   return Qnil;
965 }
966
967 DEFUN ("setq", Fsetq, 0, UNEVALLED, 0, /*
968 \(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.
969 The symbols SYM are variables; they are literal (not evaluated).
970 The values VAL are expressions; they are evaluated.
971 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
972 The second VAL is not computed until after the first SYM is set, and so on;
973 each VAL can use the new value of variables set earlier in the `setq'.
974 The return value of the `setq' form is the value of the last VAL.
975 */
976        (args))
977 {
978   /* This function can GC */
979   Lisp_Object symbol, tail, val = Qnil;
980   int nargs;
981   struct gcpro gcpro1;
982
983   GET_LIST_LENGTH (args, nargs);
984
985   if (nargs & 1)                /* Odd number of arguments? */
986     Fsignal (Qwrong_number_of_arguments, list2 (Qsetq, make_int (nargs)));
987
988   GCPRO1 (val);
989
990   PROPERTY_LIST_LOOP (tail, symbol, val, args)
991     {
992       val = Feval (val);
993       Fset (symbol, val);
994     }
995
996   UNGCPRO;
997   return val;
998 }
999
1000 DEFUN ("quote", Fquote, 1, UNEVALLED, 0, /*
1001 Return the argument, without evaluating it.  `(quote x)' yields `x'.
1002 */
1003        (args))
1004 {
1005   return XCAR (args);
1006 }
1007
1008 DEFUN ("function", Ffunction, 1, UNEVALLED, 0, /*
1009 Like `quote', but preferred for objects which are functions.
1010 In byte compilation, `function' causes its argument to be compiled.
1011 `quote' cannot do that.
1012 */
1013        (args))
1014 {
1015   return XCAR (args);
1016 }
1017
1018 \f
1019 /************************************************************************/
1020 /*                      Defining functions/variables                    */
1021 /************************************************************************/
1022 static Lisp_Object
1023 define_function (Lisp_Object name, Lisp_Object defn)
1024 {
1025   Ffset (name, defn);
1026   LOADHIST_ATTACH (name);
1027   return name;
1028 }
1029
1030 DEFUN ("defun", Fdefun, 2, UNEVALLED, 0, /*
1031 \(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.
1032 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
1033 See also the function `interactive'.
1034 */
1035        (args))
1036 {
1037   /* This function can GC */
1038   return define_function (XCAR (args),
1039                           Fcons (Qlambda, XCDR (args)));
1040 }
1041
1042 DEFUN ("defmacro", Fdefmacro, 2, UNEVALLED, 0, /*
1043 \(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.
1044 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).
1045 When the macro is called, as in (NAME ARGS...),
1046 the function (lambda ARGLIST BODY...) is applied to
1047 the list ARGS... as it appears in the expression,
1048 and the result should be a form to be evaluated instead of the original.
1049 */
1050        (args))
1051 {
1052   /* This function can GC */
1053   return define_function (XCAR (args),
1054                           Fcons (Qmacro, Fcons (Qlambda, XCDR (args))));
1055 }
1056
1057 DEFUN ("defvar", Fdefvar, 1, UNEVALLED, 0, /*
1058 \(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.
1059 You are not required to define a variable in order to use it,
1060  but the definition can supply documentation and an initial value
1061  in a way that tags can recognize.
1062
1063 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is
1064  void. (However, when you evaluate a defvar interactively, it acts like a
1065  defconst: SYMBOL's value is always set regardless of whether it's currently
1066  void.)
1067 If SYMBOL is buffer-local, its default value is what is set;
1068  buffer-local values are not affected.
1069 INITVALUE and DOCSTRING are optional.
1070 If DOCSTRING starts with *, this variable is identified as a user option.
1071  This means that M-x set-variable recognizes it.
1072 If INITVALUE is missing, SYMBOL's value is not set.
1073
1074 In lisp-interaction-mode defvar is treated as defconst.
1075 */
1076        (args))
1077 {
1078   /* This function can GC */
1079   Lisp_Object sym = XCAR (args);
1080
1081   if (!NILP (args = XCDR (args)))
1082     {
1083       Lisp_Object val = XCAR (args);
1084
1085       if (NILP (Fdefault_boundp (sym)))
1086         {
1087           struct gcpro gcpro1;
1088           GCPRO1 (val);
1089           val = Feval (val);
1090           Fset_default (sym, val);
1091           UNGCPRO;
1092         }
1093
1094       if (!NILP (args = XCDR (args)))
1095         {
1096           Lisp_Object doc = XCAR (args);
1097           Fput (sym, Qvariable_documentation, doc);
1098           if (!NILP (args = XCDR (args)))
1099             error ("too many arguments");
1100         }
1101     }
1102
1103 #ifdef I18N3
1104   if (!NILP (Vfile_domain))
1105     Fput (sym, Qvariable_domain, Vfile_domain);
1106 #endif
1107
1108   LOADHIST_ATTACH (sym);
1109   return sym;
1110 }
1111
1112 DEFUN ("defconst", Fdefconst, 2, UNEVALLED, 0, /*
1113 \(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant
1114 variable.
1115 The intent is that programs do not change this value, but users may.
1116 Always sets the value of SYMBOL to the result of evalling INITVALUE.
1117 If SYMBOL is buffer-local, its default value is what is set;
1118  buffer-local values are not affected.
1119 DOCSTRING is optional.
1120 If DOCSTRING starts with *, this variable is identified as a user option.
1121  This means that M-x set-variable recognizes it.
1122
1123 Note: do not use `defconst' for user options in libraries that are not
1124  normally loaded, since it is useful for users to be able to specify
1125  their own values for such variables before loading the library.
1126 Since `defconst' unconditionally assigns the variable,
1127  it would override the user's choice.
1128 */
1129        (args))
1130 {
1131   /* This function can GC */
1132   Lisp_Object sym = XCAR (args);
1133   Lisp_Object val = Feval (XCAR (args = XCDR (args)));
1134   struct gcpro gcpro1;
1135
1136   GCPRO1 (val);
1137
1138   Fset_default (sym, val);
1139
1140   UNGCPRO;
1141
1142   if (!NILP (args = XCDR (args)))
1143     {
1144       Lisp_Object doc = XCAR (args);
1145       Fput (sym, Qvariable_documentation, doc);
1146       if (!NILP (args = XCDR (args)))
1147         error ("too many arguments");
1148     }
1149
1150 #ifdef I18N3
1151   if (!NILP (Vfile_domain))
1152     Fput (sym, Qvariable_domain, Vfile_domain);
1153 #endif
1154
1155   LOADHIST_ATTACH (sym);
1156   return sym;
1157 }
1158
1159 DEFUN ("user-variable-p", Fuser_variable_p, 1, 1, 0, /*
1160 Return t if VARIABLE is intended to be set and modified by users.
1161 \(The alternative is a variable used internally in a Lisp program.)
1162 Determined by whether the first character of the documentation
1163 for the variable is `*'.
1164 */
1165        (variable))
1166 {
1167   Lisp_Object documentation = Fget (variable, Qvariable_documentation, Qnil);
1168
1169   return
1170     ((INTP (documentation) && XINT (documentation) < 0) ||
1171
1172      (STRINGP (documentation) &&
1173       (string_byte (XSTRING (documentation), 0) == '*')) ||
1174
1175      /* If (STRING . INTEGER), a negative integer means a user variable. */
1176      (CONSP (documentation)
1177       && STRINGP (XCAR (documentation))
1178       && INTP (XCDR (documentation))
1179       && XINT (XCDR (documentation)) < 0)) ?
1180     Qt : Qnil;
1181 }
1182
1183 DEFUN ("macroexpand-internal", Fmacroexpand_internal, 1, 2, 0, /*
1184 Return result of expanding macros at top level of FORM.
1185 If FORM is not a macro call, it is returned unchanged.
1186 Otherwise, the macro is expanded and the expansion is considered
1187 in place of FORM.  When a non-macro-call results, it is returned.
1188
1189 The second optional arg ENVIRONMENT specifies an environment of macro
1190 definitions to shadow the loaded ones for use in file byte-compilation.
1191 */
1192        (form, environment))
1193 {
1194   /* This function can GC */
1195   /* With cleanups from Hallvard Furuseth.  */
1196   REGISTER Lisp_Object expander, sym, def, tem;
1197
1198   while (1)
1199     {
1200       /* Come back here each time we expand a macro call,
1201          in case it expands into another macro call.  */
1202       if (!CONSP (form))
1203         break;
1204       /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1205       def = sym = XCAR (form);
1206       tem = Qnil;
1207       /* Trace symbols aliases to other symbols
1208          until we get a symbol that is not an alias.  */
1209       while (SYMBOLP (def))
1210         {
1211           QUIT;
1212           sym = def;
1213           tem = Fassq (sym, environment);
1214           if (NILP (tem))
1215             {
1216               def = XSYMBOL (sym)->function;
1217               if (!UNBOUNDP (def))
1218                 continue;
1219             }
1220           break;
1221         }
1222       /* Right now TEM is the result from SYM in ENVIRONMENT,
1223          and if TEM is nil then DEF is SYM's function definition.  */
1224       if (NILP (tem))
1225         {
1226           /* SYM is not mentioned in ENVIRONMENT.
1227              Look at its function definition.  */
1228           if (UNBOUNDP (def)
1229               || !CONSP (def))
1230             /* Not defined or definition not suitable */
1231             break;
1232           if (EQ (XCAR (def), Qautoload))
1233             {
1234               /* Autoloading function: will it be a macro when loaded?  */
1235               tem = Felt (def, make_int (4));
1236               if (EQ (tem, Qt) || EQ (tem, Qmacro))
1237                 {
1238                   /* Yes, load it and try again.  */
1239                   /* do_autoload GCPROs both arguments */
1240                   do_autoload (def, sym);
1241                   continue;
1242                 }
1243               else
1244                 break;
1245             }
1246           else if (!EQ (XCAR (def), Qmacro))
1247             break;
1248           else expander = XCDR (def);
1249         }
1250       else
1251         {
1252           expander = XCDR (tem);
1253           if (NILP (expander))
1254             break;
1255         }
1256       form = apply1 (expander, XCDR (form));
1257     }
1258   return form;
1259 }
1260
1261 \f
1262 /************************************************************************/
1263 /*                          Non-local exits                             */
1264 /************************************************************************/
1265
1266 DEFUN ("catch", Fcatch, 1, UNEVALLED, 0, /*
1267 \(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.
1268 TAG is evalled to get the tag to use.  Then the BODY is executed.
1269 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.
1270 If no throw happens, `catch' returns the value of the last BODY form.
1271 If a throw happens, it specifies the value to return from `catch'.
1272 */
1273        (args))
1274 {
1275   /* This function can GC */
1276   Lisp_Object tag  = Feval (XCAR (args));
1277   Lisp_Object body = XCDR (args);
1278   return internal_catch (tag, Fprogn, body, 0);
1279 }
1280
1281 /* Set up a catch, then call C function FUNC on argument ARG.
1282    FUNC should return a Lisp_Object.
1283    This is how catches are done from within C code. */
1284
1285 Lisp_Object
1286 internal_catch (Lisp_Object tag,
1287                 Lisp_Object (*func) (Lisp_Object arg),
1288                 Lisp_Object arg,
1289                 int * volatile threw)
1290 {
1291   /* This structure is made part of the chain `catchlist'.  */
1292   struct catchtag c;
1293
1294   /* Fill in the components of c, and put it on the list.  */
1295   c.next = catchlist;
1296   c.tag = tag;
1297   c.val = Qnil;
1298   c.backlist = backtrace_list;
1299 #if 0 /* FSFmacs */
1300   /* #### */
1301   c.handlerlist = handlerlist;
1302 #endif
1303   c.lisp_eval_depth = lisp_eval_depth;
1304   c.pdlcount = specpdl_depth();
1305 #if 0 /* FSFmacs */
1306   c.poll_suppress_count = async_timer_suppress_count;
1307 #endif
1308   c.gcpro = gcprolist;
1309   catchlist = &c;
1310
1311   /* Call FUNC.  */
1312   if (SETJMP (c.jmp))
1313     {
1314       /* Throw works by a longjmp that comes right here.  */
1315       if (threw) *threw = 1;
1316       return c.val;
1317     }
1318   c.val = (*func) (arg);
1319   if (threw) *threw = 0;
1320   catchlist = c.next;
1321 #ifdef ERROR_CHECK_TYPECHECK
1322   check_error_state_sanity ();
1323 #endif
1324   return c.val;
1325 }
1326
1327
1328 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1329    jump to that CATCH, returning VALUE as the value of that catch.
1330
1331    This is the guts Fthrow and Fsignal; they differ only in the way
1332    they choose the catch tag to throw to.  A catch tag for a
1333    condition-case form has a TAG of Qnil.
1334
1335    Before each catch is discarded, unbind all special bindings and
1336    execute all unwind-protect clauses made above that catch.  Unwind
1337    the handler stack as we go, so that the proper handlers are in
1338    effect for each unwind-protect clause we run.  At the end, restore
1339    some static info saved in CATCH, and longjmp to the location
1340    specified in the
1341
1342    This is used for correct unwinding in Fthrow and Fsignal.  */
1343
1344 static void
1345 unwind_to_catch (struct catchtag *c, Lisp_Object val)
1346 {
1347 #if 0 /* FSFmacs */
1348   /* #### */
1349   REGISTER int last_time;
1350 #endif
1351
1352   /* Unwind the specbind, catch, and handler stacks back to CATCH
1353      Before each catch is discarded, unbind all special bindings
1354      and execute all unwind-protect clauses made above that catch.
1355      At the end, restore some static info saved in CATCH,
1356      and longjmp to the location specified.
1357      */
1358
1359   /* Save the value somewhere it will be GC'ed.
1360      (Can't overwrite tag slot because an unwind-protect may
1361      want to throw to this same tag, which isn't yet invalid.) */
1362   c->val = val;
1363
1364 #if 0 /* FSFmacs */
1365   /* Restore the polling-suppression count.  */
1366   set_poll_suppress_count (catch->poll_suppress_count);
1367 #endif
1368
1369 #if 0 /* FSFmacs */
1370   /* #### FSFmacs has the following loop.  Is it more correct? */
1371   do
1372     {
1373       last_time = catchlist == c;
1374
1375       /* Unwind the specpdl stack, and then restore the proper set of
1376          handlers.  */
1377       unbind_to (catchlist->pdlcount, Qnil);
1378       handlerlist = catchlist->handlerlist;
1379       catchlist = catchlist->next;
1380 #ifdef ERROR_CHECK_TYPECHECK
1381       check_error_state_sanity ();
1382 #endif
1383     }
1384   while (! last_time);
1385 #else /* Actual XEmacs code */
1386   /* Unwind the specpdl stack */
1387   unbind_to (c->pdlcount, Qnil);
1388   catchlist = c->next;
1389 #ifdef ERROR_CHECK_TYPECHECK
1390   check_error_state_sanity ();
1391 #endif
1392 #endif
1393
1394   gcprolist = c->gcpro;
1395   backtrace_list = c->backlist;
1396   lisp_eval_depth = c->lisp_eval_depth;
1397
1398 #ifdef DEFEND_AGAINST_THROW_RECURSION
1399   throw_level = 0;
1400 #endif
1401   LONGJMP (c->jmp, 1);
1402 }
1403
1404 static DOESNT_RETURN
1405 throw_or_bomb_out (Lisp_Object tag, Lisp_Object val, int bomb_out_p,
1406                    Lisp_Object sig, Lisp_Object data)
1407 {
1408 #ifdef DEFEND_AGAINST_THROW_RECURSION
1409   /* die if we recurse more than is reasonable */
1410   if (++throw_level > 20)
1411     ABORT();
1412 #endif
1413
1414   /* If bomb_out_p is t, this is being called from Fsignal as a
1415      "last resort" when there is no handler for this error and
1416       the debugger couldn't be invoked, so we are throwing to
1417      'top-level.  If this tag doesn't exist (happens during the
1418      initialization stages) we would get in an infinite recursive
1419      Fsignal/Fthrow loop, so instead we bomb out to the
1420      really-early-error-handler.
1421
1422      Note that in fact the only time that the "last resort"
1423      occurs is when there's no catch for 'top-level -- the
1424      'top-level catch and the catch-all error handler are
1425      established at the same time, in initial_command_loop/
1426      top_level_1.
1427
1428      #### Fix this horrifitude!
1429      */
1430
1431   while (1)
1432     {
1433       REGISTER struct catchtag *c;
1434
1435 #if 0 /* FSFmacs */
1436       if (!NILP (tag)) /* #### */
1437 #endif
1438       for (c = catchlist; c; c = c->next)
1439         {
1440           if (EQ (c->tag, tag))
1441             unwind_to_catch (c, val);
1442         }
1443       if (!bomb_out_p)
1444         tag = Fsignal (Qno_catch, list2 (tag, val));
1445       else
1446         call1 (Qreally_early_error_handler, Fcons (sig, data));
1447     }
1448
1449   /* can't happen.  who cares? - (Sun's compiler does) */
1450   /* throw_level--; */
1451   /* getting tired of compilation warnings */
1452   /* return Qnil; */
1453 }
1454
1455 /* See above, where CATCHLIST is defined, for a description of how
1456    Fthrow() works.
1457
1458    Fthrow() is also called by Fsignal(), to do a non-local jump
1459    back to the appropriate condition-case handler after (maybe)
1460    the debugger is entered.  In that case, TAG is the value
1461    of Vcondition_handlers that was in place just after the
1462    condition-case handler was set up.  The car of this will be
1463    some data referring to the handler: Its car will be Qunbound
1464    (thus, this tag can never be generated by Lisp code), and
1465    its CDR will be the HANDLERS argument to condition_case_1()
1466    (either Qerror, Qt, or a list of handlers as in `condition-case').
1467    This works fine because Fthrow() does not care what TAG was
1468    passed to it: it just looks up the catch list for something
1469    that is EQ() to TAG.  When it finds it, it will longjmp()
1470    back to the place that established the catch (in this case,
1471    condition_case_1).  See below for more info.
1472 */
1473
1474 DEFUN ("throw", Fthrow, 2, 2, 0, /*
1475 Throw to the catch for TAG and return VALUE from it.
1476 Both TAG and VALUE are evalled.
1477 */
1478        (tag, value))
1479 {
1480   throw_or_bomb_out (tag, value, 0, Qnil, Qnil); /* Doesn't return */
1481   return Qnil;
1482 }
1483
1484 DEFUN ("unwind-protect", Funwind_protect, 1, UNEVALLED, 0, /*
1485 Do BODYFORM, protecting with UNWINDFORMS.
1486 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).
1487 If BODYFORM completes normally, its value is returned
1488 after executing the UNWINDFORMS.
1489 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1490 */
1491        (args))
1492 {
1493   /* This function can GC */
1494   int speccount = specpdl_depth();
1495
1496   record_unwind_protect (Fprogn, XCDR (args));
1497   return unbind_to (speccount, Feval (XCAR (args)));
1498 }
1499
1500 \f
1501 /************************************************************************/
1502 /*                    Signalling and trapping errors                    */
1503 /************************************************************************/
1504
1505 static Lisp_Object
1506 condition_bind_unwind (Lisp_Object loser)
1507 {
1508   Lisp_Cons *victim;
1509   /* ((handler-fun . handler-args) ... other handlers) */
1510   Lisp_Object tem = XCAR (loser);
1511
1512   while (CONSP (tem))
1513     {
1514       victim = XCONS (tem);
1515       tem = victim->cdr;
1516       free_cons (victim);
1517     }
1518   victim = XCONS (loser);
1519
1520   if (EQ (loser, Vcondition_handlers)) /* may have been rebound to some tail */
1521     Vcondition_handlers = victim->cdr;
1522
1523   free_cons (victim);
1524   return Qnil;
1525 }
1526
1527 static Lisp_Object
1528 condition_case_unwind (Lisp_Object loser)
1529 {
1530   Lisp_Cons *victim;
1531
1532   /* ((<unbound> . clauses) ... other handlers */
1533   victim = XCONS (XCAR (loser));
1534   free_cons (victim);
1535
1536   victim = XCONS (loser);
1537   if (EQ (loser, Vcondition_handlers)) /* may have been rebound to some tail */
1538     Vcondition_handlers = victim->cdr;
1539
1540   free_cons (victim);
1541   return Qnil;
1542 }
1543
1544 /* Split out from condition_case_3 so that primitive C callers
1545    don't have to cons up a lisp handler form to be evaluated. */
1546
1547 /* Call a function BFUN of one argument BARG, trapping errors as
1548    specified by HANDLERS.  If no error occurs that is indicated by
1549    HANDLERS as something to be caught, the return value of this
1550    function is the return value from BFUN.  If such an error does
1551    occur, HFUN is called, and its return value becomes the
1552    return value of condition_case_1().  The second argument passed
1553    to HFUN will always be HARG.  The first argument depends on
1554    HANDLERS:
1555
1556    If HANDLERS is Qt, all errors (this includes QUIT, but not
1557    non-local exits with `throw') cause HFUN to be invoked, and VAL
1558    (the first argument to HFUN) is a cons (SIG . DATA) of the
1559    arguments passed to `signal'.  The debugger is not invoked even if
1560    `debug-on-error' was set.
1561
1562    A HANDLERS value of Qerror is the same as Qt except that the
1563    debugger is invoked if `debug-on-error' was set.
1564
1565    Otherwise, HANDLERS should be a list of lists (CONDITION-NAME BODY ...)
1566    exactly as in `condition-case', and errors will be trapped
1567    as indicated in HANDLERS.  VAL (the first argument to HFUN) will
1568    be a cons whose car is the cons (SIG . DATA) and whose CDR is the
1569    list (BODY ...) from the appropriate slot in HANDLERS.
1570
1571    This function pushes HANDLERS onto the front of Vcondition_handlers
1572    (actually with a Qunbound marker as well -- see Fthrow() above
1573    for why), establishes a catch whose tag is this new value of
1574    Vcondition_handlers, and calls BFUN.  When Fsignal() is called,
1575    it calls Fthrow(), setting TAG to this same new value of
1576    Vcondition_handlers and setting VAL to the same thing that will
1577    be passed to HFUN, as above.  Fthrow() longjmp()s back to the
1578    jump point we just established, and we in turn just call the
1579    HFUN and return its value.
1580
1581    For a real condition-case, HFUN will always be
1582    run_condition_case_handlers() and HARG is the argument VAR
1583    to condition-case.  That function just binds VAR to the cons
1584    (SIG . DATA) that is the CAR of VAL, and calls the handler
1585    (BODY ...) that is the CDR of VAL.  Note that before calling
1586    Fthrow(), Fsignal() restored Vcondition_handlers to the value
1587    it had *before* condition_case_1() was called.  This maintains
1588    consistency (so that the state of things at exit of
1589    condition_case_1() is the same as at entry), and implies
1590    that the handler can signal the same error again (possibly
1591    after processing of its own), without getting in an infinite
1592    loop. */
1593
1594 Lisp_Object
1595 condition_case_1 (Lisp_Object handlers,
1596                   Lisp_Object (*bfun) (Lisp_Object barg),
1597                   Lisp_Object barg,
1598                   Lisp_Object (*hfun) (Lisp_Object val, Lisp_Object harg),
1599                   Lisp_Object harg)
1600 {
1601   int speccount = specpdl_depth();
1602   struct catchtag c;
1603   struct gcpro gcpro1;
1604
1605 #if 0 /* FSFmacs */
1606   c.tag = Qnil;
1607 #else
1608   /* Do consing now so out-of-memory error happens up front */
1609   /* (unbound . stuff) is a special condition-case kludge marker
1610      which is known specially by Fsignal.
1611      This is an abomination, but to fix it would require either
1612      making condition_case cons (a union of the conditions of the clauses)
1613      or changing the byte-compiler output (no thanks). */
1614   c.tag = noseeum_cons (noseeum_cons (Qunbound, handlers),
1615                         Vcondition_handlers);
1616 #endif
1617   c.val = Qnil;
1618   c.backlist = backtrace_list;
1619 #if 0 /* FSFmacs */
1620   /* #### */
1621   c.handlerlist = handlerlist;
1622 #endif
1623   c.lisp_eval_depth = lisp_eval_depth;
1624   c.pdlcount = specpdl_depth();
1625 #if 0 /* FSFmacs */
1626   c.poll_suppress_count = async_timer_suppress_count;
1627 #endif
1628   c.gcpro = gcprolist;
1629   /* #### FSFmacs does the following statement *after* the setjmp(). */
1630   c.next = catchlist;
1631
1632   if (SETJMP (c.jmp))
1633     {
1634       /* throw does ungcpro, etc */
1635       return (*hfun) (c.val, harg);
1636     }
1637
1638   record_unwind_protect (condition_case_unwind, c.tag);
1639
1640   catchlist = &c;
1641 #if 0 /* FSFmacs */
1642   h.handler = handlers;
1643   h.var = Qnil;
1644   h.next = handlerlist;
1645   h.tag = &c;
1646   handlerlist = &h;
1647 #else
1648   Vcondition_handlers = c.tag;
1649 #endif
1650   GCPRO1 (harg);                /* Somebody has to gc-protect */
1651
1652   c.val = ((*bfun) (barg));
1653
1654   /* The following is *not* true: (ben)
1655
1656      ungcpro, restoring catchlist and condition_handlers are actually
1657      redundant since unbind_to now restores them.  But it looks funny not to
1658      have this code here, and it doesn't cost anything, so I'm leaving it.*/
1659   UNGCPRO;
1660   catchlist = c.next;
1661 #ifdef ERROR_CHECK_TYPECHECK
1662   check_error_state_sanity ();
1663 #endif
1664   Vcondition_handlers = XCDR (c.tag);
1665
1666   return unbind_to (speccount, c.val);
1667 }
1668
1669 static Lisp_Object
1670 run_condition_case_handlers (Lisp_Object val, Lisp_Object var)
1671 {
1672   /* This function can GC */
1673 #if 0 /* FSFmacs */
1674   if (!NILP (h.var))
1675     specbind (h.var, c.val);
1676   val = Fprogn (Fcdr (h.chosen_clause));
1677
1678   /* Note that this just undoes the binding of h.var; whoever
1679      longjmp()ed to us unwound the stack to c.pdlcount before
1680      throwing. */
1681   unbind_to (c.pdlcount, Qnil);
1682   return val;
1683 #else
1684   int speccount;
1685
1686   CHECK_TRUE_LIST (val);
1687   if (NILP (var))
1688     return Fprogn (Fcdr (val)); /* tail call */
1689
1690   speccount = specpdl_depth();
1691   specbind (var, Fcar (val));
1692   val = Fprogn (Fcdr (val));
1693   return unbind_to (speccount, val);
1694 #endif
1695 }
1696
1697 /* Here for bytecode to call non-consfully.  This is exactly like
1698    condition-case except that it takes three arguments rather
1699    than a single list of arguments. */
1700 Lisp_Object
1701 condition_case_3 (Lisp_Object bodyform, Lisp_Object var, Lisp_Object handlers)
1702 {
1703   /* This function can GC */
1704   EXTERNAL_LIST_LOOP_2 (handler, handlers)
1705     {
1706       if (NILP (handler))
1707         ;
1708       else if (CONSP (handler))
1709         {
1710           Lisp_Object conditions = XCAR (handler);
1711           /* CONDITIONS must a condition name or a list of condition names */
1712           if (SYMBOLP (conditions))
1713             ;
1714           else
1715             {
1716               EXTERNAL_LIST_LOOP_2 (condition, conditions)
1717                 if (!SYMBOLP (condition))
1718                   goto invalid_condition_handler;
1719             }
1720         }
1721       else
1722         {
1723         invalid_condition_handler:
1724           signal_simple_error ("Invalid condition handler", handler);
1725         }
1726     }
1727
1728   CHECK_SYMBOL (var);
1729
1730   return condition_case_1 (handlers,
1731                            Feval, bodyform,
1732                            run_condition_case_handlers,
1733                            var);
1734 }
1735
1736 DEFUN ("condition-case", Fcondition_case, 2, UNEVALLED, 0, /*
1737 Regain control when an error is signalled.
1738 Usage looks like (condition-case VAR BODYFORM HANDLERS...).
1739 Executes BODYFORM and returns its value if no error happens.
1740 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1741 where the BODY is made of Lisp expressions.
1742
1743 A handler is applicable to an error if CONDITION-NAME is one of the
1744 error's condition names.  If an error happens, the first applicable
1745 handler is run.  As a special case, a CONDITION-NAME of t matches
1746 all errors, even those without the `error' condition name on them
1747 \(e.g. `quit').
1748
1749 The car of a handler may be a list of condition names
1750 instead of a single condition name.
1751
1752 When a handler handles an error,
1753 control returns to the condition-case and the handler BODY... is executed
1754 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).
1755 VAR may be nil; then you do not get access to the signal information.
1756
1757 The value of the last BODY form is returned from the condition-case.
1758 See also the function `signal' for more info.
1759
1760 Note that at the time the condition handler is invoked, the Lisp stack
1761 and the current catches, condition-cases, and bindings have all been
1762 popped back to the state they were in just before the call to
1763 `condition-case'.  This means that resignalling the error from
1764 within the handler will not result in an infinite loop.
1765
1766 If you want to establish an error handler that is called with the
1767 Lisp stack, bindings, etc. as they were when `signal' was called,
1768 rather than when the handler was set, use `call-with-condition-handler'.
1769 */
1770      (args))
1771 {
1772   /* This function can GC */
1773   Lisp_Object var = XCAR (args);
1774   Lisp_Object bodyform = XCAR (XCDR (args));
1775   Lisp_Object handlers = XCDR (XCDR (args));
1776   return condition_case_3 (bodyform, var, handlers);
1777 }
1778
1779 DEFUN ("call-with-condition-handler", Fcall_with_condition_handler, 2, MANY, 0, /*
1780 Regain control when an error is signalled, without popping the stack.
1781 Usage looks like (call-with-condition-handler HANDLER FUNCTION &rest ARGS).
1782 This function is similar to `condition-case', but the handler is invoked
1783 with the same environment (Lisp stack, bindings, catches, condition-cases)
1784 that was current when `signal' was called, rather than when the handler
1785 was established.
1786
1787 HANDLER should be a function of one argument, which is a cons of the args
1788 \(SIG . DATA) that were passed to `signal'.  It is invoked whenever
1789 `signal' is called (this differs from `condition-case', which allows
1790 you to specify which errors are trapped).  If the handler function
1791 returns, `signal' continues as if the handler were never invoked.
1792 \(It continues to look for handlers established earlier than this one,
1793 and invokes the standard error-handler if none is found.)
1794 */
1795        (int nargs, Lisp_Object *args)) /* Note!  Args side-effected! */
1796 {
1797   /* This function can GC */
1798   int speccount = specpdl_depth();
1799   Lisp_Object tem;
1800
1801   /* #### If there were a way to check that args[0] were a function
1802      which accepted one arg, that should be done here ... */
1803
1804   /* (handler-fun . handler-args) */
1805   tem = noseeum_cons (list1 (args[0]), Vcondition_handlers);
1806   record_unwind_protect (condition_bind_unwind, tem);
1807   Vcondition_handlers = tem;
1808
1809   /* Caller should have GC-protected args */
1810   return unbind_to (speccount, Ffuncall (nargs - 1, args + 1));
1811 }
1812
1813 static int
1814 condition_type_p (Lisp_Object type, Lisp_Object conditions)
1815 {
1816   if (EQ (type, Qt))
1817     /* (condition-case c # (t c)) catches -all- signals
1818      *   Use with caution! */
1819     return 1;
1820
1821   if (SYMBOLP (type))
1822     return !NILP (Fmemq (type, conditions));
1823
1824   for (; CONSP (type); type = XCDR (type))
1825     if (!NILP (Fmemq (XCAR (type), conditions)))
1826       return 1;
1827
1828   return 0;
1829 }
1830
1831 static Lisp_Object
1832 return_from_signal (Lisp_Object value)
1833 {
1834 #if 1
1835   /* Most callers are not prepared to handle gc if this
1836      returns.  So, since this feature is not very useful,
1837      take it out.  */
1838   /* Have called debugger; return value to signaller  */
1839   return value;
1840 #else  /* But the reality is that that stinks, because: */
1841   /* GACK!!! Really want some way for debug-on-quit errors
1842      to be continuable!! */
1843   error ("Returning a value from an error is no longer supported");
1844 #endif
1845 }
1846
1847 extern int in_display;
1848
1849 \f
1850 /************************************************************************/
1851 /*               the workhorse error-signaling function                 */
1852 /************************************************************************/
1853
1854 /* #### This function has not been synched with FSF.  It diverges
1855    significantly. */
1856
1857 static Lisp_Object
1858 signal_1 (Lisp_Object sig, Lisp_Object data)
1859 {
1860   /* This function can GC */
1861   struct gcpro gcpro1, gcpro2;
1862   Lisp_Object conditions;
1863   Lisp_Object handlers;
1864   /* signal_call_debugger() could get called more than once
1865      (once when a call-with-condition-handler is about to
1866      be dealt with, and another when a condition-case handler
1867      is about to be invoked).  So make sure the debugger and/or
1868      stack trace aren't done more than once. */
1869   int stack_trace_displayed = 0;
1870   int debugger_entered = 0;
1871   GCPRO2 (conditions, handlers);
1872
1873   if (!initialized)
1874     {
1875       /* who knows how much has been initialized?  Safest bet is
1876          just to bomb out immediately. */
1877       /* let's not use stderr_out() here, because that does a bunch of
1878          things that might not be safe yet. */
1879       fprintf (stderr, "Error before initialization is complete!\n");
1880       ABORT ();
1881     }
1882
1883   if (gc_in_progress || in_display)
1884     /* This is one of many reasons why you can't run lisp code from redisplay.
1885        There is no sensible way to handle errors there. */
1886     ABORT ();
1887
1888   conditions = Fget (sig, Qerror_conditions, Qnil);
1889
1890   for (handlers = Vcondition_handlers;
1891        CONSP (handlers);
1892        handlers = XCDR (handlers))
1893     {
1894       Lisp_Object handler_fun = XCAR (XCAR (handlers));
1895       Lisp_Object handler_data = XCDR (XCAR (handlers));
1896       Lisp_Object outer_handlers = XCDR (handlers);
1897
1898       if (!UNBOUNDP (handler_fun))
1899         {
1900           /* call-with-condition-handler */
1901           Lisp_Object tem;
1902           Lisp_Object all_handlers = Vcondition_handlers;
1903           struct gcpro ngcpro1;
1904           NGCPRO1 (all_handlers);
1905           Vcondition_handlers = outer_handlers;
1906
1907           tem = signal_call_debugger (conditions, sig, data,
1908                                       outer_handlers, 1,
1909                                       &stack_trace_displayed,
1910                                       &debugger_entered);
1911           if (!UNBOUNDP (tem))
1912             RETURN_NUNGCPRO (return_from_signal (tem));
1913
1914           tem = Fcons (sig, data);
1915           if (NILP (handler_data))
1916             tem = call1 (handler_fun, tem);
1917           else
1918             {
1919               /* (This code won't be used (for now?).) */
1920               struct gcpro nngcpro1;
1921               Lisp_Object args[3];
1922               NNGCPRO1 (args[0]);
1923               nngcpro1.nvars = 3;
1924               args[0] = handler_fun;
1925               args[1] = tem;
1926               args[2] = handler_data;
1927               nngcpro1.var = args;
1928               tem = Fapply (3, args);
1929               NNUNGCPRO;
1930             }
1931           NUNGCPRO;
1932 #if 0
1933           if (!EQ (tem, Qsignal))
1934             return return_from_signal (tem);
1935 #endif
1936           /* If handler didn't throw, try another handler */
1937           Vcondition_handlers = all_handlers;
1938         }
1939
1940       /* It's a condition-case handler */
1941
1942       /* t is used by handlers for all conditions, set up by C code.
1943        *  debugger is not called even if debug_on_error */
1944       else if (EQ (handler_data, Qt))
1945         {
1946           UNGCPRO;
1947           return Fthrow (handlers, Fcons (sig, data));
1948         }
1949       /* `error' is used similarly to the way `t' is used, but in
1950          addition it invokes the debugger if debug_on_error.
1951          This is normally used for the outer command-loop error
1952          handler. */
1953       else if (EQ (handler_data, Qerror))
1954         {
1955           Lisp_Object tem = signal_call_debugger (conditions, sig, data,
1956                                                   outer_handlers, 0,
1957                                                   &stack_trace_displayed,
1958                                                   &debugger_entered);
1959
1960           UNGCPRO;
1961           if (!UNBOUNDP (tem))
1962             return return_from_signal (tem);
1963
1964           tem = Fcons (sig, data);
1965           return Fthrow (handlers, tem);
1966         }
1967       else
1968         {
1969           /* handler established by real (Lisp) condition-case */
1970           Lisp_Object h;
1971
1972           for (h = handler_data; CONSP (h); h = Fcdr (h))
1973             {
1974               Lisp_Object clause = Fcar (h);
1975               Lisp_Object tem = Fcar (clause);
1976
1977               if (condition_type_p (tem, conditions))
1978                 {
1979                   tem = signal_call_debugger (conditions, sig, data,
1980                                               outer_handlers, 1,
1981                                               &stack_trace_displayed,
1982                                               &debugger_entered);
1983                   UNGCPRO;
1984                   if (!UNBOUNDP (tem))
1985                     return return_from_signal (tem);
1986
1987                   /* Doesn't return */
1988                   tem = Fcons (Fcons (sig, data), Fcdr (clause));
1989                   return Fthrow (handlers, tem);
1990                 }
1991             }
1992         }
1993     }
1994
1995   /* If no handler is present now, try to run the debugger,
1996      and if that fails, throw to top level.
1997
1998      #### The only time that no handler is present is during
1999      temacs or perhaps very early in XEmacs.  In both cases,
2000      there is no 'top-level catch. (That's why the
2001      "bomb-out" hack was added.)
2002
2003      #### Fix this horrifitude!
2004      */
2005   signal_call_debugger (conditions, sig, data, Qnil, 0,
2006                         &stack_trace_displayed,
2007                         &debugger_entered);
2008   UNGCPRO;
2009   throw_or_bomb_out (Qtop_level, Qt, 1, sig, data); /* Doesn't return */
2010   return Qnil;
2011 }
2012
2013 \f
2014 /****************** Error functions class 1 ******************/
2015
2016 /* Class 1: General functions that signal an error.
2017    These functions take an error type and a list of associated error
2018    data. */
2019
2020 /* The simplest external error function: it would be called
2021    signal_continuable_error() in the terminology below, but it's
2022    Lisp-callable. */
2023
2024 DEFUN ("signal", Fsignal, 2, 2, 0, /*
2025 Signal a continuable error.  Args are ERROR-SYMBOL, and associated DATA.
2026 An error symbol is a symbol defined using `define-error'.
2027 DATA should be a list.  Its elements are printed as part of the error message.
2028 If the signal is handled, DATA is made available to the handler.
2029 See also the function `signal-error', and the functions to handle errors:
2030 `condition-case' and `call-with-condition-handler'.
2031
2032 Note that this function can return, if the debugger is invoked and the
2033 user invokes the "return from signal" option.
2034 */
2035        (error_symbol, data))
2036 {
2037   /* Fsignal() is one of these functions that's called all the time
2038      with newly-created Lisp objects.  We allow this; but we must GC-
2039      protect the objects because all sorts of weird stuff could
2040      happen. */
2041
2042   struct gcpro gcpro1;
2043
2044   GCPRO1 (data);
2045   if (!NILP (Vcurrent_error_state))
2046     {
2047       if (!NILP (Vcurrent_warning_class))
2048         warn_when_safe_lispobj (Vcurrent_warning_class, Qwarning,
2049                                 Fcons (error_symbol, data));
2050       Fthrow (Qunbound_suspended_errors_tag, Qnil);
2051       ABORT (); /* Better not get here! */
2052     }
2053   RETURN_UNGCPRO (signal_1 (error_symbol, data));
2054 }
2055
2056 /* Signal a non-continuable error. */
2057
2058 DOESNT_RETURN
2059 signal_error (Lisp_Object sig, Lisp_Object data)
2060 {
2061   for (;;)
2062     Fsignal (sig, data);
2063 }
2064 #ifdef ERROR_CHECK_TYPECHECK
2065 void
2066 check_error_state_sanity (void)
2067 {
2068   struct catchtag *c;
2069   int found_error_tag = 0;
2070
2071   for (c = catchlist; c; c = c->next)
2072     {
2073       if (EQ (c->tag, Qunbound_suspended_errors_tag))
2074         {
2075           found_error_tag = 1;
2076           break;
2077         }
2078     }
2079
2080   assert (found_error_tag || NILP (Vcurrent_error_state));
2081 }
2082 #endif
2083
2084 static Lisp_Object
2085 restore_current_warning_class (Lisp_Object warning_class)
2086 {
2087   Vcurrent_warning_class = warning_class;
2088   return Qnil;
2089 }
2090
2091 static Lisp_Object
2092 restore_current_error_state (Lisp_Object error_state)
2093 {
2094   Vcurrent_error_state = error_state;
2095   return Qnil;
2096 }
2097
2098 static Lisp_Object
2099 call_with_suspended_errors_1 (Lisp_Object opaque_arg)
2100 {
2101   Lisp_Object val;
2102   Lisp_Object *kludgy_args = (Lisp_Object *) get_opaque_ptr (opaque_arg);
2103   Lisp_Object no_error = kludgy_args[2];
2104   int speccount = specpdl_depth ();
2105
2106   if (!EQ (Vcurrent_error_state, no_error))
2107     {
2108       record_unwind_protect (restore_current_error_state,
2109                              Vcurrent_error_state);
2110       Vcurrent_error_state = no_error;
2111     }
2112   PRIMITIVE_FUNCALL (val, get_opaque_ptr (kludgy_args[0]),
2113                      kludgy_args + 3, XINT (kludgy_args[1]));
2114   return unbind_to (speccount, val);
2115 }
2116
2117 /* Many functions would like to do one of three things if an error
2118    occurs:
2119
2120    (1) signal the error, as usual.
2121    (2) silently fail and return some error value.
2122    (3) do as (2) but issue a warning in the process.
2123
2124    Currently there's lots of stuff that passes an Error_behavior
2125    value and calls maybe_signal_error() and other such functions.
2126    This approach is inherently error-prone and broken.  A much
2127    more robust and easier approach is to use call_with_suspended_errors().
2128    Wrap this around any function in which you might want errors
2129    to not be errors.
2130 */
2131
2132 Lisp_Object
2133 call_with_suspended_errors (lisp_fn_t fun, volatile Lisp_Object retval,
2134                             Lisp_Object class, Error_behavior errb,
2135                             int nargs, ...)
2136 {
2137   va_list vargs;
2138   int speccount;
2139   Lisp_Object kludgy_args[23];
2140   Lisp_Object *args = kludgy_args + 3;
2141   int i;
2142   Lisp_Object no_error;
2143
2144   assert (SYMBOLP (class)); /* sanity-check */
2145   assert (!NILP (class));
2146   assert (nargs >= 0 && nargs < 20);
2147
2148   /* ERROR_ME means don't trap errors. (However, if errors are
2149      already trapped, we leave them trapped.)
2150
2151      Otherwise, we trap errors, and trap warnings if ERROR_ME_WARN.
2152
2153      If ERROR_ME_NOT, it causes no warnings even if warnings
2154      were previously enabled.  However, we never change the
2155      warning class from one to another. */
2156   if (!ERRB_EQ (errb, ERROR_ME))
2157     {
2158       if (ERRB_EQ (errb, ERROR_ME_NOT)) /* person wants no warnings */
2159         class = Qnil;
2160       errb = ERROR_ME_NOT;
2161       no_error = Qt;
2162     }
2163   else
2164     no_error = Qnil;
2165
2166   va_start (vargs, nargs);
2167   for (i = 0; i < nargs; i++)
2168     args[i] = va_arg (vargs, Lisp_Object);
2169   va_end (vargs);
2170
2171   /* If error-checking is not disabled, just call the function.
2172      It's important not to override disabled error-checking with
2173      enabled error-checking. */
2174
2175   if (ERRB_EQ (errb, ERROR_ME))
2176     {
2177       Lisp_Object val;
2178       PRIMITIVE_FUNCALL (val, fun, args, nargs);
2179       return val;
2180     }
2181
2182   speccount = specpdl_depth ();
2183   if (NILP (class) || NILP (Vcurrent_warning_class))
2184     {
2185       /* If we're currently calling for no warnings, then make it so.
2186          If we're currently calling for warnings and we weren't
2187          previously, then set our warning class; otherwise, leave
2188          the existing one alone. */
2189       record_unwind_protect (restore_current_warning_class,
2190                              Vcurrent_warning_class);
2191       Vcurrent_warning_class = class;
2192     }
2193
2194   {
2195     int threw;
2196     Lisp_Object the_retval;
2197     Lisp_Object opaque1 = make_opaque_ptr (kludgy_args);
2198     Lisp_Object opaque2 = make_opaque_ptr ((void *) fun);
2199     struct gcpro gcpro1, gcpro2;
2200
2201     GCPRO2 (opaque1, opaque2);
2202     kludgy_args[0] = opaque2;
2203     kludgy_args[1] = make_int (nargs);
2204     kludgy_args[2] = no_error;
2205     the_retval = internal_catch (Qunbound_suspended_errors_tag,
2206                                  call_with_suspended_errors_1,
2207                                  opaque1, &threw);
2208     free_opaque_ptr (opaque1);
2209     free_opaque_ptr (opaque2);
2210     UNGCPRO;
2211     /* Use the returned value except in non-local exit, when
2212        RETVAL applies. */
2213     /* Some perverse compilers require the perverse cast below.  */
2214     return unbind_to (speccount,
2215                       threw ? *((Lisp_Object*) &(retval)) : the_retval);
2216   }
2217 }
2218
2219 /* Signal a non-continuable error or display a warning or do nothing,
2220    according to ERRB.  CLASS is the class of warning and should
2221    refer to what sort of operation is being done (e.g. Qtoolbar,
2222    Qresource, etc.). */
2223
2224 void
2225 maybe_signal_error (Lisp_Object sig, Lisp_Object data, Lisp_Object class,
2226                     Error_behavior errb)
2227 {
2228   if (ERRB_EQ (errb, ERROR_ME_NOT))
2229     return;
2230   else if (ERRB_EQ (errb, ERROR_ME_WARN))
2231     warn_when_safe_lispobj (class, Qwarning, Fcons (sig, data));
2232   else
2233     for (;;)
2234       Fsignal (sig, data);
2235 }
2236
2237 /* Signal a continuable error or display a warning or do nothing,
2238    according to ERRB. */
2239
2240 Lisp_Object
2241 maybe_signal_continuable_error (Lisp_Object sig, Lisp_Object data,
2242                                 Lisp_Object class, Error_behavior errb)
2243 {
2244   if (ERRB_EQ (errb, ERROR_ME_NOT))
2245     return Qnil;
2246   else if (ERRB_EQ (errb, ERROR_ME_WARN))
2247     {
2248       warn_when_safe_lispobj (class, Qwarning, Fcons (sig, data));
2249       return Qnil;
2250     }
2251   else
2252     return Fsignal (sig, data);
2253 }
2254
2255 \f
2256 /****************** Error functions class 2 ******************/
2257
2258 /* Class 2: Printf-like functions that signal an error.
2259    These functions signal an error of a specified type, whose data
2260    is a single string, created using the arguments. */
2261
2262 /* dump an error message; called like printf */
2263
2264 DOESNT_RETURN
2265 type_error (Lisp_Object type, const char *fmt, ...)
2266 {
2267   Lisp_Object obj;
2268   va_list args;
2269
2270   va_start (args, fmt);
2271   obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2272                                 args);
2273   va_end (args);
2274
2275   /* Fsignal GC-protects its args */
2276   signal_error (type, list1 (obj));
2277 }
2278
2279 void
2280 maybe_type_error (Lisp_Object type, Lisp_Object class, Error_behavior errb,
2281                   const char *fmt, ...)
2282 {
2283   Lisp_Object obj;
2284   va_list args;
2285
2286   /* Optimization: */
2287   if (ERRB_EQ (errb, ERROR_ME_NOT))
2288     return;
2289
2290   va_start (args, fmt);
2291   obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2292                                 args);
2293   va_end (args);
2294
2295   /* Fsignal GC-protects its args */
2296   maybe_signal_error (type, list1 (obj), class, errb);
2297 }
2298
2299 Lisp_Object
2300 continuable_type_error (Lisp_Object type, const char *fmt, ...)
2301 {
2302   Lisp_Object obj;
2303   va_list args;
2304
2305   va_start (args, fmt);
2306   obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2307                                 args);
2308   va_end (args);
2309
2310   /* Fsignal GC-protects its args */
2311   return Fsignal (type, list1 (obj));
2312 }
2313
2314 Lisp_Object
2315 maybe_continuable_type_error (Lisp_Object type, Lisp_Object class,
2316                               Error_behavior errb, const char *fmt, ...)
2317 {
2318   Lisp_Object obj;
2319   va_list args;
2320
2321   /* Optimization: */
2322   if (ERRB_EQ (errb, ERROR_ME_NOT))
2323     return Qnil;
2324
2325   va_start (args, fmt);
2326   obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2327                                 args);
2328   va_end (args);
2329
2330   /* Fsignal GC-protects its args */
2331   return maybe_signal_continuable_error (type, list1 (obj), class, errb);
2332 }
2333
2334 \f
2335 /****************** Error functions class 3 ******************/
2336
2337 /* Class 3: Signal an error with a string and an associated object.
2338    These functions signal an error of a specified type, whose data
2339    is two objects, a string and a related Lisp object (usually the object
2340    where the error is occurring). */
2341
2342 DOESNT_RETURN
2343 signal_type_error (Lisp_Object type, const char *reason, Lisp_Object frob)
2344 {
2345   if (UNBOUNDP (frob))
2346     signal_error (type, list1 (build_translated_string (reason)));
2347   else
2348     signal_error (type, list2 (build_translated_string (reason), frob));
2349 }
2350
2351 void
2352 maybe_signal_type_error (Lisp_Object type, const char *reason,
2353                          Lisp_Object frob, Lisp_Object class,
2354                          Error_behavior errb)
2355 {
2356   /* Optimization: */
2357   if (ERRB_EQ (errb, ERROR_ME_NOT))
2358     return;
2359   maybe_signal_error (type, list2 (build_translated_string (reason), frob),
2360                                      class, errb);
2361 }
2362
2363 Lisp_Object
2364 signal_type_continuable_error (Lisp_Object type, const char *reason,
2365                                Lisp_Object frob)
2366 {
2367   return Fsignal (type, list2 (build_translated_string (reason), frob));
2368 }
2369
2370 Lisp_Object
2371 maybe_signal_type_continuable_error (Lisp_Object type, const char *reason,
2372                                      Lisp_Object frob, Lisp_Object class,
2373                                      Error_behavior errb)
2374 {
2375   /* Optimization: */
2376   if (ERRB_EQ (errb, ERROR_ME_NOT))
2377     return Qnil;
2378   return maybe_signal_continuable_error
2379     (type, list2 (build_translated_string (reason),
2380                     frob), class, errb);
2381 }
2382
2383 \f
2384 /****************** Error functions class 4 ******************/
2385
2386 /* Class 4: Printf-like functions that signal an error.
2387    These functions signal an error of a specified type, whose data
2388    is a two objects, a string (created using the arguments) and a
2389    Lisp object.
2390 */
2391
2392 DOESNT_RETURN
2393 type_error_with_frob (Lisp_Object type, Lisp_Object frob, const char *fmt, ...)
2394 {
2395   Lisp_Object obj;
2396   va_list args;
2397
2398   va_start (args, fmt);
2399   obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2400                                 args);
2401   va_end (args);
2402
2403   /* Fsignal GC-protects its args */
2404   signal_error (type, list2 (obj, frob));
2405 }
2406
2407 void
2408 maybe_type_error_with_frob (Lisp_Object type, Lisp_Object frob,
2409                             Lisp_Object class, Error_behavior errb,
2410                             const char *fmt, ...)
2411 {
2412   Lisp_Object obj;
2413   va_list args;
2414
2415   /* Optimization: */
2416   if (ERRB_EQ (errb, ERROR_ME_NOT))
2417     return;
2418
2419   va_start (args, fmt);
2420   obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2421                                 args);
2422   va_end (args);
2423
2424   /* Fsignal GC-protects its args */
2425   maybe_signal_error (type, list2 (obj, frob), class, errb);
2426 }
2427
2428 Lisp_Object
2429 continuable_type_error_with_frob (Lisp_Object type, Lisp_Object frob,
2430                                   const char *fmt, ...)
2431 {
2432   Lisp_Object obj;
2433   va_list args;
2434
2435   va_start (args, fmt);
2436   obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2437                                 args);
2438   va_end (args);
2439
2440   /* Fsignal GC-protects its args */
2441   return Fsignal (type, list2 (obj, frob));
2442 }
2443
2444 Lisp_Object
2445 maybe_continuable_type_error_with_frob (Lisp_Object type, Lisp_Object frob,
2446                                         Lisp_Object class, Error_behavior errb,
2447                                         const char *fmt, ...)
2448 {
2449   Lisp_Object obj;
2450   va_list args;
2451
2452   /* Optimization: */
2453   if (ERRB_EQ (errb, ERROR_ME_NOT))
2454     return Qnil;
2455
2456   va_start (args, fmt);
2457   obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2458                                 args);
2459   va_end (args);
2460
2461   /* Fsignal GC-protects its args */
2462   return maybe_signal_continuable_error (type, list2 (obj, frob),
2463                                          class, errb);
2464 }
2465
2466 \f
2467 /****************** Error functions class 5 ******************/
2468
2469 /* Class 5: Signal an error with a string and two associated objects.
2470    These functions signal an error of a specified type, whose data
2471    is three objects, a string and two related Lisp objects. */
2472
2473 DOESNT_RETURN
2474 signal_type_error_2 (Lisp_Object type, const char *reason,
2475                      Lisp_Object frob0, Lisp_Object frob1)
2476 {
2477   signal_error (type, list3 (build_translated_string (reason), frob0,
2478                                frob1));
2479 }
2480
2481 void
2482 maybe_signal_type_error_2 (Lisp_Object type, const char *reason,
2483                            Lisp_Object frob0, Lisp_Object frob1,
2484                            Lisp_Object class, Error_behavior errb)
2485 {
2486   /* Optimization: */
2487   if (ERRB_EQ (errb, ERROR_ME_NOT))
2488     return;
2489   maybe_signal_error (type, list3 (build_translated_string (reason), frob0,
2490                                      frob1), class, errb);
2491 }
2492
2493
2494 Lisp_Object
2495 signal_type_continuable_error_2 (Lisp_Object type, const char *reason,
2496                                  Lisp_Object frob0, Lisp_Object frob1)
2497 {
2498   return Fsignal (type, list3 (build_translated_string (reason), frob0,
2499                                  frob1));
2500 }
2501
2502 Lisp_Object
2503 maybe_signal_type_continuable_error_2 (Lisp_Object type, const char *reason,
2504                                        Lisp_Object frob0, Lisp_Object frob1,
2505                                        Lisp_Object class, Error_behavior errb)
2506 {
2507   /* Optimization: */
2508   if (ERRB_EQ (errb, ERROR_ME_NOT))
2509     return Qnil;
2510   return maybe_signal_continuable_error
2511     (type, list3 (build_translated_string (reason), frob0,
2512                     frob1),
2513      class, errb);
2514 }
2515
2516 \f
2517 /****************** Simple error functions class 2 ******************/
2518
2519 /* Simple class 2: Printf-like functions that signal an error.
2520    These functions signal an error of type Qerror, whose data
2521    is a single string, created using the arguments. */
2522
2523 /* dump an error message; called like printf */
2524
2525 DOESNT_RETURN
2526 error (const char *fmt, ...)
2527 {
2528   Lisp_Object obj;
2529   va_list args;
2530
2531   va_start (args, fmt);
2532   obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2533                                 args);
2534   va_end (args);
2535
2536   /* Fsignal GC-protects its args */
2537   signal_error (Qerror, list1 (obj));
2538 }
2539
2540 void
2541 maybe_error (Lisp_Object class, Error_behavior errb, const char *fmt, ...)
2542 {
2543   Lisp_Object obj;
2544   va_list args;
2545
2546   /* Optimization: */
2547   if (ERRB_EQ (errb, ERROR_ME_NOT))
2548     return;
2549
2550   va_start (args, fmt);
2551   obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2552                                 args);
2553   va_end (args);
2554
2555   /* Fsignal GC-protects its args */
2556   maybe_signal_error (Qerror, list1 (obj), class, errb);
2557 }
2558
2559 Lisp_Object
2560 continuable_error (const char *fmt, ...)
2561 {
2562   Lisp_Object obj;
2563   va_list args;
2564
2565   va_start (args, fmt);
2566   obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2567                                 args);
2568   va_end (args);
2569
2570   /* Fsignal GC-protects its args */
2571   return Fsignal (Qerror, list1 (obj));
2572 }
2573
2574 Lisp_Object
2575 maybe_continuable_error (Lisp_Object class, Error_behavior errb,
2576                          const char *fmt, ...)
2577 {
2578   Lisp_Object obj;
2579   va_list args;
2580
2581   /* Optimization: */
2582   if (ERRB_EQ (errb, ERROR_ME_NOT))
2583     return Qnil;
2584
2585   va_start (args, fmt);
2586   obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2587                                 args);
2588   va_end (args);
2589
2590   /* Fsignal GC-protects its args */
2591   return maybe_signal_continuable_error (Qerror, list1 (obj), class, errb);
2592 }
2593
2594 \f
2595 /****************** Simple error functions class 3 ******************/
2596
2597 /* Simple class 3: Signal an error with a string and an associated object.
2598    These functions signal an error of type Qerror, whose data
2599    is two objects, a string and a related Lisp object (usually the object
2600    where the error is occurring). */
2601
2602 DOESNT_RETURN
2603 signal_simple_error (const char *reason, Lisp_Object frob)
2604 {
2605   signal_error (Qerror, list2 (build_translated_string (reason), frob));
2606 }
2607
2608 void
2609 maybe_signal_simple_error (const char *reason, Lisp_Object frob,
2610                            Lisp_Object class, Error_behavior errb)
2611 {
2612   /* Optimization: */
2613   if (ERRB_EQ (errb, ERROR_ME_NOT))
2614     return;
2615   maybe_signal_error (Qerror, list2 (build_translated_string (reason), frob),
2616                                      class, errb);
2617 }
2618
2619 Lisp_Object
2620 signal_simple_continuable_error (const char *reason, Lisp_Object frob)
2621 {
2622   return Fsignal (Qerror, list2 (build_translated_string (reason), frob));
2623 }
2624
2625 Lisp_Object
2626 maybe_signal_simple_continuable_error (const char *reason, Lisp_Object frob,
2627                                        Lisp_Object class, Error_behavior errb)
2628 {
2629   /* Optimization: */
2630   if (ERRB_EQ (errb, ERROR_ME_NOT))
2631     return Qnil;
2632   return maybe_signal_continuable_error
2633     (Qerror, list2 (build_translated_string (reason),
2634                     frob), class, errb);
2635 }
2636
2637 \f
2638 /****************** Simple error functions class 4 ******************/
2639
2640 /* Simple class 4: Printf-like functions that signal an error.
2641    These functions signal an error of type Qerror, whose data
2642    is a two objects, a string (created using the arguments) and a
2643    Lisp object.
2644 */
2645
2646 DOESNT_RETURN
2647 error_with_frob (Lisp_Object frob, const char *fmt, ...)
2648 {
2649   Lisp_Object obj;
2650   va_list args;
2651
2652   va_start (args, fmt);
2653   obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2654                                 args);
2655   va_end (args);
2656
2657   /* Fsignal GC-protects its args */
2658   signal_error (Qerror, list2 (obj, frob));
2659 }
2660
2661 void
2662 maybe_error_with_frob (Lisp_Object frob, Lisp_Object class,
2663                        Error_behavior errb, const char *fmt, ...)
2664 {
2665   Lisp_Object obj;
2666   va_list args;
2667
2668   /* Optimization: */
2669   if (ERRB_EQ (errb, ERROR_ME_NOT))
2670     return;
2671
2672   va_start (args, fmt);
2673   obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2674                                 args);
2675   va_end (args);
2676
2677   /* Fsignal GC-protects its args */
2678   maybe_signal_error (Qerror, list2 (obj, frob), class, errb);
2679 }
2680
2681 Lisp_Object
2682 continuable_error_with_frob (Lisp_Object frob, const char *fmt, ...)
2683 {
2684   Lisp_Object obj;
2685   va_list args;
2686
2687   va_start (args, fmt);
2688   obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2689                                 args);
2690   va_end (args);
2691
2692   /* Fsignal GC-protects its args */
2693   return Fsignal (Qerror, list2 (obj, frob));
2694 }
2695
2696 Lisp_Object
2697 maybe_continuable_error_with_frob (Lisp_Object frob, Lisp_Object class,
2698                                    Error_behavior errb, const char *fmt, ...)
2699 {
2700   Lisp_Object obj;
2701   va_list args;
2702
2703   /* Optimization: */
2704   if (ERRB_EQ (errb, ERROR_ME_NOT))
2705     return Qnil;
2706
2707   va_start (args, fmt);
2708   obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt), Qnil, -1,
2709                                 args);
2710   va_end (args);
2711
2712   /* Fsignal GC-protects its args */
2713   return maybe_signal_continuable_error (Qerror, list2 (obj, frob),
2714                                          class, errb);
2715 }
2716
2717 \f
2718 /****************** Simple error functions class 5 ******************/
2719
2720 /* Simple class 5: Signal an error with a string and two associated objects.
2721    These functions signal an error of type Qerror, whose data
2722    is three objects, a string and two related Lisp objects. */
2723
2724 DOESNT_RETURN
2725 signal_simple_error_2 (const char *reason,
2726                        Lisp_Object frob0, Lisp_Object frob1)
2727 {
2728   signal_error (Qerror, list3 (build_translated_string (reason), frob0,
2729                                frob1));
2730 }
2731
2732 void
2733 maybe_signal_simple_error_2 (const char *reason, Lisp_Object frob0,
2734                              Lisp_Object frob1, Lisp_Object class,
2735                              Error_behavior errb)
2736 {
2737   /* Optimization: */
2738   if (ERRB_EQ (errb, ERROR_ME_NOT))
2739     return;
2740   maybe_signal_error (Qerror, list3 (build_translated_string (reason), frob0,
2741                                      frob1), class, errb);
2742 }
2743
2744
2745 Lisp_Object
2746 signal_simple_continuable_error_2 (const char *reason, Lisp_Object frob0,
2747                                    Lisp_Object frob1)
2748 {
2749   return Fsignal (Qerror, list3 (build_translated_string (reason), frob0,
2750                                  frob1));
2751 }
2752
2753 Lisp_Object
2754 maybe_signal_simple_continuable_error_2 (const char *reason, Lisp_Object frob0,
2755                                          Lisp_Object frob1, Lisp_Object class,
2756                                          Error_behavior errb)
2757 {
2758   /* Optimization: */
2759   if (ERRB_EQ (errb, ERROR_ME_NOT))
2760     return Qnil;
2761   return maybe_signal_continuable_error
2762     (Qerror, list3 (build_translated_string (reason), frob0,
2763                     frob1),
2764      class, errb);
2765 }
2766
2767 \f
2768 /* This is what the QUIT macro calls to signal a quit */
2769 void
2770 signal_quit (void)
2771 {
2772   /* This function can GC */
2773   if (EQ (Vquit_flag, Qcritical))
2774     debug_on_quit |= 2;         /* set critical bit. */
2775   Vquit_flag = Qnil;
2776   /* note that this is continuable. */
2777   Fsignal (Qquit, Qnil);
2778 }
2779
2780 \f
2781 /* Used in core lisp functions for efficiency */
2782 Lisp_Object
2783 signal_void_function_error (Lisp_Object function)
2784 {
2785   return Fsignal (Qvoid_function, list1 (function));
2786 }
2787
2788 Lisp_Object
2789 signal_invalid_function_error (Lisp_Object function)
2790 {
2791   return Fsignal (Qinvalid_function, list1 (function));
2792 }
2793
2794 Lisp_Object
2795 signal_wrong_number_of_arguments_error (Lisp_Object function, int nargs)
2796 {
2797   return Fsignal (Qwrong_number_of_arguments,
2798                   list2 (function, make_int (nargs)));
2799 }
2800
2801 /* Used in list traversal macros for efficiency. */
2802 DOESNT_RETURN
2803 signal_malformed_list_error (Lisp_Object list)
2804 {
2805   signal_error (Qmalformed_list, list1 (list));
2806 }
2807
2808 DOESNT_RETURN
2809 signal_malformed_property_list_error (Lisp_Object list)
2810 {
2811   signal_error (Qmalformed_property_list, list1 (list));
2812 }
2813
2814 DOESNT_RETURN
2815 signal_circular_list_error (Lisp_Object list)
2816 {
2817   signal_error (Qcircular_list, list1 (list));
2818 }
2819
2820 DOESNT_RETURN
2821 signal_circular_property_list_error (Lisp_Object list)
2822 {
2823   signal_error (Qcircular_property_list, list1 (list));
2824 }
2825
2826 DOESNT_RETURN
2827 syntax_error (const char *reason, Lisp_Object frob)
2828 {
2829   signal_type_error (Qsyntax_error, reason, frob);
2830 }
2831
2832 DOESNT_RETURN
2833 syntax_error_2 (const char *reason, Lisp_Object frob1, Lisp_Object frob2)
2834 {
2835   signal_type_error_2 (Qsyntax_error, reason, frob1, frob2);
2836 }
2837
2838 DOESNT_RETURN
2839 invalid_argument (const char *reason, Lisp_Object frob)
2840 {
2841   signal_type_error (Qinvalid_argument, reason, frob);
2842 }
2843
2844 DOESNT_RETURN
2845 invalid_argument_2 (const char *reason, Lisp_Object frob1, Lisp_Object frob2)
2846 {
2847   signal_type_error_2 (Qinvalid_argument, reason, frob1, frob2);
2848 }
2849
2850 DOESNT_RETURN
2851 invalid_operation (const char *reason, Lisp_Object frob)
2852 {
2853   signal_type_error (Qinvalid_operation, reason, frob);
2854 }
2855
2856 DOESNT_RETURN
2857 invalid_operation_2 (const char *reason, Lisp_Object frob1, Lisp_Object frob2)
2858 {
2859   signal_type_error_2 (Qinvalid_operation, reason, frob1, frob2);
2860 }
2861
2862 DOESNT_RETURN
2863 invalid_change (const char *reason, Lisp_Object frob)
2864 {
2865   signal_type_error (Qinvalid_change, reason, frob);
2866 }
2867
2868 DOESNT_RETURN
2869 invalid_change_2 (const char *reason, Lisp_Object frob1, Lisp_Object frob2)
2870 {
2871   signal_type_error_2 (Qinvalid_change, reason, frob1, frob2);
2872 }
2873
2874 \f
2875 /************************************************************************/
2876 /*                            User commands                             */
2877 /************************************************************************/
2878
2879 DEFUN ("commandp", Fcommandp, 1, 1, 0, /*
2880 Return t if FUNCTION makes provisions for interactive calling.
2881 This means it contains a description for how to read arguments to give it.
2882 The value is nil for an invalid function or a symbol with no function
2883 definition.
2884
2885 Interactively callable functions include
2886
2887 -- strings and vectors (treated as keyboard macros)
2888 -- lambda-expressions that contain a top-level call to `interactive'
2889 -- autoload definitions made by `autoload' with non-nil fourth argument
2890    (i.e. the interactive flag)
2891 -- compiled-function objects with a non-nil `compiled-function-interactive'
2892    value
2893 -- subrs (built-in functions) that are interactively callable
2894
2895 Also, a symbol satisfies `commandp' if its function definition does so.
2896 */
2897        (function))
2898 {
2899   Lisp_Object fun = indirect_function (function, 0);
2900
2901   if (COMPILED_FUNCTIONP (fun))
2902     return XCOMPILED_FUNCTION (fun)->flags.interactivep ? Qt : Qnil;
2903
2904   /* Lists may represent commands.  */
2905   if (CONSP (fun))
2906     {
2907       Lisp_Object funcar = XCAR (fun);
2908       if (EQ (funcar, Qlambda))
2909         return Fassq (Qinteractive, Fcdr (Fcdr (fun)));
2910       if (EQ (funcar, Qautoload))
2911         return Fcar (Fcdr (Fcdr (Fcdr (fun))));
2912       else
2913         return Qnil;
2914     }
2915
2916   /* Emacs primitives are interactive if their DEFUN specifies an
2917      interactive spec.  */
2918   if (SUBRP (fun))
2919     return XSUBR (fun)->prompt ? Qt : Qnil;
2920
2921   /* Strings and vectors are keyboard macros.  */
2922   if (VECTORP (fun) || STRINGP (fun))
2923     return Qt;
2924
2925   /* Everything else (including Qunbound) is not a command.  */
2926   return Qnil;
2927 }
2928
2929 DEFUN ("command-execute", Fcommand_execute, 1, 3, 0, /*
2930 Execute CMD as an editor command.
2931 CMD must be an object that satisfies the `commandp' predicate.
2932 Optional second arg RECORD-FLAG is as in `call-interactively'.
2933 The argument KEYS specifies the value to use instead of (this-command-keys)
2934 when reading the arguments.
2935 */
2936        (cmd, record_flag, keys))
2937 {
2938   /* This function can GC */
2939   Lisp_Object prefixarg;
2940   Lisp_Object final = cmd;
2941   struct backtrace backtrace;
2942   struct console *con = XCONSOLE (Vselected_console);
2943
2944   prefixarg = con->prefix_arg;
2945   con->prefix_arg = Qnil;
2946   Vcurrent_prefix_arg = prefixarg;
2947   debug_on_next_call = 0; /* #### from FSFmacs; correct? */
2948
2949   if (SYMBOLP (cmd) && !NILP (Fget (cmd, Qdisabled, Qnil)))
2950     return run_hook (Vdisabled_command_hook);
2951
2952   for (;;)
2953     {
2954       final = indirect_function (cmd, 1);
2955       if (CONSP (final) && EQ (Fcar (final), Qautoload))
2956         {
2957           /* do_autoload GCPROs both arguments */
2958           do_autoload (final, cmd);
2959         }
2960       else
2961         break;
2962     }
2963
2964   if (CONSP (final) || SUBRP (final) || COMPILED_FUNCTIONP (final))
2965     {
2966       backtrace.function = &Qcall_interactively;
2967       backtrace.args = &cmd;
2968       backtrace.nargs = 1;
2969       backtrace.evalargs = 0;
2970       backtrace.pdlcount = specpdl_depth();
2971       backtrace.debug_on_exit = 0;
2972       PUSH_BACKTRACE (backtrace);
2973
2974       final = Fcall_interactively (cmd, record_flag, keys);
2975
2976       POP_BACKTRACE (backtrace);
2977       return final;
2978     }
2979   else if (STRINGP (final) || VECTORP (final))
2980     {
2981       return Fexecute_kbd_macro (final, prefixarg);
2982     }
2983   else
2984     {
2985       Fsignal (Qwrong_type_argument,
2986                Fcons (Qcommandp,
2987                       (EQ (cmd, final)
2988                        ? list1 (cmd)
2989                        : list2 (cmd, final))));
2990       return Qnil;
2991     }
2992 }
2993
2994 DEFUN ("interactive-p", Finteractive_p, 0, 0, 0, /*
2995 Return t if function in which this appears was called interactively.
2996 This means that the function was called with call-interactively (which
2997 includes being called as the binding of a key)
2998 and input is currently coming from the keyboard (not in keyboard macro).
2999 */
3000        ())
3001 {
3002   REGISTER struct backtrace *btp;
3003   REGISTER Lisp_Object fun;
3004
3005   if (!INTERACTIVE)
3006     return Qnil;
3007
3008   /*  Unless the object was compiled, skip the frame of interactive-p itself
3009       (if interpreted) or the frame of byte-code (if called from a compiled
3010       function).  Note that *btp->function may be a symbol pointing at a
3011       compiled function. */
3012   btp = backtrace_list;
3013
3014 #if 0 /* FSFmacs */
3015
3016   /* #### FSFmacs does the following instead.  I can't figure
3017      out which one is more correct. */
3018   /* If this isn't a byte-compiled function, there may be a frame at
3019      the top for Finteractive_p itself.  If so, skip it.  */
3020   fun = Findirect_function (*btp->function);
3021   if (SUBRP (fun) && XSUBR (fun) == &Sinteractive_p)
3022     btp = btp->next;
3023
3024   /* If we're running an Emacs 18-style byte-compiled function, there
3025      may be a frame for Fbyte_code.  Now, given the strictest
3026      definition, this function isn't really being called
3027      interactively, but because that's the way Emacs 18 always builds
3028      byte-compiled functions, we'll accept it for now.  */
3029   if (EQ (*btp->function, Qbyte_code))
3030     btp = btp->next;
3031
3032   /* If this isn't a byte-compiled function, then we may now be
3033      looking at several frames for special forms.  Skip past them.  */
3034   while (btp &&
3035          btp->nargs == UNEVALLED)
3036     btp = btp->next;
3037
3038 #else
3039
3040   if (! (COMPILED_FUNCTIONP (Findirect_function (*btp->function))))
3041     btp = btp->next;
3042   for (;
3043        btp && (btp->nargs == UNEVALLED
3044                || EQ (*btp->function, Qbyte_code));
3045        btp = btp->next)
3046     {}
3047   /* btp now points at the frame of the innermost function
3048      that DOES eval its args.
3049      If it is a built-in function (such as load or eval-region)
3050      return nil.  */
3051   /* Beats me why this is necessary, but it is */
3052   if (btp && EQ (*btp->function, Qcall_interactively))
3053     return Qt;
3054
3055 #endif
3056
3057   fun = Findirect_function (*btp->function);
3058   if (SUBRP (fun))
3059     return Qnil;
3060   /* btp points to the frame of a Lisp function that called interactive-p.
3061      Return t if that function was called interactively.  */
3062   if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively))
3063     return Qt;
3064   return Qnil;
3065 }
3066
3067 \f
3068 /************************************************************************/
3069 /*                            Autoloading                               */
3070 /************************************************************************/
3071
3072 DEFUN ("autoload", Fautoload, 2, 5, 0, /*
3073 Define FUNCTION to autoload from FILENAME.
3074 FUNCTION is a symbol; FILENAME is a file name string to pass to `load'.
3075 The remaining optional arguments provide additional info about the
3076 real definition.
3077 DOCSTRING is documentation for FUNCTION.
3078 INTERACTIVE, if non-nil, says FUNCTION can be called interactively.
3079 TYPE indicates the type of the object:
3080    nil or omitted says FUNCTION is a function,
3081    `keymap' says FUNCTION is really a keymap, and
3082    `macro' or t says FUNCTION is really a macro.
3083 If FUNCTION already has a non-void function definition that is not an
3084 autoload object, this function does nothing and returns nil.
3085 */
3086        (function, filename, docstring, interactive, type))
3087 {
3088   /* This function can GC */
3089   CHECK_SYMBOL (function);
3090   CHECK_STRING (filename);
3091
3092   /* If function is defined and not as an autoload, don't override */
3093   {
3094     Lisp_Object f = XSYMBOL (function)->function;
3095     if (!UNBOUNDP (f) && !(CONSP (f) && EQ (XCAR (f), Qautoload)))
3096       return Qnil;
3097   }
3098
3099   if (purify_flag)
3100     {
3101       /* Attempt to avoid consing identical (string=) pure strings. */
3102       filename = Fsymbol_name (Fintern (filename, Qnil));
3103     }
3104
3105   return Ffset (function, Fcons (Qautoload, list4 (filename,
3106                                                    docstring,
3107                                                    interactive,
3108                                                    type)));
3109 }
3110
3111 Lisp_Object
3112 un_autoload (Lisp_Object oldqueue)
3113 {
3114   /* This function can GC */
3115   REGISTER Lisp_Object queue, first, second;
3116
3117   /* Queue to unwind is current value of Vautoload_queue.
3118      oldqueue is the shadowed value to leave in Vautoload_queue.  */
3119   queue = Vautoload_queue;
3120   Vautoload_queue = oldqueue;
3121   while (CONSP (queue))
3122     {
3123       first = XCAR (queue);
3124       second = Fcdr (first);
3125       first = Fcar (first);
3126       if (NILP (second))
3127         Vfeatures = first;
3128       else
3129         Ffset (first, second);
3130       queue = Fcdr (queue);
3131     }
3132   return Qnil;
3133 }
3134
3135 void
3136 do_autoload (Lisp_Object fundef,
3137              Lisp_Object funname)
3138 {
3139   /* This function can GC */
3140   int speccount = specpdl_depth();
3141   Lisp_Object fun = funname;
3142   struct gcpro gcpro1, gcpro2, gcpro3;
3143
3144   CHECK_SYMBOL (funname);
3145   GCPRO3 (fun, funname, fundef);
3146
3147   /* Value saved here is to be restored into Vautoload_queue */
3148   record_unwind_protect (un_autoload, Vautoload_queue);
3149   Vautoload_queue = Qt;
3150   call4 (Qload, Fcar (Fcdr (fundef)), Qnil, noninteractive ? Qt : Qnil, Qnil);
3151
3152   {
3153     Lisp_Object queue;
3154
3155     /* Save the old autoloads, in case we ever do an unload. */
3156     for (queue = Vautoload_queue; CONSP (queue); queue = XCDR (queue))
3157       {
3158         Lisp_Object first  = XCAR (queue);
3159         Lisp_Object second = Fcdr (first);
3160
3161         first = Fcar (first);
3162
3163         /* Note: This test is subtle.  The cdr of an autoload-queue entry
3164            may be an atom if the autoload entry was generated by a defalias
3165            or fset. */
3166         if (CONSP (second))
3167           Fput (first, Qautoload, (XCDR (second)));
3168       }
3169   }
3170
3171   /* Once loading finishes, don't undo it.  */
3172   Vautoload_queue = Qt;
3173   unbind_to (speccount, Qnil);
3174
3175   fun = indirect_function (fun, 0);
3176
3177 #if 0 /* FSFmacs */
3178   if (!NILP (Fequal (fun, fundef)))
3179 #else
3180   if (UNBOUNDP (fun)
3181       || (CONSP (fun)
3182           && EQ (XCAR (fun), Qautoload)))
3183 #endif
3184     error ("Autoloading failed to define function %s",
3185            string_data (XSYMBOL (funname)->name));
3186   UNGCPRO;
3187 }
3188
3189 \f
3190 /************************************************************************/
3191 /*                         eval, funcall, apply                         */
3192 /************************************************************************/
3193
3194 static Lisp_Object funcall_lambda (Lisp_Object fun,
3195                                    int nargs, Lisp_Object args[]);
3196 static int in_warnings;
3197
3198 static Lisp_Object
3199 in_warnings_restore (Lisp_Object minimus)
3200 {
3201   in_warnings = 0;
3202   return Qnil;
3203 }
3204
3205 DEFUN ("eval", Feval, 1, 1, 0, /*
3206 Evaluate FORM and return its value.
3207 */
3208        (form))
3209 {
3210   /* This function can GC */
3211   Lisp_Object fun, val, original_fun, original_args;
3212   int nargs;
3213   struct backtrace backtrace;
3214
3215   /* I think this is a pretty safe place to call Lisp code, don't you? */
3216   while (!in_warnings && !NILP (Vpending_warnings))
3217     {
3218       struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
3219       int speccount = specpdl_depth();
3220       Lisp_Object this_warning_cons, this_warning, class, level, messij;
3221
3222       record_unwind_protect (in_warnings_restore, Qnil);
3223       in_warnings = 1;
3224       this_warning_cons = Vpending_warnings;
3225       this_warning = XCAR (this_warning_cons);
3226       /* in case an error occurs in the warn function, at least
3227          it won't happen infinitely */
3228       Vpending_warnings = XCDR (Vpending_warnings);
3229       free_cons (XCONS (this_warning_cons));
3230       class = XCAR (this_warning);
3231       level = XCAR (XCDR (this_warning));
3232       messij = XCAR (XCDR (XCDR (this_warning)));
3233       free_list (this_warning);
3234
3235       if (NILP (Vpending_warnings))
3236         Vpending_warnings_tail = Qnil; /* perhaps not strictly necessary,
3237                                           but safer */
3238
3239       GCPRO4 (form, class, level, messij);
3240       if (!STRINGP (messij))
3241         messij = Fprin1_to_string (messij, Qnil);
3242       call3 (Qdisplay_warning, class, messij, level);
3243       UNGCPRO;
3244       unbind_to (speccount, Qnil);
3245     }
3246
3247   if (!CONSP (form))
3248     {
3249       if (SYMBOLP (form))
3250         return Fsymbol_value (form);
3251       else
3252         return form;
3253     }
3254
3255   QUIT;
3256   if ((consing_since_gc > gc_cons_threshold) || always_gc)
3257     {
3258       struct gcpro gcpro1;
3259       GCPRO1 (form);
3260       garbage_collect_1 ();
3261       UNGCPRO;
3262     }
3263
3264   if (++lisp_eval_depth > max_lisp_eval_depth)
3265     {
3266       if (max_lisp_eval_depth < 100)
3267         max_lisp_eval_depth = 100;
3268       if (lisp_eval_depth > max_lisp_eval_depth)
3269         error ("Lisp nesting exceeds `max-lisp-eval-depth'");
3270     }
3271
3272   /* We guaranteed CONSP (form) above */
3273   original_fun  = XCAR (form);
3274   original_args = XCDR (form);
3275
3276   GET_EXTERNAL_LIST_LENGTH (original_args, nargs);
3277
3278   backtrace.pdlcount = specpdl_depth();
3279   backtrace.function = &original_fun; /* This also protects them from gc */
3280   backtrace.args = &original_args;
3281   backtrace.nargs = UNEVALLED;
3282   backtrace.evalargs = 1;
3283   backtrace.debug_on_exit = 0;
3284   PUSH_BACKTRACE (backtrace);
3285
3286   if (debug_on_next_call)
3287     do_debug_on_call (Qt);
3288
3289   if (profiling_active)
3290     profile_increase_call_count (original_fun);
3291
3292   /* At this point, only original_fun and original_args
3293      have values that will be used below. */
3294  retry:
3295   fun = indirect_function (original_fun, 1);
3296
3297   if (SUBRP (fun))
3298     {
3299       Lisp_Subr *subr = XSUBR (fun);
3300       int max_args = subr->max_args;
3301
3302       if (nargs < subr->min_args)
3303         goto wrong_number_of_arguments;
3304
3305       if (max_args == UNEVALLED) /* Optimize for the common case */
3306         {
3307           backtrace.evalargs = 0;
3308           val = (((Lisp_Object (*) (Lisp_Object)) subr_function (subr))
3309                  (original_args));
3310         }
3311       else if (nargs <= max_args)
3312         {
3313           struct gcpro gcpro1;
3314           Lisp_Object args[SUBR_MAX_ARGS];
3315           REGISTER Lisp_Object *p = args;
3316
3317           GCPRO1 (args[0]);
3318           gcpro1.nvars = 0;
3319
3320           {
3321             LIST_LOOP_2 (arg, original_args)
3322               {
3323                 *p++ = Feval (arg);
3324                 gcpro1.nvars++;
3325               }
3326           }
3327
3328           /* &optional args default to nil. */
3329           while (p - args < max_args)
3330             *p++ = Qnil;
3331
3332           backtrace.args  = args;
3333           backtrace.nargs = nargs;
3334
3335           FUNCALL_SUBR (val, subr, args, max_args);
3336
3337           UNGCPRO;
3338         }
3339       else if (max_args == MANY)
3340         {
3341           /* Pass a vector of evaluated arguments */
3342           struct gcpro gcpro1;
3343           Lisp_Object *args = alloca_array (Lisp_Object, nargs);
3344           REGISTER Lisp_Object *p = args;
3345
3346           GCPRO1 (args[0]);
3347           gcpro1.nvars = 0;
3348
3349           {
3350             LIST_LOOP_2 (arg, original_args)
3351               {
3352                 *p++ = Feval (arg);
3353                 gcpro1.nvars++;
3354               }
3355           }
3356
3357           backtrace.args  = args;
3358           backtrace.nargs = nargs;
3359
3360           val = (((Lisp_Object (*) (int, Lisp_Object *)) subr_function (subr))
3361                  (nargs, args));
3362
3363           UNGCPRO;
3364         }
3365       else
3366         {
3367         wrong_number_of_arguments:
3368           val = signal_wrong_number_of_arguments_error (original_fun, nargs);
3369         }
3370     }
3371   else if (COMPILED_FUNCTIONP (fun))
3372     {
3373       struct gcpro gcpro1;
3374       Lisp_Object *args = alloca_array (Lisp_Object, nargs);
3375       REGISTER Lisp_Object *p = args;
3376
3377       GCPRO1 (args[0]);
3378       gcpro1.nvars = 0;
3379
3380       {
3381         LIST_LOOP_2 (arg, original_args)
3382           {
3383             *p++ = Feval (arg);
3384             gcpro1.nvars++;
3385           }
3386       }
3387
3388       backtrace.args     = args;
3389       backtrace.nargs    = nargs;
3390       backtrace.evalargs = 0;
3391
3392       val = funcall_compiled_function (fun, nargs, args);
3393
3394       /* Do the debug-on-exit now, while args is still GCPROed.  */
3395       if (backtrace.debug_on_exit)
3396         val = do_debug_on_exit (val);
3397       /* Don't do it again when we return to eval.  */
3398       backtrace.debug_on_exit = 0;
3399
3400       UNGCPRO;
3401     }
3402   else if (CONSP (fun))
3403     {
3404       Lisp_Object funcar = XCAR (fun);
3405
3406       if (EQ (funcar, Qautoload))
3407         {
3408           /* do_autoload GCPROs both arguments */
3409           do_autoload (fun, original_fun);
3410           goto retry;
3411         }
3412       else if (EQ (funcar, Qmacro))
3413         {
3414           val = Feval (apply1 (XCDR (fun), original_args));
3415         }
3416       else if (EQ (funcar, Qlambda))
3417         {
3418           struct gcpro gcpro1;
3419           Lisp_Object *args = alloca_array (Lisp_Object, nargs);
3420           REGISTER Lisp_Object *p = args;
3421
3422           GCPRO1 (args[0]);
3423           gcpro1.nvars = 0;
3424
3425           {
3426             LIST_LOOP_2 (arg, original_args)
3427               {
3428                 *p++ = Feval (arg);
3429                 gcpro1.nvars++;
3430               }
3431           }
3432
3433           UNGCPRO;
3434
3435           backtrace.args     = args; /* this also GCPROs `args' */
3436           backtrace.nargs    = nargs;
3437           backtrace.evalargs = 0;
3438
3439           val = funcall_lambda (fun, nargs, args);
3440
3441           /* Do the debug-on-exit now, while args is still GCPROed.  */
3442           if (backtrace.debug_on_exit)
3443             val = do_debug_on_exit (val);
3444           /* Don't do it again when we return to eval.  */
3445           backtrace.debug_on_exit = 0;
3446         }
3447       else
3448         {
3449           goto invalid_function;
3450         }
3451     }
3452   else /* ! (SUBRP (fun) || COMPILED_FUNCTIONP (fun) || CONSP (fun)) */
3453     {
3454     invalid_function:
3455       val = signal_invalid_function_error (fun);
3456     }
3457
3458   lisp_eval_depth--;
3459   if (backtrace.debug_on_exit)
3460     val = do_debug_on_exit (val);
3461   POP_BACKTRACE (backtrace);
3462   return val;
3463 }
3464
3465 \f
3466 /* #### Why is Feval so anal about GCPRO, Ffuncall so cavalier? */
3467 DEFUN ("funcall", Ffuncall, 1, MANY, 0, /*
3468 Call first argument as a function, passing the remaining arguments to it.
3469 Thus, (funcall 'cons 'x 'y) returns (x . y).
3470 */
3471        (int nargs, Lisp_Object *args))
3472 {
3473   /* This function can GC */
3474   Lisp_Object fun;
3475   Lisp_Object val;
3476   struct backtrace backtrace;
3477   int fun_nargs = nargs - 1;
3478   Lisp_Object *fun_args = args + 1;
3479
3480   QUIT;
3481   if ((consing_since_gc > gc_cons_threshold) || always_gc)
3482     /* Callers should gcpro lexpr args */
3483     garbage_collect_1 ();
3484
3485   if (++lisp_eval_depth > max_lisp_eval_depth)
3486     {
3487       if (max_lisp_eval_depth < 100)
3488         max_lisp_eval_depth = 100;
3489       if (lisp_eval_depth > max_lisp_eval_depth)
3490         error ("Lisp nesting exceeds `max-lisp-eval-depth'");
3491     }
3492
3493   backtrace.pdlcount = specpdl_depth();
3494   backtrace.function = &args[0];
3495   backtrace.args  = fun_args;
3496   backtrace.nargs = fun_nargs;
3497   backtrace.evalargs = 0;
3498   backtrace.debug_on_exit = 0;
3499   PUSH_BACKTRACE (backtrace);
3500
3501   if (debug_on_next_call)
3502     do_debug_on_call (Qlambda);
3503
3504  retry:
3505
3506   fun = args[0];
3507
3508   /* It might be useful to place this *after* all the checks.  */
3509   if (profiling_active)
3510     profile_increase_call_count (fun);
3511
3512   /* We could call indirect_function directly, but profiling shows
3513      this is worth optimizing by partially unrolling the loop.  */
3514   if (SYMBOLP (fun))
3515     {
3516       fun = XSYMBOL (fun)->function;
3517       if (SYMBOLP (fun))
3518         {
3519           fun = XSYMBOL (fun)->function;
3520           if (SYMBOLP (fun))
3521             fun = indirect_function (fun, 1);
3522         }
3523     }
3524
3525   if (SUBRP (fun))
3526     {
3527       Lisp_Subr *subr = XSUBR (fun);
3528       int max_args = subr->max_args;
3529       Lisp_Object spacious_args[SUBR_MAX_ARGS];
3530
3531       if (fun_nargs == max_args) /* Optimize for the common case */
3532         {
3533         funcall_subr:
3534           {
3535           /* The "extra" braces placate GCC 2.95.4. */
3536             FUNCALL_SUBR (val, subr, fun_args, max_args);
3537           }
3538         }
3539       else if (fun_nargs < subr->min_args)
3540         {
3541           goto wrong_number_of_arguments;
3542         }
3543       else if (fun_nargs < max_args)
3544         {
3545           Lisp_Object *p = spacious_args;
3546
3547           /* Default optionals to nil */
3548           while (fun_nargs--)
3549             *p++ = *fun_args++;
3550           while (p - spacious_args < max_args)
3551             *p++ = Qnil;
3552
3553           fun_args = spacious_args;
3554           goto funcall_subr;
3555         }
3556       else if (max_args == MANY)
3557         {
3558           val = SUBR_FUNCTION (subr, MANY) (fun_nargs, fun_args);
3559         }
3560       else if (max_args == UNEVALLED) /* Can't funcall a special form */
3561         {
3562           goto invalid_function;
3563         }
3564       else
3565         {
3566         wrong_number_of_arguments:
3567           val = signal_wrong_number_of_arguments_error (fun, fun_nargs);
3568         }
3569     }
3570   else if (COMPILED_FUNCTIONP (fun))
3571     {
3572       val = funcall_compiled_function (fun, fun_nargs, fun_args);
3573     }
3574   else if (CONSP (fun))
3575     {
3576       Lisp_Object funcar = XCAR (fun);
3577
3578       if (EQ (funcar, Qlambda))
3579         {
3580           val = funcall_lambda (fun, fun_nargs, fun_args);
3581         }
3582       else if (EQ (funcar, Qautoload))
3583         {
3584           /* do_autoload GCPROs both arguments */
3585           do_autoload (fun, args[0]);
3586           goto retry;
3587         }
3588       else /* Can't funcall a macro */
3589         {
3590           goto invalid_function;
3591         }
3592     }
3593   else if (UNBOUNDP (fun))
3594     {
3595       val = signal_void_function_error (args[0]);
3596     }
3597   else
3598     {
3599     invalid_function:
3600       val = signal_invalid_function_error (fun);
3601     }
3602
3603   lisp_eval_depth--;
3604   if (backtrace.debug_on_exit)
3605     val = do_debug_on_exit (val);
3606   POP_BACKTRACE (backtrace);
3607   return val;
3608 }
3609
3610 DEFUN ("functionp", Ffunctionp, 1, 1, 0, /*
3611 Return t if OBJECT can be called as a function, else nil.
3612 A function is an object that can be applied to arguments,
3613 using for example `funcall' or `apply'.
3614 */
3615        (object))
3616 {
3617   if (SYMBOLP (object))
3618     object = indirect_function (object, 0);
3619
3620   return
3621     (SUBRP (object) ||
3622      COMPILED_FUNCTIONP (object) ||
3623      (CONSP (object) &&
3624       (EQ (XCAR (object), Qlambda) ||
3625        EQ (XCAR (object), Qautoload))))
3626     ? Qt : Qnil;
3627 }
3628
3629 static Lisp_Object
3630 function_argcount (Lisp_Object function, int function_min_args_p)
3631 {
3632   Lisp_Object orig_function = function;
3633   Lisp_Object arglist;
3634
3635  retry:
3636
3637   if (SYMBOLP (function))
3638     function = indirect_function (function, 1);
3639
3640   if (SUBRP (function))
3641     {
3642       /* Using return with the ?: operator tickles a DEC CC compiler bug. */
3643       if (function_min_args_p)
3644         return Fsubr_min_args (function);
3645       else
3646         return Fsubr_max_args (function);
3647    }
3648   else if (COMPILED_FUNCTIONP (function))
3649     {
3650       arglist = compiled_function_arglist (XCOMPILED_FUNCTION (function));
3651     }
3652   else if (CONSP (function))
3653     {
3654       Lisp_Object funcar = XCAR (function);
3655
3656       if (EQ (funcar, Qmacro))
3657         {
3658           function = XCDR (function);
3659           goto retry;
3660         }
3661       else if (EQ (funcar, Qautoload))
3662         {
3663           /* do_autoload GCPROs both arguments */
3664           do_autoload (function, orig_function);
3665           function = orig_function;
3666           goto retry;
3667         }
3668       else if (EQ (funcar, Qlambda))
3669         {
3670           arglist = Fcar (XCDR (function));
3671         }
3672       else
3673         {
3674           goto invalid_function;
3675         }
3676     }
3677   else
3678     {
3679     invalid_function:
3680       return signal_invalid_function_error (orig_function);
3681     }
3682
3683   {
3684     int argcount = 0;
3685
3686     EXTERNAL_LIST_LOOP_2 (arg, arglist)
3687       {
3688         if (EQ (arg, Qand_optional))
3689           {
3690             if (function_min_args_p)
3691               break;
3692           }
3693         else if (EQ (arg, Qand_rest))
3694           {
3695             if (function_min_args_p)
3696               break;
3697             else
3698               return Qnil;
3699           }
3700         else
3701           {
3702             argcount++;
3703           }
3704       }
3705
3706     return make_int (argcount);
3707   }
3708 }
3709
3710 DEFUN ("function-min-args", Ffunction_min_args, 1, 1, 0, /*
3711 Return the number of arguments a function may be called with.
3712 The function may be any form that can be passed to `funcall',
3713 any special form, or any macro.
3714 */
3715        (function))
3716 {
3717   return function_argcount (function, 1);
3718 }
3719
3720 DEFUN ("function-max-args", Ffunction_max_args, 1, 1, 0, /*
3721 Return the number of arguments a function may be called with.
3722 The function may be any form that can be passed to `funcall',
3723 any special form, or any macro.
3724 If the function takes an arbitrary number of arguments or is
3725 a built-in special form, nil is returned.
3726 */
3727        (function))
3728 {
3729   return function_argcount (function, 0);
3730 }
3731
3732 \f
3733 DEFUN ("apply", Fapply, 2, MANY, 0, /*
3734 Call FUNCTION with the remaining args, using the last arg as a list of args.
3735 Thus, (apply '+ 1 2 '(3 4)) returns 10.
3736 */
3737        (int nargs, Lisp_Object *args))
3738 {
3739   /* This function can GC */
3740   Lisp_Object fun = args[0];
3741   Lisp_Object spread_arg = args [nargs - 1];
3742   int numargs;
3743   int funcall_nargs;
3744
3745   GET_EXTERNAL_LIST_LENGTH (spread_arg, numargs);
3746
3747   if (numargs == 0)
3748     /* (apply foo 0 1 '()) */
3749     return Ffuncall (nargs - 1, args);
3750   else if (numargs == 1)
3751     {
3752       /* (apply foo 0 1 '(2)) */
3753       args [nargs - 1] = XCAR (spread_arg);
3754       return Ffuncall (nargs, args);
3755     }
3756
3757   /* -1 for function, -1 for spread arg */
3758   numargs = nargs - 2 + numargs;
3759   /* +1 for function */
3760   funcall_nargs = 1 + numargs;
3761
3762   if (SYMBOLP (fun))
3763     fun = indirect_function (fun, 0);
3764
3765   if (SUBRP (fun))
3766     {
3767       Lisp_Subr *subr = XSUBR (fun);
3768       int max_args = subr->max_args;
3769
3770       if (numargs < subr->min_args
3771           || (max_args >= 0 && max_args < numargs))
3772         {
3773           /* Let funcall get the error */
3774         }
3775       else if (max_args > numargs)
3776         {
3777           /* Avoid having funcall cons up yet another new vector of arguments
3778              by explicitly supplying nil's for optional values */
3779           funcall_nargs += (max_args - numargs);
3780         }
3781     }
3782   else if (UNBOUNDP (fun))
3783     {
3784       /* Let funcall get the error */
3785       fun = args[0];
3786     }
3787
3788   {
3789     REGISTER int i;
3790     Lisp_Object *funcall_args = alloca_array (Lisp_Object, funcall_nargs);
3791     struct gcpro gcpro1;
3792
3793     GCPRO1 (*funcall_args);
3794     gcpro1.nvars = funcall_nargs;
3795
3796     /* Copy in the unspread args */
3797     memcpy (funcall_args, args, (nargs - 1) * sizeof (Lisp_Object));
3798     /* Spread the last arg we got.  Its first element goes in
3799        the slot that it used to occupy, hence this value of I.  */
3800     for (i = nargs - 1;
3801          !NILP (spread_arg);    /* i < 1 + numargs */
3802          i++, spread_arg = XCDR (spread_arg))
3803       {
3804         funcall_args [i] = XCAR (spread_arg);
3805       }
3806     /* Supply nil for optional args (to subrs) */
3807     for (; i < funcall_nargs; i++)
3808       funcall_args[i] = Qnil;
3809
3810
3811     RETURN_UNGCPRO (Ffuncall (funcall_nargs, funcall_args));
3812   }
3813 }
3814
3815 \f
3816 /* Apply lambda list FUN to the NARGS evaluated arguments in ARGS and
3817    return the result of evaluation. */
3818
3819 static Lisp_Object
3820 funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object args[])
3821 {
3822   /* This function can GC */
3823   Lisp_Object arglist, body, tail;
3824   int speccount = specpdl_depth();
3825   REGISTER int i = 0;
3826
3827   tail = XCDR (fun);
3828
3829   if (!CONSP (tail))
3830     goto invalid_function;
3831
3832   arglist = XCAR (tail);
3833   body    = XCDR (tail);
3834
3835   {
3836     int optional = 0, rest = 0;
3837
3838     EXTERNAL_LIST_LOOP_2 (symbol, arglist)
3839       {
3840         if (!SYMBOLP (symbol))
3841           goto invalid_function;
3842         if (EQ (symbol, Qand_rest))
3843           rest = 1;
3844         else if (EQ (symbol, Qand_optional))
3845           optional = 1;
3846         else if (rest)
3847           {
3848             specbind (symbol, Flist (nargs - i, &args[i]));
3849             i = nargs;
3850           }
3851         else if (i < nargs)
3852           specbind (symbol, args[i++]);
3853         else if (!optional)
3854           goto wrong_number_of_arguments;
3855         else
3856           specbind (symbol, Qnil);
3857       }
3858   }
3859
3860   if (i < nargs)
3861     goto wrong_number_of_arguments;
3862
3863   return unbind_to (speccount, Fprogn (body));
3864
3865  wrong_number_of_arguments:
3866   return signal_wrong_number_of_arguments_error (fun, nargs);
3867
3868  invalid_function:
3869   return signal_invalid_function_error (fun);
3870 }
3871
3872 \f
3873 /************************************************************************/
3874 /*                   Run hook variables in various ways.                */
3875 /************************************************************************/
3876
3877 DEFUN ("run-hooks", Frun_hooks, 1, MANY, 0, /*
3878 Run each hook in HOOKS.  Major mode functions use this.
3879 Each argument should be a symbol, a hook variable.
3880 These symbols are processed in the order specified.
3881 If a hook symbol has a non-nil value, that value may be a function
3882 or a list of functions to be called to run the hook.
3883 If the value is a function, it is called with no arguments.
3884 If it is a list, the elements are called, in order, with no arguments.
3885
3886 To make a hook variable buffer-local, use `make-local-hook',
3887 not `make-local-variable'.
3888 */
3889        (int nargs, Lisp_Object *args))
3890 {
3891   REGISTER int i;
3892
3893   for (i = 0; i < nargs; i++)
3894     run_hook_with_args (1, args + i, RUN_HOOKS_TO_COMPLETION);
3895
3896   return Qnil;
3897 }
3898
3899 DEFUN ("run-hook-with-args", Frun_hook_with_args, 1, MANY, 0, /*
3900 Run HOOK with the specified arguments ARGS.
3901 HOOK should be a symbol, a hook variable.  If HOOK has a non-nil
3902 value, that value may be a function or a list of functions to be
3903 called to run the hook.  If the value is a function, it is called with
3904 the given arguments and its return value is returned.  If it is a list
3905 of functions, those functions are called, in order,
3906 with the given arguments ARGS.
3907 It is best not to depend on the value returned by `run-hook-with-args',
3908 as that may change.
3909
3910 To make a hook variable buffer-local, use `make-local-hook',
3911 not `make-local-variable'.
3912 */
3913        (int nargs, Lisp_Object *args))
3914 {
3915   return run_hook_with_args (nargs, args, RUN_HOOKS_TO_COMPLETION);
3916 }
3917
3918 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success, 1, MANY, 0, /*
3919 Run HOOK with the specified arguments ARGS.
3920 HOOK should be a symbol, a hook variable.  Its value should
3921 be a list of functions.  We call those functions, one by one,
3922 passing arguments ARGS to each of them, until one of them
3923 returns a non-nil value.  Then we return that value.
3924 If all the functions return nil, we return nil.
3925
3926 To make a hook variable buffer-local, use `make-local-hook',
3927 not `make-local-variable'.
3928 */
3929        (int nargs, Lisp_Object *args))
3930 {
3931   return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_SUCCESS);
3932 }
3933
3934 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure, 1, MANY, 0, /*
3935 Run HOOK with the specified arguments ARGS.
3936 HOOK should be a symbol, a hook variable.  Its value should
3937 be a list of functions.  We call those functions, one by one,
3938 passing arguments ARGS to each of them, until one of them
3939 returns nil.  Then we return nil.
3940 If all the functions return non-nil, we return non-nil.
3941
3942 To make a hook variable buffer-local, use `make-local-hook',
3943 not `make-local-variable'.
3944 */
3945        (int nargs, Lisp_Object *args))
3946 {
3947   return run_hook_with_args (nargs, args, RUN_HOOKS_UNTIL_FAILURE);
3948 }
3949
3950 /* ARGS[0] should be a hook symbol.
3951    Call each of the functions in the hook value, passing each of them
3952    as arguments all the rest of ARGS (all NARGS - 1 elements).
3953    COND specifies a condition to test after each call
3954    to decide whether to stop.
3955    The caller (or its caller, etc) must gcpro all of ARGS,
3956    except that it isn't necessary to gcpro ARGS[0].  */
3957
3958 Lisp_Object
3959 run_hook_with_args_in_buffer (struct buffer *buf, int nargs, Lisp_Object *args,
3960                               enum run_hooks_condition cond)
3961 {
3962   Lisp_Object sym, val, ret;
3963
3964   if (!initialized || preparing_for_armageddon)
3965     /* We need to bail out of here pronto. */
3966     return Qnil;
3967
3968   /* Whenever gc_in_progress is true, preparing_for_armageddon
3969      will also be true unless something is really hosed. */
3970   assert (!gc_in_progress);
3971
3972   sym = args[0];
3973   val = symbol_value_in_buffer (sym, make_buffer (buf));
3974   ret = (cond == RUN_HOOKS_UNTIL_FAILURE ? Qt : Qnil);
3975
3976   if (UNBOUNDP (val) || NILP (val))
3977     return ret;
3978   else if (!CONSP (val) || EQ (XCAR (val), Qlambda))
3979     {
3980       args[0] = val;
3981       return Ffuncall (nargs, args);
3982     }
3983   else
3984     {
3985       struct gcpro gcpro1, gcpro2, gcpro3;
3986       Lisp_Object globals = Qnil;
3987       GCPRO3 (sym, val, globals);
3988
3989       for (;
3990            CONSP (val) && ((cond == RUN_HOOKS_TO_COMPLETION)
3991                            || (cond == RUN_HOOKS_UNTIL_SUCCESS ? NILP (ret)
3992                                : !NILP (ret)));
3993            val = XCDR (val))
3994         {
3995           if (EQ (XCAR (val), Qt))
3996             {
3997               /* t indicates this hook has a local binding;
3998                  it means to run the global binding too.  */
3999               globals = Fdefault_value (sym);
4000
4001               if ((! CONSP (globals) || EQ (XCAR (globals), Qlambda)) &&
4002                   ! NILP (globals))
4003                 {
4004                   args[0] = globals;
4005                   ret = Ffuncall (nargs, args);
4006                 }
4007               else
4008                 {
4009                   for (;
4010                        CONSP (globals) && ((cond == RUN_HOOKS_TO_COMPLETION)
4011                                            || (cond == RUN_HOOKS_UNTIL_SUCCESS
4012                                                ? NILP (ret)
4013                                                : !NILP (ret)));
4014                        globals = XCDR (globals))
4015                     {
4016                       args[0] = XCAR (globals);
4017                       /* In a global value, t should not occur.  If it does, we
4018                          must ignore it to avoid an endless loop.  */
4019                       if (!EQ (args[0], Qt))
4020                         ret = Ffuncall (nargs, args);
4021                     }
4022                 }
4023             }
4024           else
4025             {
4026               args[0] = XCAR (val);
4027               ret = Ffuncall (nargs, args);
4028             }
4029         }
4030
4031       UNGCPRO;
4032       return ret;
4033     }
4034 }
4035
4036 Lisp_Object
4037 run_hook_with_args (int nargs, Lisp_Object *args,
4038                     enum run_hooks_condition cond)
4039 {
4040   return run_hook_with_args_in_buffer (current_buffer, nargs, args, cond);
4041 }
4042
4043 #if 0
4044
4045 /* From FSF 19.30, not currently used */
4046
4047 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
4048    present value of that symbol.
4049    Call each element of FUNLIST,
4050    passing each of them the rest of ARGS.
4051    The caller (or its caller, etc) must gcpro all of ARGS,
4052    except that it isn't necessary to gcpro ARGS[0].  */
4053
4054 Lisp_Object
4055 run_hook_list_with_args (Lisp_Object funlist, int nargs, Lisp_Object *args)
4056 {
4057   Lisp_Object sym = args[0];
4058   Lisp_Object val;
4059   struct gcpro gcpro1, gcpro2;
4060
4061   GCPRO2 (sym, val);
4062
4063   for (val = funlist; CONSP (val); val = XCDR (val))
4064     {
4065       if (EQ (XCAR (val), Qt))
4066         {
4067           /* t indicates this hook has a local binding;
4068              it means to run the global binding too.  */
4069           Lisp_Object globals;
4070
4071           for (globals = Fdefault_value (sym);
4072                CONSP (globals);
4073                globals = XCDR (globals))
4074             {
4075               args[0] = XCAR (globals);
4076               /* In a global value, t should not occur.  If it does, we
4077                  must ignore it to avoid an endless loop.  */
4078               if (!EQ (args[0], Qt))
4079                 Ffuncall (nargs, args);
4080             }
4081         }
4082       else
4083         {
4084           args[0] = XCAR (val);
4085           Ffuncall (nargs, args);
4086         }
4087     }
4088   UNGCPRO;
4089   return Qnil;
4090 }
4091
4092 #endif /* 0 */
4093
4094 void
4095 va_run_hook_with_args (Lisp_Object hook_var, int nargs, ...)
4096 {
4097   /* This function can GC */
4098   struct gcpro gcpro1;
4099   int i;
4100   va_list vargs;
4101   Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs);
4102
4103   va_start (vargs, nargs);
4104   funcall_args[0] = hook_var;
4105   for (i = 0; i < nargs; i++)
4106     funcall_args[i + 1] = va_arg (vargs, Lisp_Object);
4107   va_end (vargs);
4108
4109   GCPRO1 (*funcall_args);
4110   gcpro1.nvars = nargs + 1;
4111   run_hook_with_args (nargs + 1, funcall_args, RUN_HOOKS_TO_COMPLETION);
4112   UNGCPRO;
4113 }
4114
4115 void
4116 va_run_hook_with_args_in_buffer (struct buffer *buf, Lisp_Object hook_var,
4117                                  int nargs, ...)
4118 {
4119   /* This function can GC */
4120   struct gcpro gcpro1;
4121   int i;
4122   va_list vargs;
4123   Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs);
4124
4125   va_start (vargs, nargs);
4126   funcall_args[0] = hook_var;
4127   for (i = 0; i < nargs; i++)
4128     funcall_args[i + 1] = va_arg (vargs, Lisp_Object);
4129   va_end (vargs);
4130
4131   GCPRO1 (*funcall_args);
4132   gcpro1.nvars = nargs + 1;
4133   run_hook_with_args_in_buffer (buf, nargs + 1, funcall_args,
4134                                 RUN_HOOKS_TO_COMPLETION);
4135   UNGCPRO;
4136 }
4137
4138 Lisp_Object
4139 run_hook (Lisp_Object hook)
4140 {
4141   Frun_hooks (1, &hook);
4142   return Qnil;
4143 }
4144
4145 \f
4146 /************************************************************************/
4147 /*                  Front-ends to eval, funcall, apply                  */
4148 /************************************************************************/
4149
4150 /* Apply fn to arg */
4151 Lisp_Object
4152 apply1 (Lisp_Object fn, Lisp_Object arg)
4153 {
4154   /* This function can GC */
4155   struct gcpro gcpro1;
4156   Lisp_Object args[2];
4157
4158   if (NILP (arg))
4159     return Ffuncall (1, &fn);
4160   GCPRO1 (args[0]);
4161   gcpro1.nvars = 2;
4162   args[0] = fn;
4163   args[1] = arg;
4164   RETURN_UNGCPRO (Fapply (2, args));
4165 }
4166
4167 /* Call function fn on no arguments */
4168 Lisp_Object
4169 call0 (Lisp_Object fn)
4170 {
4171   /* This function can GC */
4172   struct gcpro gcpro1;
4173
4174   GCPRO1 (fn);
4175   RETURN_UNGCPRO (Ffuncall (1, &fn));
4176 }
4177
4178 /* Call function fn with argument arg0 */
4179 Lisp_Object
4180 call1 (Lisp_Object fn,
4181        Lisp_Object arg0)
4182 {
4183   /* This function can GC */
4184   struct gcpro gcpro1;
4185   Lisp_Object args[2];
4186   args[0] = fn;
4187   args[1] = arg0;
4188   GCPRO1 (args[0]);
4189   gcpro1.nvars = 2;
4190   RETURN_UNGCPRO (Ffuncall (2, args));
4191 }
4192
4193 /* Call function fn with arguments arg0, arg1 */
4194 Lisp_Object
4195 call2 (Lisp_Object fn,
4196        Lisp_Object arg0, Lisp_Object arg1)
4197 {
4198   /* This function can GC */
4199   struct gcpro gcpro1;
4200   Lisp_Object args[3];
4201   args[0] = fn;
4202   args[1] = arg0;
4203   args[2] = arg1;
4204   GCPRO1 (args[0]);
4205   gcpro1.nvars = 3;
4206   RETURN_UNGCPRO (Ffuncall (3, args));
4207 }
4208
4209 /* Call function fn with arguments arg0, arg1, arg2 */
4210 Lisp_Object
4211 call3 (Lisp_Object fn,
4212        Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2)
4213 {
4214   /* This function can GC */
4215   struct gcpro gcpro1;
4216   Lisp_Object args[4];
4217   args[0] = fn;
4218   args[1] = arg0;
4219   args[2] = arg1;
4220   args[3] = arg2;
4221   GCPRO1 (args[0]);
4222   gcpro1.nvars = 4;
4223   RETURN_UNGCPRO (Ffuncall (4, args));
4224 }
4225
4226 /* Call function fn with arguments arg0, arg1, arg2, arg3 */
4227 Lisp_Object
4228 call4 (Lisp_Object fn,
4229        Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4230        Lisp_Object arg3)
4231 {
4232   /* This function can GC */
4233   struct gcpro gcpro1;
4234   Lisp_Object args[5];
4235   args[0] = fn;
4236   args[1] = arg0;
4237   args[2] = arg1;
4238   args[3] = arg2;
4239   args[4] = arg3;
4240   GCPRO1 (args[0]);
4241   gcpro1.nvars = 5;
4242   RETURN_UNGCPRO (Ffuncall (5, args));
4243 }
4244
4245 /* Call function fn with arguments arg0, arg1, arg2, arg3, arg4 */
4246 Lisp_Object
4247 call5 (Lisp_Object fn,
4248        Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4249        Lisp_Object arg3, Lisp_Object arg4)
4250 {
4251   /* This function can GC */
4252   struct gcpro gcpro1;
4253   Lisp_Object args[6];
4254   args[0] = fn;
4255   args[1] = arg0;
4256   args[2] = arg1;
4257   args[3] = arg2;
4258   args[4] = arg3;
4259   args[5] = arg4;
4260   GCPRO1 (args[0]);
4261   gcpro1.nvars = 6;
4262   RETURN_UNGCPRO (Ffuncall (6, args));
4263 }
4264
4265 Lisp_Object
4266 call6 (Lisp_Object fn,
4267        Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4268        Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5)
4269 {
4270   /* This function can GC */
4271   struct gcpro gcpro1;
4272   Lisp_Object args[7];
4273   args[0] = fn;
4274   args[1] = arg0;
4275   args[2] = arg1;
4276   args[3] = arg2;
4277   args[4] = arg3;
4278   args[5] = arg4;
4279   args[6] = arg5;
4280   GCPRO1 (args[0]);
4281   gcpro1.nvars = 7;
4282   RETURN_UNGCPRO (Ffuncall (7, args));
4283 }
4284
4285 Lisp_Object
4286 call7 (Lisp_Object fn,
4287        Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4288        Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5,
4289        Lisp_Object arg6)
4290 {
4291   /* This function can GC */
4292   struct gcpro gcpro1;
4293   Lisp_Object args[8];
4294   args[0] = fn;
4295   args[1] = arg0;
4296   args[2] = arg1;
4297   args[3] = arg2;
4298   args[4] = arg3;
4299   args[5] = arg4;
4300   args[6] = arg5;
4301   args[7] = arg6;
4302   GCPRO1 (args[0]);
4303   gcpro1.nvars = 8;
4304   RETURN_UNGCPRO (Ffuncall (8, args));
4305 }
4306
4307 Lisp_Object
4308 call8 (Lisp_Object fn,
4309        Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4310        Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5,
4311        Lisp_Object arg6, Lisp_Object arg7)
4312 {
4313   /* This function can GC */
4314   struct gcpro gcpro1;
4315   Lisp_Object args[9];
4316   args[0] = fn;
4317   args[1] = arg0;
4318   args[2] = arg1;
4319   args[3] = arg2;
4320   args[4] = arg3;
4321   args[5] = arg4;
4322   args[6] = arg5;
4323   args[7] = arg6;
4324   args[8] = arg7;
4325   GCPRO1 (args[0]);
4326   gcpro1.nvars = 9;
4327   RETURN_UNGCPRO (Ffuncall (9, args));
4328 }
4329
4330 Lisp_Object
4331 call0_in_buffer (struct buffer *buf, Lisp_Object fn)
4332 {
4333   if (current_buffer == buf)
4334     return call0 (fn);
4335   else
4336     {
4337       Lisp_Object val;
4338       int speccount = specpdl_depth();
4339       record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4340       set_buffer_internal (buf);
4341       val = call0 (fn);
4342       unbind_to (speccount, Qnil);
4343       return val;
4344     }
4345 }
4346
4347 Lisp_Object
4348 call1_in_buffer (struct buffer *buf, Lisp_Object fn,
4349                  Lisp_Object arg0)
4350 {
4351   if (current_buffer == buf)
4352     return call1 (fn, arg0);
4353   else
4354     {
4355       Lisp_Object val;
4356       int speccount = specpdl_depth();
4357       record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4358       set_buffer_internal (buf);
4359       val = call1 (fn, arg0);
4360       unbind_to (speccount, Qnil);
4361       return val;
4362     }
4363 }
4364
4365 Lisp_Object
4366 call2_in_buffer (struct buffer *buf, Lisp_Object fn,
4367                  Lisp_Object arg0, Lisp_Object arg1)
4368 {
4369   if (current_buffer == buf)
4370     return call2 (fn, arg0, arg1);
4371   else
4372     {
4373       Lisp_Object val;
4374       int speccount = specpdl_depth();
4375       record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4376       set_buffer_internal (buf);
4377       val = call2 (fn, arg0, arg1);
4378       unbind_to (speccount, Qnil);
4379       return val;
4380     }
4381 }
4382
4383 Lisp_Object
4384 call3_in_buffer (struct buffer *buf, Lisp_Object fn,
4385                  Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2)
4386 {
4387   if (current_buffer == buf)
4388     return call3 (fn, arg0, arg1, arg2);
4389   else
4390     {
4391       Lisp_Object val;
4392       int speccount = specpdl_depth();
4393       record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4394       set_buffer_internal (buf);
4395       val = call3 (fn, arg0, arg1, arg2);
4396       unbind_to (speccount, Qnil);
4397       return val;
4398     }
4399 }
4400
4401 Lisp_Object
4402 call4_in_buffer (struct buffer *buf, Lisp_Object fn,
4403                  Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
4404                  Lisp_Object arg3)
4405 {
4406   if (current_buffer == buf)
4407     return call4 (fn, arg0, arg1, arg2, arg3);
4408   else
4409     {
4410       Lisp_Object val;
4411       int speccount = specpdl_depth();
4412       record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4413       set_buffer_internal (buf);
4414       val = call4 (fn, arg0, arg1, arg2, arg3);
4415       unbind_to (speccount, Qnil);
4416       return val;
4417     }
4418 }
4419
4420 Lisp_Object
4421 eval_in_buffer (struct buffer *buf, Lisp_Object form)
4422 {
4423   if (current_buffer == buf)
4424     return Feval (form);
4425   else
4426     {
4427       Lisp_Object val;
4428       int speccount = specpdl_depth();
4429       record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4430       set_buffer_internal (buf);
4431       val = Feval (form);
4432       unbind_to (speccount, Qnil);
4433       return val;
4434     }
4435 }
4436
4437 \f
4438 /************************************************************************/
4439 /*         Error-catching front-ends to eval, funcall, apply            */
4440 /************************************************************************/
4441
4442 /* Call function fn on no arguments, with condition handler */
4443 Lisp_Object
4444 call0_with_handler (Lisp_Object handler, Lisp_Object fn)
4445 {
4446   /* This function can GC */
4447   struct gcpro gcpro1;
4448   Lisp_Object args[2];
4449   args[0] = handler;
4450   args[1] = fn;
4451   GCPRO1 (args[0]);
4452   gcpro1.nvars = 2;
4453   RETURN_UNGCPRO (Fcall_with_condition_handler (2, args));
4454 }
4455
4456 /* Call function fn with argument arg0, with condition handler */
4457 Lisp_Object
4458 call1_with_handler (Lisp_Object handler, Lisp_Object fn,
4459                     Lisp_Object arg0)
4460 {
4461   /* This function can GC */
4462   struct gcpro gcpro1;
4463   Lisp_Object args[3];
4464   args[0] = handler;
4465   args[1] = fn;
4466   args[2] = arg0;
4467   GCPRO1 (args[0]);
4468   gcpro1.nvars = 3;
4469   RETURN_UNGCPRO (Fcall_with_condition_handler (3, args));
4470 }
4471
4472 \f
4473 /* The following functions provide you with error-trapping versions
4474    of the various front-ends above.  They take an additional
4475    "warning_string" argument; if non-zero, a warning with this
4476    string and the actual error that occurred will be displayed
4477    in the *Warnings* buffer if an error occurs.  In all cases,
4478    QUIT is inhibited while these functions are running, and if
4479    an error occurs, Qunbound is returned instead of the normal
4480    return value.
4481    */
4482
4483 /* #### This stuff needs to catch throws as well.  We need to
4484    improve internal_catch() so it can take a "catch anything"
4485    argument similar to Qt or Qerror for condition_case_1(). */
4486
4487 static Lisp_Object
4488 caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg)
4489 {
4490   if (!NILP (errordata))
4491     {
4492       Lisp_Object args[2];
4493
4494       if (!NILP (arg))
4495         {
4496           char *str = (char *) get_opaque_ptr (arg);
4497           args[0] = build_string (str);
4498         }
4499       else
4500         args[0] = build_string ("error");
4501       /* #### This should call
4502          (with-output-to-string (display-error errordata))
4503          but that stuff is all in Lisp currently. */
4504       args[1] = errordata;
4505       warn_when_safe_lispobj
4506         (Qerror, Qwarning,
4507          emacs_doprnt_string_lisp ((const Bufbyte *) "%s: %s",
4508                                    Qnil, -1, 2, args));
4509     }
4510   return Qunbound;
4511 }
4512
4513 static Lisp_Object
4514 allow_quit_caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg)
4515 {
4516   if (CONSP (errordata) && EQ (XCAR (errordata), Qquit))
4517     return Fsignal (Qquit, XCDR (errordata));
4518   return caught_a_squirmer (errordata, arg);
4519 }
4520
4521 static Lisp_Object
4522 safe_run_hook_caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg)
4523 {
4524   Lisp_Object hook = Fcar (arg);
4525   arg = Fcdr (arg);
4526   /* Clear out the hook. */
4527   Fset (hook, Qnil);
4528   return caught_a_squirmer (errordata, arg);
4529 }
4530
4531 static Lisp_Object
4532 allow_quit_safe_run_hook_caught_a_squirmer (Lisp_Object errordata,
4533                                             Lisp_Object arg)
4534 {
4535   Lisp_Object hook = Fcar (arg);
4536   arg = Fcdr (arg);
4537   if (!CONSP (errordata) || !EQ (XCAR (errordata), Qquit))
4538     /* Clear out the hook. */
4539     Fset (hook, Qnil);
4540   return allow_quit_caught_a_squirmer (errordata, arg);
4541 }
4542
4543 static Lisp_Object
4544 catch_them_squirmers_eval_in_buffer (Lisp_Object cons)
4545 {
4546   return eval_in_buffer (XBUFFER (XCAR (cons)), XCDR (cons));
4547 }
4548
4549 Lisp_Object
4550 eval_in_buffer_trapping_errors (const char *warning_string,
4551                                 struct buffer *buf, Lisp_Object form)
4552 {
4553   int speccount = specpdl_depth();
4554   Lisp_Object tem;
4555   Lisp_Object buffer;
4556   Lisp_Object cons;
4557   Lisp_Object opaque;
4558   struct gcpro gcpro1, gcpro2;
4559
4560   XSETBUFFER (buffer, buf);
4561
4562   specbind (Qinhibit_quit, Qt);
4563   /* gc_currently_forbidden = 1; Currently no reason to do this; */
4564
4565   cons = noseeum_cons (buffer, form);
4566   opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
4567   GCPRO2 (cons, opaque);
4568   /* Qerror not Qt, so you can get a backtrace */
4569   tem = condition_case_1 (Qerror,
4570                           catch_them_squirmers_eval_in_buffer, cons,
4571                           caught_a_squirmer, opaque);
4572   free_cons (XCONS (cons));
4573   if (OPAQUE_PTRP (opaque))
4574     free_opaque_ptr (opaque);
4575   UNGCPRO;
4576
4577   /* gc_currently_forbidden = 0; */
4578   return unbind_to (speccount, tem);
4579 }
4580
4581 static Lisp_Object
4582 catch_them_squirmers_run_hook (Lisp_Object hook_symbol)
4583 {
4584   /* This function can GC */
4585   run_hook (hook_symbol);
4586   return Qnil;
4587 }
4588
4589 Lisp_Object
4590 run_hook_trapping_errors (const char *warning_string, Lisp_Object hook_symbol)
4591 {
4592   int speccount;
4593   Lisp_Object tem;
4594   Lisp_Object opaque;
4595   struct gcpro gcpro1;
4596
4597   if (!initialized || preparing_for_armageddon)
4598     return Qnil;
4599   tem = find_symbol_value (hook_symbol);
4600   if (NILP (tem) || UNBOUNDP (tem))
4601     return Qnil;
4602
4603   speccount = specpdl_depth();
4604   specbind (Qinhibit_quit, Qt);
4605
4606   opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
4607   GCPRO1 (opaque);
4608   /* Qerror not Qt, so you can get a backtrace */
4609   tem = condition_case_1 (Qerror,
4610                           catch_them_squirmers_run_hook, hook_symbol,
4611                           caught_a_squirmer, opaque);
4612   if (OPAQUE_PTRP (opaque))
4613     free_opaque_ptr (opaque);
4614   UNGCPRO;
4615
4616   return unbind_to (speccount, tem);
4617 }
4618
4619 /* Same as run_hook_trapping_errors() but also set the hook to nil
4620    if an error occurs. */
4621
4622 Lisp_Object
4623 safe_run_hook_trapping_errors (const char *warning_string,
4624                                Lisp_Object hook_symbol,
4625                                int allow_quit)
4626 {
4627   int speccount = specpdl_depth();
4628   Lisp_Object tem;
4629   Lisp_Object cons = Qnil;
4630   struct gcpro gcpro1;
4631
4632   if (!initialized || preparing_for_armageddon)
4633     return Qnil;
4634   tem = find_symbol_value (hook_symbol);
4635   if (NILP (tem) || UNBOUNDP (tem))
4636     return Qnil;
4637
4638   if (!allow_quit)
4639     specbind (Qinhibit_quit, Qt);
4640
4641   cons = noseeum_cons (hook_symbol,
4642                        warning_string ? make_opaque_ptr ((void *)warning_string)
4643                        : Qnil);
4644   GCPRO1 (cons);
4645   /* Qerror not Qt, so you can get a backtrace */
4646   tem = condition_case_1 (Qerror,
4647                           catch_them_squirmers_run_hook,
4648                           hook_symbol,
4649                           allow_quit ?
4650                           allow_quit_safe_run_hook_caught_a_squirmer :
4651                           safe_run_hook_caught_a_squirmer,
4652                           cons);
4653   if (OPAQUE_PTRP (XCDR (cons)))
4654     free_opaque_ptr (XCDR (cons));
4655   free_cons (XCONS (cons));
4656   UNGCPRO;
4657
4658   return unbind_to (speccount, tem);
4659 }
4660
4661 static Lisp_Object
4662 catch_them_squirmers_call0 (Lisp_Object function)
4663 {
4664   /* This function can GC */
4665   return call0 (function);
4666 }
4667
4668 Lisp_Object
4669 call0_trapping_errors (const char *warning_string, Lisp_Object function)
4670 {
4671   int speccount;
4672   Lisp_Object tem;
4673   Lisp_Object opaque = Qnil;
4674   struct gcpro gcpro1, gcpro2;
4675
4676   if (SYMBOLP (function))
4677     {
4678       tem = XSYMBOL (function)->function;
4679       if (NILP (tem) || UNBOUNDP (tem))
4680         return Qnil;
4681     }
4682
4683   GCPRO2 (opaque, function);
4684   speccount = specpdl_depth();
4685   specbind (Qinhibit_quit, Qt);
4686   /* gc_currently_forbidden = 1; Currently no reason to do this; */
4687
4688   opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
4689   /* Qerror not Qt, so you can get a backtrace */
4690   tem = condition_case_1 (Qerror,
4691                           catch_them_squirmers_call0, function,
4692                           caught_a_squirmer, opaque);
4693   if (OPAQUE_PTRP (opaque))
4694     free_opaque_ptr (opaque);
4695   UNGCPRO;
4696
4697   /* gc_currently_forbidden = 0; */
4698   return unbind_to (speccount, tem);
4699 }
4700
4701 static Lisp_Object
4702 catch_them_squirmers_call1 (Lisp_Object cons)
4703 {
4704   /* This function can GC */
4705   return call1 (XCAR (cons), XCDR (cons));
4706 }
4707
4708 static Lisp_Object
4709 catch_them_squirmers_call2 (Lisp_Object cons)
4710 {
4711   /* This function can GC */
4712   return call2 (XCAR (cons), XCAR (XCDR (cons)), XCAR (XCDR (XCDR (cons))));
4713 }
4714
4715 Lisp_Object
4716 call1_trapping_errors (const char *warning_string, Lisp_Object function,
4717                        Lisp_Object object)
4718 {
4719   int speccount = specpdl_depth();
4720   Lisp_Object tem;
4721   Lisp_Object cons = Qnil;
4722   Lisp_Object opaque = Qnil;
4723   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
4724
4725   if (SYMBOLP (function))
4726     {
4727       tem = XSYMBOL (function)->function;
4728       if (NILP (tem) || UNBOUNDP (tem))
4729         return Qnil;
4730     }
4731
4732   GCPRO4 (cons, opaque, function, object);
4733
4734   specbind (Qinhibit_quit, Qt);
4735   /* gc_currently_forbidden = 1; Currently no reason to do this; */
4736
4737   cons = noseeum_cons (function, object);
4738   opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
4739   /* Qerror not Qt, so you can get a backtrace */
4740   tem = condition_case_1 (Qerror,
4741                           catch_them_squirmers_call1, cons,
4742                           caught_a_squirmer, opaque);
4743   if (OPAQUE_PTRP (opaque))
4744     free_opaque_ptr (opaque);
4745   free_cons (XCONS (cons));
4746   UNGCPRO;
4747
4748   /* gc_currently_forbidden = 0; */
4749   return unbind_to (speccount, tem);
4750 }
4751
4752 Lisp_Object
4753 call2_trapping_errors (const char *warning_string, Lisp_Object function,
4754                        Lisp_Object object1, Lisp_Object object2)
4755 {
4756   int speccount = specpdl_depth();
4757   Lisp_Object tem;
4758   Lisp_Object cons = Qnil;
4759   Lisp_Object opaque = Qnil;
4760   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
4761
4762   if (SYMBOLP (function))
4763     {
4764       tem = XSYMBOL (function)->function;
4765       if (NILP (tem) || UNBOUNDP (tem))
4766         return Qnil;
4767     }
4768
4769   GCPRO5 (cons, opaque, function, object1, object2);
4770   specbind (Qinhibit_quit, Qt);
4771   /* gc_currently_forbidden = 1; Currently no reason to do this; */
4772
4773   cons = list3 (function, object1, object2);
4774   opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
4775   /* Qerror not Qt, so you can get a backtrace */
4776   tem = condition_case_1 (Qerror,
4777                           catch_them_squirmers_call2, cons,
4778                           caught_a_squirmer, opaque);
4779   if (OPAQUE_PTRP (opaque))
4780     free_opaque_ptr (opaque);
4781   free_list (cons);
4782   UNGCPRO;
4783
4784   /* gc_currently_forbidden = 0; */
4785   return unbind_to (speccount, tem);
4786 }
4787
4788 \f
4789 /************************************************************************/
4790 /*                     The special binding stack                        */
4791 /* Most C code should simply use specbind() and unbind_to().            */
4792 /* When performance is critical, use the macros in backtrace.h.         */
4793 /************************************************************************/
4794
4795 #define min_max_specpdl_size 400
4796
4797 void
4798 grow_specpdl (EMACS_INT reserved)
4799 {
4800   EMACS_INT size_needed = specpdl_depth() + reserved;
4801   if (size_needed >= max_specpdl_size)
4802     {
4803       if (max_specpdl_size < min_max_specpdl_size)
4804         max_specpdl_size = min_max_specpdl_size;
4805       if (size_needed >= max_specpdl_size)
4806         {
4807           if (!NILP (Vdebug_on_error) ||
4808               !NILP (Vdebug_on_signal))
4809             /* Leave room for some specpdl in the debugger.  */
4810             max_specpdl_size = size_needed + 100;
4811           continuable_error
4812             ("Variable binding depth exceeds max-specpdl-size");
4813         }
4814     }
4815   while (specpdl_size < size_needed)
4816     {
4817       specpdl_size *= 2;
4818       if (specpdl_size > max_specpdl_size)
4819         specpdl_size = max_specpdl_size;
4820     }
4821   XREALLOC_ARRAY (specpdl, struct specbinding, specpdl_size);
4822   specpdl_ptr = specpdl + specpdl_depth();
4823 }
4824
4825
4826 /* Handle unbinding buffer-local variables */
4827 static Lisp_Object
4828 specbind_unwind_local (Lisp_Object ovalue)
4829 {
4830   Lisp_Object current = Fcurrent_buffer ();
4831   Lisp_Object symbol = specpdl_ptr->symbol;
4832   Lisp_Cons *victim = XCONS (ovalue);
4833   Lisp_Object buf = get_buffer (victim->car, 0);
4834   ovalue = victim->cdr;
4835
4836   free_cons (victim);
4837
4838   if (NILP (buf))
4839     {
4840       /* Deleted buffer -- do nothing */
4841     }
4842   else if (symbol_value_buffer_local_info (symbol, XBUFFER (buf)) == 0)
4843     {
4844       /* Was buffer-local when binding was made, now no longer is.
4845        *  (kill-local-variable can do this.)
4846        * Do nothing in this case.
4847        */
4848     }
4849   else if (EQ (buf, current))
4850     Fset (symbol, ovalue);
4851   else
4852   {
4853     /* Urk! Somebody switched buffers */
4854     struct gcpro gcpro1;
4855     GCPRO1 (current);
4856     Fset_buffer (buf);
4857     Fset (symbol, ovalue);
4858     Fset_buffer (current);
4859     UNGCPRO;
4860   }
4861   return symbol;
4862 }
4863
4864 static Lisp_Object
4865 specbind_unwind_wasnt_local (Lisp_Object buffer)
4866 {
4867   Lisp_Object current = Fcurrent_buffer ();
4868   Lisp_Object symbol = specpdl_ptr->symbol;
4869
4870   buffer = get_buffer (buffer, 0);
4871   if (NILP (buffer))
4872     {
4873       /* Deleted buffer -- do nothing */
4874     }
4875   else if (symbol_value_buffer_local_info (symbol, XBUFFER (buffer)) == 0)
4876     {
4877       /* Was buffer-local when binding was made, now no longer is.
4878        *  (kill-local-variable can do this.)
4879        * Do nothing in this case.
4880        */
4881     }
4882   else if (EQ (buffer, current))
4883     Fkill_local_variable (symbol);
4884   else
4885     {
4886       /* Urk! Somebody switched buffers */
4887       struct gcpro gcpro1;
4888       GCPRO1 (current);
4889       Fset_buffer (buffer);
4890       Fkill_local_variable (symbol);
4891       Fset_buffer (current);
4892       UNGCPRO;
4893     }
4894   return symbol;
4895 }
4896
4897
4898 void
4899 specbind (Lisp_Object symbol, Lisp_Object value)
4900 {
4901   SPECBIND (symbol, value);
4902 }
4903
4904 void
4905 specbind_magic (Lisp_Object symbol, Lisp_Object value)
4906 {
4907   int buffer_local =
4908     symbol_value_buffer_local_info (symbol, current_buffer);
4909
4910   if (buffer_local == 0)
4911     {
4912       specpdl_ptr->old_value = find_symbol_value (symbol);
4913       specpdl_ptr->func = 0;      /* Handled specially by unbind_to */
4914     }
4915   else if (buffer_local > 0)
4916     {
4917       /* Already buffer-local */
4918       specpdl_ptr->old_value = noseeum_cons (Fcurrent_buffer (),
4919                                              find_symbol_value (symbol));
4920       specpdl_ptr->func = specbind_unwind_local;
4921     }
4922   else
4923     {
4924       /* About to become buffer-local */
4925       specpdl_ptr->old_value = Fcurrent_buffer ();
4926       specpdl_ptr->func = specbind_unwind_wasnt_local;
4927     }
4928
4929   specpdl_ptr->symbol = symbol;
4930   specpdl_ptr++;
4931   specpdl_depth_counter++;
4932
4933   Fset (symbol, value);
4934 }
4935
4936 /* Note: As long as the unwind-protect exists, its arg is automatically
4937    GCPRO'd. */
4938
4939 void
4940 record_unwind_protect (Lisp_Object (*function) (Lisp_Object arg),
4941                        Lisp_Object arg)
4942 {
4943   SPECPDL_RESERVE (1);
4944   specpdl_ptr->func = function;
4945   specpdl_ptr->symbol = Qnil;
4946   specpdl_ptr->old_value = arg;
4947   specpdl_ptr++;
4948   specpdl_depth_counter++;
4949 }
4950
4951 extern int check_sigio (void);
4952
4953 /* Unwind the stack till specpdl_depth() == COUNT.
4954    VALUE is not used, except that, purely as a convenience to the
4955    caller, it is protected from garbage-protection. */
4956 Lisp_Object
4957 unbind_to (int count, Lisp_Object value)
4958 {
4959   UNBIND_TO_GCPRO (count, value);
4960   return value;
4961 }
4962
4963 /* Don't call this directly.
4964    Only for use by UNBIND_TO* macros in backtrace.h */
4965 void
4966 unbind_to_hairy (int count)
4967 {
4968   int quitf;
4969
4970   ++specpdl_ptr;
4971   ++specpdl_depth_counter;
4972
4973   check_quit (); /* make Vquit_flag accurate */
4974   quitf = !NILP (Vquit_flag);
4975   Vquit_flag = Qnil;
4976
4977   while (specpdl_depth_counter != count)
4978     {
4979       --specpdl_ptr;
4980       --specpdl_depth_counter;
4981
4982       if (specpdl_ptr->func != 0)
4983         /* An unwind-protect */
4984         (*specpdl_ptr->func) (specpdl_ptr->old_value);
4985       else
4986         {
4987           /* We checked symbol for validity when we specbound it,
4988              so only need to call Fset if symbol has magic value.  */
4989           Lisp_Symbol *sym = XSYMBOL (specpdl_ptr->symbol);
4990           if (!SYMBOL_VALUE_MAGIC_P (sym->value))
4991             sym->value = specpdl_ptr->old_value;
4992           else
4993             Fset (specpdl_ptr->symbol, specpdl_ptr->old_value);
4994         }
4995
4996 #if 0 /* martin */
4997 #ifndef EXCEEDINGLY_QUESTIONABLE_CODE
4998       /* There should never be anything here for us to remove.
4999          If so, it indicates a logic error in Emacs.  Catches
5000          should get removed when a throw or signal occurs, or
5001          when a catch or condition-case exits normally.  But
5002          it's too dangerous to just remove this code. --ben */
5003
5004       /* Furthermore, this code is not in FSFmacs!!!
5005          Braino on mly's part? */
5006       /* If we're unwound past the pdlcount of a catch frame,
5007          that catch can't possibly still be valid. */
5008       while (catchlist && catchlist->pdlcount > specpdl_depth_counter)
5009         {
5010           catchlist = catchlist->next;
5011           /* Don't mess with gcprolist, backtrace_list here */
5012         }
5013 #endif
5014 #endif
5015     }
5016   if (quitf)
5017     Vquit_flag = Qt;
5018 }
5019
5020 \f
5021
5022 /* Get the value of symbol's global binding, even if that binding is
5023    not now dynamically visible.  May return Qunbound or magic values. */
5024
5025 Lisp_Object
5026 top_level_value (Lisp_Object symbol)
5027 {
5028   REGISTER struct specbinding *ptr = specpdl;
5029
5030   CHECK_SYMBOL (symbol);
5031   for (; ptr != specpdl_ptr; ptr++)
5032     {
5033       if (EQ (ptr->symbol, symbol))
5034         return ptr->old_value;
5035     }
5036   return XSYMBOL (symbol)->value;
5037 }
5038
5039 #if 0
5040
5041 Lisp_Object
5042 top_level_set (Lisp_Object symbol, Lisp_Object newval)
5043 {
5044   REGISTER struct specbinding *ptr = specpdl;
5045
5046   CHECK_SYMBOL (symbol);
5047   for (; ptr != specpdl_ptr; ptr++)
5048     {
5049       if (EQ (ptr->symbol, symbol))
5050         {
5051           ptr->old_value = newval;
5052           return newval;
5053         }
5054     }
5055   return Fset (symbol, newval);
5056 }
5057
5058 #endif /* 0 */
5059
5060 \f
5061 /************************************************************************/
5062 /*                            Backtraces                                */
5063 /************************************************************************/
5064
5065 DEFUN ("backtrace-debug", Fbacktrace_debug, 2, 2, 0, /*
5066 Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
5067 The debugger is entered when that frame exits, if the flag is non-nil.
5068 */
5069        (level, flag))
5070 {
5071   REGISTER struct backtrace *backlist = backtrace_list;
5072   REGISTER int i;
5073
5074   CHECK_INT (level);
5075
5076   for (i = 0; backlist && i < XINT (level); i++)
5077     {
5078       backlist = backlist->next;
5079     }
5080
5081   if (backlist)
5082     backlist->debug_on_exit = !NILP (flag);
5083
5084   return flag;
5085 }
5086
5087 static void
5088 backtrace_specials (int speccount, int speclimit, Lisp_Object stream)
5089 {
5090   int printing_bindings = 0;
5091
5092   for (; speccount > speclimit; speccount--)
5093     {
5094       if (specpdl[speccount - 1].func == 0
5095           || specpdl[speccount - 1].func == specbind_unwind_local
5096           || specpdl[speccount - 1].func == specbind_unwind_wasnt_local)
5097         {
5098           write_c_string (((!printing_bindings) ? "  # bind (" : " "),
5099                           stream);
5100           Fprin1 (specpdl[speccount - 1].symbol, stream);
5101           printing_bindings = 1;
5102         }
5103       else
5104         {
5105           if (printing_bindings) write_c_string (")\n", stream);
5106           write_c_string ("  # (unwind-protect ...)\n", stream);
5107           printing_bindings = 0;
5108         }
5109     }
5110   if (printing_bindings) write_c_string (")\n", stream);
5111 }
5112
5113 DEFUN ("backtrace", Fbacktrace, 0, 2, "", /*
5114 Print a trace of Lisp function calls currently active.
5115 Optional arg STREAM specifies the output stream to send the backtrace to,
5116 and defaults to the value of `standard-output'.
5117 Optional second arg DETAILED non-nil means show places where currently
5118 active variable bindings, catches, condition-cases, and
5119 unwind-protects, as well as function calls, were made.
5120 */
5121        (stream, detailed))
5122 {
5123   /* This function can GC */
5124   struct backtrace *backlist = backtrace_list;
5125   struct catchtag *catches = catchlist;
5126   int speccount = specpdl_depth();
5127
5128   int old_nl = print_escape_newlines;
5129   int old_pr = print_readably;
5130   Lisp_Object old_level = Vprint_level;
5131   Lisp_Object oiq = Vinhibit_quit;
5132   struct gcpro gcpro1, gcpro2;
5133
5134   /* We can't allow quits in here because that could cause the values
5135      of print_readably and print_escape_newlines to get screwed up.
5136      Normally we would use a record_unwind_protect but that would
5137      screw up the functioning of this function. */
5138   Vinhibit_quit = Qt;
5139
5140   entering_debugger = 0;
5141
5142   Vprint_level = make_int (3);
5143   print_readably = 0;
5144   print_escape_newlines = 1;
5145
5146   GCPRO2 (stream, old_level);
5147
5148   if (NILP (stream))
5149     stream = Vstandard_output;
5150   if (!noninteractive && (NILP (stream) || EQ (stream, Qt)))
5151     stream = Fselected_frame (Qnil);
5152
5153   for (;;)
5154     {
5155       if (!NILP (detailed) && catches && catches->backlist == backlist)
5156         {
5157           int catchpdl = catches->pdlcount;
5158           if (speccount > catchpdl
5159               && specpdl[catchpdl].func == condition_case_unwind)
5160             /* This is a condition-case catchpoint */
5161             catchpdl = catchpdl + 1;
5162
5163           backtrace_specials (speccount, catchpdl, stream);
5164
5165           speccount = catches->pdlcount;
5166           if (catchpdl == speccount)
5167             {
5168               write_c_string ("  # (catch ", stream);
5169               Fprin1 (catches->tag, stream);
5170               write_c_string (" ...)\n", stream);
5171             }
5172           else
5173             {
5174               write_c_string ("  # (condition-case ... . ", stream);
5175               Fprin1 (Fcdr (Fcar (catches->tag)), stream);
5176               write_c_string (")\n", stream);
5177             }
5178           catches = catches->next;
5179         }
5180       else if (!backlist)
5181         break;
5182       else
5183         {
5184           if (!NILP (detailed) && backlist->pdlcount < speccount)
5185             {
5186               backtrace_specials (speccount, backlist->pdlcount, stream);
5187               speccount = backlist->pdlcount;
5188             }
5189           write_c_string (((backlist->debug_on_exit) ? "* " : "  "),
5190                           stream);
5191           if (backlist->nargs == UNEVALLED)
5192             {
5193               Fprin1 (Fcons (*backlist->function, *backlist->args), stream);
5194               write_c_string ("\n", stream); /* from FSFmacs 19.30 */
5195             }
5196           else
5197             {
5198               Lisp_Object tem = *backlist->function;
5199               Fprin1 (tem, stream); /* This can QUIT */
5200               write_c_string ("(", stream);
5201               if (backlist->nargs == MANY)
5202                 {
5203                   int i;
5204                   Lisp_Object tail = Qnil;
5205                   struct gcpro ngcpro1;
5206
5207                   NGCPRO1 (tail);
5208                   for (tail = *backlist->args, i = 0;
5209                        !NILP (tail);
5210                        tail = Fcdr (tail), i++)
5211                     {
5212                       if (i != 0) write_c_string (" ", stream);
5213                       Fprin1 (Fcar (tail), stream);
5214                     }
5215                   NUNGCPRO;
5216                 }
5217               else
5218                 {
5219                   int i;
5220                   for (i = 0; i < backlist->nargs; i++)
5221                     {
5222                       if (!i && EQ(tem, Qbyte_code)) {
5223                         write_c_string("\"...\"", stream);
5224                         continue;
5225                       }
5226                       if (i != 0) write_c_string (" ", stream);
5227                       Fprin1 (backlist->args[i], stream);
5228                     }
5229                 }
5230               write_c_string (")\n", stream);
5231             }
5232           backlist = backlist->next;
5233         }
5234     }
5235   Vprint_level = old_level;
5236   print_readably = old_pr;
5237   print_escape_newlines = old_nl;
5238   UNGCPRO;
5239   Vinhibit_quit = oiq;
5240   return Qnil;
5241 }
5242
5243
5244 DEFUN ("backtrace-frame", Fbacktrace_frame, 1, 1, 0, /*
5245 Return the function and arguments NFRAMES up from current execution point.
5246 If that frame has not evaluated the arguments yet (or is a special form),
5247 the value is (nil FUNCTION ARG-FORMS...).
5248 If that frame has evaluated its arguments and called its function already,
5249 the value is (t FUNCTION ARG-VALUES...).
5250 A &rest arg is represented as the tail of the list ARG-VALUES.
5251 FUNCTION is whatever was supplied as car of evaluated list,
5252 or a lambda expression for macro calls.
5253 If NFRAMES is more than the number of frames, the value is nil.
5254 */
5255        (nframes))
5256 {
5257   REGISTER struct backtrace *backlist = backtrace_list;
5258   REGISTER int i;
5259   Lisp_Object tem;
5260
5261   CHECK_NATNUM (nframes);
5262
5263   /* Find the frame requested.  */
5264   for (i = XINT (nframes); backlist && (i-- > 0);)
5265     backlist = backlist->next;
5266
5267   if (!backlist)
5268     return Qnil;
5269   if (backlist->nargs == UNEVALLED)
5270     return Fcons (Qnil, Fcons (*backlist->function, *backlist->args));
5271   else
5272     {
5273       if (backlist->nargs == MANY)
5274         tem = *backlist->args;
5275       else
5276         tem = Flist (backlist->nargs, backlist->args);
5277
5278       return Fcons (Qt, Fcons (*backlist->function, tem));
5279     }
5280 }
5281
5282 \f
5283 /************************************************************************/
5284 /*                            Warnings                                  */
5285 /************************************************************************/
5286
5287 void
5288 warn_when_safe_lispobj (Lisp_Object class, Lisp_Object level,
5289                         Lisp_Object obj)
5290 {
5291   obj = list1 (list3 (class, level, obj));
5292   if (NILP (Vpending_warnings))
5293     Vpending_warnings = Vpending_warnings_tail = obj;
5294   else
5295     {
5296       Fsetcdr (Vpending_warnings_tail, obj);
5297       Vpending_warnings_tail = obj;
5298     }
5299 }
5300
5301 /* #### This should probably accept Lisp objects; but then we have
5302    to make sure that Feval() isn't called, since it might not be safe.
5303
5304    An alternative approach is to just pass some non-string type of
5305    Lisp_Object to warn_when_safe_lispobj(); `prin1-to-string' will
5306    automatically be called when it is safe to do so. */
5307
5308 void
5309 warn_when_safe (Lisp_Object class, Lisp_Object level, const char *fmt, ...)
5310 {
5311   Lisp_Object obj;
5312   va_list args;
5313
5314   va_start (args, fmt);
5315   obj = emacs_doprnt_string_va ((const Bufbyte *) GETTEXT (fmt),
5316                                 Qnil, -1, args);
5317   va_end (args);
5318
5319   warn_when_safe_lispobj (class, level, obj);
5320 }
5321
5322
5323
5324 \f
5325 /************************************************************************/
5326 /*                          Initialization                              */
5327 /************************************************************************/
5328
5329 void
5330 syms_of_eval (void)
5331 {
5332   INIT_LRECORD_IMPLEMENTATION (subr);
5333
5334   defsymbol (&Qinhibit_quit, "inhibit-quit");
5335   defsymbol (&Qautoload, "autoload");
5336   defsymbol (&Qdebug_on_error, "debug-on-error");
5337   defsymbol (&Qstack_trace_on_error, "stack-trace-on-error");
5338   defsymbol (&Qdebug_on_signal, "debug-on-signal");
5339   defsymbol (&Qstack_trace_on_signal, "stack-trace-on-signal");
5340   defsymbol (&Qdebugger, "debugger");
5341   defsymbol (&Qmacro, "macro");
5342   defsymbol (&Qand_rest, "&rest");
5343   defsymbol (&Qand_optional, "&optional");
5344   /* Note that the process code also uses Qexit */
5345   defsymbol (&Qexit, "exit");
5346   defsymbol (&Qsetq, "setq");
5347   defsymbol (&Qinteractive, "interactive");
5348   defsymbol (&Qcommandp, "commandp");
5349   defsymbol (&Qdefun, "defun");
5350   defsymbol (&Qprogn, "progn");
5351   defsymbol (&Qvalues, "values");
5352   defsymbol (&Qdisplay_warning, "display-warning");
5353   defsymbol (&Qrun_hooks, "run-hooks");
5354   defsymbol (&Qif, "if");
5355
5356   DEFSUBR (For);
5357   DEFSUBR (Fand);
5358   DEFSUBR (Fif);
5359   DEFSUBR_MACRO (Fwhen);
5360   DEFSUBR_MACRO (Funless);
5361   DEFSUBR (Fcond);
5362   DEFSUBR (Fprogn);
5363   DEFSUBR (Fprog1);
5364   DEFSUBR (Fprog2);
5365   DEFSUBR (Fsetq);
5366   DEFSUBR (Fquote);
5367   DEFSUBR (Ffunction);
5368   DEFSUBR (Fdefun);
5369   DEFSUBR (Fdefmacro);
5370   DEFSUBR (Fdefvar);
5371   DEFSUBR (Fdefconst);
5372   DEFSUBR (Fuser_variable_p);
5373   DEFSUBR (Flet);
5374   DEFSUBR (FletX);
5375   DEFSUBR (Fwhile);
5376   DEFSUBR (Fmacroexpand_internal);
5377   DEFSUBR (Fcatch);
5378   DEFSUBR (Fthrow);
5379   DEFSUBR (Funwind_protect);
5380   DEFSUBR (Fcondition_case);
5381   DEFSUBR (Fcall_with_condition_handler);
5382   DEFSUBR (Fsignal);
5383   DEFSUBR (Finteractive_p);
5384   DEFSUBR (Fcommandp);
5385   DEFSUBR (Fcommand_execute);
5386   DEFSUBR (Fautoload);
5387   DEFSUBR (Feval);
5388   DEFSUBR (Fapply);
5389   DEFSUBR (Ffuncall);
5390   DEFSUBR (Ffunctionp);
5391   DEFSUBR (Ffunction_min_args);
5392   DEFSUBR (Ffunction_max_args);
5393   DEFSUBR (Frun_hooks);
5394   DEFSUBR (Frun_hook_with_args);
5395   DEFSUBR (Frun_hook_with_args_until_success);
5396   DEFSUBR (Frun_hook_with_args_until_failure);
5397   DEFSUBR (Fbacktrace_debug);
5398   DEFSUBR (Fbacktrace);
5399   DEFSUBR (Fbacktrace_frame);
5400 }
5401
5402 void
5403 reinit_eval (void)
5404 {
5405   specpdl_ptr = specpdl;
5406   specpdl_depth_counter = 0;
5407   catchlist = 0;
5408   Vcondition_handlers = Qnil;
5409   backtrace_list = 0;
5410   Vquit_flag = Qnil;
5411   debug_on_next_call = 0;
5412   lisp_eval_depth = 0;
5413   entering_debugger = 0;
5414 }
5415
5416 void
5417 reinit_vars_of_eval (void)
5418 {
5419   preparing_for_armageddon = 0;
5420   in_warnings = 0;
5421   Qunbound_suspended_errors_tag = make_opaque_ptr (&Qunbound_suspended_errors_tag);
5422   staticpro_nodump (&Qunbound_suspended_errors_tag);
5423
5424   specpdl_size = 50;
5425   specpdl = xnew_array (struct specbinding, specpdl_size);
5426   /* XEmacs change: increase these values. */
5427   max_specpdl_size = 3000;
5428   max_lisp_eval_depth = 1000;
5429 #ifdef DEFEND_AGAINST_THROW_RECURSION
5430   throw_level = 0;
5431 #endif
5432 }
5433
5434 void
5435 vars_of_eval (void)
5436 {
5437   reinit_vars_of_eval ();
5438
5439   DEFVAR_INT ("max-specpdl-size", &max_specpdl_size /*
5440 Limit on number of Lisp variable bindings & unwind-protects before error.
5441 */ );
5442
5443   DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth /*
5444 Limit on depth in `eval', `apply' and `funcall' before error.
5445 This limit is to catch infinite recursions for you before they cause
5446 actual stack overflow in C, which would be fatal for Emacs.
5447 You can safely make it considerably larger than its default value,
5448 if that proves inconveniently small.
5449 */ );
5450
5451   DEFVAR_LISP ("quit-flag", &Vquit_flag /*
5452 Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
5453 Typing C-G sets `quit-flag' non-nil, regardless of `inhibit-quit'.
5454 */ );
5455   Vquit_flag = Qnil;
5456
5457   DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit /*
5458 Non-nil inhibits C-g quitting from happening immediately.
5459 Note that `quit-flag' will still be set by typing C-g,
5460 so a quit will be signalled as soon as `inhibit-quit' is nil.
5461 To prevent this happening, set `quit-flag' to nil
5462 before making `inhibit-quit' nil.  The value of `inhibit-quit' is
5463 ignored if a critical quit is requested by typing control-shift-G in
5464 an X frame.
5465 */ );
5466   Vinhibit_quit = Qnil;
5467
5468   DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error /*
5469 *Non-nil means automatically display a backtrace buffer
5470 after any error that is not handled by a `condition-case'.
5471 If the value is a list, an error only means to display a backtrace
5472 if one of its condition symbols appears in the list.
5473 See also variable `stack-trace-on-signal'.
5474 */ );
5475   Vstack_trace_on_error = Qnil;
5476
5477   DEFVAR_LISP ("stack-trace-on-signal", &Vstack_trace_on_signal /*
5478 *Non-nil means automatically display a backtrace buffer
5479 after any error that is signalled, whether or not it is handled by
5480 a `condition-case'.
5481 If the value is a list, an error only means to display a backtrace
5482 if one of its condition symbols appears in the list.
5483 See also variable `stack-trace-on-error'.
5484 */ );
5485   Vstack_trace_on_signal = Qnil;
5486
5487   DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors /*
5488 *List of errors for which the debugger should not be called.
5489 Each element may be a condition-name or a regexp that matches error messages.
5490 If any element applies to a given error, that error skips the debugger
5491 and just returns to top level.
5492 This overrides the variable `debug-on-error'.
5493 It does not apply to errors handled by `condition-case'.
5494 */ );
5495   Vdebug_ignored_errors = Qnil;
5496
5497   DEFVAR_LISP ("debug-on-error", &Vdebug_on_error /*
5498 *Non-nil means enter debugger if an unhandled error is signalled.
5499 The debugger will not be entered if the error is handled by
5500 a `condition-case'.
5501 If the value is a list, an error only means to enter the debugger
5502 if one of its condition symbols appears in the list.
5503 This variable is overridden by `debug-ignored-errors'.
5504 See also variables `debug-on-quit' and `debug-on-signal'.
5505 */ );
5506   Vdebug_on_error = Qnil;
5507
5508   DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal /*
5509 *Non-nil means enter debugger if an error is signalled.
5510 The debugger will be entered whether or not the error is handled by
5511 a `condition-case'.
5512 If the value is a list, an error only means to enter the debugger
5513 if one of its condition symbols appears in the list.
5514 See also variable `debug-on-quit'.
5515 */ );
5516   Vdebug_on_signal = Qnil;
5517
5518   DEFVAR_BOOL ("debug-on-quit", &debug_on_quit /*
5519 *Non-nil means enter debugger if quit is signalled (C-G, for example).
5520 Does not apply if quit is handled by a `condition-case'.  Entering the
5521 debugger can also be achieved at any time (for X11 console) by typing
5522 control-shift-G to signal a critical quit.
5523 */ );
5524   debug_on_quit = 0;
5525
5526   DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call /*
5527 Non-nil means enter debugger before next `eval', `apply' or `funcall'.
5528 */ );
5529
5530   DEFVAR_LISP ("debugger", &Vdebugger /*
5531 Function to call to invoke debugger.
5532 If due to frame exit, args are `exit' and the value being returned;
5533  this function's value will be returned instead of that.
5534 If due to error, args are `error' and a list of the args to `signal'.
5535 If due to `apply' or `funcall' entry, one arg, `lambda'.
5536 If due to `eval' entry, one arg, t.
5537 */ );
5538   Vdebugger = Qnil;
5539
5540   staticpro (&Vpending_warnings);
5541   Vpending_warnings = Qnil;
5542   dump_add_root_object (&Vpending_warnings_tail);
5543   Vpending_warnings_tail = Qnil;
5544
5545   staticpro (&Vautoload_queue);
5546   Vautoload_queue = Qnil;
5547
5548   staticpro (&Vcondition_handlers);
5549
5550   staticpro (&Vcurrent_warning_class);
5551   Vcurrent_warning_class = Qnil;
5552
5553   staticpro (&Vcurrent_error_state);
5554   Vcurrent_error_state = Qnil; /* errors as normal */
5555
5556   reinit_eval ();
5557 }