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