4.3BSD - /usr/src/new/emacs/src/eval.c

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

Defined functions

Defined variables

Defined struct's

Defined macros