src/eval.c

   1 /* Evaluator for GNU Emacs Lisp interpreter.
   2    Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
   3
   4 This file is part of GNU Emacs.
   5
   6 GNU Emacs is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 1, or (at your option)
   9 any later version.
  10
  11 GNU Emacs is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with GNU Emacs; see the file COPYING.  If not, write to
  18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19
  20
  21 #include "config.h"
  22 #include "lisp.h"
  23 #ifdef HAVE_X_WINDOWS
  24 #include "xterm.h"
  25 #endif
  26
  27 #ifndef standalone
  28 #include "commands.h"
  29 #include "keyboard.h"
  30 #else
  31 #define INTERACTIVE 1
  32 #endif
  33
  34 #include <setjmp.h>
  35
  36 /* This definition is duplicated in alloc.c and keyboard.c */
  37 /* Putting it in lisp.h makes cc bomb out! */
  38
  39 struct backtrace
  40   {
  41     struct backtrace *next;
  42     Lisp_Object *function;
  43     Lisp_Object *args;  /* Points to vector of args. */
  44     int nargs;          /* length of vector */
  45                /* if nargs is UNEVALLED, args points to slot holding 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
  54   {
  55     Lisp_Object tag;
  56     Lisp_Object val;
  57     struct catchtag *next;
  58     struct gcpro *gcpro;
  59     jmp_buf jmp;
  60     struct backtrace *backlist;
  61     struct handler *handlerlist;
  62     int lisp_eval_depth;
  63     int pdlcount;
  64     int poll_suppress_count;
  65   };
  66
  67 struct catchtag *catchlist;
  68
  69 Lisp_Object Qautoload, Qmacro, Qexit, Qinteractive, Qcommandp, Qdefun;
  70 Lisp_Object Qinhibit_quit, Vinhibit_quit, Vquit_flag;
  71 Lisp_Object Qmocklisp_arguments, Vmocklisp_arguments, Qmocklisp;
  72 Lisp_Object Qand_rest, Qand_optional;
  73 Lisp_Object Qdebug_on_error;
  74
  75 Lisp_Object Vrun_hooks;
  76
  77 /* Non-nil means record all fset's and provide's, to be undone
  78    if the file being autoloaded is not fully loaded.
  79    They are recorded by being consed onto the front of Vautoload_queue:
  80    (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide.  */
  81
  82 Lisp_Object Vautoload_queue;
  83
  84 /* Current number of specbindings allocated in specpdl.  */
  85 int specpdl_size;
  86
  87 /* Pointer to beginning of specpdl.  */
  88 struct specbinding *specpdl;
  89
  90 /* Pointer to first unused element in specpdl.  */
  91 struct specbinding *specpdl_ptr;
  92
  93 /* Maximum size allowed for specpdl allocation */
  94 int max_specpdl_size;
  95
  96 /* Depth in Lisp evaluations and function calls.  */
  97 int lisp_eval_depth;
  98
  99 /* Maximum allowed depth in Lisp evaluations and function calls.  */
 100 int max_lisp_eval_depth;
 101
 102 /* Nonzero means enter debugger before next function call */
 103 int debug_on_next_call;
 104
 105 /* Nonzero means display a backtrace if an error
 106  is handled by the command loop's error handler. */
 107 int stack_trace_on_error;
 108
 109 /* Nonzero means enter debugger if an error
 110  is handled by the command loop's error handler. */
 111 int debug_on_error;
 112
 113 /* Nonzero means enter debugger if a quit signal
 114  is handled by the command loop's error handler. */
 115 int debug_on_quit;
 116
 117 /* Nonzero means we are trying to enter the debugger.
 118    This is to prevent recursive attempts.  */
 119 int entering_debugger;
 120
 121 Lisp_Object Vdebugger;
 122
 123 void specbind (), record_unwind_protect ();
 124
 125 Lisp_Object funcall_lambda ();
 126 extern Lisp_Object ml_apply (); /* Apply a mocklisp function to unevaluated argument list */
 127
 128 init_eval_once ()
 129 {
 130   specpdl_size = 50;
 131   specpdl = (struct specbinding *) malloc (specpdl_size * sizeof (struct specbinding));
 132   max_specpdl_size = 600;
 133   max_lisp_eval_depth = 200;
 134 }
 135
 136 init_eval ()
 137 {
 138   specpdl_ptr = specpdl;
 139   catchlist = 0;
 140   handlerlist = 0;
 141   backtrace_list = 0;
 142   Vquit_flag = Qnil;
 143   debug_on_next_call = 0;
 144   lisp_eval_depth = 0;
 145   entering_debugger = 0;
 146 }
 147
 148 Lisp_Object
 149 call_debugger (arg)
 150      Lisp_Object arg;
 151 {
 152   if (lisp_eval_depth + 20 > max_lisp_eval_depth)
 153     max_lisp_eval_depth = lisp_eval_depth + 20;
 154   if (specpdl_size + 40 > max_specpdl_size)
 155     max_specpdl_size = specpdl_size + 40;
 156   debug_on_next_call = 0;
 157   entering_debugger = 1;
 158   return apply1 (Vdebugger, arg);
 159 }
 160
 161 do_debug_on_call (code)
 162      Lisp_Object code;
 163 {
 164   debug_on_next_call = 0;
 165   backtrace_list->debug_on_exit = 1;
 166   call_debugger (Fcons (code, Qnil));
 167 }
 168 \f
 169 /* NOTE!!! Every function that can call EVAL must protect its args
 170    and temporaries from garbage collection while it needs them.
 171    The definition of `For' shows what you have to do.  */
 172
 173 DEFUN ("or", For, Sor, 0, UNEVALLED, 0,
 174   "Eval args until one of them yields non-nil, then return that value.\n\
 175 The remaining args are not evalled at all.\n\
 176 If all args return nil, return nil.")
 177   (args)
 178      Lisp_Object args;
 179 {
 180   register Lisp_Object val;
 181   Lisp_Object args_left;
 182   struct gcpro gcpro1;
 183
 184   if (NILP(args))
 185     return Qnil;
 186
 187   args_left = args;
 188   GCPRO1 (args_left);
 189
 190   do
 191     {
 192       val = Feval (Fcar (args_left));
 193       if (!NILP (val))
 194         break;
 195       args_left = Fcdr (args_left);
 196     }
 197   while (!NILP(args_left));
 198
 199   UNGCPRO;
 200   return val;
 201 }
 202
 203 DEFUN ("and", Fand, Sand, 0, UNEVALLED, 0,
 204   "Eval args until one of them yields nil, then return nil.\n\
 205 The remaining args are not evalled at all.\n\
 206 If no arg yields nil, return the last arg's value.")
 207   (args)
 208      Lisp_Object args;
 209 {
 210   register Lisp_Object val;
 211   Lisp_Object args_left;
 212   struct gcpro gcpro1;
 213
 214   if (NILP(args))
 215     return Qt;
 216
 217   args_left = args;
 218   GCPRO1 (args_left);
 219
 220   do
 221     {
 222       val = Feval (Fcar (args_left));
 223       if (NILP (val))
 224         break;
 225       args_left = Fcdr (args_left);
 226     }
 227   while (!NILP(args_left));
 228
 229   UNGCPRO;
 230   return val;
 231 }
 232
 233 DEFUN ("if", Fif, Sif, 2, UNEVALLED, 0,
 234   "(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...\n\
 235 Returns the value of THEN or the value of the last of the ELSE's.\n\
 236 THEN must be one expression, but ELSE... can be zero or more expressions.\n\
 237 If COND yields nil, and there are no ELSE's, the value is nil.")
 238   (args)
 239      Lisp_Object args;
 240 {
 241   register Lisp_Object cond;
 242   struct gcpro gcpro1;
 243
 244   GCPRO1 (args);
 245   cond = Feval (Fcar (args));
 246   UNGCPRO;
 247
 248   if (!NILP (cond))
 249     return Feval (Fcar (Fcdr (args)));
 250   return Fprogn (Fcdr (Fcdr (args)));
 251 }
 252
 253 DEFUN ("cond", Fcond, Scond, 0, UNEVALLED, 0,
 254   "(cond CLAUSES...): try each clause until one succeeds.\n\
 255 Each clause looks like (CONDITION BODY...).  CONDITION is evaluated\n\
 256 and, if the value is non-nil, this clause succeeds:\n\
 257 then the expressions in BODY are evaluated and the last one's\n\
 258 value is the value of the cond-form.\n\
 259 If no clause succeeds, cond returns nil.\n\
 260 If a clause has one element, as in (CONDITION),\n\
 261 CONDITION's value if non-nil is returned from the cond-form.")
 262   (args)
 263      Lisp_Object args;
 264 {
 265   register Lisp_Object clause, val;
 266   struct gcpro gcpro1;
 267
 268   val = Qnil;
 269   GCPRO1 (args);
 270   while (!NILP (args))
 271     {
 272       clause = Fcar (args);
 273       val = Feval (Fcar (clause));
 274       if (!NILP (val))
 275         {
 276           if (!EQ (XCONS (clause)->cdr, Qnil))
 277             val = Fprogn (XCONS (clause)->cdr);
 278           break;
 279         }
 280       args = XCONS (args)->cdr;
 281     }
 282   UNGCPRO;
 283
 284   return val;
 285 }
 286
 287 DEFUN ("progn", Fprogn, Sprogn, 0, UNEVALLED, 0,
 288   "(progn BODY...): eval BODY forms sequentially and return value of last one.")
 289   (args)
 290      Lisp_Object args;
 291 {
 292   register Lisp_Object val, tem;
 293   Lisp_Object args_left;
 294   struct gcpro gcpro1;
 295
 296   /* In Mocklisp code, symbols at the front of the progn arglist
 297    are to be bound to zero. */
 298   if (!EQ (Vmocklisp_arguments, Qt))
 299     {
 300       val = make_number (0);
 301       while (!NILP (args) && (tem = Fcar (args), XTYPE (tem) == Lisp_Symbol))
 302         {
 303           QUIT;
 304           specbind (tem, val), args = Fcdr (args);
 305         }
 306     }
 307
 308   if (NILP(args))
 309     return Qnil;
 310
 311   args_left = args;
 312   GCPRO1 (args_left);
 313
 314   do
 315     {
 316       val = Feval (Fcar (args_left));
 317       args_left = Fcdr (args_left);
 318     }
 319   while (!NILP(args_left));
 320
 321   UNGCPRO;
 322   return val;
 323 }
 324
 325 DEFUN ("prog1", Fprog1, Sprog1, 1, UNEVALLED, 0,
 326   "(prog1 FIRST BODY...): eval FIRST and BODY sequentially; value from FIRST.\n\
 327 The value of FIRST is saved during the evaluation of the remaining args,\n\
 328 whose values are discarded.")
 329   (args)
 330      Lisp_Object args;
 331 {
 332   Lisp_Object val;
 333   register Lisp_Object args_left;
 334   struct gcpro gcpro1, gcpro2;
 335   register int argnum = 0;
 336
 337   if (NILP(args))
 338     return Qnil;
 339
 340   args_left = args;
 341   val = Qnil;
 342   GCPRO2 (args, val);
 343
 344   do
 345     {
 346       if (!(argnum++))
 347         val = Feval (Fcar (args_left));
 348       else
 349         Feval (Fcar (args_left));
 350       args_left = Fcdr (args_left);
 351     }
 352   while (!NILP(args_left));
 353
 354   UNGCPRO;
 355   return val;
 356 }
 357
 358 DEFUN ("prog2", Fprog2, Sprog2, 2, UNEVALLED, 0,
 359   "(prog1 X Y BODY...): eval X, Y and BODY sequentially; value from Y.\n\
 360 The value of Y is saved during the evaluation of the remaining args,\n\
 361 whose values are discarded.")
 362   (args)
 363      Lisp_Object args;
 364 {
 365   Lisp_Object val;
 366   register Lisp_Object args_left;
 367   struct gcpro gcpro1, gcpro2;
 368   register int argnum = -1;
 369
 370   val = Qnil;
 371
 372   if (NILP(args))
 373     return Qnil;
 374
 375   args_left = args;
 376   val = Qnil;
 377   GCPRO2 (args, val);
 378
 379   do
 380     {
 381       if (!(argnum++))
 382         val = Feval (Fcar (args_left));
 383       else
 384         Feval (Fcar (args_left));
 385       args_left = Fcdr (args_left);
 386     }
 387   while (!NILP(args_left));
 388
 389   UNGCPRO;
 390   return val;
 391 }
 392
 393 DEFUN ("setq", Fsetq, Ssetq, 0, UNEVALLED, 0,
 394   "(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.\n\
 395 The SYMs are not evaluated.  Thus (setq x y) sets x to the value of y.\n\
 396 Each SYM is set before the next VAL is computed.")
 397   (args)
 398      Lisp_Object args;
 399 {
 400   register Lisp_Object args_left;
 401   register Lisp_Object val, sym;
 402   struct gcpro gcpro1;
 403
 404   if (NILP(args))
 405     return Qnil;
 406
 407   args_left = args;
 408   GCPRO1 (args);
 409
 410   do
 411     {
 412       val = Feval (Fcar (Fcdr (args_left)));
 413       sym = Fcar (args_left);
 414       Fset (sym, val);
 415       args_left = Fcdr (Fcdr (args_left));
 416     }
 417   while (!NILP(args_left));
 418
 419   UNGCPRO;
 420   return val;
 421 }
 422
 423 DEFUN ("quote", Fquote, Squote, 1, UNEVALLED, 0,
 424   "Return the argument, without evaluating it.  `(quote x)' yields `x'.")
 425   (args)
 426      Lisp_Object args;
 427 {
 428   return Fcar (args);
 429 }
 430
 431 DEFUN ("function", Ffunction, Sfunction, 1, UNEVALLED, 0,
 432   "Like `quote', but preferred for objects which are functions.\n\
 433 In byte compilation, `function' causes its argument to be compiled.\n\
 434 `quote' cannot do that.")
 435   (args)
 436      Lisp_Object args;
 437 {
 438   return Fcar (args);
 439 }
 440
 441 DEFUN ("interactive-p", Finteractive_p, Sinteractive_p, 0, 0, 0,
 442   "Return t if function in which this appears was called interactively.\n\
 443 This means that the function was called with call-interactively (which\n\
 444 includes being called as the binding of a key)\n\
 445 and input is currently coming from the keyboard (not in keyboard macro).")
 446   ()
 447 {
 448   register struct backtrace *btp;
 449   register Lisp_Object fun;
 450
 451   if (!INTERACTIVE)
 452     return Qnil;
 453
 454   /*  Unless the object was compiled, skip the frame of interactive-p itself
 455       (if interpreted) or the frame of byte-code (if called from
 456       compiled function).  */
 457   btp = backtrace_list;
 458   if (XTYPE (*btp->function) != Lisp_Compiled)
 459     btp = btp->next;
 460   while (btp
 461          && (btp->nargs == UNEVALLED || EQ (*btp->function, Qbytecode)))
 462     btp = btp->next;
 463
 464   /* btp now points at the frame of the innermost function
 465      that DOES eval its args.
 466      If it is a built-in function (such as load or eval-region)
 467      return nil.  */
 468   fun = *btp->function;
 469   while (XTYPE (fun) == Lisp_Symbol)
 470     {
 471       QUIT;
 472       fun = Fsymbol_function (fun);
 473     }
 474   if (XTYPE (fun) == Lisp_Subr)
 475     return Qnil;
 476   /* btp points to the frame of a Lisp function that called interactive-p.
 477      Return t if that function was called interactively.  */
 478   if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively))
 479     return Qt;
 480   return Qnil;
 481 }
 482
 483 DEFUN ("defun", Fdefun, Sdefun, 2, UNEVALLED, 0,
 484   "(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.\n\
 485 The definition is (lambda ARGLIST [DOCSTRING] BODY...).\n\
 486 See also the function `interactive'.")
 487   (args)
 488      Lisp_Object args;
 489 {
 490   register Lisp_Object fn_name;
 491   register Lisp_Object defn;
 492
 493   fn_name = Fcar (args);
 494   defn = Fcons (Qlambda, Fcdr (args));
 495   if (!NILP (Vpurify_flag))
 496     defn = Fpurecopy (defn);
 497   Ffset (fn_name, defn);
 498   return fn_name;
 499 }
 500
 501 DEFUN ("defmacro", Fdefmacro, Sdefmacro, 2, UNEVALLED, 0,
 502   "(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.\n\
 503 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).\n\
 504 When the macro is called, as in (NAME ARGS...),\n\
 505 the function (lambda ARGLIST BODY...) is applied to\n\
 506 the list ARGS... as it appears in the expression,\n\
 507 and the result should be a form to be evaluated instead of the original.")
 508   (args)
 509      Lisp_Object args;
 510 {
 511   register Lisp_Object fn_name;
 512   register Lisp_Object defn;
 513
 514   fn_name = Fcar (args);
 515   defn = Fcons (Qmacro, Fcons (Qlambda, Fcdr (args)));
 516   if (!NILP (Vpurify_flag))
 517     defn = Fpurecopy (defn);
 518   Ffset (fn_name, defn);
 519   return fn_name;
 520 }
 521
 522 DEFUN ("defvar", Fdefvar, Sdefvar, 1, UNEVALLED, 0,
 523   "(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.\n\
 524 You are not required to define a variable in order to use it,\n\
 525 but the definition can supply documentation and an initial value\n\
 526 in a way that tags can recognize.\n\n\
 527 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.\n\
 528 If SYMBOL is buffer-local, its default value is initialized in this way.\n\
 529 INITVALUE and DOCSTRING are optional.\n\
 530 If DOCSTRING starts with *, this variable is identified as a user option.\n\
 531  This means that M-x set-variable and M-x edit-options recognize it.\n\
 532 If INITVALUE is missing, SYMBOL's value is not set.")
 533   (args)
 534      Lisp_Object args;
 535 {
 536   register Lisp_Object sym, tem;
 537
 538   sym = Fcar (args);
 539   tem = Fcdr (args);
 540   if (!NILP (tem))
 541     {
 542       tem = Fdefault_boundp (sym);
 543       if (NILP (tem))
 544         Fset_default (sym, Feval (Fcar (Fcdr (args))));
 545     }
 546   tem = Fcar (Fcdr (Fcdr (args)));
 547   if (!NILP (tem))
 548     {
 549       if (!NILP (Vpurify_flag))
 550         tem = Fpurecopy (tem);
 551       Fput (sym, Qvariable_documentation, tem);
 552     }
 553   return sym;
 554 }
 555
 556 DEFUN ("defconst", Fdefconst, Sdefconst, 2, UNEVALLED, 0,
 557   "(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant variable.\n\
 558 The intent is that programs do not change this value, but users may.\n\
 559 Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\
 560 If SYMBOL is buffer-local, its default value is initialized in this way.\n\
 561 DOCSTRING is optional.\n\
 562 If DOCSTRING starts with *, this variable is identified as a user option.\n\
 563  This means that M-x set-variable and M-x edit-options recognize it.\n\n\
 564 Note: do not use `defconst' for user options in libraries that are not\n\
 565 normally loaded, since it is useful for users to be able to specify\n\
 566 their own values for such variables before loading the library.\n\
 567 Since `defconst' unconditionally assigns the variable,\n\
 568 it would override the user's choice.")
 569   (args)
 570      Lisp_Object args;
 571 {
 572   register Lisp_Object sym, tem;
 573
 574   sym = Fcar (args);
 575   Fset_default (sym, Feval (Fcar (Fcdr (args))));
 576   tem = Fcar (Fcdr (Fcdr (args)));
 577   if (!NILP (tem))
 578     {
 579       if (!NILP (Vpurify_flag))
 580         tem = Fpurecopy (tem);
 581       Fput (sym, Qvariable_documentation, tem);
 582     }
 583   return sym;
 584 }
 585
 586 DEFUN ("user-variable-p", Fuser_variable_p, Suser_variable_p, 1, 1, 0,
 587   "Returns t if VARIABLE is intended to be set and modified by users.\n\
 588 \(The alternative is a variable used internally in a Lisp program.)\n\
 589 Determined by whether the first character of the documentation\n\
 590 for the variable is \"*\"")
 591   (variable)
 592      Lisp_Object variable;
 593 {
 594   Lisp_Object documentation;
 595
 596   documentation = Fget (variable, Qvariable_documentation);
 597   if (XTYPE (documentation) == Lisp_Int && XINT (documentation) < 0)
 598     return Qt;
 599   if ((XTYPE (documentation) == Lisp_String) &&
 600       ((unsigned char) XSTRING (documentation)->data[0] == '*'))
 601     return Qt;
 602   return Qnil;
 603 }
 604 \f
 605 DEFUN ("let*", FletX, SletX, 1, UNEVALLED, 0,
 606   "(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
 607 The value of the last form in BODY is returned.\n\
 608 Each element of VARLIST is a symbol (which is bound to nil)\n\
 609 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
 610 Each VALUEFORM can refer to the symbols already bound by this VARLIST.")
 611   (args)
 612      Lisp_Object args;
 613 {
 614   Lisp_Object varlist, val, elt;
 615   int count = specpdl_ptr - specpdl;
 616   struct gcpro gcpro1, gcpro2, gcpro3;
 617
 618   GCPRO3 (args, elt, varlist);
 619
 620   varlist = Fcar (args);
 621   while (!NILP (varlist))
 622     {
 623       QUIT;
 624       elt = Fcar (varlist);
 625       if (XTYPE (elt) == Lisp_Symbol)
 626         specbind (elt, Qnil);
 627       else
 628         {
 629           val = Feval (Fcar (Fcdr (elt)));
 630           specbind (Fcar (elt), val);
 631         }
 632       varlist = Fcdr (varlist);
 633     }
 634   UNGCPRO;
 635   val = Fprogn (Fcdr (args));
 636   return unbind_to (count, val);
 637 }
 638
 639 DEFUN ("let", Flet, Slet, 1, UNEVALLED, 0,
 640   "(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
 641 The value of the last form in BODY is returned.\n\
 642 Each element of VARLIST is a symbol (which is bound to nil)\n\
 643 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
 644 All the VALUEFORMs are evalled before any symbols are bound.")
 645   (args)
 646      Lisp_Object args;
 647 {
 648   Lisp_Object *temps, tem;
 649   register Lisp_Object elt, varlist;
 650   int count = specpdl_ptr - specpdl;
 651   register int argnum;
 652   struct gcpro gcpro1, gcpro2;
 653
 654   varlist = Fcar (args);
 655
 656   /* Make space to hold the values to give the bound variables */
 657   elt = Flength (varlist);
 658   temps = (Lisp_Object *) alloca (XFASTINT (elt) * sizeof (Lisp_Object));
 659
 660   /* Compute the values and store them in `temps' */
 661
 662   GCPRO2 (args, *temps);
 663   gcpro2.nvars = 0;
 664
 665   for (argnum = 0; !NILP (varlist); varlist = Fcdr (varlist))
 666     {
 667       QUIT;
 668       elt = Fcar (varlist);
 669       if (XTYPE (elt) == Lisp_Symbol)
 670         temps [argnum++] = Qnil;
 671       else
 672         temps [argnum++] = Feval (Fcar (Fcdr (elt)));
 673       gcpro2.nvars = argnum;
 674     }
 675   UNGCPRO;
 676
 677   varlist = Fcar (args);
 678   for (argnum = 0; !NILP (varlist); varlist = Fcdr (varlist))
 679     {
 680       elt = Fcar (varlist);
 681       tem = temps[argnum++];
 682       if (XTYPE (elt) == Lisp_Symbol)
 683         specbind (elt, tem);
 684       else
 685         specbind (Fcar (elt), tem);
 686     }
 687
 688   elt = Fprogn (Fcdr (args));
 689   return unbind_to (count, elt);
 690 }
 691
 692 DEFUN ("while", Fwhile, Swhile, 1, UNEVALLED, 0,
 693   "(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.\n\
 694 The order of execution is thus TEST, BODY, TEST, BODY and so on\n\
 695 until TEST returns nil.")
 696   (args)
 697      Lisp_Object args;
 698 {
 699   Lisp_Object test, body, tem;
 700   struct gcpro gcpro1, gcpro2;
 701
 702   GCPRO2 (test, body);
 703
 704   test = Fcar (args);
 705   body = Fcdr (args);
 706   while (tem = Feval (test), !NILP (tem))
 707     {
 708       QUIT;
 709       Fprogn (body);
 710     }
 711
 712   UNGCPRO;
 713   return Qnil;
 714 }
 715
 716 DEFUN ("macroexpand", Fmacroexpand, Smacroexpand, 1, 2, 0,
 717   "Return result of expanding macros at top level of FORM.\n\
 718 If FORM is not a macro call, it is returned unchanged.\n\
 719 Otherwise, the macro is expanded and the expansion is considered\n\
 720 in place of FORM.  When a non-macro-call results, it is returned.\n\n\
 721 The second optional arg ENVIRONMENT species an environment of macro\n\
 722 definitions to shadow the loaded ones for use in file byte-compilation.")
 723   (form, env)
 724      register Lisp_Object form;
 725      Lisp_Object env;
 726 {
 727   register Lisp_Object expander, sym, def, tem;
 728
 729   while (1)
 730     {
 731       /* Come back here each time we expand a macro call,
 732          in case it expands into another macro call.  */
 733       if (XTYPE (form) != Lisp_Cons)
 734         break;
 735       sym = XCONS (form)->car;
 736       /* Detect  ((macro lambda ...) ...)  */
 737       if (XTYPE (sym) == Lisp_Cons
 738           && EQ (XCONS (sym)->car, Qmacro))
 739         {
 740           expander = XCONS (sym)->cdr;
 741           goto explicit;
 742         }
 743       if (XTYPE (sym) != Lisp_Symbol)
 744         break;
 745       /* Trace symbols aliases to other symbols
 746          until we get a symbol that is not an alias.  */
 747       while (1)
 748         {
 749           QUIT;
 750           tem = Fassq (sym, env);
 751           if (NILP (tem))
 752             {
 753               def = XSYMBOL (sym)->function;
 754               if (XTYPE (def) == Lisp_Symbol && !EQ (def, Qunbound))
 755                 sym = def;
 756               else
 757                 break;
 758             }
 759           else
 760             {
 761 #if 0  /* This is turned off because it caused an element (foo . bar)
 762           to have the effect of defining foo as an alias for the macro bar.
 763           That is inconsistent; bar should be a function to expand foo.  */
 764               if (XTYPE (tem) == Lisp_Cons
 765                   && XTYPE (XCONS (tem)->cdr) == Lisp_Symbol)
 766                 sym = XCONS (tem)->cdr;
 767               else
 768 #endif
 769                 break;
 770             }
 771         }
 772       /* Right now TEM is the result from SYM in ENV,
 773          and if TEM is nil then DEF is SYM's function definition.  */
 774       if (NILP (tem))
 775         {
 776           /* SYM is not mentioned in ENV.
 777              Look at its function definition.  */
 778           if (EQ (def, Qunbound)
 779               || XTYPE (def) != Lisp_Cons)
 780             /* Not defined or definition not suitable */
 781             break;
 782           if (EQ (XCONS (def)->car, Qautoload))
 783             {
 784               /* Autoloading function: will it be a macro when loaded?  */
 785               tem = Fcar (Fnthcdr (make_number (4), def));
 786               if (NILP (tem))
 787                 break;
 788               /* Yes, load it and try again.  */
 789               do_autoload (def, sym);
 790               continue;
 791             }
 792           else if (!EQ (XCONS (def)->car, Qmacro))
 793             break;
 794           else expander = XCONS (def)->cdr;
 795         }
 796       else
 797         {
 798           expander = XCONS (tem)->cdr;
 799           if (NILP (expander))
 800             break;
 801         }
 802     explicit:
 803       form = apply1 (expander, XCONS (form)->cdr);
 804     }
 805   return form;
 806 }
 807 \f
 808 DEFUN ("catch", Fcatch, Scatch, 1, UNEVALLED, 0,
 809   "(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.\n\
 810 TAG is evalled to get the tag to use.  Then the BODY is executed.\n\
 811 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.\n\
 812 If no throw happens, `catch' returns the value of the last BODY form.\n\
 813 If a throw happens, it specifies the value to return from `catch'.")
 814   (args)
 815      Lisp_Object args;
 816 {
 817   register Lisp_Object tag;
 818   struct gcpro gcpro1;
 819
 820   GCPRO1 (args);
 821   tag = Feval (Fcar (args));
 822   UNGCPRO;
 823   return internal_catch (tag, Fprogn, Fcdr (args));
 824 }
 825
 826 /* Set up a catch, then call C function FUNC on argument ARG.
 827    FUNC should return a Lisp_Object.
 828    This is how catches are done from within C code. */
 829
 830 Lisp_Object
 831 internal_catch (tag, func, arg)
 832      Lisp_Object tag;
 833      Lisp_Object (*func) ();
 834      Lisp_Object arg;
 835 {
 836   /* This structure is made part of the chain `catchlist'.  */
 837   struct catchtag c;
 838
 839   /* Fill in the components of c, and put it on the list.  */
 840   c.next = catchlist;
 841   c.tag = tag;
 842   c.val = Qnil;
 843   c.backlist = backtrace_list;
 844   c.handlerlist = handlerlist;
 845   c.lisp_eval_depth = lisp_eval_depth;
 846   c.pdlcount = specpdl_ptr - specpdl;
 847   c.poll_suppress_count = poll_suppress_count;
 848   c.gcpro = gcprolist;
 849   catchlist = &c;
 850
 851   /* Call FUNC.  */
 852   if (! _setjmp (c.jmp))
 853     c.val = (*func) (arg);
 854
 855   /* Throw works by a longjmp that comes right here.  */
 856   catchlist = c.next;
 857   return c.val;
 858 }
 859
 860 /* Discard from the catchlist all catch tags back through CATCH.
 861    Before each catch is discarded, unbind all special bindings
 862    made within that catch.  Also, when discarding a catch that
 863    corresponds to a condition handler, discard that handler.
 864
 865    At the end, restore some static info saved in CATCH.
 866
 867    This is used for correct unwinding in Fthrow and Fsignal,
 868    before doing the longjmp that actually destroys the stack frames
 869    in which these handlers and catches reside.  */
 870
 871 static void
 872 unbind_catch (catch)
 873      struct catchtag *catch;
 874 {
 875   register int last_time;
 876
 877   do
 878     {
 879       last_time = catchlist == catch;
 880       unbind_to (catchlist->pdlcount, Qnil);
 881       handlerlist = catchlist->handlerlist;
 882       catchlist = catchlist->next;
 883     }
 884   while (! last_time);
 885
 886   gcprolist = catch->gcpro;
 887   backtrace_list = catch->backlist;
 888   lisp_eval_depth = catch->lisp_eval_depth;
 889 }
 890
 891 DEFUN ("throw", Fthrow, Sthrow, 2, 2, 0,
 892   "(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.\n\
 893 Both TAG and VALUE are evalled.")
 894   (tag, val)
 895      register Lisp_Object tag, val;
 896 {
 897   register struct catchtag *c;
 898
 899   while (1)
 900     {
 901       if (!NILP (tag))
 902         for (c = catchlist; c; c = c->next)
 903           {
 904             if (EQ (c->tag, tag))
 905               {
 906                 /* Restore the polling-suppression count.  */
 907                 if (c->poll_suppress_count > poll_suppress_count)
 908                   abort ();
 909                 while (c->poll_suppress_count < poll_suppress_count)
 910                   start_polling ();
 911                 c->val = val;
 912                 unbind_catch (c);
 913                 _longjmp (c->jmp, 1);
 914               }
 915           }
 916       tag = Fsignal (Qno_catch, Fcons (tag, Fcons (val, Qnil)));
 917     }
 918 }
 919
 920
 921 DEFUN ("unwind-protect", Funwind_protect, Sunwind_protect, 1, UNEVALLED, 0,
 922   "Do BODYFORM, protecting with UNWINDFORMS.\n\
 923 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).\n\
 924 If BODYFORM completes normally, its value is returned\n\
 925 after executing the UNWINDFORMS.\n\
 926 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.")
 927   (args)
 928      Lisp_Object args;
 929 {
 930   Lisp_Object val;
 931   int count = specpdl_ptr - specpdl;
 932
 933   record_unwind_protect (0, Fcdr (args));
 934   val = Feval (Fcar (args));
 935   return unbind_to (count, val);
 936 }
 937 \f
 938 /* Chain of condition handlers currently in effect.
 939    The elements of this chain are contained in the stack frames
 940    of Fcondition_case and internal_condition_case.
 941    When an error is signaled (by calling Fsignal, below),
 942    this chain is searched for an element that applies.  */
 943
 944 struct handler *handlerlist;
 945
 946 DEFUN ("condition-case", Fcondition_case, Scondition_case, 2, UNEVALLED, 0,
 947   "Regain control when an error is signaled.\n\
 948 Usage looks like (condition-case VAR BODYFORM HANDLERS...).\n\
 949 executes BODYFORM and returns its value if no error happens.\n\
 950 Each element of HANDLERS looks like (CONDITION-NAME BODY...)\n\
 951 where the BODY is made of Lisp expressions.\n\n\
 952 A handler is applicable to an error\n\
 953 if CONDITION-NAME is one of the error's condition names.\n\
 954 If an error happens, the first applicable handler is run.\n\
 955 \n\
 956 When a handler handles an error,\n\
 957 control returns to the condition-case and the handler BODY... is executed\n\
 958 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\
 959 VAR may be nil; then you do not get access to the signal information.\n\
 960 \n\
 961 The value of the last BODY form is returned from the condition-case.\n\
 962 See also the function `signal' for more info.")
 963   (args)
 964      Lisp_Object args;
 965 {
 966   Lisp_Object val;
 967   struct catchtag c;
 968   struct handler h;
 969   register Lisp_Object tem;
 970
 971   tem = Fcar (args);
 972   CHECK_SYMBOL (tem, 0);
 973
 974   c.tag = Qnil;
 975   c.val = Qnil;
 976   c.backlist = backtrace_list;
 977   c.handlerlist = handlerlist;
 978   c.lisp_eval_depth = lisp_eval_depth;
 979   c.pdlcount = specpdl_ptr - specpdl;
 980   c.poll_suppress_count = poll_suppress_count;
 981   c.gcpro = gcprolist;
 982   if (_setjmp (c.jmp))
 983     {
 984       if (!NILP (h.var))
 985         specbind (h.var, Fcdr (c.val));
 986       val = Fprogn (Fcdr (Fcar (c.val)));
 987       unbind_to (c.pdlcount, Qnil);
 988       return val;
 989     }
 990   c.next = catchlist;
 991   catchlist = &c;
 992   h.var = Fcar (args);
 993   h.handler = Fcdr (Fcdr (args));
 994
 995   for (val = h.handler; ! NILP (val); val = Fcdr (val))
 996     {
 997       tem = Fcar (val);
 998       if ((!NILP (tem)) &&
 999           (!CONSP (tem) || (XTYPE (XCONS (tem)->car) != Lisp_Symbol)))
1000         error ("Invalid condition handler", tem);
1001     }
1002
1003   h.next = handlerlist;
1004   h.poll_suppress_count = poll_suppress_count;
1005   h.tag = &c;
1006   handlerlist = &h;
1007
1008   val = Feval (Fcar (Fcdr (args)));
1009   catchlist = c.next;
1010   handlerlist = h.next;
1011   return val;
1012 }
1013
1014 Lisp_Object
1015 internal_condition_case (bfun, handlers, hfun)
1016      Lisp_Object (*bfun) ();
1017      Lisp_Object handlers;
1018      Lisp_Object (*hfun) ();
1019 {
1020   Lisp_Object val;
1021   struct catchtag c;
1022   struct handler h;
1023
1024   c.tag = Qnil;
1025   c.val = Qnil;
1026   c.backlist = backtrace_list;
1027   c.handlerlist = handlerlist;
1028   c.lisp_eval_depth = lisp_eval_depth;
1029   c.pdlcount = specpdl_ptr - specpdl;
1030   c.poll_suppress_count = poll_suppress_count;
1031   c.gcpro = gcprolist;
1032   if (_setjmp (c.jmp))
1033     {
1034       return (*hfun) (Fcdr (c.val));
1035     }
1036   c.next = catchlist;
1037   catchlist = &c;
1038   h.handler = handlers;
1039   h.var = Qnil;
1040   h.poll_suppress_count = poll_suppress_count;
1041   h.next = handlerlist;
1042   h.tag = &c;
1043   handlerlist = &h;
1044
1045   val = (*bfun) ();
1046   catchlist = c.next;
1047   handlerlist = h.next;
1048   return val;
1049 }
1050
1051 static Lisp_Object find_handler_clause ();
1052
1053 DEFUN ("signal", Fsignal, Ssignal, 2, 2, 0,
1054   "Signal an error.  Args are SIGNAL-NAME, and associated DATA.\n\
1055 This function does not return.\n\n\
1056 A signal name is a symbol with an `error-conditions' property\n\
1057 that is a list of condition names.\n\
1058 A handler for any of those names will get to handle this signal.\n\
1059 The symbol `error' should normally be one of them.\n\
1060 \n\
1061 DATA should be a list.  Its elements are printed as part of the error message.\n\
1062 If the signal is handled, DATA is made available to the handler.\n\
1063 See also the function `condition-case'.")
1064   (sig, data)
1065      Lisp_Object sig, data;
1066 {
1067   register struct handler *allhandlers = handlerlist;
1068   Lisp_Object conditions;
1069   extern int gc_in_progress;
1070   extern int waiting_for_input;
1071   Lisp_Object debugger_value;
1072
1073   quit_error_check ();
1074   immediate_quit = 0;
1075   if (gc_in_progress || waiting_for_input)
1076     abort ();
1077
1078   TOTALLY_UNBLOCK_INPUT;
1079
1080   conditions = Fget (sig, Qerror_conditions);
1081
1082   for (; handlerlist; handlerlist = handlerlist->next)
1083     {
1084       register Lisp_Object clause;
1085       clause = find_handler_clause (handlerlist->handler, conditions,
1086                                     sig, data, &debugger_value);
1087
1088 #if 0 /* Most callers are not prepared to handle gc if this returns.
1089          So, since this feature is not very useful, take it out.  */
1090       /* If have called debugger and user wants to continue,
1091          just return nil.  */
1092       if (EQ (clause, Qlambda))
1093         return debugger_value;
1094 #else
1095       if (EQ (clause, Qlambda))
1096         error ("Returning a value from an error is no longer supported");
1097 #endif
1098
1099       if (!NILP (clause))
1100         {
1101           struct handler *h = handlerlist;
1102           /* Restore the polling-suppression count.  */
1103           if (h->poll_suppress_count > poll_suppress_count)
1104             abort ();
1105           while (h->poll_suppress_count < poll_suppress_count)
1106             start_polling ();
1107           handlerlist = allhandlers;
1108           unbind_catch (h->tag);
1109           h->tag->val = Fcons (clause, Fcons (sig, data));
1110           _longjmp (h->tag->jmp, 1);
1111         }
1112     }
1113
1114   handlerlist = allhandlers;
1115   /* If no handler is present now, try to run the debugger,
1116      and if that fails, throw to top level.  */
1117   find_handler_clause (Qerror, conditions, sig, data, &debugger_value);
1118   Fthrow (Qtop_level, Qt);
1119 }
1120
1121 /* Value of Qlambda means we have called debugger and
1122    user has continued.  Store value returned fromdebugger
1123    into *debugger_value_ptr */
1124
1125 static Lisp_Object
1126 find_handler_clause (handlers, conditions, sig, data, debugger_value_ptr)
1127      Lisp_Object handlers, conditions, sig, data;
1128      Lisp_Object *debugger_value_ptr;
1129 {
1130   register Lisp_Object h;
1131   register Lisp_Object tem;
1132   register Lisp_Object tem1;
1133
1134   if (EQ (handlers, Qt))  /* t is used by handlers for all conditions, set up by C code.  */
1135     return Qt;
1136   if (EQ (handlers, Qerror))  /* error is used similarly, but means display a backtrace too */
1137     {
1138       if (stack_trace_on_error)
1139         internal_with_output_to_temp_buffer ("*Backtrace*", Fbacktrace, Qnil);
1140       if (!entering_debugger
1141           && EQ (sig, Qquit) ? debug_on_quit : debug_on_error)
1142         {
1143           int count = specpdl_ptr - specpdl;
1144           specbind (Qdebug_on_error, Qnil);
1145           *debugger_value_ptr =
1146             call_debugger (Fcons (Qerror,
1147                                   Fcons (Fcons (sig, data),
1148                                          Qnil)));
1149           return unbind_to (count, Qlambda);
1150         }
1151       return Qt;
1152     }
1153   for (h = handlers; CONSP (h); h = Fcdr (h))
1154     {
1155       tem1 = Fcar (h);
1156       if (!CONSP (tem1))
1157         continue;
1158       tem = Fmemq (Fcar (tem1), conditions);
1159       if (!NILP (tem))
1160         return tem1;
1161     }
1162   return Qnil;
1163 }
1164
1165 /* dump an error message; called like printf */
1166
1167 /* VARARGS 1 */
1168 void
1169 error (m, a1, a2, a3)
1170      char *m;
1171 {
1172   char buf[200];
1173   sprintf (buf, m, a1, a2, a3);
1174
1175   while (1)
1176     Fsignal (Qerror, Fcons (build_string (buf), Qnil));
1177 }
1178 \f
1179 DEFUN ("commandp", Fcommandp, Scommandp, 1, 1, 0,
1180   "T if FUNCTION makes provisions for interactive calling.\n\
1181 This means it contains a description for how to read arguments to give it.\n\
1182 The value is nil for an invalid function or a symbol with no function\n\
1183 definition.\n\
1184 \n\
1185 Interactively callable functions include strings and vectors (treated\n\
1186 as keyboard macros), lambda-expressions that contain a top-level call\n\
1187 to `interactive', autoload definitions made by `autoload' with non-nil\n\
1188 fourth argument, and some of the built-in functions of Lisp.\n\
1189 \n\
1190 Also, a symbol satisfies `commandp' if its function definition does so.")
1191   (function)
1192      Lisp_Object function;
1193 {
1194   register Lisp_Object fun;
1195   register Lisp_Object funcar;
1196   register Lisp_Object tem;
1197   register int i = 0;
1198
1199   fun = function;
1200
1201   /* Dereference symbols, but avoid infinte loops.  Eech.  */
1202   while (XTYPE (fun) == Lisp_Symbol)
1203     {
1204       if (++i > 10) return Qnil;
1205       tem = Ffboundp (fun);
1206       if (NILP (tem)) return Qnil;
1207       fun = Fsymbol_function (fun);
1208     }
1209
1210   /* Emacs primitives are interactive if their DEFUN specifies an
1211      interactive spec.  */
1212   if (XTYPE (fun) == Lisp_Subr)
1213     {
1214       if (XSUBR (fun)->prompt)
1215         return Qt;
1216       else
1217         return Qnil;
1218     }
1219
1220   /* Bytecode objects are interactive if they are long enough to
1221      have an element whose index is COMPILED_INTERACTIVE, which is
1222      where the interactive spec is stored.  */
1223   else if (XTYPE (fun) == Lisp_Compiled)
1224     return (XVECTOR (fun)->size > COMPILED_INTERACTIVE
1225             ? Qt : Qnil);
1226
1227   /* Strings and vectors are keyboard macros.  */
1228   if (XTYPE (fun) == Lisp_String
1229       || XTYPE (fun) == Lisp_Vector)
1230     return Qt;
1231
1232   /* Lists may represent commands.  */
1233   if (!CONSP (fun))
1234     return Qnil;
1235   funcar = Fcar (fun);
1236   if (XTYPE (funcar) != Lisp_Symbol)
1237     return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1238   if (EQ (funcar, Qlambda))
1239     return Fassq (Qinteractive, Fcdr (Fcdr (fun)));
1240   if (EQ (funcar, Qmocklisp))
1241     return Qt;  /* All mocklisp functions can be called interactively */
1242   if (EQ (funcar, Qautoload))
1243     return Fcar (Fcdr (Fcdr (Fcdr (fun))));
1244   else
1245     return Qnil;
1246 }
1247
1248 /* ARGSUSED */
1249 DEFUN ("autoload", Fautoload, Sautoload, 2, 5, 0,
1250   "Define FUNCTION to autoload from FILE.\n\
1251 FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\
1252 Third arg DOCSTRING is documentation for the function.\n\
1253 Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\
1254 Fifth arg MACRO if non-nil says the function is really a macro.\n\
1255 Third through fifth args give info about the real definition.\n\
1256 They default to nil.\n\
1257 If FUNCTION is already defined other than as an autoload,\n\
1258 this does nothing and returns nil.")
1259   (function, file, docstring, interactive, macro)
1260      Lisp_Object function, file, docstring, interactive, macro;
1261 {
1262 #ifdef NO_ARG_ARRAY
1263   Lisp_Object args[4];
1264 #endif
1265
1266   CHECK_SYMBOL (function, 0);
1267   CHECK_STRING (file, 1);
1268
1269   /* If function is defined and not as an autoload, don't override */
1270   if (!EQ (XSYMBOL (function)->function, Qunbound)
1271       && !(XTYPE (XSYMBOL (function)->function) == Lisp_Cons
1272            && EQ (XCONS (XSYMBOL (function)->function)->car, Qautoload)))
1273     return Qnil;
1274
1275 #ifdef NO_ARG_ARRAY
1276   args[0] = file;
1277   args[1] = docstring;
1278   args[2] = interactive;
1279   args[3] = macro;
1280
1281   return Ffset (function, Fcons (Qautoload, Flist (4, &args[0])));
1282 #else /* NO_ARG_ARRAY */
1283   return Ffset (function, Fcons (Qautoload, Flist (4, &file)));
1284 #endif /* not NO_ARG_ARRAY */
1285 }
1286
1287 Lisp_Object
1288 un_autoload (oldqueue)
1289      Lisp_Object oldqueue;
1290 {
1291   register Lisp_Object queue, first, second;
1292
1293   /* Queue to unwind is current value of Vautoload_queue.
1294      oldqueue is the shadowed value to leave in Vautoload_queue.  */
1295   queue = Vautoload_queue;
1296   Vautoload_queue = oldqueue;
1297   while (CONSP (queue))
1298     {
1299       first = Fcar (queue);
1300       second = Fcdr (first);
1301       first = Fcar (first);
1302       if (EQ (second, Qnil))
1303         Vfeatures = first;
1304       else
1305         Ffset (first, second);
1306       queue = Fcdr (queue);
1307     }
1308   return Qnil;
1309 }
1310
1311 do_autoload (fundef, funname)
1312      Lisp_Object fundef, funname;
1313 {
1314   int count = specpdl_ptr - specpdl;
1315   Lisp_Object fun, val;
1316
1317   fun = funname;
1318   CHECK_SYMBOL (funname, 0);
1319
1320   /* Value saved here is to be restored into Vautoload_queue */
1321   record_unwind_protect (un_autoload, Vautoload_queue);
1322   Vautoload_queue = Qt;
1323   Fload (Fcar (Fcdr (fundef)), Qnil, noninteractive ? Qt : Qnil, Qnil);
1324   /* Once loading finishes, don't undo it.  */
1325   Vautoload_queue = Qt;
1326   unbind_to (count, Qnil);
1327
1328   while (XTYPE (fun) == Lisp_Symbol)
1329     {
1330       QUIT;
1331       val = XSYMBOL (fun)->function;
1332       if (EQ (val, Qunbound))
1333         Fsymbol_function (fun); /* Get the right kind of error! */
1334       fun = val;
1335     }
1336   if (XTYPE (fun) == Lisp_Cons
1337       && EQ (XCONS (fun)->car, Qautoload))
1338     error ("Autoloading failed to define function %s",
1339            XSYMBOL (funname)->name->data);
1340 }
1341 \f
1342 DEFUN ("eval", Feval, Seval, 1, 1, 0,
1343   "Evaluate FORM and return its value.")
1344   (form)
1345      Lisp_Object form;
1346 {
1347   Lisp_Object fun, val, original_fun, original_args;
1348   Lisp_Object funcar;
1349   struct backtrace backtrace;
1350   struct gcpro gcpro1, gcpro2, gcpro3;
1351
1352   if (XTYPE (form) == Lisp_Symbol)
1353     {
1354       if (EQ (Vmocklisp_arguments, Qt))
1355         return Fsymbol_value (form);
1356       val = Fsymbol_value (form);
1357       if (NILP (val))
1358         XFASTINT (val) = 0;
1359       else if (EQ (val, Qt))
1360         XFASTINT (val) = 1;
1361       return val;
1362     }
1363   if (!CONSP (form))
1364     return form;
1365
1366   QUIT;
1367   if (consing_since_gc > gc_cons_threshold)
1368     {
1369       GCPRO1 (form);
1370       Fgarbage_collect ();
1371       UNGCPRO;
1372     }
1373
1374   if (++lisp_eval_depth > max_lisp_eval_depth)
1375     {
1376       if (max_lisp_eval_depth < 100)
1377         max_lisp_eval_depth = 100;
1378       if (lisp_eval_depth > max_lisp_eval_depth)
1379         error ("Lisp nesting exceeds max-lisp-eval-depth");
1380     }
1381
1382   original_fun = Fcar (form);
1383   original_args = Fcdr (form);
1384
1385   backtrace.next = backtrace_list;
1386   backtrace_list = &backtrace;
1387   backtrace.function = &original_fun; /* This also protects them from gc */
1388   backtrace.args = &original_args;
1389   backtrace.nargs = UNEVALLED;
1390   backtrace.evalargs = 1;
1391   backtrace.debug_on_exit = 0;
1392
1393   if (debug_on_next_call)
1394     do_debug_on_call (Qt);
1395
1396   /* At this point, only original_fun and original_args
1397      have values that will be used below */
1398  retry:
1399   fun = original_fun;
1400   while (XTYPE (fun) == Lisp_Symbol)
1401     {
1402       QUIT;
1403       val = XSYMBOL (fun)->function;
1404       if (EQ (val, Qunbound))
1405         Fsymbol_function (fun); /* Get the right kind of error! */
1406       fun = val;
1407     }
1408
1409   if (XTYPE (fun) == Lisp_Subr)
1410     {
1411       Lisp_Object numargs;
1412       Lisp_Object argvals[7];
1413       Lisp_Object args_left;
1414       register int i, maxargs;
1415
1416       args_left = original_args;
1417       numargs = Flength (args_left);
1418
1419       if (XINT (numargs) < XSUBR (fun)->min_args ||
1420           (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < XINT (numargs)))
1421         return Fsignal (Qwrong_number_of_arguments, Fcons (fun, Fcons (numargs, Qnil)));
1422
1423       if (XSUBR (fun)->max_args == UNEVALLED)
1424         {
1425           backtrace.evalargs = 0;
1426           val = (*XSUBR (fun)->function) (args_left);
1427           goto done;
1428         }
1429
1430       if (XSUBR (fun)->max_args == MANY)
1431         {
1432           /* Pass a vector of evaluated arguments */
1433           Lisp_Object *vals;
1434           register int argnum = 0;
1435
1436           vals = (Lisp_Object *) alloca (XINT (numargs) * sizeof (Lisp_Object));
1437
1438           GCPRO3 (args_left, fun, fun);
1439           gcpro3.var = vals;
1440           gcpro3.nvars = 0;
1441
1442           while (!NILP (args_left))
1443             {
1444               vals[argnum++] = Feval (Fcar (args_left));
1445               args_left = Fcdr (args_left);
1446               gcpro3.nvars = argnum;
1447             }
1448
1449           backtrace.args = vals;
1450           backtrace.nargs = XINT (numargs);
1451
1452           val = (*XSUBR (fun)->function) (XINT (numargs), vals);
1453           UNGCPRO;
1454           goto done;
1455         }
1456
1457       GCPRO3 (args_left, fun, fun);
1458       gcpro3.var = argvals;
1459       gcpro3.nvars = 0;
1460
1461       maxargs = XSUBR (fun)->max_args;
1462       for (i = 0; i < maxargs; args_left = Fcdr (args_left))
1463         {
1464           argvals[i] = Feval (Fcar (args_left));
1465           gcpro3.nvars = ++i;
1466         }
1467
1468       UNGCPRO;
1469
1470       backtrace.args = argvals;
1471       backtrace.nargs = XINT (numargs);
1472
1473       switch (i)
1474         {
1475         case 0:
1476           val = (*XSUBR (fun)->function) ();
1477           goto done;
1478         case 1:
1479           val = (*XSUBR (fun)->function) (argvals[0]);
1480           goto done;
1481         case 2:
1482           val = (*XSUBR (fun)->function) (argvals[0], argvals[1]);
1483           goto done;
1484         case 3:
1485           val = (*XSUBR (fun)->function) (argvals[0], argvals[1],
1486                                           argvals[2]);
1487           goto done;
1488         case 4:
1489           val = (*XSUBR (fun)->function) (argvals[0], argvals[1],
1490                                           argvals[2], argvals[3]);
1491           goto done;
1492         case 5:
1493           val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2],
1494                                           argvals[3], argvals[4]);
1495           goto done;
1496         case 6:
1497           val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2],
1498                                           argvals[3], argvals[4], argvals[5]);
1499           goto done;
1500
1501         default:
1502           error ("Ffuncall doesn't handle that number of arguments.");
1503           goto done;
1504         }
1505     }
1506   if (XTYPE (fun) == Lisp_Compiled)
1507     val = apply_lambda (fun, original_args, 1);
1508   else
1509     {
1510       if (!CONSP (fun))
1511         return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1512       funcar = Fcar (fun);
1513       if (XTYPE (funcar) != Lisp_Symbol)
1514         return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1515       if (EQ (funcar, Qautoload))
1516         {
1517           do_autoload (fun, original_fun);
1518           goto retry;
1519         }
1520       if (EQ (funcar, Qmacro))
1521         val = Feval (apply1 (Fcdr (fun), original_args));
1522       else if (EQ (funcar, Qlambda))
1523         val = apply_lambda (fun, original_args, 1);
1524       else if (EQ (funcar, Qmocklisp))
1525         val = ml_apply (fun, original_args);
1526       else
1527         return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1528     }
1529  done:
1530   if (!EQ (Vmocklisp_arguments, Qt))
1531     {
1532       if (NILP (val))
1533         XFASTINT (val) = 0;
1534       else if (EQ (val, Qt))
1535         XFASTINT (val) = 1;
1536     }
1537   lisp_eval_depth--;
1538   if (backtrace.debug_on_exit)
1539     val = call_debugger (Fcons (Qexit, Fcons (val, Qnil)));
1540   backtrace_list = backtrace.next;
1541   return val;
1542 }
1543 \f
1544 DEFUN ("apply", Fapply, Sapply, 2, MANY, 0,
1545   "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
1546 Thus, (apply '+ 1 2 '(3 4)) returns 10.")
1547   (nargs, args)
1548      int nargs;
1549      Lisp_Object *args;
1550 {
1551   register int i, numargs;
1552   register Lisp_Object spread_arg;
1553   register Lisp_Object *funcall_args;
1554   Lisp_Object fun;
1555   struct gcpro gcpro1;
1556
1557   fun = args [0];
1558   funcall_args = 0;
1559   spread_arg = args [nargs - 1];
1560   CHECK_LIST (spread_arg, nargs);
1561
1562   numargs = XINT (Flength (spread_arg));
1563
1564   if (numargs == 0)
1565     return Ffuncall (nargs - 1, args);
1566   else if (numargs == 1)
1567     {
1568       args [nargs - 1] = XCONS (spread_arg)->car;
1569       return Ffuncall (nargs, args);
1570     }
1571
1572   numargs += nargs - 2;
1573
1574   while (XTYPE (fun) == Lisp_Symbol)
1575     {
1576       QUIT;
1577       fun = XSYMBOL (fun)->function;
1578       if (EQ (fun, Qunbound))
1579         {
1580           /* Let funcall get the error */
1581           fun = args[0];
1582           goto funcall;
1583         }
1584     }
1585
1586   if (XTYPE (fun) == Lisp_Subr)
1587     {
1588       if (numargs < XSUBR (fun)->min_args
1589           || (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs))
1590         goto funcall;           /* Let funcall get the error */
1591       else if (XSUBR (fun)->max_args > numargs)
1592         {
1593           /* Avoid making funcall cons up a yet another new vector of arguments
1594              by explicitly supplying nil's for optional values */
1595           funcall_args = (Lisp_Object *) alloca ((1 + XSUBR (fun)->max_args)
1596                                                  * sizeof (Lisp_Object));
1597           for (i = numargs; i < XSUBR (fun)->max_args;)
1598             funcall_args[++i] = Qnil;
1599           GCPRO1 (*funcall_args);
1600           gcpro1.nvars = 1 + XSUBR (fun)->max_args;
1601         }
1602     }
1603  funcall:
1604   /* We add 1 to numargs because funcall_args includes the
1605      function itself as well as its arguments.  */
1606   if (!funcall_args)
1607     {
1608       funcall_args = (Lisp_Object *) alloca ((1 + numargs)
1609                                              * sizeof (Lisp_Object));
1610       GCPRO1 (*funcall_args);
1611       gcpro1.nvars = 1 + numargs;
1612     }
1613
1614   bcopy (args, funcall_args, nargs * sizeof (Lisp_Object));
1615   /* Spread the last arg we got.  Its first element goes in
1616      the slot that it used to occupy, hence this value of I.  */
1617   i = nargs - 1;
1618   while (!NILP (spread_arg))
1619     {
1620       funcall_args [i++] = XCONS (spread_arg)->car;
1621       spread_arg = XCONS (spread_arg)->cdr;
1622     }
1623
1624   RETURN_UNGCPRO (Ffuncall (gcpro1.nvars, funcall_args));
1625 }
1626 \f
1627 /* Apply fn to arg */
1628 Lisp_Object
1629 apply1 (fn, arg)
1630      Lisp_Object fn, arg;
1631 {
1632   struct gcpro gcpro1;
1633
1634   GCPRO1 (fn);
1635   if (NILP (arg))
1636     RETURN_UNGCPRO (Ffuncall (1, &fn));
1637   gcpro1.nvars = 2;
1638 #ifdef NO_ARG_ARRAY
1639   {
1640     Lisp_Object args[2];
1641     args[0] = fn;
1642     args[1] = arg;
1643     gcpro1.var = args;
1644     RETURN_UNGCPRO (Fapply (2, args));
1645   }
1646 #else /* not NO_ARG_ARRAY */
1647   RETURN_UNGCPRO (Fapply (2, &fn));
1648 #endif /* not NO_ARG_ARRAY */
1649 }
1650
1651 /* Call function fn on no arguments */
1652 Lisp_Object
1653 call0 (fn)
1654      Lisp_Object fn;
1655 {
1656   struct gcpro gcpro1;
1657
1658   GCPRO1 (fn);
1659   RETURN_UNGCPRO (Ffuncall (1, &fn));
1660 }
1661
1662 /* Call function fn with argument arg */
1663 /* ARGSUSED */
1664 Lisp_Object
1665 call1 (fn, arg)
1666      Lisp_Object fn, arg;
1667 {
1668   struct gcpro gcpro1;
1669 #ifdef NO_ARG_ARRAY
1670   Lisp_Object args[2];
1671
1672   args[0] = fn;
1673   args[1] = arg;
1674   GCPRO1 (args[0]);
1675   gcpro1.nvars = 2;
1676   RETURN_UNGCPRO (Ffuncall (2, args));
1677 #else /* not NO_ARG_ARRAY */
1678   GCPRO1 (fn);
1679   gcpro1.nvars = 2;
1680   RETURN_UNGCPRO (Ffuncall (2, &fn));
1681 #endif /* not NO_ARG_ARRAY */
1682 }
1683
1684 /* Call function fn with arguments arg, arg1 */
1685 /* ARGSUSED */
1686 Lisp_Object
1687 call2 (fn, arg, arg1)
1688      Lisp_Object fn, arg, arg1;
1689 {
1690   struct gcpro gcpro1;
1691 #ifdef NO_ARG_ARRAY
1692   Lisp_Object args[3];
1693   args[0] = fn;
1694   args[1] = arg;
1695   args[2] = arg1;
1696   GCPRO1 (args[0]);
1697   gcpro1.nvars = 3;
1698   RETURN_UNGCPRO (Ffuncall (3, args));
1699 #else /* not NO_ARG_ARRAY */
1700   GCPRO1 (fn);
1701   gcpro1.nvars = 3;
1702   RETURN_UNGCPRO (Ffuncall (3, &fn));
1703 #endif /* not NO_ARG_ARRAY */
1704 }
1705
1706 /* Call function fn with arguments arg, arg1, arg2 */
1707 /* ARGSUSED */
1708 Lisp_Object
1709 call3 (fn, arg, arg1, arg2)
1710      Lisp_Object fn, arg, arg1, arg2;
1711 {
1712   struct gcpro gcpro1;
1713 #ifdef NO_ARG_ARRAY
1714   Lisp_Object args[4];
1715   args[0] = fn;
1716   args[1] = arg;
1717   args[2] = arg1;
1718   args[3] = arg2;
1719   GCPRO1 (args[0]);
1720   gcpro1.nvars = 4;
1721   RETURN_UNGCPRO (Ffuncall (4, args));
1722 #else /* not NO_ARG_ARRAY */
1723   GCPRO1 (fn);
1724   gcpro1.nvars = 4;
1725   RETURN_UNGCPRO (Ffuncall (4, &fn));
1726 #endif /* not NO_ARG_ARRAY */
1727 }
1728
1729 DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0,
1730   "Call first argument as a function, passing remaining arguments to it.\n\
1731 Thus, (funcall 'cons 'x 'y) returns (x . y).")
1732   (nargs, args)
1733      int nargs;
1734      Lisp_Object *args;
1735 {
1736   Lisp_Object fun;
1737   Lisp_Object funcar;
1738   int numargs = nargs - 1;
1739   Lisp_Object lisp_numargs;
1740   Lisp_Object val;
1741   struct backtrace backtrace;
1742   register Lisp_Object *internal_args;
1743   register int i;
1744
1745   QUIT;
1746   if (consing_since_gc > gc_cons_threshold)
1747     Fgarbage_collect ();
1748
1749   if (++lisp_eval_depth > max_lisp_eval_depth)
1750     {
1751       if (max_lisp_eval_depth < 100)
1752         max_lisp_eval_depth = 100;
1753       if (lisp_eval_depth > max_lisp_eval_depth)
1754         error ("Lisp nesting exceeds max-lisp-eval-depth");
1755     }
1756
1757   backtrace.next = backtrace_list;
1758   backtrace_list = &backtrace;
1759   backtrace.function = &args[0];
1760   backtrace.args = &args[1];
1761   backtrace.nargs = nargs - 1;
1762   backtrace.evalargs = 0;
1763   backtrace.debug_on_exit = 0;
1764
1765   if (debug_on_next_call)
1766     do_debug_on_call (Qlambda);
1767
1768  retry:
1769
1770   fun = args[0];
1771   while (XTYPE (fun) == Lisp_Symbol)
1772     {
1773       QUIT;
1774       val = XSYMBOL (fun)->function;
1775       if (EQ (val, Qunbound))
1776         Fsymbol_function (fun); /* Get the right kind of error! */
1777       fun = val;
1778     }
1779
1780   if (XTYPE (fun) == Lisp_Subr)
1781     {
1782       if (numargs < XSUBR (fun)->min_args
1783           || (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs))
1784         {
1785           XFASTINT (lisp_numargs) = numargs;
1786           return Fsignal (Qwrong_number_of_arguments, Fcons (fun, Fcons (lisp_numargs, Qnil)));
1787         }
1788
1789       if (XSUBR (fun)->max_args == UNEVALLED)
1790         return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1791
1792       if (XSUBR (fun)->max_args == MANY)
1793         {
1794           val = (*XSUBR (fun)->function) (numargs, args + 1);
1795           goto done;
1796         }
1797
1798       if (XSUBR (fun)->max_args > numargs)
1799         {
1800           internal_args = (Lisp_Object *) alloca (XSUBR (fun)->max_args * sizeof (Lisp_Object));
1801           bcopy (args + 1, internal_args, numargs * sizeof (Lisp_Object));
1802           for (i = numargs; i < XSUBR (fun)->max_args; i++)
1803             internal_args[i] = Qnil;
1804         }
1805       else
1806         internal_args = args + 1;
1807       switch (XSUBR (fun)->max_args)
1808         {
1809         case 0:
1810           val = (*XSUBR (fun)->function) ();
1811           goto done;
1812         case 1:
1813           val = (*XSUBR (fun)->function) (internal_args[0]);
1814           goto done;
1815         case 2:
1816           val = (*XSUBR (fun)->function) (internal_args[0],
1817                                           internal_args[1]);
1818           goto done;
1819         case 3:
1820           val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1],
1821                                           internal_args[2]);
1822           goto done;
1823         case 4:
1824           val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1],
1825                                           internal_args[2],
1826                                           internal_args[3]);
1827           goto done;
1828         case 5:
1829           val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1],
1830                                           internal_args[2], internal_args[3],
1831                                           internal_args[4]);
1832           goto done;
1833         case 6:
1834           val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1],
1835                                           internal_args[2], internal_args[3],
1836                                           internal_args[4], internal_args[5]);
1837           goto done;
1838
1839         default:
1840           error ("funcall: this number of args not handled.");
1841         }
1842     }
1843   if (XTYPE (fun) == Lisp_Compiled)
1844     val = funcall_lambda (fun, numargs, args + 1);
1845   else
1846     {
1847       if (!CONSP (fun))
1848         return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1849       funcar = Fcar (fun);
1850       if (XTYPE (funcar) != Lisp_Symbol)
1851         return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1852       if (EQ (funcar, Qlambda))
1853         val = funcall_lambda (fun, numargs, args + 1);
1854       else if (EQ (funcar, Qmocklisp))
1855         val = ml_apply (fun, Flist (numargs, args + 1));
1856       else if (EQ (funcar, Qautoload))
1857         {
1858           do_autoload (fun, args[0]);
1859           goto retry;
1860         }
1861       else
1862         return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1863     }
1864  done:
1865   lisp_eval_depth--;
1866   if (backtrace.debug_on_exit)
1867     val = call_debugger (Fcons (Qexit, Fcons (val, Qnil)));
1868   backtrace_list = backtrace.next;
1869   return val;
1870 }
1871 \f
1872 Lisp_Object
1873 apply_lambda (fun, args, eval_flag)
1874      Lisp_Object fun, args;
1875      int eval_flag;
1876 {
1877   Lisp_Object args_left;
1878   Lisp_Object numargs;
1879   register Lisp_Object *arg_vector;
1880   struct gcpro gcpro1, gcpro2, gcpro3;
1881   register int i;
1882   register Lisp_Object tem;
1883
1884   numargs = Flength (args);
1885   arg_vector = (Lisp_Object *) alloca (XINT (numargs) * sizeof (Lisp_Object));
1886   args_left = args;
1887
1888   GCPRO3 (*arg_vector, args_left, fun);
1889   gcpro1.nvars = 0;
1890
1891   for (i = 0; i < XINT (numargs);)
1892     {
1893       tem = Fcar (args_left), args_left = Fcdr (args_left);
1894       if (eval_flag) tem = Feval (tem);
1895       arg_vector[i++] = tem;
1896       gcpro1.nvars = i;
1897     }
1898
1899   UNGCPRO;
1900
1901   if (eval_flag)
1902     {
1903       backtrace_list->args = arg_vector;
1904       backtrace_list->nargs = i;
1905     }
1906   backtrace_list->evalargs = 0;
1907   tem = funcall_lambda (fun, XINT (numargs), arg_vector);
1908
1909   /* Do the debug-on-exit now, while arg_vector still exists.  */
1910   if (backtrace_list->debug_on_exit)
1911     tem = call_debugger (Fcons (Qexit, Fcons (tem, Qnil)));
1912   /* Don't do it again when we return to eval.  */
1913   backtrace_list->debug_on_exit = 0;
1914   return tem;
1915 }
1916
1917 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
1918    and return the result of evaluation.
1919    FUN must be either a lambda-expression or a compiled-code object.  */
1920
1921 Lisp_Object
1922 funcall_lambda (fun, nargs, arg_vector)
1923      Lisp_Object fun;
1924      int nargs;
1925      register Lisp_Object *arg_vector;
1926 {
1927   Lisp_Object val, tem;
1928   register Lisp_Object syms_left;
1929   Lisp_Object numargs;
1930   register Lisp_Object next;
1931   int count = specpdl_ptr - specpdl;
1932   register int i;
1933   int optional = 0, rest = 0;
1934
1935   specbind (Qmocklisp_arguments, Qt);   /* t means NOT mocklisp! */
1936
1937   XFASTINT (numargs) = nargs;
1938
1939   if (XTYPE (fun) == Lisp_Cons)
1940     syms_left = Fcar (Fcdr (fun));
1941   else if (XTYPE (fun) == Lisp_Compiled)
1942     syms_left = XVECTOR (fun)->contents[COMPILED_ARGLIST];
1943   else abort ();
1944
1945   i = 0;
1946   for (; !NILP (syms_left); syms_left = Fcdr (syms_left))
1947     {
1948       QUIT;
1949       next = Fcar (syms_left);
1950       while (XTYPE (next) != Lisp_Symbol)
1951         next = Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1952       if (EQ (next, Qand_rest))
1953         rest = 1;
1954       else if (EQ (next, Qand_optional))
1955         optional = 1;
1956       else if (rest)
1957         {
1958           specbind (next, Flist (nargs - i, &arg_vector[i]));
1959           i = nargs;
1960         }
1961       else if (i < nargs)
1962         {
1963           tem = arg_vector[i++];
1964           specbind (next, tem);
1965         }
1966       else if (!optional)
1967         return Fsignal (Qwrong_number_of_arguments, Fcons (fun, Fcons (numargs, Qnil)));
1968       else
1969         specbind (next, Qnil);
1970     }
1971
1972   if (i < nargs)
1973     return Fsignal (Qwrong_number_of_arguments, Fcons (fun, Fcons (numargs, Qnil)));
1974
1975   if (XTYPE (fun) == Lisp_Cons)
1976     val = Fprogn (Fcdr (Fcdr (fun)));
1977   else
1978     val = Fbyte_code (XVECTOR (fun)->contents[COMPILED_BYTECODE],
1979                       XVECTOR (fun)->contents[COMPILED_CONSTANTS],
1980                       XVECTOR (fun)->contents[COMPILED_STACK_DEPTH]);
1981   return unbind_to (count, val);
1982 }
1983 \f
1984 void
1985 grow_specpdl ()
1986 {
1987   register int count = specpdl_ptr - specpdl;
1988   if (specpdl_size >= max_specpdl_size)
1989     {
1990       if (max_specpdl_size < 400)
1991         max_specpdl_size = 400;
1992       if (specpdl_size >= max_specpdl_size)
1993         {
1994           Fsignal (Qerror,
1995                    Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil));
1996           max_specpdl_size *= 2;
1997         }
1998     }
1999   specpdl_size *= 2;
2000   if (specpdl_size > max_specpdl_size)
2001     specpdl_size = max_specpdl_size;
2002   specpdl = (struct specbinding *) xrealloc (specpdl, specpdl_size * sizeof (struct specbinding));
2003   specpdl_ptr = specpdl + count;
2004 }
2005
2006 void
2007 specbind (symbol, value)
2008      Lisp_Object symbol, value;
2009 {
2010   extern void store_symval_forwarding (); /* in eval.c */
2011   Lisp_Object ovalue;
2012
2013   CHECK_SYMBOL (symbol, 0);
2014
2015   if (specpdl_ptr == specpdl + specpdl_size)
2016     grow_specpdl ();
2017   specpdl_ptr->symbol = symbol;
2018   specpdl_ptr->func = 0;
2019   ovalue = XSYMBOL (symbol)->value;
2020   specpdl_ptr->old_value = EQ (ovalue, Qunbound) ? Qunbound : Fsymbol_value (symbol);
2021   specpdl_ptr++;
2022   if (XTYPE (ovalue) == Lisp_Buffer_Objfwd)
2023     store_symval_forwarding (symbol, ovalue, value);
2024   else
2025     Fset (symbol, value);
2026 }
2027
2028 void
2029 record_unwind_protect (function, arg)
2030      Lisp_Object (*function)();
2031      Lisp_Object arg;
2032 {
2033   if (specpdl_ptr == specpdl + specpdl_size)
2034     grow_specpdl ();
2035   specpdl_ptr->func = function;
2036   specpdl_ptr->symbol = Qnil;
2037   specpdl_ptr->old_value = arg;
2038   specpdl_ptr++;
2039 }
2040
2041 Lisp_Object
2042 unbind_to (count, value)
2043      int count;
2044      Lisp_Object value;
2045 {
2046   int quitf = !NILP (Vquit_flag);
2047   struct gcpro gcpro1;
2048
2049   GCPRO1 (value);
2050
2051   Vquit_flag = Qnil;
2052
2053   while (specpdl_ptr != specpdl + count)
2054     {
2055       --specpdl_ptr;
2056       if (specpdl_ptr->func != 0)
2057         (*specpdl_ptr->func) (specpdl_ptr->old_value);
2058       /* Note that a "binding" of nil is really an unwind protect,
2059         so in that case the "old value" is a list of forms to evaluate.  */
2060       else if (NILP (specpdl_ptr->symbol))
2061         Fprogn (specpdl_ptr->old_value);
2062       else
2063         Fset (specpdl_ptr->symbol, specpdl_ptr->old_value);
2064     }
2065   if (NILP (Vquit_flag) && quitf) Vquit_flag = Qt;
2066
2067   UNGCPRO;
2068
2069   return value;
2070 }
2071 \f
2072 #if 0
2073
2074 /* Get the value of symbol's global binding, even if that binding
2075  is not now dynamically visible.  */
2076
2077 Lisp_Object
2078 top_level_value (symbol)
2079      Lisp_Object symbol;
2080 {
2081   register struct specbinding *ptr = specpdl;
2082
2083   CHECK_SYMBOL (symbol, 0);
2084   for (; ptr != specpdl_ptr; ptr++)
2085     {
2086       if (EQ (ptr->symbol, symbol))
2087         return ptr->old_value;
2088     }
2089   return Fsymbol_value (symbol);
2090 }
2091
2092 Lisp_Object
2093 top_level_set (symbol, newval)
2094      Lisp_Object symbol, newval;
2095 {
2096   register struct specbinding *ptr = specpdl;
2097
2098   CHECK_SYMBOL (symbol, 0);
2099   for (; ptr != specpdl_ptr; ptr++)
2100     {
2101       if (EQ (ptr->symbol, symbol))
2102         {
2103           ptr->old_value = newval;
2104           return newval;
2105         }
2106     }
2107   return Fset (symbol, newval);
2108 }
2109
2110 #endif /* 0 */
2111 \f
2112 DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
2113   "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\
2114 The debugger is entered when that frame exits, if the flag is non-nil.")
2115   (level, flag)
2116      Lisp_Object level, flag;
2117 {
2118   register struct backtrace *backlist = backtrace_list;
2119   register int i;
2120
2121   CHECK_NUMBER (level, 0);
2122
2123   for (i = 0; backlist && i < XINT (level); i++)
2124     {
2125       backlist = backlist->next;
2126     }
2127
2128   if (backlist)
2129     backlist->debug_on_exit = !NILP (flag);
2130
2131   return flag;
2132 }
2133
2134 DEFUN ("backtrace", Fbacktrace, Sbacktrace, 0, 0, "",
2135   "Print a trace of Lisp function calls currently active.\n\
2136 Output stream used is value of `standard-output'.")
2137   ()
2138 {
2139   register struct backtrace *backlist = backtrace_list;
2140   register int i;
2141   Lisp_Object tail;
2142   Lisp_Object tem;
2143   extern Lisp_Object Vprint_level;
2144   struct gcpro gcpro1;
2145
2146   entering_debugger = 0;
2147
2148   XFASTINT (Vprint_level) = 3;
2149
2150   tail = Qnil;
2151   GCPRO1 (tail);
2152
2153   while (backlist)
2154     {
2155       write_string (backlist->debug_on_exit ? "* " : "  ", 2);
2156       if (backlist->nargs == UNEVALLED)
2157         {
2158           Fprin1 (Fcons (*backlist->function, *backlist->args), Qnil);
2159         }
2160       else
2161         {
2162           tem = *backlist->function;
2163           Fprin1 (tem, Qnil);   /* This can QUIT */
2164           write_string ("(", -1);
2165           if (backlist->nargs == MANY)
2166             {
2167               for (tail = *backlist->args, i = 0;
2168                    !NILP (tail);
2169                    tail = Fcdr (tail), i++)
2170                 {
2171                   if (i) write_string (" ", -1);
2172                   Fprin1 (Fcar (tail), Qnil);
2173                 }
2174             }
2175           else
2176             {
2177               for (i = 0; i < backlist->nargs; i++)
2178                 {
2179                   if (i) write_string (" ", -1);
2180                   Fprin1 (backlist->args[i], Qnil);
2181                 }
2182             }
2183         }
2184       write_string (")\n", -1);
2185       backlist = backlist->next;
2186     }
2187
2188   Vprint_level = Qnil;
2189   UNGCPRO;
2190   return Qnil;
2191 }
2192
2193 DEFUN ("backtrace-frame", Fbacktrace_frame, Sbacktrace_frame, 1, 1, "",
2194   "Return the function and arguments N frames up from current execution point.\n\
2195 If that frame has not evaluated the arguments yet (or is a special form),\n\
2196 the value is (nil FUNCTION ARG-FORMS...).\n\
2197 If that frame has evaluated its arguments and called its function already,\n\
2198 the value is (t FUNCTION ARG-VALUES...).\n\
2199 A &rest arg is represented as the tail of the list ARG-VALUES.\n\
2200 FUNCTION is whatever was supplied as car of evaluated list,\n\
2201 or a lambda expression for macro calls.\n\
2202 If N is more than the number of frames, the value is nil.")
2203   (nframes)
2204      Lisp_Object nframes;
2205 {
2206   register struct backtrace *backlist = backtrace_list;
2207   register int i;
2208   Lisp_Object tem;
2209
2210   CHECK_NATNUM (nframes, 0);
2211
2212   /* Find the frame requested.  */
2213   for (i = 0; i < XFASTINT (nframes); i++)
2214     backlist = backlist->next;
2215
2216   if (!backlist)
2217     return Qnil;
2218   if (backlist->nargs == UNEVALLED)
2219     return Fcons (Qnil, Fcons (*backlist->function, *backlist->args));
2220   else
2221     {
2222       if (backlist->nargs == MANY)
2223         tem = *backlist->args;
2224       else
2225         tem = Flist (backlist->nargs, backlist->args);
2226
2227       return Fcons (Qt, Fcons (*backlist->function, tem));
2228     }
2229 }
2230 \f
2231 syms_of_eval ()
2232 {
2233   DEFVAR_INT ("max-specpdl-size", &max_specpdl_size,
2234     "Limit on number of Lisp variable bindings & unwind-protects before error.");
2235
2236   DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth,
2237     "Limit on depth in `eval', `apply' and `funcall' before error.\n\
2238 This limit is to catch infinite recursions for you before they cause\n\
2239 actual stack overflow in C, which would be fatal for Emacs.\n\
2240 You can safely make it considerably larger than its default value,\n\
2241 if that proves inconveniently small.");
2242
2243   DEFVAR_LISP ("quit-flag", &Vquit_flag,
2244     "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
2245 Typing C-G sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
2246   Vquit_flag = Qnil;
2247
2248   DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit,
2249     "Non-nil inhibits C-g quitting from happening immediately.\n\
2250 Note that `quit-flag' will still be set by typing C-g,\n\
2251 so a quit will be signalled as soon as `inhibit-quit' is nil.\n\
2252 To prevent this happening, set `quit-flag' to nil\n\
2253 before making `inhibit-quit' nil.");
2254   Vinhibit_quit = Qnil;
2255
2256   Qinhibit_quit = intern ("inhibit-quit");
2257   staticpro (&Qinhibit_quit);
2258
2259   Qautoload = intern ("autoload");
2260   staticpro (&Qautoload);
2261
2262   Qdebug_on_error = intern ("debug-on-error");
2263   staticpro (&Qdebug_on_error);
2264
2265   Qmacro = intern ("macro");
2266   staticpro (&Qmacro);
2267
2268   /* Note that the process handling also uses Qexit, but we don't want
2269      to staticpro it twice, so we just do it here.  */
2270   Qexit = intern ("exit");
2271   staticpro (&Qexit);
2272
2273   Qinteractive = intern ("interactive");
2274   staticpro (&Qinteractive);
2275
2276   Qcommandp = intern ("commandp");
2277   staticpro (&Qcommandp);
2278
2279   Qdefun = intern ("defun");
2280   staticpro (&Qdefun);
2281
2282   Qand_rest = intern ("&rest");
2283   staticpro (&Qand_rest);
2284
2285   Qand_optional = intern ("&optional");
2286   staticpro (&Qand_optional);
2287
2288   DEFVAR_BOOL ("stack-trace-on-error", &stack_trace_on_error,
2289     "*Non-nil means automatically display a backtrace buffer\n\
2290 after any error that is handled by the editor command loop.");
2291   stack_trace_on_error = 0;
2292
2293   DEFVAR_BOOL ("debug-on-error", &debug_on_error,
2294     "*Non-nil means enter debugger if an error is signaled.\n\
2295 Does not apply to errors handled by `condition-case'.\n\
2296 See also variable `debug-on-quit'.");
2297   debug_on_error = 0;
2298
2299   DEFVAR_BOOL ("debug-on-quit", &debug_on_quit,
2300     "*Non-nil means enter debugger if quit is signaled (C-G, for example).\n\
2301 Does not apply if quit is handled by a `condition-case'.");
2302   debug_on_quit = 0;
2303
2304   DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call,
2305     "Non-nil means enter debugger before next `eval', `apply' or `funcall'.");
2306
2307   DEFVAR_LISP ("debugger", &Vdebugger,
2308     "Function to call to invoke debugger.\n\
2309 If due to frame exit, args are `exit' and the value being returned;\n\
2310  this function's value will be returned instead of that.\n\
2311 If due to error, args are `error' and a list of the args to `signal'.\n\
2312 If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
2313 If due to `eval' entry, one arg, t.");
2314   Vdebugger = Qnil;
2315
2316   Qmocklisp_arguments = intern ("mocklisp-arguments");
2317   staticpro (&Qmocklisp_arguments);
2318   DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments,
2319     "While in a mocklisp function, the list of its unevaluated args.");
2320   Vmocklisp_arguments = Qt;
2321
2322   DEFVAR_LISP ("run-hooks", &Vrun_hooks,
2323     "Set to the function `run-hooks', if that function has been defined.\n\
2324 Otherwise, nil (in a bare Emacs without preloaded Lisp code).");
2325   Vrun_hooks = Qnil;
2326
2327   staticpro (&Vautoload_queue);
2328   Vautoload_queue = Qnil;
2329
2330   defsubr (&Sor);
2331   defsubr (&Sand);
2332   defsubr (&Sif);
2333   defsubr (&Scond);
2334   defsubr (&Sprogn);
2335   defsubr (&Sprog1);
2336   defsubr (&Sprog2);
2337   defsubr (&Ssetq);
2338   defsubr (&Squote);
2339   defsubr (&Sfunction);
2340   defsubr (&Sdefun);
2341   defsubr (&Sdefmacro);
2342   defsubr (&Sdefvar);
2343   defsubr (&Sdefconst);
2344   defsubr (&Suser_variable_p);
2345   defsubr (&Slet);
2346   defsubr (&SletX);
2347   defsubr (&Swhile);
2348   defsubr (&Smacroexpand);
2349   defsubr (&Scatch);
2350   defsubr (&Sthrow);
2351   defsubr (&Sunwind_protect);
2352   defsubr (&Scondition_case);
2353   defsubr (&Ssignal);
2354   defsubr (&Sinteractive_p);
2355   defsubr (&Scommandp);
2356   defsubr (&Sautoload);
2357   defsubr (&Seval);
2358   defsubr (&Sapply);
2359   defsubr (&Sfuncall);
2360   defsubr (&Sbacktrace_debug);
2361   defsubr (&Sbacktrace);
2362   defsubr (&Sbacktrace_frame);
2363 }