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