src/eval.c

   1 /* Evaluator for GNU Emacs Lisp interpreter.
   2    Copyright (C) 1985, 1986, 1987, 1992 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 if (! NILP (Fcdr (Fcdr (elt))))
 628         Fsignal (Qerror,
 629                  Fcons (build_string ("`let' bindings can have only one value-form"),
 630                         elt));
 631       else
 632         {
 633           val = Feval (Fcar (Fcdr (elt)));
 634           specbind (Fcar (elt), val);
 635         }
 636       varlist = Fcdr (varlist);
 637     }
 638   UNGCPRO;
 639   val = Fprogn (Fcdr (args));
 640   return unbind_to (count, val);
 641 }
 642
 643 DEFUN ("let", Flet, Slet, 1, UNEVALLED, 0,
 644   "(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
 645 The value of the last form in BODY is returned.\n\
 646 Each element of VARLIST is a symbol (which is bound to nil)\n\
 647 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
 648 All the VALUEFORMs are evalled before any symbols are bound.")
 649   (args)
 650      Lisp_Object args;
 651 {
 652   Lisp_Object *temps, tem;
 653   register Lisp_Object elt, varlist;
 654   int count = specpdl_ptr - specpdl;
 655   register int argnum;
 656   struct gcpro gcpro1, gcpro2;
 657
 658   varlist = Fcar (args);
 659
 660   /* Make space to hold the values to give the bound variables */
 661   elt = Flength (varlist);
 662   temps = (Lisp_Object *) alloca (XFASTINT (elt) * sizeof (Lisp_Object));
 663
 664   /* Compute the values and store them in `temps' */
 665
 666   GCPRO2 (args, *temps);
 667   gcpro2.nvars = 0;
 668
 669   for (argnum = 0; !NILP (varlist); varlist = Fcdr (varlist))
 670     {
 671       QUIT;
 672       elt = Fcar (varlist);
 673       if (XTYPE (elt) == Lisp_Symbol)
 674         temps [argnum++] = Qnil;
 675       else if (! NILP (Fcdr (Fcdr (elt))))
 676         Fsignal (Qerror,
 677                  Fcons (build_string ("`let' bindings can have only one value-form"),
 678                         elt));
 679       else
 680         temps [argnum++] = Feval (Fcar (Fcdr (elt)));
 681       gcpro2.nvars = argnum;
 682     }
 683   UNGCPRO;
 684
 685   varlist = Fcar (args);
 686   for (argnum = 0; !NILP (varlist); varlist = Fcdr (varlist))
 687     {
 688       elt = Fcar (varlist);
 689       tem = temps[argnum++];
 690       if (XTYPE (elt) == Lisp_Symbol)
 691         specbind (elt, tem);
 692       else
 693         specbind (Fcar (elt), tem);
 694     }
 695
 696   elt = Fprogn (Fcdr (args));
 697   return unbind_to (count, elt);
 698 }
 699
 700 DEFUN ("while", Fwhile, Swhile, 1, UNEVALLED, 0,
 701   "(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.\n\
 702 The order of execution is thus TEST, BODY, TEST, BODY and so on\n\
 703 until TEST returns nil.")
 704   (args)
 705      Lisp_Object args;
 706 {
 707   Lisp_Object test, body, tem;
 708   struct gcpro gcpro1, gcpro2;
 709
 710   GCPRO2 (test, body);
 711
 712   test = Fcar (args);
 713   body = Fcdr (args);
 714   while (tem = Feval (test), !NILP (tem))
 715     {
 716       QUIT;
 717       Fprogn (body);
 718     }
 719
 720   UNGCPRO;
 721   return Qnil;
 722 }
 723
 724 DEFUN ("macroexpand", Fmacroexpand, Smacroexpand, 1, 2, 0,
 725   "Return result of expanding macros at top level of FORM.\n\
 726 If FORM is not a macro call, it is returned unchanged.\n\
 727 Otherwise, the macro is expanded and the expansion is considered\n\
 728 in place of FORM.  When a non-macro-call results, it is returned.\n\n\
 729 The second optional arg ENVIRONMENT species an environment of macro\n\
 730 definitions to shadow the loaded ones for use in file byte-compilation.")
 731   (form, env)
 732      register Lisp_Object form;
 733      Lisp_Object env;
 734 {
 735   register Lisp_Object expander, sym, def, tem;
 736
 737   while (1)
 738     {
 739       /* Come back here each time we expand a macro call,
 740          in case it expands into another macro call.  */
 741       if (XTYPE (form) != Lisp_Cons)
 742         break;
 743       sym = XCONS (form)->car;
 744       /* Detect  ((macro lambda ...) ...)  */
 745       if (XTYPE (sym) == Lisp_Cons
 746           && EQ (XCONS (sym)->car, Qmacro))
 747         {
 748           expander = XCONS (sym)->cdr;
 749           goto explicit;
 750         }
 751       if (XTYPE (sym) != Lisp_Symbol)
 752         break;
 753       /* Trace symbols aliases to other symbols
 754          until we get a symbol that is not an alias.  */
 755       while (1)
 756         {
 757           QUIT;
 758           tem = Fassq (sym, env);
 759           if (NILP (tem))
 760             {
 761               def = XSYMBOL (sym)->function;
 762               if (XTYPE (def) == Lisp_Symbol && !EQ (def, Qunbound))
 763                 sym = def;
 764               else
 765                 break;
 766             }
 767           else
 768             {
 769 #if 0  /* This is turned off because it caused an element (foo . bar)
 770           to have the effect of defining foo as an alias for the macro bar.
 771           That is inconsistent; bar should be a function to expand foo.  */
 772               if (XTYPE (tem) == Lisp_Cons
 773                   && XTYPE (XCONS (tem)->cdr) == Lisp_Symbol)
 774                 sym = XCONS (tem)->cdr;
 775               else
 776 #endif
 777                 break;
 778             }
 779         }
 780       /* Right now TEM is the result from SYM in ENV,
 781          and if TEM is nil then DEF is SYM's function definition.  */
 782       if (NILP (tem))
 783         {
 784           /* SYM is not mentioned in ENV.
 785              Look at its function definition.  */
 786           if (EQ (def, Qunbound)
 787               || XTYPE (def) != Lisp_Cons)
 788             /* Not defined or definition not suitable */
 789             break;
 790           if (EQ (XCONS (def)->car, Qautoload))
 791             {
 792               /* Autoloading function: will it be a macro when loaded?  */
 793               tem = Fcar (Fnthcdr (make_number (4), def));
 794               if (NILP (tem))
 795                 break;
 796               /* Yes, load it and try again.  */
 797               do_autoload (def, sym);
 798               continue;
 799             }
 800           else if (!EQ (XCONS (def)->car, Qmacro))
 801             break;
 802           else expander = XCONS (def)->cdr;
 803         }
 804       else
 805         {
 806           expander = XCONS (tem)->cdr;
 807           if (NILP (expander))
 808             break;
 809         }
 810     explicit:
 811       form = apply1 (expander, XCONS (form)->cdr);
 812     }
 813   return form;
 814 }
 815 \f
 816 DEFUN ("catch", Fcatch, Scatch, 1, UNEVALLED, 0,
 817   "(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.\n\
 818 TAG is evalled to get the tag to use.  Then the BODY is executed.\n\
 819 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.\n\
 820 If no throw happens, `catch' returns the value of the last BODY form.\n\
 821 If a throw happens, it specifies the value to return from `catch'.")
 822   (args)
 823      Lisp_Object args;
 824 {
 825   register Lisp_Object tag;
 826   struct gcpro gcpro1;
 827
 828   GCPRO1 (args);
 829   tag = Feval (Fcar (args));
 830   UNGCPRO;
 831   return internal_catch (tag, Fprogn, Fcdr (args));
 832 }
 833
 834 /* Set up a catch, then call C function FUNC on argument ARG.
 835    FUNC should return a Lisp_Object.
 836    This is how catches are done from within C code. */
 837
 838 Lisp_Object
 839 internal_catch (tag, func, arg)
 840      Lisp_Object tag;
 841      Lisp_Object (*func) ();
 842      Lisp_Object arg;
 843 {
 844   /* This structure is made part of the chain `catchlist'.  */
 845   struct catchtag c;
 846
 847   /* Fill in the components of c, and put it on the list.  */
 848   c.next = catchlist;
 849   c.tag = tag;
 850   c.val = Qnil;
 851   c.backlist = backtrace_list;
 852   c.handlerlist = handlerlist;
 853   c.lisp_eval_depth = lisp_eval_depth;
 854   c.pdlcount = specpdl_ptr - specpdl;
 855   c.poll_suppress_count = poll_suppress_count;
 856   c.gcpro = gcprolist;
 857   catchlist = &c;
 858
 859   /* Call FUNC.  */
 860   if (! _setjmp (c.jmp))
 861     c.val = (*func) (arg);
 862
 863   /* Throw works by a longjmp that comes right here.  */
 864   catchlist = c.next;
 865   return c.val;
 866 }
 867
 868 /* Discard from the catchlist all catch tags back through CATCH.
 869    Before each catch is discarded, unbind all special bindings
 870    made within that catch.  Also, when discarding a catch that
 871    corresponds to a condition handler, discard that handler.
 872
 873    At the end, restore some static info saved in CATCH.
 874
 875    This is used for correct unwinding in Fthrow and Fsignal,
 876    before doing the longjmp that actually destroys the stack frames
 877    in which these handlers and catches reside.  */
 878
 879 static void
 880 unbind_catch (catch)
 881      struct catchtag *catch;
 882 {
 883   register int last_time;
 884
 885   do
 886     {
 887       last_time = catchlist == catch;
 888       unbind_to (catchlist->pdlcount, Qnil);
 889       handlerlist = catchlist->handlerlist;
 890       catchlist = catchlist->next;
 891     }
 892   while (! last_time);
 893
 894   gcprolist = catch->gcpro;
 895   backtrace_list = catch->backlist;
 896   lisp_eval_depth = catch->lisp_eval_depth;
 897 }
 898
 899 DEFUN ("throw", Fthrow, Sthrow, 2, 2, 0,
 900   "(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.\n\
 901 Both TAG and VALUE are evalled.")
 902   (tag, val)
 903      register Lisp_Object tag, val;
 904 {
 905   register struct catchtag *c;
 906
 907   while (1)
 908     {
 909       if (!NILP (tag))
 910         for (c = catchlist; c; c = c->next)
 911           {
 912             if (EQ (c->tag, tag))
 913               {
 914                 /* Restore the polling-suppression count.  */
 915                 if (c->poll_suppress_count > poll_suppress_count)
 916                   abort ();
 917                 while (c->poll_suppress_count < poll_suppress_count)
 918                   start_polling ();
 919                 c->val = val;
 920                 unbind_catch (c);
 921                 _longjmp (c->jmp, 1);
 922               }
 923           }
 924       tag = Fsignal (Qno_catch, Fcons (tag, Fcons (val, Qnil)));
 925     }
 926 }
 927
 928
 929 DEFUN ("unwind-protect", Funwind_protect, Sunwind_protect, 1, UNEVALLED, 0,
 930   "Do BODYFORM, protecting with UNWINDFORMS.\n\
 931 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).\n\
 932 If BODYFORM completes normally, its value is returned\n\
 933 after executing the UNWINDFORMS.\n\
 934 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.")
 935   (args)
 936      Lisp_Object args;
 937 {
 938   Lisp_Object val;
 939   int count = specpdl_ptr - specpdl;
 940
 941   record_unwind_protect (0, Fcdr (args));
 942   val = Feval (Fcar (args));
 943   return unbind_to (count, val);
 944 }
 945 \f
 946 /* Chain of condition handlers currently in effect.
 947    The elements of this chain are contained in the stack frames
 948    of Fcondition_case and internal_condition_case.
 949    When an error is signaled (by calling Fsignal, below),
 950    this chain is searched for an element that applies.  */
 951
 952 struct handler *handlerlist;
 953
 954 DEFUN ("condition-case", Fcondition_case, Scondition_case, 2, UNEVALLED, 0,
 955   "Regain control when an error is signaled.\n\
 956 Usage looks like (condition-case VAR BODYFORM HANDLERS...).\n\
 957 executes BODYFORM and returns its value if no error happens.\n\
 958 Each element of HANDLERS looks like (CONDITION-NAME BODY...)\n\
 959 where the BODY is made of Lisp expressions.\n\n\
 960 A handler is applicable to an error\n\
 961 if CONDITION-NAME is one of the error's condition names.\n\
 962 If an error happens, the first applicable handler is run.\n\
 963 \n\
 964 When a handler handles an error,\n\
 965 control returns to the condition-case and the handler BODY... is executed\n\
 966 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\
 967 VAR may be nil; then you do not get access to the signal information.\n\
 968 \n\
 969 The value of the last BODY form is returned from the condition-case.\n\
 970 See also the function `signal' for more info.")
 971   (args)
 972      Lisp_Object args;
 973 {
 974   Lisp_Object val;
 975   struct catchtag c;
 976   struct handler h;
 977   register Lisp_Object tem;
 978
 979   tem = Fcar (args);
 980   CHECK_SYMBOL (tem, 0);
 981
 982   c.tag = Qnil;
 983   c.val = Qnil;
 984   c.backlist = backtrace_list;
 985   c.handlerlist = handlerlist;
 986   c.lisp_eval_depth = lisp_eval_depth;
 987   c.pdlcount = specpdl_ptr - specpdl;
 988   c.poll_suppress_count = poll_suppress_count;
 989   c.gcpro = gcprolist;
 990   if (_setjmp (c.jmp))
 991     {
 992       if (!NILP (h.var))
 993         specbind (h.var, Fcdr (c.val));
 994       val = Fprogn (Fcdr (Fcar (c.val)));
 995       unbind_to (c.pdlcount, Qnil);
 996       return val;
 997     }
 998   c.next = catchlist;
 999   catchlist = &c;
1000   h.var = Fcar (args);
1001   h.handler = Fcdr (Fcdr (args));
1002
1003   for (val = h.handler; ! NILP (val); val = Fcdr (val))
1004     {
1005       tem = Fcar (val);
1006       if ((!NILP (tem)) &&
1007           (!CONSP (tem) || (XTYPE (XCONS (tem)->car) != Lisp_Symbol)))
1008         error ("Invalid condition handler", tem);
1009     }
1010
1011   h.next = handlerlist;
1012   h.poll_suppress_count = poll_suppress_count;
1013   h.tag = &c;
1014   handlerlist = &h;
1015
1016   val = Feval (Fcar (Fcdr (args)));
1017   catchlist = c.next;
1018   handlerlist = h.next;
1019   return val;
1020 }
1021
1022 Lisp_Object
1023 internal_condition_case (bfun, handlers, hfun)
1024      Lisp_Object (*bfun) ();
1025      Lisp_Object handlers;
1026      Lisp_Object (*hfun) ();
1027 {
1028   Lisp_Object val;
1029   struct catchtag c;
1030   struct handler h;
1031
1032   c.tag = Qnil;
1033   c.val = Qnil;
1034   c.backlist = backtrace_list;
1035   c.handlerlist = handlerlist;
1036   c.lisp_eval_depth = lisp_eval_depth;
1037   c.pdlcount = specpdl_ptr - specpdl;
1038   c.poll_suppress_count = poll_suppress_count;
1039   c.gcpro = gcprolist;
1040   if (_setjmp (c.jmp))
1041     {
1042       return (*hfun) (Fcdr (c.val));
1043     }
1044   c.next = catchlist;
1045   catchlist = &c;
1046   h.handler = handlers;
1047   h.var = Qnil;
1048   h.poll_suppress_count = poll_suppress_count;
1049   h.next = handlerlist;
1050   h.tag = &c;
1051   handlerlist = &h;
1052
1053   val = (*bfun) ();
1054   catchlist = c.next;
1055   handlerlist = h.next;
1056   return val;
1057 }
1058
1059 static Lisp_Object find_handler_clause ();
1060
1061 DEFUN ("signal", Fsignal, Ssignal, 2, 2, 0,
1062   "Signal an error.  Args are SIGNAL-NAME, and associated DATA.\n\
1063 This function does not return.\n\n\
1064 A signal name is a symbol with an `error-conditions' property\n\
1065 that is a list of condition names.\n\
1066 A handler for any of those names will get to handle this signal.\n\
1067 The symbol `error' should normally be one of them.\n\
1068 \n\
1069 DATA should be a list.  Its elements are printed as part of the error message.\n\
1070 If the signal is handled, DATA is made available to the handler.\n\
1071 See also the function `condition-case'.")
1072   (sig, data)
1073      Lisp_Object sig, data;
1074 {
1075   register struct handler *allhandlers = handlerlist;
1076   Lisp_Object conditions;
1077   extern int gc_in_progress;
1078   extern int waiting_for_input;
1079   Lisp_Object debugger_value;
1080
1081   quit_error_check ();
1082   immediate_quit = 0;
1083   if (gc_in_progress || waiting_for_input)
1084     abort ();
1085
1086   TOTALLY_UNBLOCK_INPUT;
1087
1088   conditions = Fget (sig, Qerror_conditions);
1089
1090   for (; handlerlist; handlerlist = handlerlist->next)
1091     {
1092       register Lisp_Object clause;
1093       clause = find_handler_clause (handlerlist->handler, conditions,
1094                                     sig, data, &debugger_value);
1095
1096 #if 0 /* Most callers are not prepared to handle gc if this returns.
1097          So, since this feature is not very useful, take it out.  */
1098       /* If have called debugger and user wants to continue,
1099          just return nil.  */
1100       if (EQ (clause, Qlambda))
1101         return debugger_value;
1102 #else
1103       if (EQ (clause, Qlambda))
1104         error ("Returning a value from an error is no longer supported");
1105 #endif
1106
1107       if (!NILP (clause))
1108         {
1109           struct handler *h = handlerlist;
1110           /* Restore the polling-suppression count.  */
1111           if (h->poll_suppress_count > poll_suppress_count)
1112             abort ();
1113           while (h->poll_suppress_count < poll_suppress_count)
1114             start_polling ();
1115           handlerlist = allhandlers;
1116           unbind_catch (h->tag);
1117           h->tag->val = Fcons (clause, Fcons (sig, data));
1118           _longjmp (h->tag->jmp, 1);
1119         }
1120     }
1121
1122   handlerlist = allhandlers;
1123   /* If no handler is present now, try to run the debugger,
1124      and if that fails, throw to top level.  */
1125   find_handler_clause (Qerror, conditions, sig, data, &debugger_value);
1126   Fthrow (Qtop_level, Qt);
1127 }
1128
1129 /* Value of Qlambda means we have called debugger and
1130    user has continued.  Store value returned fromdebugger
1131    into *debugger_value_ptr */
1132
1133 static Lisp_Object
1134 find_handler_clause (handlers, conditions, sig, data, debugger_value_ptr)
1135      Lisp_Object handlers, conditions, sig, data;
1136      Lisp_Object *debugger_value_ptr;
1137 {
1138   register Lisp_Object h;
1139   register Lisp_Object tem;
1140   register Lisp_Object tem1;
1141
1142   if (EQ (handlers, Qt))  /* t is used by handlers for all conditions, set up by C code.  */
1143     return Qt;
1144   if (EQ (handlers, Qerror))  /* error is used similarly, but means display a backtrace too */
1145     {
1146       if (stack_trace_on_error)
1147         internal_with_output_to_temp_buffer ("*Backtrace*", Fbacktrace, Qnil);
1148       if (!entering_debugger
1149           && EQ (sig, Qquit) ? debug_on_quit : debug_on_error)
1150         {
1151           int count = specpdl_ptr - specpdl;
1152           specbind (Qdebug_on_error, Qnil);
1153           *debugger_value_ptr =
1154             call_debugger (Fcons (Qerror,
1155                                   Fcons (Fcons (sig, data),
1156                                          Qnil)));
1157           return unbind_to (count, Qlambda);
1158         }
1159       return Qt;
1160     }
1161   for (h = handlers; CONSP (h); h = Fcdr (h))
1162     {
1163       tem1 = Fcar (h);
1164       if (!CONSP (tem1))
1165         continue;
1166       tem = Fmemq (Fcar (tem1), conditions);
1167       if (!NILP (tem))
1168         return tem1;
1169     }
1170   return Qnil;
1171 }
1172
1173 /* dump an error message; called like printf */
1174
1175 /* VARARGS 1 */
1176 void
1177 error (m, a1, a2, a3)
1178      char *m;
1179 {
1180   char buf[200];
1181   sprintf (buf, m, a1, a2, a3);
1182
1183   while (1)
1184     Fsignal (Qerror, Fcons (build_string (buf), Qnil));
1185 }
1186 \f
1187 DEFUN ("commandp", Fcommandp, Scommandp, 1, 1, 0,
1188   "T if FUNCTION makes provisions for interactive calling.\n\
1189 This means it contains a description for how to read arguments to give it.\n\
1190 The value is nil for an invalid function or a symbol with no function\n\
1191 definition.\n\
1192 \n\
1193 Interactively callable functions include strings and vectors (treated\n\
1194 as keyboard macros), lambda-expressions that contain a top-level call\n\
1195 to `interactive', autoload definitions made by `autoload' with non-nil\n\
1196 fourth argument, and some of the built-in functions of Lisp.\n\
1197 \n\
1198 Also, a symbol satisfies `commandp' if its function definition does so.")
1199   (function)
1200      Lisp_Object function;
1201 {
1202   register Lisp_Object fun;
1203   register Lisp_Object funcar;
1204   register Lisp_Object tem;
1205   register int i = 0;
1206
1207   fun = function;
1208
1209   /* Dereference symbols, but avoid infinte loops.  Eech.  */
1210   while (XTYPE (fun) == Lisp_Symbol)
1211     {
1212       if (++i > 10) return Qnil;
1213       tem = Ffboundp (fun);
1214       if (NILP (tem)) return Qnil;
1215       fun = Fsymbol_function (fun);
1216     }
1217
1218   /* Emacs primitives are interactive if their DEFUN specifies an
1219      interactive spec.  */
1220   if (XTYPE (fun) == Lisp_Subr)
1221     {
1222       if (XSUBR (fun)->prompt)
1223         return Qt;
1224       else
1225         return Qnil;
1226     }
1227
1228   /* Bytecode objects are interactive if they are long enough to
1229      have an element whose index is COMPILED_INTERACTIVE, which is
1230      where the interactive spec is stored.  */
1231   else if (XTYPE (fun) == Lisp_Compiled)
1232     return (XVECTOR (fun)->size > COMPILED_INTERACTIVE
1233             ? Qt : Qnil);
1234
1235   /* Strings and vectors are keyboard macros.  */
1236   if (XTYPE (fun) == Lisp_String
1237       || XTYPE (fun) == Lisp_Vector)
1238     return Qt;
1239
1240   /* Lists may represent commands.  */
1241   if (!CONSP (fun))
1242     return Qnil;
1243   funcar = Fcar (fun);
1244   if (XTYPE (funcar) != Lisp_Symbol)
1245     return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1246   if (EQ (funcar, Qlambda))
1247     return Fassq (Qinteractive, Fcdr (Fcdr (fun)));
1248   if (EQ (funcar, Qmocklisp))
1249     return Qt;  /* All mocklisp functions can be called interactively */
1250   if (EQ (funcar, Qautoload))
1251     return Fcar (Fcdr (Fcdr (Fcdr (fun))));
1252   else
1253     return Qnil;
1254 }
1255
1256 /* ARGSUSED */
1257 DEFUN ("autoload", Fautoload, Sautoload, 2, 5, 0,
1258   "Define FUNCTION to autoload from FILE.\n\
1259 FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\
1260 Third arg DOCSTRING is documentation for the function.\n\
1261 Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\
1262 Fifth arg MACRO if non-nil says the function is really a macro.\n\
1263 Third through fifth args give info about the real definition.\n\
1264 They default to nil.\n\
1265 If FUNCTION is already defined other than as an autoload,\n\
1266 this does nothing and returns nil.")
1267   (function, file, docstring, interactive, macro)
1268      Lisp_Object function, file, docstring, interactive, macro;
1269 {
1270 #ifdef NO_ARG_ARRAY
1271   Lisp_Object args[4];
1272 #endif
1273
1274   CHECK_SYMBOL (function, 0);
1275   CHECK_STRING (file, 1);
1276
1277   /* If function is defined and not as an autoload, don't override */
1278   if (!EQ (XSYMBOL (function)->function, Qunbound)
1279       && !(XTYPE (XSYMBOL (function)->function) == Lisp_Cons
1280            && EQ (XCONS (XSYMBOL (function)->function)->car, Qautoload)))
1281     return Qnil;
1282
1283 #ifdef NO_ARG_ARRAY
1284   args[0] = file;
1285   args[1] = docstring;
1286   args[2] = interactive;
1287   args[3] = macro;
1288
1289   return Ffset (function, Fcons (Qautoload, Flist (4, &args[0])));
1290 #else /* NO_ARG_ARRAY */
1291   return Ffset (function, Fcons (Qautoload, Flist (4, &file)));
1292 #endif /* not NO_ARG_ARRAY */
1293 }
1294
1295 Lisp_Object
1296 un_autoload (oldqueue)
1297      Lisp_Object oldqueue;
1298 {
1299   register Lisp_Object queue, first, second;
1300
1301   /* Queue to unwind is current value of Vautoload_queue.
1302      oldqueue is the shadowed value to leave in Vautoload_queue.  */
1303   queue = Vautoload_queue;
1304   Vautoload_queue = oldqueue;
1305   while (CONSP (queue))
1306     {
1307       first = Fcar (queue);
1308       second = Fcdr (first);
1309       first = Fcar (first);
1310       if (EQ (second, Qnil))
1311         Vfeatures = first;
1312       else
1313         Ffset (first, second);
1314       queue = Fcdr (queue);
1315     }
1316   return Qnil;
1317 }
1318
1319 do_autoload (fundef, funname)
1320      Lisp_Object fundef, funname;
1321 {
1322   int count = specpdl_ptr - specpdl;
1323   Lisp_Object fun, val;
1324
1325   fun = funname;
1326   CHECK_SYMBOL (funname, 0);
1327
1328   /* Value saved here is to be restored into Vautoload_queue */
1329   record_unwind_protect (un_autoload, Vautoload_queue);
1330   Vautoload_queue = Qt;
1331   Fload (Fcar (Fcdr (fundef)), Qnil, noninteractive ? Qt : Qnil, Qnil);
1332   /* Once loading finishes, don't undo it.  */
1333   Vautoload_queue = Qt;
1334   unbind_to (count, Qnil);
1335
1336   while (XTYPE (fun) == Lisp_Symbol)
1337     {
1338       QUIT;
1339       val = XSYMBOL (fun)->function;
1340       if (EQ (val, Qunbound))
1341         Fsymbol_function (fun); /* Get the right kind of error! */
1342       fun = val;
1343     }
1344   if (XTYPE (fun) == Lisp_Cons
1345       && EQ (XCONS (fun)->car, Qautoload))
1346     error ("Autoloading failed to define function %s",
1347            XSYMBOL (funname)->name->data);
1348 }
1349 \f
1350 DEFUN ("eval", Feval, Seval, 1, 1, 0,
1351   "Evaluate FORM and return its value.")
1352   (form)
1353      Lisp_Object form;
1354 {
1355   Lisp_Object fun, val, original_fun, original_args;
1356   Lisp_Object funcar;
1357   struct backtrace backtrace;
1358   struct gcpro gcpro1, gcpro2, gcpro3;
1359
1360   if (XTYPE (form) == Lisp_Symbol)
1361     {
1362       if (EQ (Vmocklisp_arguments, Qt))
1363         return Fsymbol_value (form);
1364       val = Fsymbol_value (form);
1365       if (NILP (val))
1366         XFASTINT (val) = 0;
1367       else if (EQ (val, Qt))
1368         XFASTINT (val) = 1;
1369       return val;
1370     }
1371   if (!CONSP (form))
1372     return form;
1373
1374   QUIT;
1375   if (consing_since_gc > gc_cons_threshold)
1376     {
1377       GCPRO1 (form);
1378       Fgarbage_collect ();
1379       UNGCPRO;
1380     }
1381
1382   if (++lisp_eval_depth > max_lisp_eval_depth)
1383     {
1384       if (max_lisp_eval_depth < 100)
1385         max_lisp_eval_depth = 100;
1386       if (lisp_eval_depth > max_lisp_eval_depth)
1387         error ("Lisp nesting exceeds max-lisp-eval-depth");
1388     }
1389
1390   original_fun = Fcar (form);
1391   original_args = Fcdr (form);
1392
1393   backtrace.next = backtrace_list;
1394   backtrace_list = &backtrace;
1395   backtrace.function = &original_fun; /* This also protects them from gc */
1396   backtrace.args = &original_args;
1397   backtrace.nargs = UNEVALLED;
1398   backtrace.evalargs = 1;
1399   backtrace.debug_on_exit = 0;
1400
1401   if (debug_on_next_call)
1402     do_debug_on_call (Qt);
1403
1404   /* At this point, only original_fun and original_args
1405      have values that will be used below */
1406  retry:
1407   fun = original_fun;
1408   while (XTYPE (fun) == Lisp_Symbol)
1409     {
1410       QUIT;
1411       val = XSYMBOL (fun)->function;
1412       if (EQ (val, Qunbound))
1413         Fsymbol_function (fun); /* Get the right kind of error! */
1414       fun = val;
1415     }
1416
1417   if (XTYPE (fun) == Lisp_Subr)
1418     {
1419       Lisp_Object numargs;
1420       Lisp_Object argvals[7];
1421       Lisp_Object args_left;
1422       register int i, maxargs;
1423
1424       args_left = original_args;
1425       numargs = Flength (args_left);
1426
1427       if (XINT (numargs) < XSUBR (fun)->min_args ||
1428           (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < XINT (numargs)))
1429         return Fsignal (Qwrong_number_of_arguments, Fcons (fun, Fcons (numargs, Qnil)));
1430
1431       if (XSUBR (fun)->max_args == UNEVALLED)
1432         {
1433           backtrace.evalargs = 0;
1434           val = (*XSUBR (fun)->function) (args_left);
1435           goto done;
1436         }
1437
1438       if (XSUBR (fun)->max_args == MANY)
1439         {
1440           /* Pass a vector of evaluated arguments */
1441           Lisp_Object *vals;
1442           register int argnum = 0;
1443
1444           vals = (Lisp_Object *) alloca (XINT (numargs) * sizeof (Lisp_Object));
1445
1446           GCPRO3 (args_left, fun, fun);
1447           gcpro3.var = vals;
1448           gcpro3.nvars = 0;
1449
1450           while (!NILP (args_left))
1451             {
1452               vals[argnum++] = Feval (Fcar (args_left));
1453               args_left = Fcdr (args_left);
1454               gcpro3.nvars = argnum;
1455             }
1456
1457           backtrace.args = vals;
1458           backtrace.nargs = XINT (numargs);
1459
1460           val = (*XSUBR (fun)->function) (XINT (numargs), vals);
1461           UNGCPRO;
1462           goto done;
1463         }
1464
1465       GCPRO3 (args_left, fun, fun);
1466       gcpro3.var = argvals;
1467       gcpro3.nvars = 0;
1468
1469       maxargs = XSUBR (fun)->max_args;
1470       for (i = 0; i < maxargs; args_left = Fcdr (args_left))
1471         {
1472           argvals[i] = Feval (Fcar (args_left));
1473           gcpro3.nvars = ++i;
1474         }
1475
1476       UNGCPRO;
1477
1478       backtrace.args = argvals;
1479       backtrace.nargs = XINT (numargs);
1480
1481       switch (i)
1482         {
1483         case 0:
1484           val = (*XSUBR (fun)->function) ();
1485           goto done;
1486         case 1:
1487           val = (*XSUBR (fun)->function) (argvals[0]);
1488           goto done;
1489         case 2:
1490           val = (*XSUBR (fun)->function) (argvals[0], argvals[1]);
1491           goto done;
1492         case 3:
1493           val = (*XSUBR (fun)->function) (argvals[0], argvals[1],
1494                                           argvals[2]);
1495           goto done;
1496         case 4:
1497           val = (*XSUBR (fun)->function) (argvals[0], argvals[1],
1498                                           argvals[2], argvals[3]);
1499           goto done;
1500         case 5:
1501           val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2],
1502                                           argvals[3], argvals[4]);
1503           goto done;
1504         case 6:
1505           val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2],
1506                                           argvals[3], argvals[4], argvals[5]);
1507           goto done;
1508
1509         default:
1510           /* Someone has created a subr that takes more arguments than
1511              is supported by this code.  We need to either rewrite the
1512              subr to use a different argument protocol, or add more
1513              cases to this switch.  */
1514           abort ();
1515         }
1516     }
1517   if (XTYPE (fun) == Lisp_Compiled)
1518     val = apply_lambda (fun, original_args, 1);
1519   else
1520     {
1521       if (!CONSP (fun))
1522         return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1523       funcar = Fcar (fun);
1524       if (XTYPE (funcar) != Lisp_Symbol)
1525         return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1526       if (EQ (funcar, Qautoload))
1527         {
1528           do_autoload (fun, original_fun);
1529           goto retry;
1530         }
1531       if (EQ (funcar, Qmacro))
1532         val = Feval (apply1 (Fcdr (fun), original_args));
1533       else if (EQ (funcar, Qlambda))
1534         val = apply_lambda (fun, original_args, 1);
1535       else if (EQ (funcar, Qmocklisp))
1536         val = ml_apply (fun, original_args);
1537       else
1538         return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1539     }
1540  done:
1541   if (!EQ (Vmocklisp_arguments, Qt))
1542     {
1543       if (NILP (val))
1544         XFASTINT (val) = 0;
1545       else if (EQ (val, Qt))
1546         XFASTINT (val) = 1;
1547     }
1548   lisp_eval_depth--;
1549   if (backtrace.debug_on_exit)
1550     val = call_debugger (Fcons (Qexit, Fcons (val, Qnil)));
1551   backtrace_list = backtrace.next;
1552   return val;
1553 }
1554 \f
1555 DEFUN ("apply", Fapply, Sapply, 2, MANY, 0,
1556   "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
1557 Thus, (apply '+ 1 2 '(3 4)) returns 10.")
1558   (nargs, args)
1559      int nargs;
1560      Lisp_Object *args;
1561 {
1562   register int i, numargs;
1563   register Lisp_Object spread_arg;
1564   register Lisp_Object *funcall_args;
1565   Lisp_Object fun;
1566   struct gcpro gcpro1;
1567
1568   fun = args [0];
1569   funcall_args = 0;
1570   spread_arg = args [nargs - 1];
1571   CHECK_LIST (spread_arg, nargs);
1572
1573   numargs = XINT (Flength (spread_arg));
1574
1575   if (numargs == 0)
1576     return Ffuncall (nargs - 1, args);
1577   else if (numargs == 1)
1578     {
1579       args [nargs - 1] = XCONS (spread_arg)->car;
1580       return Ffuncall (nargs, args);
1581     }
1582
1583   numargs += nargs - 2;
1584
1585   while (XTYPE (fun) == Lisp_Symbol)
1586     {
1587       QUIT;
1588       fun = XSYMBOL (fun)->function;
1589       if (EQ (fun, Qunbound))
1590         {
1591           /* Let funcall get the error */
1592           fun = args[0];
1593           goto funcall;
1594         }
1595     }
1596
1597   if (XTYPE (fun) == Lisp_Subr)
1598     {
1599       if (numargs < XSUBR (fun)->min_args
1600           || (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs))
1601         goto funcall;           /* Let funcall get the error */
1602       else if (XSUBR (fun)->max_args > numargs)
1603         {
1604           /* Avoid making funcall cons up a yet another new vector of arguments
1605              by explicitly supplying nil's for optional values */
1606           funcall_args = (Lisp_Object *) alloca ((1 + XSUBR (fun)->max_args)
1607                                                  * sizeof (Lisp_Object));
1608           for (i = numargs; i < XSUBR (fun)->max_args;)
1609             funcall_args[++i] = Qnil;
1610           GCPRO1 (*funcall_args);
1611           gcpro1.nvars = 1 + XSUBR (fun)->max_args;
1612         }
1613     }
1614  funcall:
1615   /* We add 1 to numargs because funcall_args includes the
1616      function itself as well as its arguments.  */
1617   if (!funcall_args)
1618     {
1619       funcall_args = (Lisp_Object *) alloca ((1 + numargs)
1620                                              * sizeof (Lisp_Object));
1621       GCPRO1 (*funcall_args);
1622       gcpro1.nvars = 1 + numargs;
1623     }
1624
1625   bcopy (args, funcall_args, nargs * sizeof (Lisp_Object));
1626   /* Spread the last arg we got.  Its first element goes in
1627      the slot that it used to occupy, hence this value of I.  */
1628   i = nargs - 1;
1629   while (!NILP (spread_arg))
1630     {
1631       funcall_args [i++] = XCONS (spread_arg)->car;
1632       spread_arg = XCONS (spread_arg)->cdr;
1633     }
1634
1635   RETURN_UNGCPRO (Ffuncall (gcpro1.nvars, funcall_args));
1636 }
1637 \f
1638 /* Apply fn to arg */
1639 Lisp_Object
1640 apply1 (fn, arg)
1641      Lisp_Object fn, arg;
1642 {
1643   struct gcpro gcpro1;
1644
1645   GCPRO1 (fn);
1646   if (NILP (arg))
1647     RETURN_UNGCPRO (Ffuncall (1, &fn));
1648   gcpro1.nvars = 2;
1649 #ifdef NO_ARG_ARRAY
1650   {
1651     Lisp_Object args[2];
1652     args[0] = fn;
1653     args[1] = arg;
1654     gcpro1.var = args;
1655     RETURN_UNGCPRO (Fapply (2, args));
1656   }
1657 #else /* not NO_ARG_ARRAY */
1658   RETURN_UNGCPRO (Fapply (2, &fn));
1659 #endif /* not NO_ARG_ARRAY */
1660 }
1661
1662 /* Call function fn on no arguments */
1663 Lisp_Object
1664 call0 (fn)
1665      Lisp_Object fn;
1666 {
1667   struct gcpro gcpro1;
1668
1669   GCPRO1 (fn);
1670   RETURN_UNGCPRO (Ffuncall (1, &fn));
1671 }
1672
1673 /* Call function fn with argument arg */
1674 /* ARGSUSED */
1675 Lisp_Object
1676 call1 (fn, arg)
1677      Lisp_Object fn, arg;
1678 {
1679   struct gcpro gcpro1;
1680 #ifdef NO_ARG_ARRAY
1681   Lisp_Object args[2];
1682
1683   args[0] = fn;
1684   args[1] = arg;
1685   GCPRO1 (args[0]);
1686   gcpro1.nvars = 2;
1687   RETURN_UNGCPRO (Ffuncall (2, args));
1688 #else /* not NO_ARG_ARRAY */
1689   GCPRO1 (fn);
1690   gcpro1.nvars = 2;
1691   RETURN_UNGCPRO (Ffuncall (2, &fn));
1692 #endif /* not NO_ARG_ARRAY */
1693 }
1694
1695 /* Call function fn with arguments arg, arg1 */
1696 /* ARGSUSED */
1697 Lisp_Object
1698 call2 (fn, arg, arg1)
1699      Lisp_Object fn, arg, arg1;
1700 {
1701   struct gcpro gcpro1;
1702 #ifdef NO_ARG_ARRAY
1703   Lisp_Object args[3];
1704   args[0] = fn;
1705   args[1] = arg;
1706   args[2] = arg1;
1707   GCPRO1 (args[0]);
1708   gcpro1.nvars = 3;
1709   RETURN_UNGCPRO (Ffuncall (3, args));
1710 #else /* not NO_ARG_ARRAY */
1711   GCPRO1 (fn);
1712   gcpro1.nvars = 3;
1713   RETURN_UNGCPRO (Ffuncall (3, &fn));
1714 #endif /* not NO_ARG_ARRAY */
1715 }
1716
1717 /* Call function fn with arguments arg, arg1, arg2 */
1718 /* ARGSUSED */
1719 Lisp_Object
1720 call3 (fn, arg, arg1, arg2)
1721      Lisp_Object fn, arg, arg1, arg2;
1722 {
1723   struct gcpro gcpro1;
1724 #ifdef NO_ARG_ARRAY
1725   Lisp_Object args[4];
1726   args[0] = fn;
1727   args[1] = arg;
1728   args[2] = arg1;
1729   args[3] = arg2;
1730   GCPRO1 (args[0]);
1731   gcpro1.nvars = 4;
1732   RETURN_UNGCPRO (Ffuncall (4, args));
1733 #else /* not NO_ARG_ARRAY */
1734   GCPRO1 (fn);
1735   gcpro1.nvars = 4;
1736   RETURN_UNGCPRO (Ffuncall (4, &fn));
1737 #endif /* not NO_ARG_ARRAY */
1738 }
1739
1740 DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0,
1741   "Call first argument as a function, passing remaining arguments to it.\n\
1742 Thus, (funcall 'cons 'x 'y) returns (x . y).")
1743   (nargs, args)
1744      int nargs;
1745      Lisp_Object *args;
1746 {
1747   Lisp_Object fun;
1748   Lisp_Object funcar;
1749   int numargs = nargs - 1;
1750   Lisp_Object lisp_numargs;
1751   Lisp_Object val;
1752   struct backtrace backtrace;
1753   register Lisp_Object *internal_args;
1754   register int i;
1755
1756   QUIT;
1757   if (consing_since_gc > gc_cons_threshold)
1758     Fgarbage_collect ();
1759
1760   if (++lisp_eval_depth > max_lisp_eval_depth)
1761     {
1762       if (max_lisp_eval_depth < 100)
1763         max_lisp_eval_depth = 100;
1764       if (lisp_eval_depth > max_lisp_eval_depth)
1765         error ("Lisp nesting exceeds max-lisp-eval-depth");
1766     }
1767
1768   backtrace.next = backtrace_list;
1769   backtrace_list = &backtrace;
1770   backtrace.function = &args[0];
1771   backtrace.args = &args[1];
1772   backtrace.nargs = nargs - 1;
1773   backtrace.evalargs = 0;
1774   backtrace.debug_on_exit = 0;
1775
1776   if (debug_on_next_call)
1777     do_debug_on_call (Qlambda);
1778
1779  retry:
1780
1781   fun = args[0];
1782   while (XTYPE (fun) == Lisp_Symbol)
1783     {
1784       QUIT;
1785       val = XSYMBOL (fun)->function;
1786       if (EQ (val, Qunbound))
1787         Fsymbol_function (fun); /* Get the right kind of error! */
1788       fun = val;
1789     }
1790
1791   if (XTYPE (fun) == Lisp_Subr)
1792     {
1793       if (numargs < XSUBR (fun)->min_args
1794           || (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs))
1795         {
1796           XFASTINT (lisp_numargs) = numargs;
1797           return Fsignal (Qwrong_number_of_arguments, Fcons (fun, Fcons (lisp_numargs, Qnil)));
1798         }
1799
1800       if (XSUBR (fun)->max_args == UNEVALLED)
1801         return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1802
1803       if (XSUBR (fun)->max_args == MANY)
1804         {
1805           val = (*XSUBR (fun)->function) (numargs, args + 1);
1806           goto done;
1807         }
1808
1809       if (XSUBR (fun)->max_args > numargs)
1810         {
1811           internal_args = (Lisp_Object *) alloca (XSUBR (fun)->max_args * sizeof (Lisp_Object));
1812           bcopy (args + 1, internal_args, numargs * sizeof (Lisp_Object));
1813           for (i = numargs; i < XSUBR (fun)->max_args; i++)
1814             internal_args[i] = Qnil;
1815         }
1816       else
1817         internal_args = args + 1;
1818       switch (XSUBR (fun)->max_args)
1819         {
1820         case 0:
1821           val = (*XSUBR (fun)->function) ();
1822           goto done;
1823         case 1:
1824           val = (*XSUBR (fun)->function) (internal_args[0]);
1825           goto done;
1826         case 2:
1827           val = (*XSUBR (fun)->function) (internal_args[0],
1828                                           internal_args[1]);
1829           goto done;
1830         case 3:
1831           val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1],
1832                                           internal_args[2]);
1833           goto done;
1834         case 4:
1835           val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1],
1836                                           internal_args[2],
1837                                           internal_args[3]);
1838           goto done;
1839         case 5:
1840           val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1],
1841                                           internal_args[2], internal_args[3],
1842                                           internal_args[4]);
1843           goto done;
1844         case 6:
1845           val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1],
1846                                           internal_args[2], internal_args[3],
1847                                           internal_args[4], internal_args[5]);
1848           goto done;
1849
1850         default:
1851
1852           /* If a subr takes more than 6 arguments without using MANY
1853              or UNEVALLED, we need to extend this function to support it.
1854              Until this is done, there is no way to call the function.  */
1855           abort ();
1856         }
1857     }
1858   if (XTYPE (fun) == Lisp_Compiled)
1859     val = funcall_lambda (fun, numargs, args + 1);
1860   else
1861     {
1862       if (!CONSP (fun))
1863         return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1864       funcar = Fcar (fun);
1865       if (XTYPE (funcar) != Lisp_Symbol)
1866         return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1867       if (EQ (funcar, Qlambda))
1868         val = funcall_lambda (fun, numargs, args + 1);
1869       else if (EQ (funcar, Qmocklisp))
1870         val = ml_apply (fun, Flist (numargs, args + 1));
1871       else if (EQ (funcar, Qautoload))
1872         {
1873           do_autoload (fun, args[0]);
1874           goto retry;
1875         }
1876       else
1877         return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1878     }
1879  done:
1880   lisp_eval_depth--;
1881   if (backtrace.debug_on_exit)
1882     val = call_debugger (Fcons (Qexit, Fcons (val, Qnil)));
1883   backtrace_list = backtrace.next;
1884   return val;
1885 }
1886 \f
1887 Lisp_Object
1888 apply_lambda (fun, args, eval_flag)
1889      Lisp_Object fun, args;
1890      int eval_flag;
1891 {
1892   Lisp_Object args_left;
1893   Lisp_Object numargs;
1894   register Lisp_Object *arg_vector;
1895   struct gcpro gcpro1, gcpro2, gcpro3;
1896   register int i;
1897   register Lisp_Object tem;
1898
1899   numargs = Flength (args);
1900   arg_vector = (Lisp_Object *) alloca (XINT (numargs) * sizeof (Lisp_Object));
1901   args_left = args;
1902
1903   GCPRO3 (*arg_vector, args_left, fun);
1904   gcpro1.nvars = 0;
1905
1906   for (i = 0; i < XINT (numargs);)
1907     {
1908       tem = Fcar (args_left), args_left = Fcdr (args_left);
1909       if (eval_flag) tem = Feval (tem);
1910       arg_vector[i++] = tem;
1911       gcpro1.nvars = i;
1912     }
1913
1914   UNGCPRO;
1915
1916   if (eval_flag)
1917     {
1918       backtrace_list->args = arg_vector;
1919       backtrace_list->nargs = i;
1920     }
1921   backtrace_list->evalargs = 0;
1922   tem = funcall_lambda (fun, XINT (numargs), arg_vector);
1923
1924   /* Do the debug-on-exit now, while arg_vector still exists.  */
1925   if (backtrace_list->debug_on_exit)
1926     tem = call_debugger (Fcons (Qexit, Fcons (tem, Qnil)));
1927   /* Don't do it again when we return to eval.  */
1928   backtrace_list->debug_on_exit = 0;
1929   return tem;
1930 }
1931
1932 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
1933    and return the result of evaluation.
1934    FUN must be either a lambda-expression or a compiled-code object.  */
1935
1936 Lisp_Object
1937 funcall_lambda (fun, nargs, arg_vector)
1938      Lisp_Object fun;
1939      int nargs;
1940      register Lisp_Object *arg_vector;
1941 {
1942   Lisp_Object val, tem;
1943   register Lisp_Object syms_left;
1944   Lisp_Object numargs;
1945   register Lisp_Object next;
1946   int count = specpdl_ptr - specpdl;
1947   register int i;
1948   int optional = 0, rest = 0;
1949
1950   specbind (Qmocklisp_arguments, Qt);   /* t means NOT mocklisp! */
1951
1952   XFASTINT (numargs) = nargs;
1953
1954   if (XTYPE (fun) == Lisp_Cons)
1955     syms_left = Fcar (Fcdr (fun));
1956   else if (XTYPE (fun) == Lisp_Compiled)
1957     syms_left = XVECTOR (fun)->contents[COMPILED_ARGLIST];
1958   else abort ();
1959
1960   i = 0;
1961   for (; !NILP (syms_left); syms_left = Fcdr (syms_left))
1962     {
1963       QUIT;
1964       next = Fcar (syms_left);
1965       while (XTYPE (next) != Lisp_Symbol)
1966         next = Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1967       if (EQ (next, Qand_rest))
1968         rest = 1;
1969       else if (EQ (next, Qand_optional))
1970         optional = 1;
1971       else if (rest)
1972         {
1973           specbind (next, Flist (nargs - i, &arg_vector[i]));
1974           i = nargs;
1975         }
1976       else if (i < nargs)
1977         {
1978           tem = arg_vector[i++];
1979           specbind (next, tem);
1980         }
1981       else if (!optional)
1982         return Fsignal (Qwrong_number_of_arguments, Fcons (fun, Fcons (numargs, Qnil)));
1983       else
1984         specbind (next, Qnil);
1985     }
1986
1987   if (i < nargs)
1988     return Fsignal (Qwrong_number_of_arguments, Fcons (fun, Fcons (numargs, Qnil)));
1989
1990   if (XTYPE (fun) == Lisp_Cons)
1991     val = Fprogn (Fcdr (Fcdr (fun)));
1992   else
1993     val = Fbyte_code (XVECTOR (fun)->contents[COMPILED_BYTECODE],
1994                       XVECTOR (fun)->contents[COMPILED_CONSTANTS],
1995                       XVECTOR (fun)->contents[COMPILED_STACK_DEPTH]);
1996   return unbind_to (count, val);
1997 }
1998 \f
1999 void
2000 grow_specpdl ()
2001 {
2002   register int count = specpdl_ptr - specpdl;
2003   if (specpdl_size >= max_specpdl_size)
2004     {
2005       if (max_specpdl_size < 400)
2006         max_specpdl_size = 400;
2007       if (specpdl_size >= max_specpdl_size)
2008         {
2009           Fsignal (Qerror,
2010                    Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil));
2011           max_specpdl_size *= 2;
2012         }
2013     }
2014   specpdl_size *= 2;
2015   if (specpdl_size > max_specpdl_size)
2016     specpdl_size = max_specpdl_size;
2017   specpdl = (struct specbinding *) xrealloc (specpdl, specpdl_size * sizeof (struct specbinding));
2018   specpdl_ptr = specpdl + count;
2019 }
2020
2021 void
2022 specbind (symbol, value)
2023      Lisp_Object symbol, value;
2024 {
2025   extern void store_symval_forwarding (); /* in eval.c */
2026   Lisp_Object ovalue;
2027
2028   CHECK_SYMBOL (symbol, 0);
2029
2030   if (specpdl_ptr == specpdl + specpdl_size)
2031     grow_specpdl ();
2032   specpdl_ptr->symbol = symbol;
2033   specpdl_ptr->func = 0;
2034   ovalue = XSYMBOL (symbol)->value;
2035   specpdl_ptr->old_value = EQ (ovalue, Qunbound) ? Qunbound : Fsymbol_value (symbol);
2036   specpdl_ptr++;
2037   if (XTYPE (ovalue) == Lisp_Buffer_Objfwd)
2038     store_symval_forwarding (symbol, ovalue, value);
2039   else
2040     Fset (symbol, value);
2041 }
2042
2043 void
2044 record_unwind_protect (function, arg)
2045      Lisp_Object (*function)();
2046      Lisp_Object arg;
2047 {
2048   if (specpdl_ptr == specpdl + specpdl_size)
2049     grow_specpdl ();
2050   specpdl_ptr->func = function;
2051   specpdl_ptr->symbol = Qnil;
2052   specpdl_ptr->old_value = arg;
2053   specpdl_ptr++;
2054 }
2055
2056 Lisp_Object
2057 unbind_to (count, value)
2058      int count;
2059      Lisp_Object value;
2060 {
2061   int quitf = !NILP (Vquit_flag);
2062   struct gcpro gcpro1;
2063
2064   GCPRO1 (value);
2065
2066   Vquit_flag = Qnil;
2067
2068   while (specpdl_ptr != specpdl + count)
2069     {
2070       --specpdl_ptr;
2071       if (specpdl_ptr->func != 0)
2072         (*specpdl_ptr->func) (specpdl_ptr->old_value);
2073       /* Note that a "binding" of nil is really an unwind protect,
2074         so in that case the "old value" is a list of forms to evaluate.  */
2075       else if (NILP (specpdl_ptr->symbol))
2076         Fprogn (specpdl_ptr->old_value);
2077       else
2078         Fset (specpdl_ptr->symbol, specpdl_ptr->old_value);
2079     }
2080   if (NILP (Vquit_flag) && quitf) Vquit_flag = Qt;
2081
2082   UNGCPRO;
2083
2084   return value;
2085 }
2086 \f
2087 #if 0
2088
2089 /* Get the value of symbol's global binding, even if that binding
2090  is not now dynamically visible.  */
2091
2092 Lisp_Object
2093 top_level_value (symbol)
2094      Lisp_Object symbol;
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         return ptr->old_value;
2103     }
2104   return Fsymbol_value (symbol);
2105 }
2106
2107 Lisp_Object
2108 top_level_set (symbol, newval)
2109      Lisp_Object symbol, newval;
2110 {
2111   register struct specbinding *ptr = specpdl;
2112
2113   CHECK_SYMBOL (symbol, 0);
2114   for (; ptr != specpdl_ptr; ptr++)
2115     {
2116       if (EQ (ptr->symbol, symbol))
2117         {
2118           ptr->old_value = newval;
2119           return newval;
2120         }
2121     }
2122   return Fset (symbol, newval);
2123 }
2124
2125 #endif /* 0 */
2126 \f
2127 DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
2128   "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\
2129 The debugger is entered when that frame exits, if the flag is non-nil.")
2130   (level, flag)
2131      Lisp_Object level, flag;
2132 {
2133   register struct backtrace *backlist = backtrace_list;
2134   register int i;
2135
2136   CHECK_NUMBER (level, 0);
2137
2138   for (i = 0; backlist && i < XINT (level); i++)
2139     {
2140       backlist = backlist->next;
2141     }
2142
2143   if (backlist)
2144     backlist->debug_on_exit = !NILP (flag);
2145
2146   return flag;
2147 }
2148
2149 DEFUN ("backtrace", Fbacktrace, Sbacktrace, 0, 0, "",
2150   "Print a trace of Lisp function calls currently active.\n\
2151 Output stream used is value of `standard-output'.")
2152   ()
2153 {
2154   register struct backtrace *backlist = backtrace_list;
2155   register int i;
2156   Lisp_Object tail;
2157   Lisp_Object tem;
2158   extern Lisp_Object Vprint_level;
2159   struct gcpro gcpro1;
2160
2161   entering_debugger = 0;
2162
2163   XFASTINT (Vprint_level) = 3;
2164
2165   tail = Qnil;
2166   GCPRO1 (tail);
2167
2168   while (backlist)
2169     {
2170       write_string (backlist->debug_on_exit ? "* " : "  ", 2);
2171       if (backlist->nargs == UNEVALLED)
2172         {
2173           Fprin1 (Fcons (*backlist->function, *backlist->args), Qnil);
2174         }
2175       else
2176         {
2177           tem = *backlist->function;
2178           Fprin1 (tem, Qnil);   /* This can QUIT */
2179           write_string ("(", -1);
2180           if (backlist->nargs == MANY)
2181             {
2182               for (tail = *backlist->args, i = 0;
2183                    !NILP (tail);
2184                    tail = Fcdr (tail), i++)
2185                 {
2186                   if (i) write_string (" ", -1);
2187                   Fprin1 (Fcar (tail), Qnil);
2188                 }
2189             }
2190           else
2191             {
2192               for (i = 0; i < backlist->nargs; i++)
2193                 {
2194                   if (i) write_string (" ", -1);
2195                   Fprin1 (backlist->args[i], Qnil);
2196                 }
2197             }
2198         }
2199       write_string (")\n", -1);
2200       backlist = backlist->next;
2201     }
2202
2203   Vprint_level = Qnil;
2204   UNGCPRO;
2205   return Qnil;
2206 }
2207
2208 DEFUN ("backtrace-frame", Fbacktrace_frame, Sbacktrace_frame, 1, 1, "",
2209   "Return the function and arguments N frames up from current execution point.\n\
2210 If that frame has not evaluated the arguments yet (or is a special form),\n\
2211 the value is (nil FUNCTION ARG-FORMS...).\n\
2212 If that frame has evaluated its arguments and called its function already,\n\
2213 the value is (t FUNCTION ARG-VALUES...).\n\
2214 A &rest arg is represented as the tail of the list ARG-VALUES.\n\
2215 FUNCTION is whatever was supplied as car of evaluated list,\n\
2216 or a lambda expression for macro calls.\n\
2217 If N is more than the number of frames, the value is nil.")
2218   (nframes)
2219      Lisp_Object nframes;
2220 {
2221   register struct backtrace *backlist = backtrace_list;
2222   register int i;
2223   Lisp_Object tem;
2224
2225   CHECK_NATNUM (nframes, 0);
2226
2227   /* Find the frame requested.  */
2228   for (i = 0; i < XFASTINT (nframes); i++)
2229     backlist = backlist->next;
2230
2231   if (!backlist)
2232     return Qnil;
2233   if (backlist->nargs == UNEVALLED)
2234     return Fcons (Qnil, Fcons (*backlist->function, *backlist->args));
2235   else
2236     {
2237       if (backlist->nargs == MANY)
2238         tem = *backlist->args;
2239       else
2240         tem = Flist (backlist->nargs, backlist->args);
2241
2242       return Fcons (Qt, Fcons (*backlist->function, tem));
2243     }
2244 }
2245 \f
2246 syms_of_eval ()
2247 {
2248   DEFVAR_INT ("max-specpdl-size", &max_specpdl_size,
2249     "Limit on number of Lisp variable bindings & unwind-protects before error.");
2250
2251   DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth,
2252     "Limit on depth in `eval', `apply' and `funcall' before error.\n\
2253 This limit is to catch infinite recursions for you before they cause\n\
2254 actual stack overflow in C, which would be fatal for Emacs.\n\
2255 You can safely make it considerably larger than its default value,\n\
2256 if that proves inconveniently small.");
2257
2258   DEFVAR_LISP ("quit-flag", &Vquit_flag,
2259     "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
2260 Typing C-G sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
2261   Vquit_flag = Qnil;
2262
2263   DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit,
2264     "Non-nil inhibits C-g quitting from happening immediately.\n\
2265 Note that `quit-flag' will still be set by typing C-g,\n\
2266 so a quit will be signalled as soon as `inhibit-quit' is nil.\n\
2267 To prevent this happening, set `quit-flag' to nil\n\
2268 before making `inhibit-quit' nil.");
2269   Vinhibit_quit = Qnil;
2270
2271   Qinhibit_quit = intern ("inhibit-quit");
2272   staticpro (&Qinhibit_quit);
2273
2274   Qautoload = intern ("autoload");
2275   staticpro (&Qautoload);
2276
2277   Qdebug_on_error = intern ("debug-on-error");
2278   staticpro (&Qdebug_on_error);
2279
2280   Qmacro = intern ("macro");
2281   staticpro (&Qmacro);
2282
2283   /* Note that the process handling also uses Qexit, but we don't want
2284      to staticpro it twice, so we just do it here.  */
2285   Qexit = intern ("exit");
2286   staticpro (&Qexit);
2287
2288   Qinteractive = intern ("interactive");
2289   staticpro (&Qinteractive);
2290
2291   Qcommandp = intern ("commandp");
2292   staticpro (&Qcommandp);
2293
2294   Qdefun = intern ("defun");
2295   staticpro (&Qdefun);
2296
2297   Qand_rest = intern ("&rest");
2298   staticpro (&Qand_rest);
2299
2300   Qand_optional = intern ("&optional");
2301   staticpro (&Qand_optional);
2302
2303   DEFVAR_BOOL ("stack-trace-on-error", &stack_trace_on_error,
2304     "*Non-nil means automatically display a backtrace buffer\n\
2305 after any error that is handled by the editor command loop.");
2306   stack_trace_on_error = 0;
2307
2308   DEFVAR_BOOL ("debug-on-error", &debug_on_error,
2309     "*Non-nil means enter debugger if an error is signaled.\n\
2310 Does not apply to errors handled by `condition-case'.\n\
2311 See also variable `debug-on-quit'.");
2312   debug_on_error = 0;
2313
2314   DEFVAR_BOOL ("debug-on-quit", &debug_on_quit,
2315     "*Non-nil means enter debugger if quit is signaled (C-G, for example).\n\
2316 Does not apply if quit is handled by a `condition-case'.");
2317   debug_on_quit = 0;
2318
2319   DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call,
2320     "Non-nil means enter debugger before next `eval', `apply' or `funcall'.");
2321
2322   DEFVAR_LISP ("debugger", &Vdebugger,
2323     "Function to call to invoke debugger.\n\
2324 If due to frame exit, args are `exit' and the value being returned;\n\
2325  this function's value will be returned instead of that.\n\
2326 If due to error, args are `error' and a list of the args to `signal'.\n\
2327 If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
2328 If due to `eval' entry, one arg, t.");
2329   Vdebugger = Qnil;
2330
2331   Qmocklisp_arguments = intern ("mocklisp-arguments");
2332   staticpro (&Qmocklisp_arguments);
2333   DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments,
2334     "While in a mocklisp function, the list of its unevaluated args.");
2335   Vmocklisp_arguments = Qt;
2336
2337   DEFVAR_LISP ("run-hooks", &Vrun_hooks,
2338     "Set to the function `run-hooks', if that function has been defined.\n\
2339 Otherwise, nil (in a bare Emacs without preloaded Lisp code).");
2340   Vrun_hooks = Qnil;
2341
2342   staticpro (&Vautoload_queue);
2343   Vautoload_queue = Qnil;
2344
2345   defsubr (&Sor);
2346   defsubr (&Sand);
2347   defsubr (&Sif);
2348   defsubr (&Scond);
2349   defsubr (&Sprogn);
2350   defsubr (&Sprog1);
2351   defsubr (&Sprog2);
2352   defsubr (&Ssetq);
2353   defsubr (&Squote);
2354   defsubr (&Sfunction);
2355   defsubr (&Sdefun);
2356   defsubr (&Sdefmacro);
2357   defsubr (&Sdefvar);
2358   defsubr (&Sdefconst);
2359   defsubr (&Suser_variable_p);
2360   defsubr (&Slet);
2361   defsubr (&SletX);
2362   defsubr (&Swhile);
2363   defsubr (&Smacroexpand);
2364   defsubr (&Scatch);
2365   defsubr (&Sthrow);
2366   defsubr (&Sunwind_protect);
2367   defsubr (&Scondition_case);
2368   defsubr (&Ssignal);
2369   defsubr (&Sinteractive_p);
2370   defsubr (&Scommandp);
2371   defsubr (&Sautoload);
2372   defsubr (&Seval);
2373   defsubr (&Sapply);
2374   defsubr (&Sfuncall);
2375   defsubr (&Sbacktrace_debug);
2376   defsubr (&Sbacktrace);
2377   defsubr (&Sbacktrace_frame);
2378 }