1 /* Evaluator for GNU Emacs Lisp interpreter.
   2    Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1999, 2000, 2001,
   3                  2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
   4                  Free Software Foundation, Inc.
   5 
   6 This file is part of GNU Emacs.
   7 
   8 GNU Emacs is free software: you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation, either version 3 of the License, or
  11 (at your option) any later version.
  12 
  13 GNU Emacs is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17 
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
  20 
  21 
  22 #include <config.h>
  23 #include <setjmp.h>
  24 #include "lisp.h"
  25 #include "blockinput.h"
  26 #include "commands.h"
  27 #include "keyboard.h"
  28 #include "dispextern.h"
  29 #include "frame.h"              /* For XFRAME.  */
  30 
  31 #if HAVE_X_WINDOWS
  32 #include "xterm.h"
  33 #endif
  34 
  35 /* This definition is duplicated in alloc.c and keyboard.c */
  36 /* Putting it in lisp.h makes cc bomb out! */
  37 
  38 struct backtrace
  39 {
  40   struct backtrace *next;
  41   Lisp_Object *function;
  42   Lisp_Object *args;    /* Points to vector of args. */
  43   int nargs;            /* Length of vector.
  44                            If nargs is UNEVALLED, args points to slot holding
  45                            list of unevalled args */
  46   char evalargs;
  47   /* Nonzero means call value of debugger when done with this operation. */
  48   char debug_on_exit;
  49 };
  50 
  51 struct backtrace *backtrace_list;
  52 
  53 struct catchtag *catchlist;
  54 
  55 #ifdef DEBUG_GCPRO
  56 /* Count levels of GCPRO to detect failure to UNGCPRO.  */
  57 int gcpro_level;
  58 #endif
  59 
  60 Lisp_Object Qautoload, Qmacro, Qexit, Qinteractive, Qcommandp, Qdefun;
  61 Lisp_Object Qinhibit_quit, Vinhibit_quit, Vquit_flag;
  62 Lisp_Object Qand_rest, Qand_optional;
  63 Lisp_Object Qdebug_on_error;
  64 Lisp_Object Qdeclare;
  65 Lisp_Object Qdebug;
  66 extern Lisp_Object Qinteractive_form;
  67 
  68 /* This holds either the symbol `run-hooks' or nil.
  69    It is nil at an early stage of startup, and when Emacs
  70    is shutting down.  */
  71 
  72 Lisp_Object Vrun_hooks;
  73 
  74 /* Non-nil means record all fset's and provide's, to be undone
  75    if the file being autoloaded is not fully loaded.
  76    They are recorded by being consed onto the front of Vautoload_queue:
  77    (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide.  */
  78 
  79 Lisp_Object Vautoload_queue;
  80 
  81 /* Current number of specbindings allocated in specpdl.  */
  82 
  83 int specpdl_size;
  84 
  85 /* Pointer to beginning of specpdl.  */
  86 
  87 struct specbinding *specpdl;
  88 
  89 /* Pointer to first unused element in specpdl.  */
  90 
  91 struct specbinding *specpdl_ptr;
  92 
  93 /* Maximum size allowed for specpdl allocation */
  94 
  95 EMACS_INT max_specpdl_size;
  96 
  97 /* Depth in Lisp evaluations and function calls.  */
  98 
  99 int lisp_eval_depth;
 100 
 101 /* Maximum allowed depth in Lisp evaluations and function calls.  */
 102 
 103 EMACS_INT max_lisp_eval_depth;
 104 
 105 /* Nonzero means enter debugger before next function call */
 106 
 107 int debug_on_next_call;
 108 
 109 /* Non-zero means debugger may continue.  This is zero when the
 110    debugger is called during redisplay, where it might not be safe to
 111    continue the interrupted redisplay. */
 112 
 113 int debugger_may_continue;
 114 
 115 /* List of conditions (non-nil atom means all) which cause a backtrace
 116    if an error is handled by the command loop's error handler.  */
 117 
 118 Lisp_Object Vstack_trace_on_error;
 119 
 120 /* List of conditions (non-nil atom means all) which enter the debugger
 121    if an error is handled by the command loop's error handler.  */
 122 
 123 Lisp_Object Vdebug_on_error;
 124 
 125 /* List of conditions and regexps specifying error messages which
 126    do not enter the debugger even if Vdebug_on_error says they should.  */
 127 
 128 Lisp_Object Vdebug_ignored_errors;
 129 
 130 /* Non-nil means call the debugger even if the error will be handled.  */
 131 
 132 Lisp_Object Vdebug_on_signal;
 133 
 134 /* Hook for edebug to use.  */
 135 
 136 Lisp_Object Vsignal_hook_function;
 137 
 138 /* Nonzero means enter debugger if a quit signal
 139    is handled by the command loop's error handler. */
 140 
 141 int debug_on_quit;
 142 
 143 /* The value of num_nonmacro_input_events as of the last time we
 144    started to enter the debugger.  If we decide to enter the debugger
 145    again when this is still equal to num_nonmacro_input_events, then we
 146    know that the debugger itself has an error, and we should just
 147    signal the error instead of entering an infinite loop of debugger
 148    invocations.  */
 149 
 150 int when_entered_debugger;
 151 
 152 Lisp_Object Vdebugger;
 153 
 154 /* The function from which the last `signal' was called.  Set in
 155    Fsignal.  */
 156 
 157 Lisp_Object Vsignaling_function;
 158 
 159 /* Set to non-zero while processing X events.  Checked in Feval to
 160    make sure the Lisp interpreter isn't called from a signal handler,
 161    which is unsafe because the interpreter isn't reentrant.  */
 162 
 163 int handling_signal;
 164 
 165 /* Function to process declarations in defmacro forms.  */
 166 
 167 Lisp_Object Vmacro_declaration_function;
 168 
 169 extern Lisp_Object Qrisky_local_variable;
 170 
 171 extern Lisp_Object Qfunction;
 172 
 173 static Lisp_Object funcall_lambda P_ ((Lisp_Object, int, Lisp_Object*));
 174 static void unwind_to_catch P_ ((struct catchtag *, Lisp_Object)) NO_RETURN;
 175 
 176 #if __GNUC__
 177 /* "gcc -O3" enables automatic function inlining, which optimizes out
 178    the arguments for the invocations of these functions, whereas they
 179    expect these values on the stack.  */
 180 Lisp_Object apply1 () __attribute__((noinline));
 181 Lisp_Object call2 () __attribute__((noinline));
 182 #endif
 183 
 184 void
 185 init_eval_once ()
 186 {
 187   specpdl_size = 50;
 188   specpdl = (struct specbinding *) xmalloc (specpdl_size * sizeof (struct specbinding));
 189   specpdl_ptr = specpdl;
 190   /* Don't forget to update docs (lispref node "Local Variables").  */
 191   max_specpdl_size = 1000;
 192   max_lisp_eval_depth = 500;
 193 
 194   Vrun_hooks = Qnil;
 195 }
 196 
 197 void
 198 init_eval ()
 199 {
 200   specpdl_ptr = specpdl;
 201   catchlist = 0;
 202   handlerlist = 0;
 203   backtrace_list = 0;
 204   Vquit_flag = Qnil;
 205   debug_on_next_call = 0;
 206   lisp_eval_depth = 0;
 207 #ifdef DEBUG_GCPRO
 208   gcpro_level = 0;
 209 #endif
 210   /* This is less than the initial value of num_nonmacro_input_events.  */
 211   when_entered_debugger = -1;
 212 }
 213 
 214 /* unwind-protect function used by call_debugger.  */
 215 
 216 static Lisp_Object
 217 restore_stack_limits (data)
 218      Lisp_Object data;
 219 {
 220   max_specpdl_size = XINT (XCAR (data));
 221   max_lisp_eval_depth = XINT (XCDR (data));
 222   return Qnil;
 223 }
 224 
 225 /* Call the Lisp debugger, giving it argument ARG.  */
 226 
 227 Lisp_Object
 228 call_debugger (arg)
 229      Lisp_Object arg;
 230 {
 231   int debug_while_redisplaying;
 232   int count = SPECPDL_INDEX ();
 233   Lisp_Object val;
 234   int old_max = max_specpdl_size;
 235 
 236   /* Temporarily bump up the stack limits,
 237      so the debugger won't run out of stack.  */
 238 
 239   max_specpdl_size += 1;
 240   record_unwind_protect (restore_stack_limits,
 241                          Fcons (make_number (old_max),
 242                                 make_number (max_lisp_eval_depth)));
 243   max_specpdl_size = old_max;
 244 
 245   if (lisp_eval_depth + 40 > max_lisp_eval_depth)
 246     max_lisp_eval_depth = lisp_eval_depth + 40;
 247 
 248   if (SPECPDL_INDEX () + 100 > max_specpdl_size)
 249     max_specpdl_size = SPECPDL_INDEX () + 100;
 250 
 251 #ifdef HAVE_WINDOW_SYSTEM
 252   if (display_hourglass_p)
 253     cancel_hourglass ();
 254 #endif
 255 
 256   debug_on_next_call = 0;
 257   when_entered_debugger = num_nonmacro_input_events;
 258 
 259   /* Resetting redisplaying_p to 0 makes sure that debug output is
 260      displayed if the debugger is invoked during redisplay.  */
 261   debug_while_redisplaying = redisplaying_p;
 262   redisplaying_p = 0;
 263   specbind (intern ("debugger-may-continue"),
 264             debug_while_redisplaying ? Qnil : Qt);
 265   specbind (Qinhibit_redisplay, Qnil);
 266   specbind (Qdebug_on_error, Qnil);
 267 
 268 #if 0 /* Binding this prevents execution of Lisp code during
 269          redisplay, which necessarily leads to display problems.  */
 270   specbind (Qinhibit_eval_during_redisplay, Qt);
 271 #endif
 272 
 273   val = apply1 (Vdebugger, arg);
 274 
 275   /* Interrupting redisplay and resuming it later is not safe under
 276      all circumstances.  So, when the debugger returns, abort the
 277      interrupted redisplay by going back to the top-level.  */
 278   if (debug_while_redisplaying)
 279     Ftop_level ();
 280 
 281   return unbind_to (count, val);
 282 }
 283 
 284 void
 285 do_debug_on_call (code)
 286      Lisp_Object code;
 287 {
 288   debug_on_next_call = 0;
 289   backtrace_list->debug_on_exit = 1;
 290   call_debugger (Fcons (code, Qnil));
 291 }
 292 
 293 /* NOTE!!! Every function that can call EVAL must protect its args
 294    and temporaries from garbage collection while it needs them.
 295    The definition of `For' shows what you have to do.  */
 296 
 297 DEFUN ("or", For, Sor, 0, UNEVALLED, 0,
 298        doc: /* Eval args until one of them yields non-nil, then return that value.
 299 The remaining args are not evalled at all.
 300 If all args return nil, return nil.
 301 usage: (or CONDITIONS...)  */)
 302      (args)
 303      Lisp_Object args;
 304 {
 305   register Lisp_Object val = Qnil;
 306   struct gcpro gcpro1;
 307 
 308   GCPRO1 (args);
 309 
 310   while (CONSP (args))
 311     {
 312       val = Feval (XCAR (args));
 313       if (!NILP (val))
 314         break;
 315       args = XCDR (args);
 316     }
 317 
 318   UNGCPRO;
 319   return val;
 320 }
 321 
 322 DEFUN ("and", Fand, Sand, 0, UNEVALLED, 0,
 323        doc: /* Eval args until one of them yields nil, then return nil.
 324 The remaining args are not evalled at all.
 325 If no arg yields nil, return the last arg's value.
 326 usage: (and CONDITIONS...)  */)
 327      (args)
 328      Lisp_Object args;
 329 {
 330   register Lisp_Object val = Qt;
 331   struct gcpro gcpro1;
 332 
 333   GCPRO1 (args);
 334 
 335   while (CONSP (args))
 336     {
 337       val = Feval (XCAR (args));
 338       if (NILP (val))
 339         break;
 340       args = XCDR (args);
 341     }
 342 
 343   UNGCPRO;
 344   return val;
 345 }
 346 
 347 DEFUN ("if", Fif, Sif, 2, UNEVALLED, 0,
 348        doc: /* If COND yields non-nil, do THEN, else do ELSE...
 349 Returns the value of THEN or the value of the last of the ELSE's.
 350 THEN must be one expression, but ELSE... can be zero or more expressions.
 351 If COND yields nil, and there are no ELSE's, the value is nil.
 352 usage: (if COND THEN ELSE...)  */)
 353      (args)
 354      Lisp_Object args;
 355 {
 356   register Lisp_Object cond;
 357   struct gcpro gcpro1;
 358 
 359   GCPRO1 (args);
 360   cond = Feval (Fcar (args));
 361   UNGCPRO;
 362 
 363   if (!NILP (cond))
 364     return Feval (Fcar (Fcdr (args)));
 365   return Fprogn (Fcdr (Fcdr (args)));
 366 }
 367 
 368 DEFUN ("cond", Fcond, Scond, 0, UNEVALLED, 0,
 369        doc: /* Try each clause until one succeeds.
 370 Each clause looks like (CONDITION BODY...).  CONDITION is evaluated
 371 and, if the value is non-nil, this clause succeeds:
 372 then the expressions in BODY are evaluated and the last one's
 373 value is the value of the cond-form.
 374 If no clause succeeds, cond returns nil.
 375 If a clause has one element, as in (CONDITION),
 376 CONDITION's value if non-nil is returned from the cond-form.
 377 usage: (cond CLAUSES...)  */)
 378      (args)
 379      Lisp_Object args;
 380 {
 381   register Lisp_Object clause, val;
 382   struct gcpro gcpro1;
 383 
 384   val = Qnil;
 385   GCPRO1 (args);
 386   while (!NILP (args))
 387     {
 388       clause = Fcar (args);
 389       val = Feval (Fcar (clause));
 390       if (!NILP (val))
 391         {
 392           if (!EQ (XCDR (clause), Qnil))
 393             val = Fprogn (XCDR (clause));
 394           break;
 395         }
 396       args = XCDR (args);
 397     }
 398   UNGCPRO;
 399 
 400   return val;
 401 }
 402 
 403 DEFUN ("progn", Fprogn, Sprogn, 0, UNEVALLED, 0,
 404        doc: /* Eval BODY forms sequentially and return value of last one.
 405 usage: (progn BODY...)  */)
 406      (args)
 407      Lisp_Object args;
 408 {
 409   register Lisp_Object val = Qnil;
 410   struct gcpro gcpro1;
 411 
 412   GCPRO1 (args);
 413 
 414   while (CONSP (args))
 415     {
 416       val = Feval (XCAR (args));
 417       args = XCDR (args);
 418     }
 419 
 420   UNGCPRO;
 421   return val;
 422 }
 423 
 424 DEFUN ("prog1", Fprog1, Sprog1, 1, UNEVALLED, 0,
 425        doc: /* Eval FIRST and BODY sequentially; return value from FIRST.
 426 The value of FIRST is saved during the evaluation of the remaining args,
 427 whose values are discarded.
 428 usage: (prog1 FIRST BODY...)  */)
 429      (args)
 430      Lisp_Object args;
 431 {
 432   Lisp_Object val;
 433   register Lisp_Object args_left;
 434   struct gcpro gcpro1, gcpro2;
 435   register int argnum = 0;
 436 
 437   if (NILP (args))
 438     return Qnil;
 439 
 440   args_left = args;
 441   val = Qnil;
 442   GCPRO2 (args, val);
 443 
 444   do
 445     {
 446       if (!(argnum++))
 447         val = Feval (Fcar (args_left));
 448       else
 449         Feval (Fcar (args_left));
 450       args_left = Fcdr (args_left);
 451     }
 452   while (!NILP(args_left));
 453 
 454   UNGCPRO;
 455   return val;
 456 }
 457 
 458 DEFUN ("prog2", Fprog2, Sprog2, 2, UNEVALLED, 0,
 459        doc: /* Eval FORM1, FORM2 and BODY sequentially; return value from FORM2.
 460 The value of FORM2 is saved during the evaluation of the
 461 remaining args, whose values are discarded.
 462 usage: (prog2 FORM1 FORM2 BODY...)  */)
 463      (args)
 464      Lisp_Object args;
 465 {
 466   Lisp_Object val;
 467   register Lisp_Object args_left;
 468   struct gcpro gcpro1, gcpro2;
 469   register int argnum = -1;
 470 
 471   val = Qnil;
 472 
 473   if (NILP (args))
 474     return Qnil;
 475 
 476   args_left = args;
 477   val = Qnil;
 478   GCPRO2 (args, val);
 479 
 480   do
 481     {
 482       if (!(argnum++))
 483         val = Feval (Fcar (args_left));
 484       else
 485         Feval (Fcar (args_left));
 486       args_left = Fcdr (args_left);
 487     }
 488   while (!NILP (args_left));
 489 
 490   UNGCPRO;
 491   return val;
 492 }
 493 
 494 DEFUN ("setq", Fsetq, Ssetq, 0, UNEVALLED, 0,
 495        doc: /* Set each SYM to the value of its VAL.
 496 The symbols SYM are variables; they are literal (not evaluated).
 497 The values VAL are expressions; they are evaluated.
 498 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
 499 The second VAL is not computed until after the first SYM is set, and so on;
 500 each VAL can use the new value of variables set earlier in the `setq'.
 501 The return value of the `setq' form is the value of the last VAL.
 502 usage: (setq [SYM VAL]...)  */)
 503      (args)
 504      Lisp_Object args;
 505 {
 506   register Lisp_Object args_left;
 507   register Lisp_Object val, sym;
 508   struct gcpro gcpro1;
 509 
 510   if (NILP (args))
 511     return Qnil;
 512 
 513   args_left = args;
 514   GCPRO1 (args);
 515 
 516   do
 517     {
 518       val = Feval (Fcar (Fcdr (args_left)));
 519       sym = Fcar (args_left);
 520       Fset (sym, val);
 521       args_left = Fcdr (Fcdr (args_left));
 522     }
 523   while (!NILP(args_left));
 524 
 525   UNGCPRO;
 526   return val;
 527 }
 528 
 529 DEFUN ("quote", Fquote, Squote, 1, UNEVALLED, 0,
 530        doc: /* Return the argument, without evaluating it.  `(quote x)' yields `x'.
 531 usage: (quote ARG)  */)
 532      (args)
 533      Lisp_Object args;
 534 {
 535   if (!NILP (Fcdr (args)))
 536     xsignal2 (Qwrong_number_of_arguments, Qquote, Flength (args));
 537   return Fcar (args);
 538 }
 539 
 540 DEFUN ("function", Ffunction, Sfunction, 1, UNEVALLED, 0,
 541        doc: /* Like `quote', but preferred for objects which are functions.
 542 In byte compilation, `function' causes its argument to be compiled.
 543 `quote' cannot do that.
 544 usage: (function ARG)  */)
 545      (args)
 546      Lisp_Object args;
 547 {
 548   if (!NILP (Fcdr (args)))
 549     xsignal2 (Qwrong_number_of_arguments, Qfunction, Flength (args));
 550   return Fcar (args);
 551 }
 552 
 553 
 554 DEFUN ("interactive-p", Finteractive_p, Sinteractive_p, 0, 0, 0,
 555        doc: /* Return t if the containing function was run directly by user input.
 556 This means that the function was called with `call-interactively'
 557 \(which includes being called as the binding of a key)
 558 and input is currently coming from the keyboard (not a keyboard macro),
 559 and Emacs is not running in batch mode (`noninteractive' is nil).
 560 
 561 The only known proper use of `interactive-p' is in deciding whether to
 562 display a helpful message, or how to display it.  If you're thinking
 563 of using it for any other purpose, it is quite likely that you're
 564 making a mistake.  Think: what do you want to do when the command is
 565 called from a keyboard macro?
 566 
 567 To test whether your function was called with `call-interactively',
 568 either (i) add an extra optional argument and give it an `interactive'
 569 spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
 570 use `called-interactively-p'.  */)
 571      ()
 572 {
 573   return (INTERACTIVE && interactive_p (1)) ? Qt : Qnil;
 574 }
 575 
 576 
 577 DEFUN ("called-interactively-p", Fcalled_interactively_p, Scalled_interactively_p, 0, 1, 0,
 578        doc: /* Return t if the containing function was called by `call-interactively'.
 579 If KIND is `interactive', then only return t if the call was made
 580 interactively by the user, i.e. not in `noninteractive' mode nor
 581 when `executing-kbd-macro'.
 582 If KIND is `any', on the other hand, it will return t for any kind of
 583 interactive call, including being called as the binding of a key, or
 584 from a keyboard macro, or in `noninteractive' mode.
 585 
 586 The only known proper use of `interactive' for KIND is in deciding
 587 whether to display a helpful message, or how to display it.  If you're
 588 thinking of using it for any other purpose, it is quite likely that
 589 you're making a mistake.  Think: what do you want to do when the
 590 command is called from a keyboard macro?
 591 
 592 This function is meant for implementing advice and other
 593 function-modifying features.  Instead of using this, it is sometimes
 594 cleaner to give your function an extra optional argument whose
 595 `interactive' spec specifies non-nil unconditionally (\"p\" is a good
 596 way to do this), or via (not (or executing-kbd-macro noninteractive)).  */)
 597      (kind)
 598      Lisp_Object kind;
 599 {
 600   return ((INTERACTIVE || !EQ (kind, intern ("interactive")))
 601           && interactive_p (1)) ? Qt : Qnil;
 602 }
 603 
 604 
 605 /*  Return 1 if function in which this appears was called using
 606     call-interactively.
 607 
 608     EXCLUDE_SUBRS_P non-zero means always return 0 if the function
 609     called is a built-in.  */
 610 
 611 int
 612 interactive_p (exclude_subrs_p)
 613      int exclude_subrs_p;
 614 {
 615   struct backtrace *btp;
 616   Lisp_Object fun;
 617 
 618   btp = backtrace_list;
 619 
 620   /* If this isn't a byte-compiled function, there may be a frame at
 621      the top for Finteractive_p.  If so, skip it.  */
 622   fun = Findirect_function (*btp->function, Qnil);
 623   if (SUBRP (fun) && (XSUBR (fun) == &Sinteractive_p
 624                       || XSUBR (fun) == &Scalled_interactively_p))
 625     btp = btp->next;
 626 
 627   /* If we're running an Emacs 18-style byte-compiled function, there
 628      may be a frame for Fbytecode at the top level.  In any version of
 629      Emacs there can be Fbytecode frames for subexpressions evaluated
 630      inside catch and condition-case.  Skip past them.
 631 
 632      If this isn't a byte-compiled function, then we may now be
 633      looking at several frames for special forms.  Skip past them.  */
 634   while (btp
 635          && (EQ (*btp->function, Qbytecode)
 636              || btp->nargs == UNEVALLED))
 637     btp = btp->next;
 638 
 639   /* btp now points at the frame of the innermost function that isn't
 640      a special form, ignoring frames for Finteractive_p and/or
 641      Fbytecode at the top.  If this frame is for a built-in function
 642      (such as load or eval-region) return nil.  */
 643   fun = Findirect_function (*btp->function, Qnil);
 644   if (exclude_subrs_p && SUBRP (fun))
 645     return 0;
 646 
 647   /* btp points to the frame of a Lisp function that called interactive-p.
 648      Return t if that function was called interactively.  */
 649   if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively))
 650     return 1;
 651   return 0;
 652 }
 653 
 654 
 655 DEFUN ("defun", Fdefun, Sdefun, 2, UNEVALLED, 0,
 656        doc: /* Define NAME as a function.
 657 The definition is (lambda ARGLIST [DOCSTRING] BODY...).
 658 See also the function `interactive'.
 659 usage: (defun NAME ARGLIST [DOCSTRING] BODY...)  */)
 660      (args)
 661      Lisp_Object args;
 662 {
 663   register Lisp_Object fn_name;
 664   register Lisp_Object defn;
 665 
 666   fn_name = Fcar (args);
 667   CHECK_SYMBOL (fn_name);
 668   defn = Fcons (Qlambda, Fcdr (args));
 669   if (!NILP (Vpurify_flag))
 670     defn = Fpurecopy (defn);
 671   if (CONSP (XSYMBOL (fn_name)->function)
 672       && EQ (XCAR (XSYMBOL (fn_name)->function), Qautoload))
 673     LOADHIST_ATTACH (Fcons (Qt, fn_name));
 674   Ffset (fn_name, defn);
 675   LOADHIST_ATTACH (Fcons (Qdefun, fn_name));
 676   return fn_name;
 677 }
 678 
 679 DEFUN ("defmacro", Fdefmacro, Sdefmacro, 2, UNEVALLED, 0,
 680        doc: /* Define NAME as a macro.
 681 The actual definition looks like
 682  (macro lambda ARGLIST [DOCSTRING] [DECL] BODY...).
 683 When the macro is called, as in (NAME ARGS...),
 684 the function (lambda ARGLIST BODY...) is applied to
 685 the list ARGS... as it appears in the expression,
 686 and the result should be a form to be evaluated instead of the original.
 687 
 688 DECL is a declaration, optional, which can specify how to indent
 689 calls to this macro, how Edebug should handle it, and which argument
 690 should be treated as documentation.  It looks like this:
 691   (declare SPECS...)
 692 The elements can look like this:
 693   (indent INDENT)
 694         Set NAME's `lisp-indent-function' property to INDENT.
 695 
 696   (debug DEBUG)
 697         Set NAME's `edebug-form-spec' property to DEBUG.  (This is
 698         equivalent to writing a `def-edebug-spec' for the macro.)
 699 
 700   (doc-string ELT)
 701         Set NAME's `doc-string-elt' property to ELT.
 702 
 703 usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...)  */)
 704      (args)
 705      Lisp_Object args;
 706 {
 707   register Lisp_Object fn_name;
 708   register Lisp_Object defn;
 709   Lisp_Object lambda_list, doc, tail;
 710 
 711   fn_name = Fcar (args);
 712   CHECK_SYMBOL (fn_name);
 713   lambda_list = Fcar (Fcdr (args));
 714   tail = Fcdr (Fcdr (args));
 715 
 716   doc = Qnil;
 717   if (STRINGP (Fcar (tail)))
 718     {
 719       doc = XCAR (tail);
 720       tail = XCDR (tail);
 721     }
 722 
 723   while (CONSP (Fcar (tail))
 724          && EQ (Fcar (Fcar (tail)), Qdeclare))
 725     {
 726       if (!NILP (Vmacro_declaration_function))
 727         {
 728           struct gcpro gcpro1;
 729           GCPRO1 (args);
 730           call2 (Vmacro_declaration_function, fn_name, Fcar (tail));
 731           UNGCPRO;
 732         }
 733 
 734       tail = Fcdr (tail);
 735     }
 736 
 737   if (NILP (doc))
 738     tail = Fcons (lambda_list, tail);
 739   else
 740     tail = Fcons (lambda_list, Fcons (doc, tail));
 741   defn = Fcons (Qmacro, Fcons (Qlambda, tail));
 742 
 743   if (!NILP (Vpurify_flag))
 744     defn = Fpurecopy (defn);
 745   if (CONSP (XSYMBOL (fn_name)->function)
 746       && EQ (XCAR (XSYMBOL (fn_name)->function), Qautoload))
 747     LOADHIST_ATTACH (Fcons (Qt, fn_name));
 748   Ffset (fn_name, defn);
 749   LOADHIST_ATTACH (Fcons (Qdefun, fn_name));
 750   return fn_name;
 751 }
 752 
 753 
 754 DEFUN ("defvaralias", Fdefvaralias, Sdefvaralias, 2, 3, 0,
 755        doc: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
 756 Aliased variables always have the same value; setting one sets the other.
 757 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS.  If it is
 758 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
 759 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
 760 itself an alias.  If NEW-ALIAS is bound, and BASE-VARIABLE is not,
 761 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
 762 The return value is BASE-VARIABLE.  */)
 763      (new_alias, base_variable, docstring)
 764      Lisp_Object new_alias, base_variable, docstring;
 765 {
 766   struct Lisp_Symbol *sym;
 767 
 768   CHECK_SYMBOL (new_alias);
 769   CHECK_SYMBOL (base_variable);
 770 
 771   sym = XSYMBOL (new_alias);
 772 
 773   if (sym->constant)
 774     /* Not sure why, but why not?  */
 775     error ("Cannot make a constant an alias");
 776 
 777   switch (sym->redirect)
 778     {
 779     case SYMBOL_FORWARDED:
 780       error ("Cannot make an internal variable an alias");
 781     case SYMBOL_LOCALIZED:
 782       error ("Don't know how to make a localized variable an alias");
 783     }
 784 
 785   /* http://lists.gnu.org/archive/html/emacs-devel/2008-04/msg00834.html
 786      If n_a is bound, but b_v is not, set the value of b_v to n_a,
 787      so that old-code that affects n_a before the aliasing is setup
 788      still works.  */
 789   if (NILP (Fboundp (base_variable)))
 790     set_internal (base_variable, find_symbol_value (new_alias), Qnil, 1);
 791 
 792   {
 793     struct specbinding *p;
 794 
 795     for (p = specpdl_ptr - 1; p >= specpdl; p--)
 796       if (p->func == NULL
 797           && (EQ (new_alias,
 798                   CONSP (p->symbol) ? XCAR (p->symbol) : p->symbol)))
 799         error ("Don't know how to make a let-bound variable an alias");
 800   }
 801 
 802   sym->redirect = SYMBOL_VARALIAS;
 803   SET_SYMBOL_ALIAS (sym, XSYMBOL (base_variable));
 804   sym->constant = SYMBOL_CONSTANT_P (base_variable);
 805   LOADHIST_ATTACH (new_alias);
 806   /* Even if docstring is nil: remove old docstring.  */
 807   Fput (new_alias, Qvariable_documentation, docstring);
 808 
 809   return base_variable;
 810 }
 811 
 812 
 813 DEFUN ("defvar", Fdefvar, Sdefvar, 1, UNEVALLED, 0,
 814        doc: /* Define SYMBOL as a variable, and return SYMBOL.
 815 You are not required to define a variable in order to use it,
 816 but the definition can supply documentation and an initial value
 817 in a way that tags can recognize.
 818 
 819 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.
 820 If SYMBOL is buffer-local, its default value is what is set;
 821  buffer-local values are not affected.
 822 INITVALUE and DOCSTRING are optional.
 823 If DOCSTRING starts with *, this variable is identified as a user option.
 824  This means that M-x set-variable recognizes it.
 825  See also `user-variable-p'.
 826 If INITVALUE is missing, SYMBOL's value is not set.
 827 
 828 If SYMBOL has a local binding, then this form affects the local
 829 binding.  This is usually not what you want.  Thus, if you need to
 830 load a file defining variables, with this form or with `defconst' or
 831 `defcustom', you should always load that file _outside_ any bindings
 832 for these variables.  \(`defconst' and `defcustom' behave similarly in
 833 this respect.)
 834 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING)  */)
 835      (args)
 836      Lisp_Object args;
 837 {
 838   register Lisp_Object sym, tem, tail;
 839 
 840   sym = Fcar (args);
 841   tail = Fcdr (args);
 842   if (!NILP (Fcdr (Fcdr (tail))))
 843     error ("Too many arguments");
 844 
 845   tem = Fdefault_boundp (sym);
 846   if (!NILP (tail))
 847     {
 848       if (SYMBOL_CONSTANT_P (sym))
 849         {
 850           /* For upward compatibility, allow (defvar :foo (quote :foo)).  */
 851           Lisp_Object tem = Fcar (tail);
 852           if (! (CONSP (tem)
 853                  && EQ (XCAR (tem), Qquote)
 854                  && CONSP (XCDR (tem))
 855                  && EQ (XCAR (XCDR (tem)), sym)))
 856             error ("Constant symbol `%s' specified in defvar",
 857                    SDATA (SYMBOL_NAME (sym)));
 858         }
 859 
 860       if (NILP (tem))
 861         Fset_default (sym, Feval (Fcar (tail)));
 862       else
 863         { /* Check if there is really a global binding rather than just a let
 864              binding that shadows the global unboundness of the var.  */
 865           volatile struct specbinding *pdl = specpdl_ptr;
 866           while (--pdl >= specpdl)
 867             {
 868               if (EQ (pdl->symbol, sym) && !pdl->func
 869                   && EQ (pdl->old_value, Qunbound))
 870                 {
 871                   message_with_string ("Warning: defvar ignored because %s is let-bound",
 872                                        SYMBOL_NAME (sym), 1);
 873                   break;
 874                 }
 875             }
 876         }
 877       tail = Fcdr (tail);
 878       tem = Fcar (tail);
 879       if (!NILP (tem))
 880         {
 881           if (!NILP (Vpurify_flag))
 882             tem = Fpurecopy (tem);
 883           Fput (sym, Qvariable_documentation, tem);
 884         }
 885       LOADHIST_ATTACH (sym);
 886     }
 887   else
 888     /* Simple (defvar <var>) should not count as a definition at all.
 889        It could get in the way of other definitions, and unloading this
 890        package could try to make the variable unbound.  */
 891     ;
 892 
 893   return sym;
 894 }
 895 
 896 DEFUN ("defconst", Fdefconst, Sdefconst, 2, UNEVALLED, 0,
 897        doc: /* Define SYMBOL as a constant variable.
 898 The intent is that neither programs nor users should ever change this value.
 899 Always sets the value of SYMBOL to the result of evalling INITVALUE.
 900 If SYMBOL is buffer-local, its default value is what is set;
 901  buffer-local values are not affected.
 902 DOCSTRING is optional.
 903 
 904 If SYMBOL has a local binding, then this form sets the local binding's
 905 value.  However, you should normally not make local bindings for
 906 variables defined with this form.
 907 usage: (defconst SYMBOL INITVALUE [DOCSTRING])  */)
 908      (args)
 909      Lisp_Object args;
 910 {
 911   register Lisp_Object sym, tem;
 912 
 913   sym = Fcar (args);
 914   if (!NILP (Fcdr (Fcdr (Fcdr (args)))))
 915     error ("Too many arguments");
 916 
 917   tem = Feval (Fcar (Fcdr (args)));
 918   if (!NILP (Vpurify_flag))
 919     tem = Fpurecopy (tem);
 920   Fset_default (sym, tem);
 921   tem = Fcar (Fcdr (Fcdr (args)));
 922   if (!NILP (tem))
 923     {
 924       if (!NILP (Vpurify_flag))
 925         tem = Fpurecopy (tem);
 926       Fput (sym, Qvariable_documentation, tem);
 927     }
 928   Fput (sym, Qrisky_local_variable, Qt);
 929   LOADHIST_ATTACH (sym);
 930   return sym;
 931 }
 932 
 933 /* Error handler used in Fuser_variable_p.  */
 934 static Lisp_Object
 935 user_variable_p_eh (ignore)
 936      Lisp_Object ignore;
 937 {
 938   return Qnil;
 939 }
 940 
 941 static Lisp_Object
 942 lisp_indirect_variable (Lisp_Object sym)
 943 {
 944   XSETSYMBOL (sym, indirect_variable (XSYMBOL (sym)));
 945   return sym;
 946 }
 947 
 948 DEFUN ("user-variable-p", Fuser_variable_p, Suser_variable_p, 1, 1, 0,
 949        doc: /* Return t if VARIABLE is intended to be set and modified by users.
 950 \(The alternative is a variable used internally in a Lisp program.)
 951 A variable is a user variable if
 952 \(1) the first character of its documentation is `*', or
 953 \(2) it is customizable (its property list contains a non-nil value
 954     of `standard-value' or `custom-autoload'), or
 955 \(3) it is an alias for another user variable.
 956 Return nil if VARIABLE is an alias and there is a loop in the
 957 chain of symbols.  */)
 958      (variable)
 959      Lisp_Object variable;
 960 {
 961   Lisp_Object documentation;
 962 
 963   if (!SYMBOLP (variable))
 964       return Qnil;
 965 
 966   /* If indirect and there's an alias loop, don't check anything else.  */
 967   if (XSYMBOL (variable)->redirect == SYMBOL_VARALIAS
 968       && NILP (internal_condition_case_1 (lisp_indirect_variable, variable,
 969                                           Qt, user_variable_p_eh)))
 970     return Qnil;
 971 
 972   while (1)
 973     {
 974       documentation = Fget (variable, Qvariable_documentation);
 975       if (INTEGERP (documentation) && XINT (documentation) < 0)
 976         return Qt;
 977       if (STRINGP (documentation)
 978           && ((unsigned char) SREF (documentation, 0) == '*'))
 979         return Qt;
 980       /* If it is (STRING . INTEGER), a negative integer means a user variable.  */
 981       if (CONSP (documentation)
 982           && STRINGP (XCAR (documentation))
 983           && INTEGERP (XCDR (documentation))
 984           && XINT (XCDR (documentation)) < 0)
 985         return Qt;
 986       /* Customizable?  See `custom-variable-p'.  */
 987       if ((!NILP (Fget (variable, intern ("standard-value"))))
 988           || (!NILP (Fget (variable, intern ("custom-autoload")))))
 989         return Qt;
 990 
 991       if (!(XSYMBOL (variable)->redirect == SYMBOL_VARALIAS))
 992         return Qnil;
 993 
 994       /* An indirect variable?  Let's follow the chain.  */
 995       XSETSYMBOL (variable, SYMBOL_ALIAS (XSYMBOL (variable)));
 996     }
 997 }
 998 
 999 DEFUN ("let*", FletX, SletX, 1, UNEVALLED, 0,
1000        doc: /* Bind variables according to VARLIST then eval BODY.
1001 The value of the last form in BODY is returned.
1002 Each element of VARLIST is a symbol (which is bound to nil)
1003 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
1004 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
1005 usage: (let* VARLIST BODY...)  */)
1006      (args)
1007      Lisp_Object args;
1008 {
1009   Lisp_Object varlist, val, elt;
1010   int count = SPECPDL_INDEX ();
1011   struct gcpro gcpro1, gcpro2, gcpro3;
1012 
1013   GCPRO3 (args, elt, varlist);
1014 
1015   varlist = Fcar (args);
1016   while (!NILP (varlist))
1017     {
1018       QUIT;
1019       elt = Fcar (varlist);
1020       if (SYMBOLP (elt))
1021         specbind (elt, Qnil);
1022       else if (! NILP (Fcdr (Fcdr (elt))))
1023         signal_error ("`let' bindings can have only one value-form", elt);
1024       else
1025         {
1026           val = Feval (Fcar (Fcdr (elt)));
1027           specbind (Fcar (elt), val);
1028         }
1029       varlist = Fcdr (varlist);
1030     }
1031   UNGCPRO;
1032   val = Fprogn (Fcdr (args));
1033   return unbind_to (count, val);
1034 }
1035 
1036 DEFUN ("let", Flet, Slet, 1, UNEVALLED, 0,
1037        doc: /* Bind variables according to VARLIST then eval BODY.
1038 The value of the last form in BODY is returned.
1039 Each element of VARLIST is a symbol (which is bound to nil)
1040 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
1041 All the VALUEFORMs are evalled before any symbols are bound.
1042 usage: (let VARLIST BODY...)  */)
1043      (args)
1044      Lisp_Object args;
1045 {
1046   Lisp_Object *temps, tem;
1047   register Lisp_Object elt, varlist;
1048   int count = SPECPDL_INDEX ();
1049   register int argnum;
1050   struct gcpro gcpro1, gcpro2;
1051 
1052   varlist = Fcar (args);
1053 
1054   /* Make space to hold the values to give the bound variables */
1055   elt = Flength (varlist);
1056   temps = (Lisp_Object *) alloca (XFASTINT (elt) * sizeof (Lisp_Object));
1057 
1058   /* Compute the values and store them in `temps' */
1059 
1060   GCPRO2 (args, *temps);
1061   gcpro2.nvars = 0;
1062 
1063   for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist))
1064     {
1065       QUIT;
1066       elt = XCAR (varlist);
1067       if (SYMBOLP (elt))
1068         temps [argnum++] = Qnil;
1069       else if (! NILP (Fcdr (Fcdr (elt))))
1070         signal_error ("`let' bindings can have only one value-form", elt);
1071       else
1072         temps [argnum++] = Feval (Fcar (Fcdr (elt)));
1073       gcpro2.nvars = argnum;
1074     }
1075   UNGCPRO;
1076 
1077   varlist = Fcar (args);
1078   for (argnum = 0; CONSP (varlist); varlist = XCDR (varlist))
1079     {
1080       elt = XCAR (varlist);
1081       tem = temps[argnum++];
1082       if (SYMBOLP (elt))
1083         specbind (elt, tem);
1084       else
1085         specbind (Fcar (elt), tem);
1086     }
1087 
1088   elt = Fprogn (Fcdr (args));
1089   return unbind_to (count, elt);
1090 }
1091 
1092 DEFUN ("while", Fwhile, Swhile, 1, UNEVALLED, 0,
1093        doc: /* If TEST yields non-nil, eval BODY... and repeat.
1094 The order of execution is thus TEST, BODY, TEST, BODY and so on
1095 until TEST returns nil.
1096 usage: (while TEST BODY...)  */)
1097      (args)
1098      Lisp_Object args;
1099 {
1100   Lisp_Object test, body;
1101   struct gcpro gcpro1, gcpro2;
1102 
1103   GCPRO2 (test, body);
1104 
1105   test = Fcar (args);
1106   body = Fcdr (args);
1107   while (!NILP (Feval (test)))
1108     {
1109       QUIT;
1110       Fprogn (body);
1111     }
1112 
1113   UNGCPRO;
1114   return Qnil;
1115 }
1116 
1117 DEFUN ("macroexpand", Fmacroexpand, Smacroexpand, 1, 2, 0,
1118        doc: /* Return result of expanding macros at top level of FORM.
1119 If FORM is not a macro call, it is returned unchanged.
1120 Otherwise, the macro is expanded and the expansion is considered
1121 in place of FORM.  When a non-macro-call results, it is returned.
1122 
1123 The second optional arg ENVIRONMENT specifies an environment of macro
1124 definitions to shadow the loaded ones for use in file byte-compilation.  */)
1125      (form, environment)
1126      Lisp_Object form;
1127      Lisp_Object environment;
1128 {
1129   /* With cleanups from Hallvard Furuseth.  */
1130   register Lisp_Object expander, sym, def, tem;
1131 
1132   while (1)
1133     {
1134       /* Come back here each time we expand a macro call,
1135          in case it expands into another macro call.  */
1136       if (!CONSP (form))
1137         break;
1138       /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
1139       def = sym = XCAR (form);
1140       tem = Qnil;
1141       /* Trace symbols aliases to other symbols
1142          until we get a symbol that is not an alias.  */
1143       while (SYMBOLP (def))
1144         {
1145           QUIT;
1146           sym = def;
1147           tem = Fassq (sym, environment);
1148           if (NILP (tem))
1149             {
1150               def = XSYMBOL (sym)->function;
1151               if (!EQ (def, Qunbound))
1152                 continue;
1153             }
1154           break;
1155         }
1156       /* Right now TEM is the result from SYM in ENVIRONMENT,
1157          and if TEM is nil then DEF is SYM's function definition.  */
1158       if (NILP (tem))
1159         {
1160           /* SYM is not mentioned in ENVIRONMENT.
1161              Look at its function definition.  */
1162           if (EQ (def, Qunbound) || !CONSP (def))
1163             /* Not defined or definition not suitable */
1164             break;
1165           if (EQ (XCAR (def), Qautoload))
1166             {
1167               /* Autoloading function: will it be a macro when loaded?  */
1168               tem = Fnth (make_number (4), def);
1169               if (EQ (tem, Qt) || EQ (tem, Qmacro))
1170                 /* Yes, load it and try again.  */
1171                 {
1172                   struct gcpro gcpro1;
1173                   GCPRO1 (form);
1174                   do_autoload (def, sym);
1175                   UNGCPRO;
1176                   continue;
1177                 }
1178               else
1179                 break;
1180             }
1181           else if (!EQ (XCAR (def), Qmacro))
1182             break;
1183           else expander = XCDR (def);
1184         }
1185       else
1186         {
1187           expander = XCDR (tem);
1188           if (NILP (expander))
1189             break;
1190         }
1191       form = apply1 (expander, XCDR (form));
1192     }
1193   return form;
1194 }
1195 
1196 DEFUN ("catch", Fcatch, Scatch, 1, UNEVALLED, 0,
1197        doc: /* Eval BODY allowing nonlocal exits using `throw'.
1198 TAG is evalled to get the tag to use; it must not be nil.
1199 
1200 Then the BODY is executed.
1201 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
1202 If no throw happens, `catch' returns the value of the last BODY form.
1203 If a throw happens, it specifies the value to return from `catch'.
1204 usage: (catch TAG BODY...)  */)
1205      (args)
1206      Lisp_Object args;
1207 {
1208   register Lisp_Object tag;
1209   struct gcpro gcpro1;
1210 
1211   GCPRO1 (args);
1212   tag = Feval (Fcar (args));
1213   UNGCPRO;
1214   return internal_catch (tag, Fprogn, Fcdr (args));
1215 }
1216 
1217 /* Set up a catch, then call C function FUNC on argument ARG.
1218    FUNC should return a Lisp_Object.
1219    This is how catches are done from within C code. */
1220 
1221 Lisp_Object
1222 internal_catch (tag, func, arg)
1223      Lisp_Object tag;
1224      Lisp_Object (*func) ();
1225      Lisp_Object arg;
1226 {
1227   /* This structure is made part of the chain `catchlist'.  */
1228   struct catchtag c;
1229 
1230   /* Fill in the components of c, and put it on the list.  */
1231   c.next = catchlist;
1232   c.tag = tag;
1233   c.val = Qnil;
1234   c.backlist = backtrace_list;
1235   c.handlerlist = handlerlist;
1236   c.lisp_eval_depth = lisp_eval_depth;
1237   c.pdlcount = SPECPDL_INDEX ();
1238   c.poll_suppress_count = poll_suppress_count;
1239   c.interrupt_input_blocked = interrupt_input_blocked;
1240   c.gcpro = gcprolist;
1241   c.byte_stack = byte_stack_list;
1242   catchlist = &c;
1243 
1244   /* Call FUNC.  */
1245   if (! _setjmp (c.jmp))
1246     c.val = (*func) (arg);
1247 
1248   /* Throw works by a longjmp that comes right here.  */
1249   catchlist = c.next;
1250   return c.val;
1251 }
1252 
1253 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
1254    jump to that CATCH, returning VALUE as the value of that catch.
1255 
1256    This is the guts Fthrow and Fsignal; they differ only in the way
1257    they choose the catch tag to throw to.  A catch tag for a
1258    condition-case form has a TAG of Qnil.
1259 
1260    Before each catch is discarded, unbind all special bindings and
1261    execute all unwind-protect clauses made above that catch.  Unwind
1262    the handler stack as we go, so that the proper handlers are in
1263    effect for each unwind-protect clause we run.  At the end, restore
1264    some static info saved in CATCH, and longjmp to the location
1265    specified in the
1266 
1267    This is used for correct unwinding in Fthrow and Fsignal.  */
1268 
1269 static void
1270 unwind_to_catch (catch, value)
1271      struct catchtag *catch;
1272      Lisp_Object value;
1273 {
1274   register int last_time;
1275 
1276   /* Save the value in the tag.  */
1277   catch->val = value;
1278 
1279   /* Restore certain special C variables.  */
1280   set_poll_suppress_count (catch->poll_suppress_count);
1281   UNBLOCK_INPUT_TO (catch->interrupt_input_blocked);
1282   handling_signal = 0;
1283   immediate_quit = 0;
1284 
1285   do
1286     {
1287       last_time = catchlist == catch;
1288 
1289       /* Unwind the specpdl stack, and then restore the proper set of
1290          handlers.  */
1291       unbind_to (catchlist->pdlcount, Qnil);
1292       handlerlist = catchlist->handlerlist;
1293       catchlist = catchlist->next;
1294     }
1295   while (! last_time);
1296 
1297 #if HAVE_X_WINDOWS
1298   /* If x_catch_errors was done, turn it off now.
1299      (First we give unbind_to a chance to do that.)  */
1300 #if 0 /* This would disable x_catch_errors after x_connection_closed.
1301        * The catch must remain in effect during that delicate
1302        * state. --lorentey  */
1303   x_fully_uncatch_errors ();
1304 #endif
1305 #endif
1306 
1307   byte_stack_list = catch->byte_stack;
1308   gcprolist = catch->gcpro;
1309 #ifdef DEBUG_GCPRO
1310   if (gcprolist != 0)
1311     gcpro_level = gcprolist->level + 1;
1312   else
1313     gcpro_level = 0;
1314 #endif
1315   backtrace_list = catch->backlist;
1316   lisp_eval_depth = catch->lisp_eval_depth;
1317 
1318   _longjmp (catch->jmp, 1);
1319 }
1320 
1321 DEFUN ("throw", Fthrow, Sthrow, 2, 2, 0,
1322        doc: /* Throw to the catch for TAG and return VALUE from it.
1323 Both TAG and VALUE are evalled.  */)
1324      (tag, value)
1325      register Lisp_Object tag, value;
1326 {
1327   register struct catchtag *c;
1328 
1329   if (!NILP (tag))
1330     for (c = catchlist; c; c = c->next)
1331       {
1332         if (EQ (c->tag, tag))
1333           unwind_to_catch (c, value);
1334       }
1335   xsignal2 (Qno_catch, tag, value);
1336 }
1337 
1338 
1339 DEFUN ("unwind-protect", Funwind_protect, Sunwind_protect, 1, UNEVALLED, 0,
1340        doc: /* Do BODYFORM, protecting with UNWINDFORMS.
1341 If BODYFORM completes normally, its value is returned
1342 after executing the UNWINDFORMS.
1343 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
1344 usage: (unwind-protect BODYFORM UNWINDFORMS...)  */)
1345      (args)
1346      Lisp_Object args;
1347 {
1348   Lisp_Object val;
1349   int count = SPECPDL_INDEX ();
1350 
1351   record_unwind_protect (Fprogn, Fcdr (args));
1352   val = Feval (Fcar (args));
1353   return unbind_to (count, val);
1354 }
1355 
1356 /* Chain of condition handlers currently in effect.
1357    The elements of this chain are contained in the stack frames
1358    of Fcondition_case and internal_condition_case.
1359    When an error is signaled (by calling Fsignal, below),
1360    this chain is searched for an element that applies.  */
1361 
1362 struct handler *handlerlist;
1363 
1364 DEFUN ("condition-case", Fcondition_case, Scondition_case, 2, UNEVALLED, 0,
1365        doc: /* Regain control when an error is signaled.
1366 Executes BODYFORM and returns its value if no error happens.
1367 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
1368 where the BODY is made of Lisp expressions.
1369 
1370 A handler is applicable to an error
1371 if CONDITION-NAME is one of the error's condition names.
1372 If an error happens, the first applicable handler is run.
1373 
1374 The car of a handler may be a list of condition names
1375 instead of a single condition name.  Then it handles all of them.
1376 
1377 When a handler handles an error, control returns to the `condition-case'
1378 and it executes the handler's BODY...
1379 with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
1380 (If VAR is nil, the handler can't access that information.)
1381 Then the value of the last BODY form is returned from the `condition-case'
1382 expression.
1383 
1384 See also the function `signal' for more info.
1385 usage: (condition-case VAR BODYFORM &rest HANDLERS)  */)
1386      (args)
1387      Lisp_Object args;
1388 {
1389   register Lisp_Object bodyform, handlers;
1390   volatile Lisp_Object var;
1391 
1392   var      = Fcar (args);
1393   bodyform = Fcar (Fcdr (args));
1394   handlers = Fcdr (Fcdr (args));
1395 
1396   return internal_lisp_condition_case (var, bodyform, handlers);
1397 }
1398 
1399 /* Like Fcondition_case, but the args are separate
1400    rather than passed in a list.  Used by Fbyte_code.  */
1401 
1402 Lisp_Object
1403 internal_lisp_condition_case (var, bodyform, handlers)
1404      volatile Lisp_Object var;
1405      Lisp_Object bodyform, handlers;
1406 {
1407   Lisp_Object val;
1408   struct catchtag c;
1409   struct handler h;
1410 
1411   CHECK_SYMBOL (var);
1412 
1413   for (val = handlers; CONSP (val); val = XCDR (val))
1414     {
1415       Lisp_Object tem;
1416       tem = XCAR (val);
1417       if (! (NILP (tem)
1418              || (CONSP (tem)
1419                  && (SYMBOLP (XCAR (tem))
1420                      || CONSP (XCAR (tem))))))
1421         error ("Invalid condition handler", tem);
1422     }
1423 
1424   c.tag = Qnil;
1425   c.val = Qnil;
1426   c.backlist = backtrace_list;
1427   c.handlerlist = handlerlist;
1428   c.lisp_eval_depth = lisp_eval_depth;
1429   c.pdlcount = SPECPDL_INDEX ();
1430   c.poll_suppress_count = poll_suppress_count;
1431   c.interrupt_input_blocked = interrupt_input_blocked;
1432   c.gcpro = gcprolist;
1433   c.byte_stack = byte_stack_list;
1434   if (_setjmp (c.jmp))
1435     {
1436       if (!NILP (h.var))
1437         specbind (h.var, c.val);
1438       val = Fprogn (Fcdr (h.chosen_clause));
1439 
1440       /* Note that this just undoes the binding of h.var; whoever
1441          longjumped to us unwound the stack to c.pdlcount before
1442          throwing. */
1443       unbind_to (c.pdlcount, Qnil);
1444       return val;
1445     }
1446   c.next = catchlist;
1447   catchlist = &c;
1448 
1449   h.var = var;
1450   h.handler = handlers;
1451   h.next = handlerlist;
1452   h.tag = &c;
1453   handlerlist = &h;
1454 
1455   val = Feval (bodyform);
1456   catchlist = c.next;
1457   handlerlist = h.next;
1458   return val;
1459 }
1460 
1461 /* Call the function BFUN with no arguments, catching errors within it
1462    according to HANDLERS.  If there is an error, call HFUN with
1463    one argument which is the data that describes the error:
1464    (SIGNALNAME . DATA)
1465 
1466    HANDLERS can be a list of conditions to catch.
1467    If HANDLERS is Qt, catch all errors.
1468    If HANDLERS is Qerror, catch all errors
1469    but allow the debugger to run if that is enabled.  */
1470 
1471 Lisp_Object
1472 internal_condition_case (bfun, handlers, hfun)
1473      Lisp_Object (*bfun) ();
1474      Lisp_Object handlers;
1475      Lisp_Object (*hfun) ();
1476 {
1477   Lisp_Object val;
1478   struct catchtag c;
1479   struct handler h;
1480 
1481   /* Since Fsignal will close off all calls to x_catch_errors,
1482      we will get the wrong results if some are not closed now.  */
1483 #if HAVE_X_WINDOWS
1484   if (x_catching_errors ())
1485     abort ();
1486 #endif
1487 
1488   c.tag = Qnil;
1489   c.val = Qnil;
1490   c.backlist = backtrace_list;
1491   c.handlerlist = handlerlist;
1492   c.lisp_eval_depth = lisp_eval_depth;
1493   c.pdlcount = SPECPDL_INDEX ();
1494   c.poll_suppress_count = poll_suppress_count;
1495   c.interrupt_input_blocked = interrupt_input_blocked;
1496   c.gcpro = gcprolist;
1497   c.byte_stack = byte_stack_list;
1498   if (_setjmp (c.jmp))
1499     {
1500       return (*hfun) (c.val);
1501     }
1502   c.next = catchlist;
1503   catchlist = &c;
1504   h.handler = handlers;
1505   h.var = Qnil;
1506   h.next = handlerlist;
1507   h.tag = &c;
1508   handlerlist = &h;
1509 
1510   val = (*bfun) ();
1511   catchlist = c.next;
1512   handlerlist = h.next;
1513   return val;
1514 }
1515 
1516 /* Like internal_condition_case but call BFUN with ARG as its argument.  */
1517 
1518 Lisp_Object
1519 internal_condition_case_1 (bfun, arg, handlers, hfun)
1520      Lisp_Object (*bfun) ();
1521      Lisp_Object arg;
1522      Lisp_Object handlers;
1523      Lisp_Object (*hfun) ();
1524 {
1525   Lisp_Object val;
1526   struct catchtag c;
1527   struct handler h;
1528 
1529   /* Since Fsignal will close off all calls to x_catch_errors,
1530      we will get the wrong results if some are not closed now.  */
1531 #if HAVE_X_WINDOWS
1532   if (x_catching_errors ())
1533     abort ();
1534 #endif
1535 
1536   c.tag = Qnil;
1537   c.val = Qnil;
1538   c.backlist = backtrace_list;
1539   c.handlerlist = handlerlist;
1540   c.lisp_eval_depth = lisp_eval_depth;
1541   c.pdlcount = SPECPDL_INDEX ();
1542   c.poll_suppress_count = poll_suppress_count;
1543   c.interrupt_input_blocked = interrupt_input_blocked;
1544   c.gcpro = gcprolist;
1545   c.byte_stack = byte_stack_list;
1546   if (_setjmp (c.jmp))
1547     {
1548       return (*hfun) (c.val);
1549     }
1550   c.next = catchlist;
1551   catchlist = &c;
1552   h.handler = handlers;
1553   h.var = Qnil;
1554   h.next = handlerlist;
1555   h.tag = &c;
1556   handlerlist = &h;
1557 
1558   val = (*bfun) (arg);
1559   catchlist = c.next;
1560   handlerlist = h.next;
1561   return val;
1562 }
1563 
1564 /* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as
1565    its arguments.  */
1566 
1567 Lisp_Object
1568 internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object),
1569                            Lisp_Object arg1,
1570                            Lisp_Object arg2,
1571                            Lisp_Object handlers,
1572                            Lisp_Object (*hfun) (Lisp_Object))
1573 {
1574   Lisp_Object val;
1575   struct catchtag c;
1576   struct handler h;
1577 
1578   /* Since Fsignal will close off all calls to x_catch_errors,
1579      we will get the wrong results if some are not closed now.  */
1580 #if HAVE_X_WINDOWS
1581   if (x_catching_errors ())
1582     abort ();
1583 #endif
1584 
1585   c.tag = Qnil;
1586   c.val = Qnil;
1587   c.backlist = backtrace_list;
1588   c.handlerlist = handlerlist;
1589   c.lisp_eval_depth = lisp_eval_depth;
1590   c.pdlcount = SPECPDL_INDEX ();
1591   c.poll_suppress_count = poll_suppress_count;
1592   c.interrupt_input_blocked = interrupt_input_blocked;
1593   c.gcpro = gcprolist;
1594   c.byte_stack = byte_stack_list;
1595   if (_setjmp (c.jmp))
1596     {
1597       return (*hfun) (c.val);
1598     }
1599   c.next = catchlist;
1600   catchlist = &c;
1601   h.handler = handlers;
1602   h.var = Qnil;
1603   h.next = handlerlist;
1604   h.tag = &c;
1605   handlerlist = &h;
1606 
1607   val = (*bfun) (arg1, arg2);
1608   catchlist = c.next;
1609   handlerlist = h.next;
1610   return val;
1611 }
1612 
1613 /* Like internal_condition_case but call BFUN with NARGS as first,
1614    and ARGS as second argument.  */
1615 
1616 Lisp_Object
1617 internal_condition_case_n (Lisp_Object (*bfun) (int, Lisp_Object*),
1618                            int nargs,
1619                            Lisp_Object *args,
1620                            Lisp_Object handlers,
1621                            Lisp_Object (*hfun) (Lisp_Object))
1622 {
1623   Lisp_Object val;
1624   struct catchtag c;
1625   struct handler h;
1626 
1627   /* Since Fsignal will close off all calls to x_catch_errors,
1628      we will get the wrong results if some are not closed now.  */
1629 #if HAVE_X_WINDOWS
1630   if (x_catching_errors ())
1631     abort ();
1632 #endif
1633 
1634   c.tag = Qnil;
1635   c.val = Qnil;
1636   c.backlist = backtrace_list;
1637   c.handlerlist = handlerlist;
1638   c.lisp_eval_depth = lisp_eval_depth;
1639   c.pdlcount = SPECPDL_INDEX ();
1640   c.poll_suppress_count = poll_suppress_count;
1641   c.interrupt_input_blocked = interrupt_input_blocked;
1642   c.gcpro = gcprolist;
1643   c.byte_stack = byte_stack_list;
1644   if (_setjmp (c.jmp))
1645     {
1646       return (*hfun) (c.val);
1647     }
1648   c.next = catchlist;
1649   catchlist = &c;
1650   h.handler = handlers;
1651   h.var = Qnil;
1652   h.next = handlerlist;
1653   h.tag = &c;
1654   handlerlist = &h;
1655 
1656   val = (*bfun) (nargs, args);
1657   catchlist = c.next;
1658   handlerlist = h.next;
1659   return val;
1660 }
1661 
1662 
1663 static Lisp_Object find_handler_clause P_ ((Lisp_Object, Lisp_Object,
1664                                             Lisp_Object, Lisp_Object));
1665 
1666 DEFUN ("signal", Fsignal, Ssignal, 2, 2, 0,
1667        doc: /* Signal an error.  Args are ERROR-SYMBOL and associated DATA.
1668 This function does not return.
1669 
1670 An error symbol is a symbol with an `error-conditions' property
1671 that is a list of condition names.
1672 A handler for any of those names will get to handle this signal.
1673 The symbol `error' should normally be one of them.
1674 
1675 DATA should be a list.  Its elements are printed as part of the error message.
1676 See Info anchor `(elisp)Definition of signal' for some details on how this
1677 error message is constructed.
1678 If the signal is handled, DATA is made available to the handler.
1679 See also the function `condition-case'.  */)
1680      (error_symbol, data)
1681      Lisp_Object error_symbol, data;
1682 {
1683   /* When memory is full, ERROR-SYMBOL is nil,
1684      and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1685      That is a special case--don't do this in other situations.  */
1686   register struct handler *allhandlers = handlerlist;
1687   Lisp_Object conditions;
1688   extern int gc_in_progress;
1689   extern int waiting_for_input;
1690   Lisp_Object string;
1691   Lisp_Object real_error_symbol;
1692   struct backtrace *bp;
1693 
1694   immediate_quit = handling_signal = 0;
1695   abort_on_gc = 0;
1696   if (gc_in_progress || waiting_for_input)
1697     abort ();
1698 
1699   if (NILP (error_symbol))
1700     real_error_symbol = Fcar (data);
1701   else
1702     real_error_symbol = error_symbol;
1703 
1704 #if 0 /* rms: I don't know why this was here,
1705          but it is surely wrong for an error that is handled.  */
1706 #ifdef HAVE_WINDOW_SYSTEM
1707   if (display_hourglass_p)
1708     cancel_hourglass ();
1709 #endif
1710 #endif
1711 
1712   /* This hook is used by edebug.  */
1713   if (! NILP (Vsignal_hook_function)
1714       && ! NILP (error_symbol))
1715     {
1716       /* Edebug takes care of restoring these variables when it exits.  */
1717       if (lisp_eval_depth + 20 > max_lisp_eval_depth)
1718         max_lisp_eval_depth = lisp_eval_depth + 20;
1719 
1720       if (SPECPDL_INDEX () + 40 > max_specpdl_size)
1721         max_specpdl_size = SPECPDL_INDEX () + 40;
1722 
1723       call2 (Vsignal_hook_function, error_symbol, data);
1724     }
1725 
1726   conditions = Fget (real_error_symbol, Qerror_conditions);
1727 
1728   /* Remember from where signal was called.  Skip over the frame for
1729      `signal' itself.  If a frame for `error' follows, skip that,
1730      too.  Don't do this when ERROR_SYMBOL is nil, because that
1731      is a memory-full error.  */
1732   Vsignaling_function = Qnil;
1733   if (backtrace_list && !NILP (error_symbol))
1734     {
1735       bp = backtrace_list->next;
1736       if (bp && bp->function && EQ (*bp->function, Qerror))
1737         bp = bp->next;
1738       if (bp && bp->function)
1739         Vsignaling_function = *bp->function;
1740     }
1741 
1742   for (; handlerlist; handlerlist = handlerlist->next)
1743     {
1744       register Lisp_Object clause;
1745 
1746       clause = find_handler_clause (handlerlist->handler, conditions,
1747                                     error_symbol, data);
1748 
1749       if (EQ (clause, Qlambda))
1750         {
1751           /* We can't return values to code which signaled an error, but we
1752              can continue code which has signaled a quit.  */
1753           if (EQ (real_error_symbol, Qquit))
1754             return Qnil;
1755           else
1756             error ("Cannot return from the debugger in an error");
1757         }
1758 
1759       if (!NILP (clause))
1760         {
1761           Lisp_Object unwind_data;
1762           struct handler *h = handlerlist;
1763 
1764           handlerlist = allhandlers;
1765 
1766           if (NILP (error_symbol))
1767             unwind_data = data;
1768           else
1769             unwind_data = Fcons (error_symbol, data);
1770           h->chosen_clause = clause;
1771           unwind_to_catch (h->tag, unwind_data);
1772         }
1773     }
1774 
1775   handlerlist = allhandlers;
1776   /* If no handler is present now, try to run the debugger,
1777      and if that fails, throw to top level.  */
1778   find_handler_clause (Qerror, conditions, error_symbol, data);
1779   if (catchlist != 0)
1780     Fthrow (Qtop_level, Qt);
1781 
1782   if (! NILP (error_symbol))
1783     data = Fcons (error_symbol, data);
1784 
1785   string = Ferror_message_string (data);
1786   fatal ("%s", SDATA (string), 0);
1787 }
1788 
1789 /* Internal version of Fsignal that never returns.
1790    Used for anything but Qquit (which can return from Fsignal).  */
1791 
1792 void
1793 xsignal (error_symbol, data)
1794      Lisp_Object error_symbol, data;
1795 {
1796   Fsignal (error_symbol, data);
1797   abort ();
1798 }
1799 
1800 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list.  */
1801 
1802 void
1803 xsignal0 (error_symbol)
1804      Lisp_Object error_symbol;
1805 {
1806   xsignal (error_symbol, Qnil);
1807 }
1808 
1809 void
1810 xsignal1 (error_symbol, arg)
1811      Lisp_Object error_symbol, arg;
1812 {
1813   xsignal (error_symbol, list1 (arg));
1814 }
1815 
1816 void
1817 xsignal2 (error_symbol, arg1, arg2)
1818      Lisp_Object error_symbol, arg1, arg2;
1819 {
1820   xsignal (error_symbol, list2 (arg1, arg2));
1821 }
1822 
1823 void
1824 xsignal3 (error_symbol, arg1, arg2, arg3)
1825      Lisp_Object error_symbol, arg1, arg2, arg3;
1826 {
1827   xsignal (error_symbol, list3 (arg1, arg2, arg3));
1828 }
1829 
1830 /* Signal `error' with message S, and additional arg ARG.
1831    If ARG is not a genuine list, make it a one-element list.  */
1832 
1833 void
1834 signal_error (s, arg)
1835      char *s;
1836      Lisp_Object arg;
1837 {
1838   Lisp_Object tortoise, hare;
1839 
1840   hare = tortoise = arg;
1841   while (CONSP (hare))
1842     {
1843       hare = XCDR (hare);
1844       if (!CONSP (hare))
1845         break;
1846 
1847       hare = XCDR (hare);
1848       tortoise = XCDR (tortoise);
1849 
1850       if (EQ (hare, tortoise))
1851         break;
1852     }
1853 
1854   if (!NILP (hare))
1855     arg = Fcons (arg, Qnil);    /* Make it a list.  */
1856 
1857   xsignal (Qerror, Fcons (build_string (s), arg));
1858 }
1859 
1860 
1861 /* Return nonzero if LIST is a non-nil atom or
1862    a list containing one of CONDITIONS.  */
1863 
1864 static int
1865 wants_debugger (list, conditions)
1866      Lisp_Object list, conditions;
1867 {
1868   if (NILP (list))
1869     return 0;
1870   if (! CONSP (list))
1871     return 1;
1872 
1873   while (CONSP (conditions))
1874     {
1875       Lisp_Object this, tail;
1876       this = XCAR (conditions);
1877       for (tail = list; CONSP (tail); tail = XCDR (tail))
1878         if (EQ (XCAR (tail), this))
1879           return 1;
1880       conditions = XCDR (conditions);
1881     }
1882   return 0;
1883 }
1884 
1885 /* Return 1 if an error with condition-symbols CONDITIONS,
1886    and described by SIGNAL-DATA, should skip the debugger
1887    according to debugger-ignored-errors.  */
1888 
1889 static int
1890 skip_debugger (conditions, data)
1891      Lisp_Object conditions, data;
1892 {
1893   Lisp_Object tail;
1894   int first_string = 1;
1895   Lisp_Object error_message;
1896 
1897   error_message = Qnil;
1898   for (tail = Vdebug_ignored_errors; CONSP (tail); tail = XCDR (tail))
1899     {
1900       if (STRINGP (XCAR (tail)))
1901         {
1902           if (first_string)
1903             {
1904               error_message = Ferror_message_string (data);
1905               first_string = 0;
1906             }
1907 
1908           if (fast_string_match (XCAR (tail), error_message) >= 0)
1909             return 1;
1910         }
1911       else
1912         {
1913           Lisp_Object contail;
1914 
1915           for (contail = conditions; CONSP (contail); contail = XCDR (contail))
1916             if (EQ (XCAR (tail), XCAR (contail)))
1917               return 1;
1918         }
1919     }
1920 
1921   return 0;
1922 }
1923 
1924 /* Call the debugger if calling it is currently enabled for CONDITIONS.
1925    SIG and DATA describe the signal, as in find_handler_clause.  */
1926 
1927 static int
1928 maybe_call_debugger (conditions, sig, data)
1929      Lisp_Object conditions, sig, data;
1930 {
1931   Lisp_Object combined_data;
1932 
1933   combined_data = Fcons (sig, data);
1934 
1935   if (
1936       /* Don't try to run the debugger with interrupts blocked.
1937          The editing loop would return anyway.  */
1938       ! INPUT_BLOCKED_P
1939       /* Does user want to enter debugger for this kind of error?  */
1940       && (EQ (sig, Qquit)
1941           ? debug_on_quit
1942           : wants_debugger (Vdebug_on_error, conditions))
1943       && ! skip_debugger (conditions, combined_data)
1944       /* rms: what's this for? */
1945       && when_entered_debugger < num_nonmacro_input_events)
1946     {
1947       call_debugger (Fcons (Qerror, Fcons (combined_data, Qnil)));
1948       return 1;
1949     }
1950 
1951   return 0;
1952 }
1953 
1954 /* Value of Qlambda means we have called debugger and user has continued.
1955    There are two ways to pass SIG and DATA:
1956     = SIG is the error symbol, and DATA is the rest of the data.
1957     = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
1958        This is for memory-full errors only.
1959 
1960    We need to increase max_specpdl_size temporarily around
1961    anything we do that can push on the specpdl, so as not to get
1962    a second error here in case we're handling specpdl overflow.  */
1963 
1964 static Lisp_Object
1965 find_handler_clause (handlers, conditions, sig, data)
1966      Lisp_Object handlers, conditions, sig, data;
1967 {
1968   register Lisp_Object h;
1969   register Lisp_Object tem;
1970   int debugger_called = 0;
1971   int debugger_considered = 0;
1972 
1973   /* t is used by handlers for all conditions, set up by C code.  */
1974   if (EQ (handlers, Qt))
1975     return Qt;
1976 
1977   /* Don't run the debugger for a memory-full error.
1978      (There is no room in memory to do that!)  */
1979   if (NILP (sig))
1980     debugger_considered = 1;
1981 
1982   /* error is used similarly, but means print an error message
1983      and run the debugger if that is enabled.  */
1984   if (EQ (handlers, Qerror)
1985       || !NILP (Vdebug_on_signal)) /* This says call debugger even if
1986                                       there is a handler.  */
1987     {
1988       if (!NILP (sig) && wants_debugger (Vstack_trace_on_error, conditions))
1989         {
1990           max_lisp_eval_depth += 15;
1991           max_specpdl_size++;
1992           if (noninteractive)
1993             Fbacktrace ();
1994           else
1995             internal_with_output_to_temp_buffer
1996               ("*Backtrace*",
1997                (Lisp_Object (*) (Lisp_Object)) Fbacktrace,
1998                Qnil);
1999           max_specpdl_size--;
2000           max_lisp_eval_depth -= 15;
2001         }
2002 
2003       if (!debugger_considered)
2004         {
2005           debugger_considered = 1;
2006           debugger_called = maybe_call_debugger (conditions, sig, data);
2007         }
2008 
2009       /* If there is no handler, return saying whether we ran the debugger.  */
2010       if (EQ (handlers, Qerror))
2011         {
2012           if (debugger_called)
2013             return Qlambda;
2014           return Qt;
2015         }
2016     }
2017 
2018   for (h = handlers; CONSP (h); h = Fcdr (h))
2019     {
2020       Lisp_Object handler, condit;
2021 
2022       handler = Fcar (h);
2023       if (!CONSP (handler))
2024         continue;
2025       condit = Fcar (handler);
2026       /* Handle a single condition name in handler HANDLER.  */
2027       if (SYMBOLP (condit))
2028         {
2029           tem = Fmemq (Fcar (handler), conditions);
2030           if (!NILP (tem))
2031             return handler;
2032         }
2033       /* Handle a list of condition names in handler HANDLER.  */
2034       else if (CONSP (condit))
2035         {
2036           Lisp_Object tail;
2037           for (tail = condit; CONSP (tail); tail = XCDR (tail))
2038             {
2039               tem = Fmemq (Fcar (tail), conditions);
2040               if (!NILP (tem))
2041                 {
2042                   /* This handler is going to apply.
2043                      Does it allow the debugger to run first?  */
2044                   if (! debugger_considered && !NILP (Fmemq (Qdebug, condit)))
2045                     maybe_call_debugger (conditions, sig, data);
2046                   return handler;
2047                 }
2048             }
2049         }
2050     }
2051 
2052   return Qnil;
2053 }
2054 
2055 /* dump an error message; called like printf */
2056 
2057 /* VARARGS 1 */
2058 void
2059 error (m, a1, a2, a3)
2060      char *m;
2061      char *a1, *a2, *a3;
2062 {
2063   char buf[200];
2064   int size = 200;
2065   int mlen;
2066   char *buffer = buf;
2067   char *args[3];
2068   int allocated = 0;
2069   Lisp_Object string;
2070 
2071   args[0] = a1;
2072   args[1] = a2;
2073   args[2] = a3;
2074 
2075   mlen = strlen (m);
2076 
2077   while (1)
2078     {
2079       int used = doprnt (buffer, size, m, m + mlen, 3, args);
2080       if (used < size)
2081         break;
2082       size *= 2;
2083       if (allocated)
2084         buffer = (char *) xrealloc (buffer, size);
2085       else
2086         {
2087           buffer = (char *) xmalloc (size);
2088           allocated = 1;
2089         }
2090     }
2091 
2092   string = build_string (buffer);
2093   if (allocated)
2094     xfree (buffer);
2095 
2096   xsignal1 (Qerror, string);
2097 }
2098 
2099 DEFUN ("commandp", Fcommandp, Scommandp, 1, 2, 0,
2100        doc: /* Non-nil if FUNCTION makes provisions for interactive calling.
2101 This means it contains a description for how to read arguments to give it.
2102 The value is nil for an invalid function or a symbol with no function
2103 definition.
2104 
2105 Interactively callable functions include strings and vectors (treated
2106 as keyboard macros), lambda-expressions that contain a top-level call
2107 to `interactive', autoload definitions made by `autoload' with non-nil
2108 fourth argument, and some of the built-in functions of Lisp.
2109 
2110 Also, a symbol satisfies `commandp' if its function definition does so.
2111 
2112 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
2113 then strings and vectors are not accepted.  */)
2114      (function, for_call_interactively)
2115      Lisp_Object function, for_call_interactively;
2116 {
2117   register Lisp_Object fun;
2118   register Lisp_Object funcar;
2119   Lisp_Object if_prop = Qnil;
2120 
2121   fun = function;
2122 
2123   fun = indirect_function (fun); /* Check cycles. */
2124   if (NILP (fun) || EQ (fun, Qunbound))
2125     return Qnil;
2126 
2127   /* Check an `interactive-form' property if present, analogous to the
2128      function-documentation property. */
2129   fun = function;
2130   while (SYMBOLP (fun))
2131     {
2132       Lisp_Object tmp = Fget (fun, Qinteractive_form);
2133       if (!NILP (tmp))
2134         if_prop = Qt;
2135       fun = Fsymbol_function (fun);
2136     }
2137 
2138   /* Emacs primitives are interactive if their DEFUN specifies an
2139      interactive spec.  */
2140   if (SUBRP (fun))
2141     return XSUBR (fun)->intspec ? Qt : if_prop;
2142 
2143   /* Bytecode objects are interactive if they are long enough to
2144      have an element whose index is COMPILED_INTERACTIVE, which is
2145      where the interactive spec is stored.  */
2146   else if (COMPILEDP (fun))
2147     return ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_INTERACTIVE
2148             ? Qt : if_prop);
2149 
2150   /* Strings and vectors are keyboard macros.  */
2151   if (STRINGP (fun) || VECTORP (fun))
2152     return (NILP (for_call_interactively) ? Qt : Qnil);
2153 
2154   /* Lists may represent commands.  */
2155   if (!CONSP (fun))
2156     return Qnil;
2157   funcar = XCAR (fun);
2158   if (EQ (funcar, Qlambda))
2159     return !NILP (Fassq (Qinteractive, Fcdr (XCDR (fun)))) ? Qt : if_prop;
2160   if (EQ (funcar, Qautoload))
2161     return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun))))) ? Qt : if_prop;
2162   else
2163     return Qnil;
2164 }
2165 
2166 DEFUN ("autoload", Fautoload, Sautoload, 2, 5, 0,
2167        doc: /* Define FUNCTION to autoload from FILE.
2168 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
2169 Third arg DOCSTRING is documentation for the function.
2170 Fourth arg INTERACTIVE if non-nil says function can be called interactively.
2171 Fifth arg TYPE indicates the type of the object:
2172    nil or omitted says FUNCTION is a function,
2173    `keymap' says FUNCTION is really a keymap, and
2174    `macro' or t says FUNCTION is really a macro.
2175 Third through fifth args give info about the real definition.
2176 They default to nil.
2177 If FUNCTION is already defined other than as an autoload,
2178 this does nothing and returns nil.  */)
2179      (function, file, docstring, interactive, type)
2180      Lisp_Object function, file, docstring, interactive, type;
2181 {
2182   CHECK_SYMBOL (function);
2183   CHECK_STRING (file);
2184 
2185   /* If function is defined and not as an autoload, don't override */
2186   if (!EQ (XSYMBOL (function)->function, Qunbound)
2187       && !(CONSP (XSYMBOL (function)->function)
2188            && EQ (XCAR (XSYMBOL (function)->function), Qautoload)))
2189     return Qnil;
2190 
2191   if (NILP (Vpurify_flag))
2192     /* Only add entries after dumping, because the ones before are
2193        not useful and else we get loads of them from the loaddefs.el.  */
2194     LOADHIST_ATTACH (Fcons (Qautoload, function));
2195   else
2196     /* We don't want the docstring in purespace (instead,
2197        Snarf-documentation should (hopefully) overwrite it).
2198        We used to use 0 here, but that leads to accidental sharing in
2199        purecopy's hash-consing, so we use a (hopefully) unique integer
2200        instead.  */
2201     docstring = make_number (XHASH (function));
2202   return Ffset (function,
2203                 Fpurecopy (list5 (Qautoload, file, docstring,
2204                                   interactive, type)));
2205 }
2206 
2207 Lisp_Object
2208 un_autoload (oldqueue)
2209      Lisp_Object oldqueue;
2210 {
2211   register Lisp_Object queue, first, second;
2212 
2213   /* Queue to unwind is current value of Vautoload_queue.
2214      oldqueue is the shadowed value to leave in Vautoload_queue.  */
2215   queue = Vautoload_queue;
2216   Vautoload_queue = oldqueue;
2217   while (CONSP (queue))
2218     {
2219       first = XCAR (queue);
2220       second = Fcdr (first);
2221       first = Fcar (first);
2222       if (EQ (first, make_number (0)))
2223         Vfeatures = second;
2224       else
2225         Ffset (first, second);
2226       queue = XCDR (queue);
2227     }
2228   return Qnil;
2229 }
2230 
2231 /* Load an autoloaded function.
2232    FUNNAME is the symbol which is the function's name.
2233    FUNDEF is the autoload definition (a list).  */
2234 
2235 void
2236 do_autoload (fundef, funname)
2237      Lisp_Object fundef, funname;
2238 {
2239   int count = SPECPDL_INDEX ();
2240   Lisp_Object fun;
2241   struct gcpro gcpro1, gcpro2, gcpro3;
2242 
2243   /* This is to make sure that loadup.el gives a clear picture
2244      of what files are preloaded and when.  */
2245   if (! NILP (Vpurify_flag))
2246     error ("Attempt to autoload %s while preparing to dump",
2247            SDATA (SYMBOL_NAME (funname)));
2248 
2249   fun = funname;
2250   CHECK_SYMBOL (funname);
2251   GCPRO3 (fun, funname, fundef);
2252 
2253   /* Preserve the match data.  */
2254   record_unwind_save_match_data ();
2255 
2256   /* If autoloading gets an error (which includes the error of failing
2257      to define the function being called), we use Vautoload_queue
2258      to undo function definitions and `provide' calls made by
2259      the function.  We do this in the specific case of autoloading
2260      because autoloading is not an explicit request "load this file",
2261      but rather a request to "call this function".
2262      
2263      The value saved here is to be restored into Vautoload_queue.  */
2264   record_unwind_protect (un_autoload, Vautoload_queue);
2265   Vautoload_queue = Qt;
2266   Fload (Fcar (Fcdr (fundef)), Qnil, Qt, Qnil, Qt);
2267 
2268   /* Once loading finishes, don't undo it.  */
2269   Vautoload_queue = Qt;
2270   unbind_to (count, Qnil);
2271 
2272   fun = Findirect_function (fun, Qnil);
2273 
2274   if (!NILP (Fequal (fun, fundef)))
2275     error ("Autoloading failed to define function %s",
2276            SDATA (SYMBOL_NAME (funname)));
2277   UNGCPRO;
2278 }
2279 
2280 
2281 DEFUN ("eval", Feval, Seval, 1, 1, 0,
2282        doc: /* Evaluate FORM and return its value.  */)
2283      (form)
2284      Lisp_Object form;
2285 {
2286   Lisp_Object fun, val, original_fun, original_args;
2287   Lisp_Object funcar;
2288   struct backtrace backtrace;
2289   struct gcpro gcpro1, gcpro2, gcpro3;
2290 
2291   if (handling_signal)
2292     abort ();
2293 
2294   if (SYMBOLP (form))
2295     return Fsymbol_value (form);
2296   if (!CONSP (form))
2297     return form;
2298 
2299   QUIT;
2300   if ((consing_since_gc > gc_cons_threshold
2301        && consing_since_gc > gc_relative_threshold)
2302       ||
2303       (!NILP (Vmemory_full) && consing_since_gc > memory_full_cons_threshold))
2304     {
2305       GCPRO1 (form);
2306       Fgarbage_collect ();
2307       UNGCPRO;
2308     }
2309 
2310   if (++lisp_eval_depth > max_lisp_eval_depth)
2311     {
2312       if (max_lisp_eval_depth < 100)
2313         max_lisp_eval_depth = 100;
2314       if (lisp_eval_depth > max_lisp_eval_depth)
2315         error ("Lisp nesting exceeds `max-lisp-eval-depth'");
2316     }
2317 
2318   original_fun = Fcar (form);
2319   original_args = Fcdr (form);
2320 
2321   backtrace.next = backtrace_list;
2322   backtrace_list = &backtrace;
2323   backtrace.function = &original_fun; /* This also protects them from gc */
2324   backtrace.args = &original_args;
2325   backtrace.nargs = UNEVALLED;
2326   backtrace.evalargs = 1;
2327   backtrace.debug_on_exit = 0;
2328 
2329   if (debug_on_next_call)
2330     do_debug_on_call (Qt);
2331 
2332   /* At this point, only original_fun and original_args
2333      have values that will be used below */
2334  retry:
2335 
2336   /* Optimize for no indirection.  */
2337   fun = original_fun;
2338   if (SYMBOLP (fun) && !EQ (fun, Qunbound)
2339       && (fun = XSYMBOL (fun)->function, SYMBOLP (fun)))
2340     fun = indirect_function (fun);
2341 
2342   if (SUBRP (fun))
2343     {
2344       Lisp_Object numargs;
2345       Lisp_Object argvals[8];
2346       Lisp_Object args_left;
2347       register int i, maxargs;
2348 
2349       args_left = original_args;
2350       numargs = Flength (args_left);
2351 
2352       CHECK_CONS_LIST ();
2353 
2354       if (XINT (numargs) < XSUBR (fun)->min_args ||
2355           (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < XINT (numargs)))
2356         xsignal2 (Qwrong_number_of_arguments, original_fun, numargs);
2357 
2358       if (XSUBR (fun)->max_args == UNEVALLED)
2359         {
2360           backtrace.evalargs = 0;
2361           val = (*XSUBR (fun)->function) (args_left);
2362           goto done;
2363         }
2364 
2365       if (XSUBR (fun)->max_args == MANY)
2366         {
2367           /* Pass a vector of evaluated arguments */
2368           Lisp_Object *vals;
2369           register int argnum = 0;
2370 
2371           vals = (Lisp_Object *) alloca (XINT (numargs) * sizeof (Lisp_Object));
2372 
2373           GCPRO3 (args_left, fun, fun);
2374           gcpro3.var = vals;
2375           gcpro3.nvars = 0;
2376 
2377           while (!NILP (args_left))
2378             {
2379               vals[argnum++] = Feval (Fcar (args_left));
2380               args_left = Fcdr (args_left);
2381               gcpro3.nvars = argnum;
2382             }
2383 
2384           backtrace.args = vals;
2385           backtrace.nargs = XINT (numargs);
2386 
2387           val = (*XSUBR (fun)->function) (XINT (numargs), vals);
2388           UNGCPRO;
2389           goto done;
2390         }
2391 
2392       GCPRO3 (args_left, fun, fun);
2393       gcpro3.var = argvals;
2394       gcpro3.nvars = 0;
2395 
2396       maxargs = XSUBR (fun)->max_args;
2397       for (i = 0; i < maxargs; args_left = Fcdr (args_left))
2398         {
2399           argvals[i] = Feval (Fcar (args_left));
2400           gcpro3.nvars = ++i;
2401         }
2402 
2403       UNGCPRO;
2404 
2405       backtrace.args = argvals;
2406       backtrace.nargs = XINT (numargs);
2407 
2408       switch (i)
2409         {
2410         case 0:
2411           val = (*XSUBR (fun)->function) ();
2412           goto done;
2413         case 1:
2414           val = (*XSUBR (fun)->function) (argvals[0]);
2415           goto done;
2416         case 2:
2417           val = (*XSUBR (fun)->function) (argvals[0], argvals[1]);
2418           goto done;
2419         case 3:
2420           val = (*XSUBR (fun)->function) (argvals[0], argvals[1],
2421                                           argvals[2]);
2422           goto done;
2423         case 4:
2424           val = (*XSUBR (fun)->function) (argvals[0], argvals[1],
2425                                           argvals[2], argvals[3]);
2426           goto done;
2427         case 5:
2428           val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2],
2429                                           argvals[3], argvals[4]);
2430           goto done;
2431         case 6:
2432           val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2],
2433                                           argvals[3], argvals[4], argvals[5]);
2434           goto done;
2435         case 7:
2436           val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2],
2437                                           argvals[3], argvals[4], argvals[5],
2438                                           argvals[6]);
2439           goto done;
2440 
2441         case 8:
2442           val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2],
2443                                           argvals[3], argvals[4], argvals[5],
2444                                           argvals[6], argvals[7]);
2445           goto done;
2446 
2447         default:
2448           /* Someone has created a subr that takes more arguments than
2449              is supported by this code.  We need to either rewrite the
2450              subr to use a different argument protocol, or add more
2451              cases to this switch.  */
2452           abort ();
2453         }
2454     }
2455   if (COMPILEDP (fun))
2456     val = apply_lambda (fun, original_args, 1);
2457   else
2458     {
2459       if (EQ (fun, Qunbound))
2460         xsignal1 (Qvoid_function, original_fun);
2461       if (!CONSP (fun))
2462         xsignal1 (Qinvalid_function, original_fun);
2463       funcar = XCAR (fun);
2464       if (!SYMBOLP (funcar))
2465         xsignal1 (Qinvalid_function, original_fun);
2466       if (EQ (funcar, Qautoload))
2467         {
2468           do_autoload (fun, original_fun);
2469           goto retry;
2470         }
2471       if (EQ (funcar, Qmacro))
2472         val = Feval (apply1 (Fcdr (fun), original_args));
2473       else if (EQ (funcar, Qlambda))
2474         val = apply_lambda (fun, original_args, 1);
2475       else
2476         xsignal1 (Qinvalid_function, original_fun);
2477     }
2478  done:
2479   CHECK_CONS_LIST ();
2480 
2481   lisp_eval_depth--;
2482   if (backtrace.debug_on_exit)
2483     val = call_debugger (Fcons (Qexit, Fcons (val, Qnil)));
2484   backtrace_list = backtrace.next;
2485 
2486   return val;
2487 }
2488 
2489 DEFUN ("apply", Fapply, Sapply, 2, MANY, 0,
2490        doc: /* Call FUNCTION with our remaining args, using our last arg as list of args.
2491 Then return the value FUNCTION returns.
2492 Thus, (apply '+ 1 2 '(3 4)) returns 10.
2493 usage: (apply FUNCTION &rest ARGUMENTS)  */)
2494      (nargs, args)
2495      int nargs;
2496      Lisp_Object *args;
2497 {
2498   register int i, numargs;
2499   register Lisp_Object spread_arg;
2500   register Lisp_Object *funcall_args;
2501   Lisp_Object fun;
2502   struct gcpro gcpro1;
2503 
2504   fun = args [0];
2505   funcall_args = 0;
2506   spread_arg = args [nargs - 1];
2507   CHECK_LIST (spread_arg);
2508 
2509   numargs = XINT (Flength (spread_arg));
2510 
2511   if (numargs == 0)
2512     return Ffuncall (nargs - 1, args);
2513   else if (numargs == 1)
2514     {
2515       args [nargs - 1] = XCAR (spread_arg);
2516       return Ffuncall (nargs, args);
2517     }
2518 
2519   numargs += nargs - 2;
2520 
2521   /* Optimize for no indirection.  */
2522   if (SYMBOLP (fun) && !EQ (fun, Qunbound)
2523       && (fun = XSYMBOL (fun)->function, SYMBOLP (fun)))
2524     fun = indirect_function (fun);
2525   if (EQ (fun, Qunbound))
2526     {
2527       /* Let funcall get the error */
2528       fun = args[0];
2529       goto funcall;
2530     }
2531 
2532   if (SUBRP (fun))
2533     {
2534       if (numargs < XSUBR (fun)->min_args
2535           || (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs))
2536         goto funcall;           /* Let funcall get the error */
2537       else if (XSUBR (fun)->max_args > numargs)
2538         {
2539           /* Avoid making funcall cons up a yet another new vector of arguments
2540              by explicitly supplying nil's for optional values */
2541           funcall_args = (Lisp_Object *) alloca ((1 + XSUBR (fun)->max_args)
2542                                                  * sizeof (Lisp_Object));
2543           for (i = numargs; i < XSUBR (fun)->max_args;)
2544             funcall_args[++i] = Qnil;
2545           GCPRO1 (*funcall_args);
2546           gcpro1.nvars = 1 + XSUBR (fun)->max_args;
2547         }
2548     }
2549  funcall:
2550   /* We add 1 to numargs because funcall_args includes the
2551      function itself as well as its arguments.  */
2552   if (!funcall_args)
2553     {
2554       funcall_args = (Lisp_Object *) alloca ((1 + numargs)
2555                                              * sizeof (Lisp_Object));
2556       GCPRO1 (*funcall_args);
2557       gcpro1.nvars = 1 + numargs;
2558     }
2559 
2560   bcopy (args, funcall_args, nargs * sizeof (Lisp_Object));
2561   /* Spread the last arg we got.  Its first element goes in
2562      the slot that it used to occupy, hence this value of I.  */
2563   i = nargs - 1;
2564   while (!NILP (spread_arg))
2565     {
2566       funcall_args [i++] = XCAR (spread_arg);
2567       spread_arg = XCDR (spread_arg);
2568     }
2569 
2570   /* By convention, the caller needs to gcpro Ffuncall's args.  */
2571   RETURN_UNGCPRO (Ffuncall (gcpro1.nvars, funcall_args));
2572 }
2573 
2574 /* Run hook variables in various ways.  */
2575 
2576 enum run_hooks_condition {to_completion, until_success, until_failure};
2577 static Lisp_Object run_hook_with_args P_ ((int, Lisp_Object *,
2578                                            enum run_hooks_condition));
2579 
2580 DEFUN ("run-hooks", Frun_hooks, Srun_hooks, 0, MANY, 0,
2581        doc: /* Run each hook in HOOKS.
2582 Each argument should be a symbol, a hook variable.
2583 These symbols are processed in the order specified.
2584 If a hook symbol has a non-nil value, that value may be a function
2585 or a list of functions to be called to run the hook.
2586 If the value is a function, it is called with no arguments.
2587 If it is a list, the elements are called, in order, with no arguments.
2588 
2589 Major modes should not use this function directly to run their mode
2590 hook; they should use `run-mode-hooks' instead.
2591 
2592 Do not use `make-local-variable' to make a hook variable buffer-local.
2593 Instead, use `add-hook' and specify t for the LOCAL argument.
2594 usage: (run-hooks &rest HOOKS)  */)
2595      (nargs, args)
2596      int nargs;
2597      Lisp_Object *args;
2598 {
2599   Lisp_Object hook[1];
2600   register int i;
2601 
2602   for (i = 0; i < nargs; i++)
2603     {
2604       hook[0] = args[i];
2605       run_hook_with_args (1, hook, to_completion);
2606     }
2607 
2608   return Qnil;
2609 }
2610 
2611 DEFUN ("run-hook-with-args", Frun_hook_with_args,
2612        Srun_hook_with_args, 1, MANY, 0,
2613        doc: /* Run HOOK with the specified arguments ARGS.
2614 HOOK should be a symbol, a hook variable.  If HOOK has a non-nil
2615 value, that value may be a function or a list of functions to be
2616 called to run the hook.  If the value is a function, it is called with
2617 the given arguments and its return value is returned.  If it is a list
2618 of functions, those functions are called, in order,
2619 with the given arguments ARGS.
2620 It is best not to depend on the value returned by `run-hook-with-args',
2621 as that may change.
2622 
2623 Do not use `make-local-variable' to make a hook variable buffer-local.
2624 Instead, use `add-hook' and specify t for the LOCAL argument.
2625 usage: (run-hook-with-args HOOK &rest ARGS)  */)
2626      (nargs, args)
2627      int nargs;
2628      Lisp_Object *args;
2629 {
2630   return run_hook_with_args (nargs, args, to_completion);
2631 }
2632 
2633 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success,
2634        Srun_hook_with_args_until_success, 1, MANY, 0,
2635        doc: /* Run HOOK with the specified arguments ARGS.
2636 HOOK should be a symbol, a hook variable.  If HOOK has a non-nil
2637 value, that value may be a function or a list of functions to be
2638 called to run the hook.  If the value is a function, it is called with
2639 the given arguments and its return value is returned.
2640 If it is a list of functions, those functions are called, in order,
2641 with the given arguments ARGS, until one of them
2642 returns a non-nil value.  Then we return that value.
2643 However, if they all return nil, we return nil.
2644 
2645 Do not use `make-local-variable' to make a hook variable buffer-local.
2646 Instead, use `add-hook' and specify t for the LOCAL argument.
2647 usage: (run-hook-with-args-until-success HOOK &rest ARGS)  */)
2648      (nargs, args)
2649      int nargs;
2650      Lisp_Object *args;
2651 {
2652   return run_hook_with_args (nargs, args, until_success);
2653 }
2654 
2655 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure,
2656        Srun_hook_with_args_until_failure, 1, MANY, 0,
2657        doc: /* Run HOOK with the specified arguments ARGS.
2658 HOOK should be a symbol, a hook variable.  If HOOK has a non-nil
2659 value, that value may be a function or a list of functions to be
2660 called to run the hook.  If the value is a function, it is called with
2661 the given arguments and its return value is returned.
2662 If it is a list of functions, those functions are called, in order,
2663 with the given arguments ARGS, until one of them returns nil.
2664 Then we return nil.  However, if they all return non-nil, we return non-nil.
2665 
2666 Do not use `make-local-variable' to make a hook variable buffer-local.
2667 Instead, use `add-hook' and specify t for the LOCAL argument.
2668 usage: (run-hook-with-args-until-failure HOOK &rest ARGS)  */)
2669      (nargs, args)
2670      int nargs;
2671      Lisp_Object *args;
2672 {
2673   return run_hook_with_args (nargs, args, until_failure);
2674 }
2675 
2676 /* ARGS[0] should be a hook symbol.
2677    Call each of the functions in the hook value, passing each of them
2678    as arguments all the rest of ARGS (all NARGS - 1 elements).
2679    COND specifies a condition to test after each call
2680    to decide whether to stop.
2681    The caller (or its caller, etc) must gcpro all of ARGS,
2682    except that it isn't necessary to gcpro ARGS[0].  */
2683 
2684 static Lisp_Object
2685 run_hook_with_args (nargs, args, cond)
2686      int nargs;
2687      Lisp_Object *args;
2688      enum run_hooks_condition cond;
2689 {
2690   Lisp_Object sym, val, ret;
2691   struct gcpro gcpro1, gcpro2, gcpro3;
2692 
2693   /* If we are dying or still initializing,
2694      don't do anything--it would probably crash if we tried.  */
2695   if (NILP (Vrun_hooks))
2696     return Qnil;
2697 
2698   sym = args[0];
2699   val = find_symbol_value (sym);
2700   ret = (cond == until_failure ? Qt : Qnil);
2701 
2702   if (EQ (val, Qunbound) || NILP (val))
2703     return ret;
2704   else if (!CONSP (val) || EQ (XCAR (val), Qlambda))
2705     {
2706       args[0] = val;
2707       return Ffuncall (nargs, args);
2708     }
2709   else
2710     {
2711       Lisp_Object globals = Qnil;
2712       GCPRO3 (sym, val, globals);
2713 
2714       for (;
2715            CONSP (val) && ((cond == to_completion)
2716                            || (cond == until_success ? NILP (ret)
2717                                : !NILP (ret)));
2718            val = XCDR (val))
2719         {
2720           if (EQ (XCAR (val), Qt))
2721             {
2722               /* t indicates this hook has a local binding;
2723                  it means to run the global binding too.  */
2724               globals = Fdefault_value (sym);
2725               if (NILP (globals)) continue;
2726 
2727               if (!CONSP (globals) || EQ (XCAR (globals), Qlambda))
2728                 {
2729                   args[0] = globals;
2730                   ret = Ffuncall (nargs, args);
2731                 }
2732               else
2733                 {
2734                   for (;
2735                        CONSP (globals) && ((cond == to_completion)
2736                                            || (cond == until_success ? NILP (ret)
2737                                                : !NILP (ret)));
2738                        globals = XCDR (globals))
2739                     {
2740                       args[0] = XCAR (globals);
2741                       /* In a global value, t should not occur.  If it does, we
2742                          must ignore it to avoid an endless loop.  */
2743                       if (!EQ (args[0], Qt))
2744                         ret = Ffuncall (nargs, args);
2745                     }
2746                 }
2747             }
2748           else
2749             {
2750               args[0] = XCAR (val);
2751               ret = Ffuncall (nargs, args);
2752             }
2753         }
2754 
2755       UNGCPRO;
2756       return ret;
2757     }
2758 }
2759 
2760 /* Run a hook symbol ARGS[0], but use FUNLIST instead of the actual
2761    present value of that symbol.
2762    Call each element of FUNLIST,
2763    passing each of them the rest of ARGS.
2764    The caller (or its caller, etc) must gcpro all of ARGS,
2765    except that it isn't necessary to gcpro ARGS[0].  */
2766 
2767 Lisp_Object
2768 run_hook_list_with_args (funlist, nargs, args)
2769      Lisp_Object funlist;
2770      int nargs;
2771      Lisp_Object *args;
2772 {
2773   Lisp_Object sym;
2774   Lisp_Object val;
2775   Lisp_Object globals;
2776   struct gcpro gcpro1, gcpro2, gcpro3;
2777 
2778   sym = args[0];
2779   globals = Qnil;
2780   GCPRO3 (sym, val, globals);
2781 
2782   for (val = funlist; CONSP (val); val = XCDR (val))
2783     {
2784       if (EQ (XCAR (val), Qt))
2785         {
2786           /* t indicates this hook has a local binding;
2787              it means to run the global binding too.  */
2788 
2789           for (globals = Fdefault_value (sym);
2790                CONSP (globals);
2791                globals = XCDR (globals))
2792             {
2793               args[0] = XCAR (globals);
2794               /* In a global value, t should not occur.  If it does, we
2795                  must ignore it to avoid an endless loop.  */
2796               if (!EQ (args[0], Qt))
2797                 Ffuncall (nargs, args);
2798             }
2799         }
2800       else
2801         {
2802           args[0] = XCAR (val);
2803           Ffuncall (nargs, args);
2804         }
2805     }
2806   UNGCPRO;
2807   return Qnil;
2808 }
2809 
2810 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2.  */
2811 
2812 void
2813 run_hook_with_args_2 (hook, arg1, arg2)
2814      Lisp_Object hook, arg1, arg2;
2815 {
2816   Lisp_Object temp[3];
2817   temp[0] = hook;
2818   temp[1] = arg1;
2819   temp[2] = arg2;
2820 
2821   Frun_hook_with_args (3, temp);
2822 }
2823 
2824 /* Apply fn to arg */
2825 Lisp_Object
2826 apply1 (fn, arg)
2827      Lisp_Object fn, arg;
2828 {
2829   struct gcpro gcpro1;
2830 
2831   GCPRO1 (fn);
2832   if (NILP (arg))
2833     RETURN_UNGCPRO (Ffuncall (1, &fn));
2834   gcpro1.nvars = 2;
2835   {
2836     Lisp_Object args[2];
2837     args[0] = fn;
2838     args[1] = arg;
2839     gcpro1.var = args;
2840     RETURN_UNGCPRO (Fapply (2, args));
2841   }
2842 }
2843 
2844 /* Call function fn on no arguments */
2845 Lisp_Object
2846 call0 (fn)
2847      Lisp_Object fn;
2848 {
2849   struct gcpro gcpro1;
2850 
2851   GCPRO1 (fn);
2852   RETURN_UNGCPRO (Ffuncall (1, &fn));
2853 }
2854 
2855 /* Call function fn with 1 argument arg1 */
2856 /* ARGSUSED */
2857 Lisp_Object
2858 call1 (fn, arg1)
2859      Lisp_Object fn, arg1;
2860 {
2861   struct gcpro gcpro1;
2862   Lisp_Object args[2];
2863 
2864   args[0] = fn;
2865   args[1] = arg1;
2866   GCPRO1 (args[0]);
2867   gcpro1.nvars = 2;
2868   RETURN_UNGCPRO (Ffuncall (2, args));
2869 }
2870 
2871 /* Call function fn with 2 arguments arg1, arg2 */
2872 /* ARGSUSED */
2873 Lisp_Object
2874 call2 (fn, arg1, arg2)
2875      Lisp_Object fn, arg1, arg2;
2876 {
2877   struct gcpro gcpro1;
2878   Lisp_Object args[3];
2879   args[0] = fn;
2880   args[1] = arg1;
2881   args[2] = arg2;
2882   GCPRO1 (args[0]);
2883   gcpro1.nvars = 3;
2884   RETURN_UNGCPRO (Ffuncall (3, args));
2885 }
2886 
2887 /* Call function fn with 3 arguments arg1, arg2, arg3 */
2888 /* ARGSUSED */
2889 Lisp_Object
2890 call3 (fn, arg1, arg2, arg3)
2891      Lisp_Object fn, arg1, arg2, arg3;
2892 {
2893   struct gcpro gcpro1;
2894   Lisp_Object args[4];
2895   args[0] = fn;
2896   args[1] = arg1;
2897   args[2] = arg2;
2898   args[3] = arg3;
2899   GCPRO1 (args[0]);
2900   gcpro1.nvars = 4;
2901   RETURN_UNGCPRO (Ffuncall (4, args));
2902 }
2903 
2904 /* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
2905 /* ARGSUSED */
2906 Lisp_Object
2907 call4 (fn, arg1, arg2, arg3, arg4)
2908      Lisp_Object fn, arg1, arg2, arg3, arg4;
2909 {
2910   struct gcpro gcpro1;
2911   Lisp_Object args[5];
2912   args[0] = fn;
2913   args[1] = arg1;
2914   args[2] = arg2;
2915   args[3] = arg3;
2916   args[4] = arg4;
2917   GCPRO1 (args[0]);
2918   gcpro1.nvars = 5;
2919   RETURN_UNGCPRO (Ffuncall (5, args));
2920 }
2921 
2922 /* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
2923 /* ARGSUSED */
2924 Lisp_Object
2925 call5 (fn, arg1, arg2, arg3, arg4, arg5)
2926      Lisp_Object fn, arg1, arg2, arg3, arg4, arg5;
2927 {
2928   struct gcpro gcpro1;
2929   Lisp_Object args[6];
2930   args[0] = fn;
2931   args[1] = arg1;
2932   args[2] = arg2;
2933   args[3] = arg3;
2934   args[4] = arg4;
2935   args[5] = arg5;
2936   GCPRO1 (args[0]);
2937   gcpro1.nvars = 6;
2938   RETURN_UNGCPRO (Ffuncall (6, args));
2939 }
2940 
2941 /* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
2942 /* ARGSUSED */
2943 Lisp_Object
2944 call6 (fn, arg1, arg2, arg3, arg4, arg5, arg6)
2945      Lisp_Object fn, arg1, arg2, arg3, arg4, arg5, arg6;
2946 {
2947   struct gcpro gcpro1;
2948   Lisp_Object args[7];
2949   args[0] = fn;
2950   args[1] = arg1;
2951   args[2] = arg2;
2952   args[3] = arg3;
2953   args[4] = arg4;
2954   args[5] = arg5;
2955   args[6] = arg6;
2956   GCPRO1 (args[0]);
2957   gcpro1.nvars = 7;
2958   RETURN_UNGCPRO (Ffuncall (7, args));
2959 }
2960 
2961 /* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7 */
2962 /* ARGSUSED */
2963 Lisp_Object
2964 call7 (fn, arg1, arg2, arg3, arg4, arg5, arg6, arg7)
2965      Lisp_Object fn, arg1, arg2, arg3, arg4, arg5, arg6, arg7;
2966 {
2967   struct gcpro gcpro1;
2968   Lisp_Object args[8];
2969   args[0] = fn;
2970   args[1] = arg1;
2971   args[2] = arg2;
2972   args[3] = arg3;
2973   args[4] = arg4;
2974   args[5] = arg5;
2975   args[6] = arg6;
2976   args[7] = arg7;
2977   GCPRO1 (args[0]);
2978   gcpro1.nvars = 8;
2979   RETURN_UNGCPRO (Ffuncall (8, args));
2980 }
2981 
2982 /* The caller should GCPRO all the elements of ARGS.  */
2983 
2984 DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0,
2985        doc: /* Call first argument as a function, passing remaining arguments to it.
2986 Return the value that function returns.
2987 Thus, (funcall 'cons 'x 'y) returns (x . y).
2988 usage: (funcall FUNCTION &rest ARGUMENTS)  */)
2989      (nargs, args)
2990      int nargs;
2991      Lisp_Object *args;
2992 {
2993   Lisp_Object fun, original_fun;
2994   Lisp_Object funcar;
2995   int numargs = nargs - 1;
2996   Lisp_Object lisp_numargs;
2997   Lisp_Object val;
2998   struct backtrace backtrace;
2999   register Lisp_Object *internal_args;
3000   register int i;
3001 
3002   QUIT;
3003   if ((consing_since_gc > gc_cons_threshold
3004        && consing_since_gc > gc_relative_threshold)
3005       ||
3006       (!NILP (Vmemory_full) && consing_since_gc > memory_full_cons_threshold))
3007     Fgarbage_collect ();
3008 
3009   if (++lisp_eval_depth > max_lisp_eval_depth)
3010     {
3011       if (max_lisp_eval_depth < 100)
3012         max_lisp_eval_depth = 100;
3013       if (lisp_eval_depth > max_lisp_eval_depth)
3014         error ("Lisp nesting exceeds `max-lisp-eval-depth'");
3015     }
3016 
3017   backtrace.next = backtrace_list;
3018   backtrace_list = &backtrace;
3019   backtrace.function = &args[0];
3020   backtrace.args = &args[1];
3021   backtrace.nargs = nargs - 1;
3022   backtrace.evalargs = 0;
3023   backtrace.debug_on_exit = 0;
3024 
3025   if (debug_on_next_call)
3026     do_debug_on_call (Qlambda);
3027 
3028   CHECK_CONS_LIST ();
3029 
3030   original_fun = args[0];
3031 
3032  retry:
3033 
3034   /* Optimize for no indirection.  */
3035   fun = original_fun;
3036   if (SYMBOLP (fun) && !EQ (fun, Qunbound)
3037       && (fun = XSYMBOL (fun)->function, SYMBOLP (fun)))
3038     fun = indirect_function (fun);
3039 
3040   if (SUBRP (fun))
3041     {
3042        if (numargs < XSUBR (fun)->min_args
3043           || (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs))
3044         {
3045           XSETFASTINT (lisp_numargs, numargs);
3046           xsignal2 (Qwrong_number_of_arguments, original_fun, lisp_numargs);
3047         }
3048 
3049       if (XSUBR (fun)->max_args == UNEVALLED)
3050         xsignal1 (Qinvalid_function, original_fun);
3051 
3052       if (XSUBR (fun)->max_args == MANY)
3053         {
3054           val = (*XSUBR (fun)->function) (numargs, args + 1);
3055           goto done;
3056         }
3057 
3058       if (XSUBR (fun)->max_args > numargs)
3059         {
3060           internal_args = (Lisp_Object *) alloca (XSUBR (fun)->max_args * sizeof (Lisp_Object));
3061           bcopy (args + 1, internal_args, numargs * sizeof (Lisp_Object));
3062           for (i = numargs; i < XSUBR (fun)->max_args; i++)
3063             internal_args[i] = Qnil;
3064         }
3065       else
3066         internal_args = args + 1;
3067       switch (XSUBR (fun)->max_args)
3068         {
3069         case 0:
3070           val = (*XSUBR (fun)->function) ();
3071           goto done;
3072         case 1:
3073           val = (*XSUBR (fun)->function) (internal_args[0]);
3074           goto done;
3075         case 2:
3076           val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1]);
3077           goto done;
3078         case 3:
3079           val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1],
3080                                           internal_args[2]);
3081           goto done;
3082         case 4:
3083           val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1],
3084                                           internal_args[2], internal_args[3]);
3085           goto done;
3086         case 5:
3087           val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1],
3088                                           internal_args[2], internal_args[3],
3089                                           internal_args[4]);
3090           goto done;
3091         case 6:
3092           val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1],
3093                                           internal_args[2], internal_args[3],
3094                                           internal_args[4], internal_args[5]);
3095           goto done;
3096         case 7:
3097           val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1],
3098                                           internal_args[2], internal_args[3],
3099                                           internal_args[4], internal_args[5],
3100                                           internal_args[6]);
3101           goto done;
3102 
3103         case 8:
3104           val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1],
3105                                           internal_args[2], internal_args[3],
3106                                           internal_args[4], internal_args[5],
3107                                           internal_args[6], internal_args[7]);
3108           goto done;
3109 
3110         default:
3111 
3112           /* If a subr takes more than 8 arguments without using MANY
3113              or UNEVALLED, we need to extend this function to support it.
3114              Until this is done, there is no way to call the function.  */
3115           abort ();
3116         }
3117     }
3118   if (COMPILEDP (fun))
3119     val = funcall_lambda (fun, numargs, args + 1);
3120   else
3121     {
3122       if (EQ (fun, Qunbound))
3123         xsignal1 (Qvoid_function, original_fun);
3124       if (!CONSP (fun))
3125         xsignal1 (Qinvalid_function, original_fun);
3126       funcar = XCAR (fun);
3127       if (!SYMBOLP (funcar))
3128         xsignal1 (Qinvalid_function, original_fun);
3129       if (EQ (funcar, Qlambda))
3130         val = funcall_lambda (fun, numargs, args + 1);
3131       else if (EQ (funcar, Qautoload))
3132         {
3133           do_autoload (fun, original_fun);
3134           CHECK_CONS_LIST ();
3135           goto retry;
3136         }
3137       else
3138         xsignal1 (Qinvalid_function, original_fun);
3139     }
3140  done:
3141   CHECK_CONS_LIST ();
3142   lisp_eval_depth--;
3143   if (backtrace.debug_on_exit)
3144     val = call_debugger (Fcons (Qexit, Fcons (val, Qnil)));
3145   backtrace_list = backtrace.next;
3146   return val;
3147 }
3148 
3149 Lisp_Object
3150 apply_lambda (fun, args, eval_flag)
3151      Lisp_Object fun, args;
3152      int eval_flag;
3153 {
3154   Lisp_Object args_left;
3155   Lisp_Object numargs;
3156   register Lisp_Object *arg_vector;
3157   struct gcpro gcpro1, gcpro2, gcpro3;
3158   register int i;
3159   register Lisp_Object tem;
3160 
3161   numargs = Flength (args);
3162   arg_vector = (Lisp_Object *) alloca (XINT (numargs) * sizeof (Lisp_Object));
3163   args_left = args;
3164 
3165   GCPRO3 (*arg_vector, args_left, fun);
3166   gcpro1.nvars = 0;
3167 
3168   for (i = 0; i < XINT (numargs);)
3169     {
3170       tem = Fcar (args_left), args_left = Fcdr (args_left);
3171       if (eval_flag) tem = Feval (tem);
3172       arg_vector[i++] = tem;
3173       gcpro1.nvars = i;
3174     }
3175 
3176   UNGCPRO;
3177 
3178   if (eval_flag)
3179     {
3180       backtrace_list->args = arg_vector;
3181       backtrace_list->nargs = i;
3182     }
3183   backtrace_list->evalargs = 0;
3184   tem = funcall_lambda (fun, XINT (numargs), arg_vector);
3185 
3186   /* Do the debug-on-exit now, while arg_vector still exists.  */
3187   if (backtrace_list->debug_on_exit)
3188     tem = call_debugger (Fcons (Qexit, Fcons (tem, Qnil)));
3189   /* Don't do it again when we return to eval.  */
3190   backtrace_list->debug_on_exit = 0;
3191   return tem;
3192 }
3193 
3194 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
3195    and return the result of evaluation.
3196    FUN must be either a lambda-expression or a compiled-code object.  */
3197 
3198 static Lisp_Object
3199 funcall_lambda (fun, nargs, arg_vector)
3200      Lisp_Object fun;
3201      int nargs;
3202      register Lisp_Object *arg_vector;
3203 {
3204   Lisp_Object val, syms_left, next;
3205   int count = SPECPDL_INDEX ();
3206   int i, optional, rest;
3207 
3208   if (CONSP (fun))
3209     {
3210       syms_left = XCDR (fun);
3211       if (CONSP (syms_left))
3212         syms_left = XCAR (syms_left);
3213       else
3214         xsignal1 (Qinvalid_function, fun);
3215     }
3216   else if (COMPILEDP (fun))
3217     syms_left = AREF (fun, COMPILED_ARGLIST);
3218   else
3219     abort ();
3220 
3221   i = optional = rest = 0;
3222   for (; CONSP (syms_left); syms_left = XCDR (syms_left))
3223     {
3224       QUIT;
3225 
3226       next = XCAR (syms_left);
3227       if (!SYMBOLP (next))
3228         xsignal1 (Qinvalid_function, fun);
3229 
3230       if (EQ (next, Qand_rest))
3231         rest = 1;
3232       else if (EQ (next, Qand_optional))
3233         optional = 1;
3234       else if (rest)
3235         {
3236           specbind (next, Flist (nargs - i, &arg_vector[i]));
3237           i = nargs;
3238         }
3239       else if (i < nargs)
3240         specbind (next, arg_vector[i++]);
3241       else if (!optional)
3242         xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs));
3243       else
3244         specbind (next, Qnil);
3245     }
3246 
3247   if (!NILP (syms_left))
3248     xsignal1 (Qinvalid_function, fun);
3249   else if (i < nargs)
3250     xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs));
3251 
3252   if (CONSP (fun))
3253     val = Fprogn (XCDR (XCDR (fun)));
3254   else
3255     {
3256       /* If we have not actually read the bytecode string
3257          and constants vector yet, fetch them from the file.  */
3258       if (CONSP (AREF (fun, COMPILED_BYTECODE)))
3259         Ffetch_bytecode (fun);
3260       val = Fbyte_code (AREF (fun, COMPILED_BYTECODE),
3261                         AREF (fun, COMPILED_CONSTANTS),
3262                         AREF (fun, COMPILED_STACK_DEPTH));
3263     }
3264 
3265   return unbind_to (count, val);
3266 }
3267 
3268 DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode,
3269        1, 1, 0,
3270        doc: /* If byte-compiled OBJECT is lazy-loaded, fetch it now.  */)
3271      (object)
3272      Lisp_Object object;
3273 {
3274   Lisp_Object tem;
3275 
3276   if (COMPILEDP (object) && CONSP (AREF (object, COMPILED_BYTECODE)))
3277     {
3278       tem = read_doc_string (AREF (object, COMPILED_BYTECODE));
3279       if (!CONSP (tem))
3280         {
3281           tem = AREF (object, COMPILED_BYTECODE);
3282           if (CONSP (tem) && STRINGP (XCAR (tem)))
3283             error ("Invalid byte code in %s", SDATA (XCAR (tem)));
3284           else
3285             error ("Invalid byte code");
3286         }
3287       ASET (object, COMPILED_BYTECODE, XCAR (tem));
3288       ASET (object, COMPILED_CONSTANTS, XCDR (tem));
3289     }
3290   return object;
3291 }
3292 
3293 void
3294 grow_specpdl ()
3295 {
3296   register int count = SPECPDL_INDEX ();
3297   if (specpdl_size >= max_specpdl_size)
3298     {
3299       if (max_specpdl_size < 400)
3300         max_specpdl_size = 400;
3301       if (specpdl_size >= max_specpdl_size)
3302         signal_error ("Variable binding depth exceeds max-specpdl-size", Qnil);
3303     }
3304   specpdl_size *= 2;
3305   if (specpdl_size > max_specpdl_size)
3306     specpdl_size = max_specpdl_size;
3307   specpdl = (struct specbinding *) xrealloc (specpdl, specpdl_size * sizeof (struct specbinding));
3308   specpdl_ptr = specpdl + count;
3309 }
3310 
3311 /* specpdl_ptr->symbol is a field which describes which variable is
3312    let-bound, so it can be properly undone when we unbind_to.
3313    It can have the following two shapes:
3314    - SYMBOL : if it's a plain symbol, it means that we have let-bound
3315      a symbol that is not buffer-local (at least at the time
3316      the let binding started).  Note also that it should not be
3317      aliased (i.e. when let-binding V1 that's aliased to V2, we want
3318      to record V2 here).
3319    - (SYMBOL WHERE . BUFFER) : this means that it is a let-binding for
3320      variable SYMBOL which can be buffer-local.  WHERE tells us
3321      which buffer is affected (or nil if the let-binding affects the
3322      global value of the variable) and BUFFER tells us which buffer was
3323      current (i.e. if WHERE is non-nil, then BUFFER==WHERE, otherwise
3324      BUFFER did not yet have a buffer-local value).  */
3325 
3326 void
3327 specbind (symbol, value)
3328      Lisp_Object symbol, value;
3329 {
3330   struct Lisp_Symbol *sym;
3331 
3332   eassert (!handling_signal);
3333 
3334   CHECK_SYMBOL (symbol);
3335   sym = XSYMBOL (symbol);
3336   if (specpdl_ptr == specpdl + specpdl_size)
3337     grow_specpdl ();
3338 
3339  start:
3340   switch (sym->redirect)
3341     {
3342     case SYMBOL_VARALIAS:
3343       sym = indirect_variable (sym); XSETSYMBOL (symbol, sym); goto start;
3344     case SYMBOL_PLAINVAL:
3345         { /* The most common case is that of a non-constant symbol with a
3346              trivial value.  Make that as fast as we can.  */
3347           specpdl_ptr->symbol = symbol;
3348           specpdl_ptr->old_value = SYMBOL_VAL (sym);
3349           specpdl_ptr->func = NULL;
3350           ++specpdl_ptr;
3351           if (!sym->constant)
3352             SET_SYMBOL_VAL (sym, value);
3353           else
3354             set_internal (symbol, value, Qnil, 1);
3355           break;
3356         }
3357     case SYMBOL_LOCALIZED:
3358       if (SYMBOL_BLV (sym)->frame_local)
3359         error ("Frame-local vars cannot be let-bound");
3360     case SYMBOL_FORWARDED:
3361       {
3362         Lisp_Object ovalue = find_symbol_value (symbol);
3363         specpdl_ptr->func = 0;
3364         specpdl_ptr->old_value = ovalue;
3365 
3366         eassert (sym->redirect != SYMBOL_LOCALIZED
3367                  || (EQ (SYMBOL_BLV (sym)->where,
3368                          SYMBOL_BLV (sym)->frame_local ?
3369                          Fselected_frame () : Fcurrent_buffer ())));
3370 
3371         if (sym->redirect == SYMBOL_LOCALIZED
3372             || BUFFER_OBJFWDP (SYMBOL_FWD (sym)))
3373           {
3374             Lisp_Object where, cur_buf = Fcurrent_buffer ();
3375 
3376             /* For a local variable, record both the symbol and which
3377                buffer's or frame's value we are saving.  */
3378             if (!NILP (Flocal_variable_p (symbol, Qnil)))
3379               {
3380                 eassert (sym->redirect != SYMBOL_LOCALIZED
3381                          || (BLV_FOUND (SYMBOL_BLV (sym))
3382                              && EQ (cur_buf, SYMBOL_BLV (sym)->where)));
3383                 where = cur_buf;
3384               }
3385             else if (sym->redirect == SYMBOL_LOCALIZED
3386                      && BLV_FOUND (SYMBOL_BLV (sym)))
3387               where = SYMBOL_BLV (sym)->where;
3388             else
3389               where = Qnil;
3390 
3391             /* We're not using the `unused' slot in the specbinding
3392                structure because this would mean we have to do more
3393                work for simple variables.  */
3394             /* FIXME: The third value `current_buffer' is only used in
3395                let_shadows_buffer_binding_p which is itself only used
3396                in set_internal for local_if_set.  */
3397             eassert (NILP (where) || EQ (where, cur_buf));
3398             specpdl_ptr->symbol = Fcons (symbol, Fcons (where, cur_buf));
3399 
3400             /* If SYMBOL is a per-buffer variable which doesn't have a
3401                buffer-local value here, make the `let' change the global
3402                value by changing the value of SYMBOL in all buffers not
3403                having their own value.  This is consistent with what
3404                happens with other buffer-local variables.  */
3405             if (NILP (where)
3406                 && sym->redirect == SYMBOL_FORWARDED)
3407               {
3408                 eassert (BUFFER_OBJFWDP (SYMBOL_FWD (sym)));
3409                 ++specpdl_ptr;
3410                 Fset_default (symbol, value);
3411                 return;
3412               }
3413           }
3414         else
3415           specpdl_ptr->symbol = symbol;
3416 
3417         specpdl_ptr++;
3418         set_internal (symbol, value, Qnil, 1);
3419         break;
3420       }
3421     default: abort ();
3422     }
3423 }
3424 
3425 void
3426 record_unwind_protect (function, arg)
3427      Lisp_Object (*function) P_ ((Lisp_Object));
3428      Lisp_Object arg;
3429 {
3430   eassert (!handling_signal);
3431 
3432   if (specpdl_ptr == specpdl + specpdl_size)
3433     grow_specpdl ();
3434   specpdl_ptr->func = function;
3435   specpdl_ptr->symbol = Qnil;
3436   specpdl_ptr->old_value = arg;
3437   specpdl_ptr++;
3438 }
3439 
3440 Lisp_Object
3441 unbind_to (count, value)
3442      int count;
3443      Lisp_Object value;
3444 {
3445   Lisp_Object quitf = Vquit_flag;
3446   struct gcpro gcpro1, gcpro2;
3447 
3448   GCPRO2 (value, quitf);
3449   Vquit_flag = Qnil;
3450 
3451   while (specpdl_ptr != specpdl + count)
3452     {
3453       /* Copy the binding, and decrement specpdl_ptr, before we do
3454          the work to unbind it.  We decrement first
3455          so that an error in unbinding won't try to unbind
3456          the same entry again, and we copy the binding first
3457          in case more bindings are made during some of the code we run.  */
3458 
3459       struct specbinding this_binding;
3460       this_binding = *--specpdl_ptr;
3461 
3462       if (this_binding.func != 0)
3463         (*this_binding.func) (this_binding.old_value);
3464       /* If the symbol is a list, it is really (SYMBOL WHERE
3465          . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
3466          frame.  If WHERE is a buffer or frame, this indicates we
3467          bound a variable that had a buffer-local or frame-local
3468          binding.  WHERE nil means that the variable had the default
3469          value when it was bound.  CURRENT-BUFFER is the buffer that
3470          was current when the variable was bound.  */
3471       else if (CONSP (this_binding.symbol))
3472         {
3473           Lisp_Object symbol, where;
3474 
3475           symbol = XCAR (this_binding.symbol);
3476           where = XCAR (XCDR (this_binding.symbol));
3477 
3478           if (NILP (where))
3479             Fset_default (symbol, this_binding.old_value);
3480           /* If `where' is non-nil, reset the value in the appropriate
3481              local binding, but only if that binding still exists.  */
3482           else if (BUFFERP (where)
3483                    ? !NILP (Flocal_variable_p (symbol, where))
3484                    : !NILP (Fassq (symbol, XFRAME (where)->param_alist)))
3485             set_internal (symbol, this_binding.old_value, where, 1);
3486         }
3487       /* If variable has a trivial value (no forwarding), we can
3488          just set it.  No need to check for constant symbols here,
3489          since that was already done by specbind.  */
3490       else if (XSYMBOL (this_binding.symbol)->redirect == SYMBOL_PLAINVAL)
3491         SET_SYMBOL_VAL (XSYMBOL (this_binding.symbol),
3492                         this_binding.old_value);
3493       else
3494         /* NOTE: we only ever come here if make_local_foo was used for
3495            the first time on this var within this let.  */
3496         Fset_default (this_binding.symbol, this_binding.old_value);
3497     }
3498 
3499   if (NILP (Vquit_flag) && !NILP (quitf))
3500     Vquit_flag = quitf;
3501 
3502   UNGCPRO;
3503   return value;
3504 }
3505 
3506 DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
3507        doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
3508 The debugger is entered when that frame exits, if the flag is non-nil.  */)
3509      (level, flag)
3510      Lisp_Object level, flag;
3511 {
3512   register struct backtrace *backlist = backtrace_list;
3513   register int i;
3514 
3515   CHECK_NUMBER (level);
3516 
3517   for (i = 0; backlist && i < XINT (level); i++)
3518     {
3519       backlist = backlist->next;
3520     }
3521 
3522   if (backlist)
3523     backlist->debug_on_exit = !NILP (flag);
3524 
3525   return flag;
3526 }
3527 
3528 DEFUN ("backtrace", Fbacktrace, Sbacktrace, 0, 0, "",
3529        doc: /* Print a trace of Lisp function calls currently active.
3530 Output stream used is value of `standard-output'.  */)
3531      ()
3532 {
3533   register struct backtrace *backlist = backtrace_list;
3534   register int i;
3535   Lisp_Object tail;
3536   Lisp_Object tem;
3537   extern Lisp_Object Vprint_level;
3538   struct gcpro gcpro1;
3539 
3540   XSETFASTINT (Vprint_level, 3);
3541 
3542   tail = Qnil;
3543   GCPRO1 (tail);
3544 
3545   while (backlist)
3546     {
3547       write_string (backlist->debug_on_exit ? "* " : "  ", 2);
3548       if (backlist->nargs == UNEVALLED)
3549         {
3550           Fprin1 (Fcons (*backlist->function, *backlist->args), Qnil);
3551           write_string ("\n", -1);
3552         }
3553       else
3554         {
3555           tem = *backlist->function;
3556           Fprin1 (tem, Qnil);   /* This can QUIT */
3557           write_string ("(", -1);
3558           if (backlist->nargs == MANY)
3559             {
3560               for (tail = *backlist->args, i = 0;
3561                    !NILP (tail);
3562                    tail = Fcdr (tail), i++)
3563                 {
3564                   if (i) write_string (" ", -1);
3565                   Fprin1 (Fcar (tail), Qnil);
3566                 }
3567             }
3568           else
3569             {
3570               for (i = 0; i < backlist->nargs; i++)
3571                 {
3572                   if (i) write_string (" ", -1);
3573                   Fprin1 (backlist->args[i], Qnil);
3574                 }
3575             }
3576           write_string (")\n", -1);
3577         }
3578       backlist = backlist->next;
3579     }
3580 
3581   Vprint_level = Qnil;
3582   UNGCPRO;
3583   return Qnil;
3584 }
3585 
3586 DEFUN ("backtrace-frame", Fbacktrace_frame, Sbacktrace_frame, 1, 1, NULL,
3587        doc: /* Return the function and arguments NFRAMES up from current execution point.
3588 If that frame has not evaluated the arguments yet (or is a special form),
3589 the value is (nil FUNCTION ARG-FORMS...).
3590 If that frame has evaluated its arguments and called its function already,
3591 the value is (t FUNCTION ARG-VALUES...).
3592 A &rest arg is represented as the tail of the list ARG-VALUES.
3593 FUNCTION is whatever was supplied as car of evaluated list,
3594 or a lambda expression for macro calls.
3595 If NFRAMES is more than the number of frames, the value is nil.  */)
3596      (nframes)
3597      Lisp_Object nframes;
3598 {
3599   register struct backtrace *backlist = backtrace_list;
3600   register int i;
3601   Lisp_Object tem;
3602 
3603   CHECK_NATNUM (nframes);
3604 
3605   /* Find the frame requested.  */
3606   for (i = 0; backlist && i < XFASTINT (nframes); i++)
3607     backlist = backlist->next;
3608 
3609   if (!backlist)
3610     return Qnil;
3611   if (backlist->nargs == UNEVALLED)
3612     return Fcons (Qnil, Fcons (*backlist->function, *backlist->args));
3613   else
3614     {
3615       if (backlist->nargs == MANY)
3616         tem = *backlist->args;
3617       else
3618         tem = Flist (backlist->nargs, backlist->args);
3619 
3620       return Fcons (Qt, Fcons (*backlist->function, tem));
3621     }
3622 }
3623 
3624 
3625 void
3626 mark_backtrace ()
3627 {
3628   register struct backtrace *backlist;
3629   register int i;
3630 
3631   for (backlist = backtrace_list; backlist; backlist = backlist->next)
3632     {
3633       mark_object (*backlist->function);
3634 
3635       if (backlist->nargs == UNEVALLED || backlist->nargs == MANY)
3636         i = 0;
3637       else
3638         i = backlist->nargs - 1;
3639       for (; i >= 0; i--)
3640         mark_object (backlist->args[i]);
3641     }
3642 }
3643 
3644 void
3645 syms_of_eval ()
3646 {
3647   DEFVAR_INT ("max-specpdl-size", &max_specpdl_size,
3648               doc: /* *Limit on number of Lisp variable bindings and `unwind-protect's.
3649 If Lisp code tries to increase the total number past this amount,
3650 an error is signaled.
3651 You can safely use a value considerably larger than the default value,
3652 if that proves inconveniently small.  However, if you increase it too far,
3653 Emacs could run out of memory trying to make the stack bigger.  */);
3654 
3655   DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth,
3656               doc: /* *Limit on depth in `eval', `apply' and `funcall' before error.
3657 
3658 This limit serves to catch infinite recursions for you before they cause
3659 actual stack overflow in C, which would be fatal for Emacs.
3660 You can safely make it considerably larger than its default value,
3661 if that proves inconveniently small.  However, if you increase it too far,
3662 Emacs could overflow the real C stack, and crash.  */);
3663 
3664   DEFVAR_LISP ("quit-flag", &Vquit_flag,
3665                doc: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
3666 If the value is t, that means do an ordinary quit.
3667 If the value equals `throw-on-input', that means quit by throwing
3668 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
3669 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
3670 but `inhibit-quit' non-nil prevents anything from taking notice of that.  */);
3671   Vquit_flag = Qnil;
3672 
3673   DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit,
3674                doc: /* Non-nil inhibits C-g quitting from happening immediately.
3675 Note that `quit-flag' will still be set by typing C-g,
3676 so a quit will be signaled as soon as `inhibit-quit' is nil.
3677 To prevent this happening, set `quit-flag' to nil
3678 before making `inhibit-quit' nil.  */);
3679   Vinhibit_quit = Qnil;
3680 
3681   Qinhibit_quit = intern_c_string ("inhibit-quit");
3682   staticpro (&Qinhibit_quit);
3683 
3684   Qautoload = intern_c_string ("autoload");
3685   staticpro (&Qautoload);
3686 
3687   Qdebug_on_error = intern_c_string ("debug-on-error");
3688   staticpro (&Qdebug_on_error);
3689 
3690   Qmacro = intern_c_string ("macro");
3691   staticpro (&Qmacro);
3692 
3693   Qdeclare = intern_c_string ("declare");
3694   staticpro (&Qdeclare);
3695 
3696   /* Note that the process handling also uses Qexit, but we don't want
3697      to staticpro it twice, so we just do it here.  */
3698   Qexit = intern_c_string ("exit");
3699   staticpro (&Qexit);
3700 
3701   Qinteractive = intern_c_string ("interactive");
3702   staticpro (&Qinteractive);
3703 
3704   Qcommandp = intern_c_string ("commandp");
3705   staticpro (&Qcommandp);
3706 
3707   Qdefun = intern_c_string ("defun");
3708   staticpro (&Qdefun);
3709 
3710   Qand_rest = intern_c_string ("&rest");
3711   staticpro (&Qand_rest);
3712 
3713   Qand_optional = intern_c_string ("&optional");
3714   staticpro (&Qand_optional);
3715 
3716   Qdebug = intern_c_string ("debug");
3717   staticpro (&Qdebug);
3718 
3719   DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error,
3720                doc: /* *Non-nil means errors display a backtrace buffer.
3721 More precisely, this happens for any error that is handled
3722 by the editor command loop.
3723 If the value is a list, an error only means to display a backtrace
3724 if one of its condition symbols appears in the list.  */);
3725   Vstack_trace_on_error = Qnil;
3726 
3727   DEFVAR_LISP ("debug-on-error", &Vdebug_on_error,
3728                doc: /* *Non-nil means enter debugger if an error is signaled.
3729 Does not apply to errors handled by `condition-case' or those
3730 matched by `debug-ignored-errors'.
3731 If the value is a list, an error only means to enter the debugger
3732 if one of its condition symbols appears in the list.
3733 When you evaluate an expression interactively, this variable
3734 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
3735 The command `toggle-debug-on-error' toggles this.
3736 See also the variable `debug-on-quit'.  */);
3737   Vdebug_on_error = Qnil;
3738 
3739   DEFVAR_LISP ("debug-ignored-errors", &Vdebug_ignored_errors,
3740     doc: /* *List of errors for which the debugger should not be called.
3741 Each element may be a condition-name or a regexp that matches error messages.
3742 If any element applies to a given error, that error skips the debugger
3743 and just returns to top level.
3744 This overrides the variable `debug-on-error'.
3745 It does not apply to errors handled by `condition-case'.  */);
3746   Vdebug_ignored_errors = Qnil;
3747 
3748   DEFVAR_BOOL ("debug-on-quit", &debug_on_quit,
3749     doc: /* *Non-nil means enter debugger if quit is signaled (C-g, for example).
3750 Does not apply if quit is handled by a `condition-case'.  */);
3751   debug_on_quit = 0;
3752 
3753   DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call,
3754                doc: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'.  */);
3755 
3756   DEFVAR_BOOL ("debugger-may-continue", &debugger_may_continue,
3757                doc: /* Non-nil means debugger may continue execution.
3758 This is nil when the debugger is called under circumstances where it
3759 might not be safe to continue.  */);
3760   debugger_may_continue = 1;
3761 
3762   DEFVAR_LISP ("debugger", &Vdebugger,
3763                doc: /* Function to call to invoke debugger.
3764 If due to frame exit, args are `exit' and the value being returned;
3765  this function's value will be returned instead of that.
3766 If due to error, args are `error' and a list of the args to `signal'.
3767 If due to `apply' or `funcall' entry, one arg, `lambda'.
3768 If due to `eval' entry, one arg, t.  */);
3769   Vdebugger = Qnil;
3770 
3771   DEFVAR_LISP ("signal-hook-function", &Vsignal_hook_function,
3772                doc: /* If non-nil, this is a function for `signal' to call.
3773 It receives the same arguments that `signal' was given.
3774 The Edebug package uses this to regain control.  */);
3775   Vsignal_hook_function = Qnil;
3776 
3777   DEFVAR_LISP ("debug-on-signal", &Vdebug_on_signal,
3778                doc: /* *Non-nil means call the debugger regardless of condition handlers.
3779 Note that `debug-on-error', `debug-on-quit' and friends
3780 still determine whether to handle the particular condition.  */);
3781   Vdebug_on_signal = Qnil;
3782 
3783   DEFVAR_LISP ("macro-declaration-function", &Vmacro_declaration_function,
3784                doc: /* Function to process declarations in a macro definition.
3785 The function will be called with two args MACRO and DECL.
3786 MACRO is the name of the macro being defined.
3787 DECL is a list `(declare ...)' containing the declarations.
3788 The value the function returns is not used.  */);
3789   Vmacro_declaration_function = Qnil;
3790 
3791   Vrun_hooks = intern_c_string ("run-hooks");
3792   staticpro (&Vrun_hooks);
3793 
3794   staticpro (&Vautoload_queue);
3795   Vautoload_queue = Qnil;
3796   staticpro (&Vsignaling_function);
3797   Vsignaling_function = Qnil;
3798 
3799   defsubr (&Sor);
3800   defsubr (&Sand);
3801   defsubr (&Sif);
3802   defsubr (&Scond);
3803   defsubr (&Sprogn);
3804   defsubr (&Sprog1);
3805   defsubr (&Sprog2);
3806   defsubr (&Ssetq);
3807   defsubr (&Squote);
3808   defsubr (&Sfunction);
3809   defsubr (&Sdefun);
3810   defsubr (&Sdefmacro);
3811   defsubr (&Sdefvar);
3812   defsubr (&Sdefvaralias);
3813   defsubr (&Sdefconst);
3814   defsubr (&Suser_variable_p);
3815   defsubr (&Slet);
3816   defsubr (&SletX);
3817   defsubr (&Swhile);
3818   defsubr (&Smacroexpand);
3819   defsubr (&Scatch);
3820   defsubr (&Sthrow);
3821   defsubr (&Sunwind_protect);
3822   defsubr (&Scondition_case);
3823   defsubr (&Ssignal);
3824   defsubr (&Sinteractive_p);
3825   defsubr (&Scalled_interactively_p);
3826   defsubr (&Scommandp);
3827   defsubr (&Sautoload);
3828   defsubr (&Seval);
3829   defsubr (&Sapply);
3830   defsubr (&Sfuncall);
3831   defsubr (&Srun_hooks);
3832   defsubr (&Srun_hook_with_args);
3833   defsubr (&Srun_hook_with_args_until_success);
3834   defsubr (&Srun_hook_with_args_until_failure);
3835   defsubr (&Sfetch_bytecode);
3836   defsubr (&Sbacktrace_debug);
3837   defsubr (&Sbacktrace);
3838   defsubr (&Sbacktrace_frame);
3839 }
3840 
3841 /* arch-tag: 014a07aa-33ab-4a8f-a3d2-ee8a4a9ff7fb
3842    (do not change this comment) */