1: /* Evaluator for GNU Emacs Lisp interpreter.
    2:    Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1999, 2000, 2001,
    3:                  2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
    4: 
    5: This file is part of GNU Emacs.
    6: 
    7: GNU Emacs is free software; you can redistribute it and/or modify
    8: it under the terms of the GNU General Public License as published by
    9: the Free Software Foundation; either version 2, or (at your option)
   10: any later version.
   11: 
   12: GNU Emacs is distributed in the hope that it will be useful,
   13: but WITHOUT ANY WARRANTY; without even the implied warranty of
   14: MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   15: GNU General Public License for more details.
   16: 
   17: You should have received a copy of the GNU General Public License
   18: along with GNU Emacs; see the file COPYING.  If not, write to
   19: the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
   20: Boston, MA 02110-1301, USA.  */
   21: 
   22: 
   23: #include <config.h>
   24: #include "lisp.h"
   25: #include "blockinput.h"
   26: #include "commands.h"
   27: #include "keyboard.h"
   28: #include "dispextern.h"
   29: #include <setjmp.h>
   30: 
   31: #if HAVE_X_WINDOWS
   32: #include "xterm.h"
   33: #endif
   34: 
   35: /* This definition is duplicated in alloc.c and keyboard.c */
   36: /* Putting it in lisp.h makes cc bomb out! */
   37: 
   38: struct backtrace
   39: {
   40:   struct backtrace *next;
   41:   Lisp_Object *function;
   42:   Lisp_Object *args;    /* Points to vector of args. */
   43:   int nargs;            /* Length of vector.
   44:                            If nargs is UNEVALLED, args points to slot holding
   45:                            list of unevalled args */
   46:   char evalargs;
   47:   /* Nonzero means call value of debugger when done with this operation. */
   48:   char debug_on_exit;
   49: };
   50: 
   51: struct backtrace *backtrace_list;
   52: 
   53: /* This structure helps implement the `catch' and `throw' control
   54:    structure.  A struct catchtag contains all the information needed
   55:    to restore the state of the interpreter after a non-local jump.
   56: 
   57:    Handlers for error conditions (represented by `struct handler'
   58:    structures) just point to a catch tag to do the cleanup required
   59:    for their jumps.
   60: 
   61:    catchtag structures are chained together in the C calling stack;
   62:    the `next' member points to the next outer catchtag.
   63: 
   64:    A call like (throw TAG VAL) searches for a catchtag whose `tag'
   65:    member is TAG, and then unbinds to it.  The `val' member is used to
   66:    hold VAL while the stack is unwound; `val' is returned as the value
   67:    of the catch form.
   68: 
   69:    All the other members are concerned with restoring the interpreter
   70:    state.  */
   71: 
   72: struct catchtag
   73: {
   74:   Lisp_Object tag;
   75:   Lisp_Object val;
   76:   struct catchtag *next;
   77:   struct gcpro *gcpro;
   78:   jmp_buf jmp;
   79:   struct backtrace *backlist;
   80:   struct handler *handlerlist;
   81:   int lisp_eval_depth;
   82:   int pdlcount;
   83:   int poll_suppress_count;
   84:   int interrupt_input_blocked;
   85:   struct byte_stack *byte_stack;
   86: };
   87: 
   88: struct catchtag *catchlist;
   89: 
   90: #ifdef DEBUG_GCPRO
   91: /* Count levels of GCPRO to detect failure to UNGCPRO.  */
   92: int gcpro_level;
   93: #endif
   94: 
   95: Lisp_Object Qautoload, Qmacro, Qexit, Qinteractive, Qcommandp, Qdefun;
   96: Lisp_Object Qinhibit_quit, Vinhibit_quit, Vquit_flag;
   97: Lisp_Object Qand_rest, Qand_optional;
   98: Lisp_Object Qdebug_on_error;
   99: Lisp_Object Qdeclare;
  100: 
  101: /* This holds either the symbol `run-hooks' or nil.
  102:    It is nil at an early stage of startup, and when Emacs
  103:    is shutting down.  */
  104: 
  105: Lisp_Object Vrun_hooks;
  106: 
  107: /* Non-nil means record all fset's and provide's, to be undone
  108:    if the file being autoloaded is not fully loaded.
  109:    They are recorded by being consed onto the front of Vautoload_queue:
  110:    (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide.  */
  111: 
  112: Lisp_Object Vautoload_queue;
  113: 
  114: /* Current number of specbindings allocated in specpdl.  */
  115: 
  116: int specpdl_size;
  117: 
  118: /* Pointer to beginning of specpdl.  */
  119: 
  120: struct specbinding *specpdl;
  121: 
  122: /* Pointer to first unused element in specpdl.  */
  123: 
  124: struct specbinding *specpdl_ptr;
  125: 
  126: /* Maximum size allowed for specpdl allocation */
  127: 
  128: EMACS_INT max_specpdl_size;
  129: 
  130: /* Depth in Lisp evaluations and function calls.  */
  131: 
  132: int lisp_eval_depth;
  133: 
  134: /* Maximum allowed depth in Lisp evaluations and function calls.  */
  135: 
  136: EMACS_INT max_lisp_eval_depth;
  137: 
  138: /* Nonzero means enter debugger before next function call */
  139: 
  140: int debug_on_next_call;
  141: 
  142: /* Non-zero means debugger may continue.  This is zero when the
  143:    debugger is called during redisplay, where it might not be safe to
  144:    continue the interrupted redisplay. */
  145: 
  146: int debugger_may_continue;
  147: 
  148: /* List of conditions (non-nil atom means all) which cause a backtrace
  149:    if an error is handled by the command loop's error handler.  */
  150: 
  151: Lisp_Object Vstack_trace_on_error;
  152: 
  153: /* List of conditions (non-nil atom means all) which enter the debugger
  154:    if an error is handled by the command loop's error handler.  */
  155: 
  156: Lisp_Object Vdebug_on_error;
  157: 
  158: /* List of conditions and regexps specifying error messages which
  159:    do not enter the debugger even if Vdebug_on_error says they should.  */
  160: 
  161: Lisp_Object Vdebug_ignored_errors;
  162: 
  163: /* Non-nil means call the debugger even if the error will be handled.  */
  164: 
  165: Lisp_Object Vdebug_on_signal;
  166: 
  167: /* Hook for edebug to use.  */
  168: 
  169: Lisp_Object Vsignal_hook_function;
  170: 
  171: /* Nonzero means enter debugger if a quit signal
  172:    is handled by the command loop's error handler. */
  173: 
  174: int debug_on_quit;
  175: 
  176: /* The value of num_nonmacro_input_events as of the last time we
  177:    started to enter the debugger.  If we decide to enter the debugger
  178:    again when this is still equal to num_nonmacro_input_events, then we
  179:    know that the debugger itself has an error, and we should just
  180:    signal the error instead of entering an infinite loop of debugger
  181:    invocations.  */
  182: 
  183: int when_entered_debugger;
  184: 
  185: Lisp_Object Vdebugger;
  186: 
  187: /* The function from which the last `signal' was called.  Set in
  188:    Fsignal.  */
  189: 
  190: Lisp_Object Vsignaling_function;
  191: 
  192: /* Set to non-zero while processing X events.  Checked in Feval to
  193:    make sure the Lisp interpreter isn't called from a signal handler,
  194:    which is unsafe because the interpreter isn't reentrant.  */
  195: 
  196: int handling_signal;
  197: 
  198: /* Function to process declarations in defmacro forms.  */
  199: 
  200: Lisp_Object Vmacro_declaration_function;
  201: 
  202: extern Lisp_Object Qrisky_local_variable;
  203: 
  204: static Lisp_Object funcall_lambda P_ ((Lisp_Object, int, Lisp_Object*));
  205: static void unwind_to_catch P_ ((struct catchtag *, Lisp_Object)) NO_RETURN;
  206: 
  207: #if __GNUC__
  208: /* "gcc -O3" enables automatic function inlining, which optimizes out
  209:    the arguments for the invocations of these functions, whereas they
  210:    expect these values on the stack.  */
  211: Lisp_Object apply1 () __attribute__((noinline));
  212: Lisp_Object call2 () __attribute__((noinline));
  213: #endif
  214: ^L
  215: void
  216: init_eval_once ()
  217: {
  218:   specpdl_size = 50;
  219:   specpdl = (struct specbinding *) xmalloc (specpdl_size * sizeof (struct specbinding));
  220:   specpdl_ptr = specpdl;
  221:   /* Don't forget to update docs (lispref node "Local Variables").  */
  222:   max_specpdl_size = 1000;
  223:   max_lisp_eval_depth = 300;
  224: 
  225:   Vrun_hooks = Qnil;
  226: }
  227: 
  228: void
  229: init_eval ()
  230: {
  231:   specpdl_ptr = specpdl;
  232:   catchlist = 0;
  233:   handlerlist = 0;
  234:   backtrace_list = 0;
  235:   Vquit_flag = Qnil;
  236:   debug_on_next_call = 0;
  237:   lisp_eval_depth = 0;
  238: #ifdef DEBUG_GCPRO
  239:   gcpro_level = 0;
  240: #endif
  241:   /* This is less than the initial value of num_nonmacro_input_events.  */
  242:   when_entered_debugger = -1;
  243: }
  244: 
  245: /* unwind-protect function used by call_debugger.  */
  246: 
  247: static Lisp_Object
  248: restore_stack_limits (data)
  249:      Lisp_Object data;
  250: {
  251:   max_specpdl_size = XINT (XCAR (data));
  252:   max_lisp_eval_depth = XINT (XCDR (data));
  253:   return Qnil;
  254: }
  255: 
  256: /* Call the Lisp debugger, giving it argument ARG.  */
  257: 
  258: Lisp_Object
  259: call_debugger (arg)
  260:      Lisp_Object arg;
  261: {
  262:   int debug_while_redisplaying;
  263:   int count = SPECPDL_INDEX ();
  264:   Lisp_Object val;
  265:   int old_max = max_specpdl_size;
  266: 
  267:   /* Temporarily bump up the stack limits,
  268:      so the debugger won't run out of stack.  */
  269: 
  270:   max_specpdl_size += 1;
  271:   record_unwind_protect (restore_stack_limits,
  272:                          Fcons (make_number (old_max),
  273:                                 make_number (max_lisp_eval_depth)));
  274:   max_specpdl_size = old_max;
  275: 
  276:   if (lisp_eval_depth + 40 > max_lisp_eval_depth)
  277:     max_lisp_eval_depth = lisp_eval_depth + 40;
  278: 
  279:   if (SPECPDL_INDEX () + 100 > max_specpdl_size)
  280:     max_specpdl_size = SPECPDL_INDEX () + 100;
  281: 
  282: #ifdef HAVE_X_WINDOWS
  283:   if (display_hourglass_p)
  284:     cancel_hourglass ();
  285: #endif
  286: 
  287:   debug_on_next_call = 0;
  288:   when_entered_debugger = num_nonmacro_input_events;
  289: 
  290:   /* Resetting redisplaying_p to 0 makes sure that debug output is
  291:      displayed if the debugger is invoked during redisplay.  */
  292:   debug_while_redisplaying = redisplaying_p;
  293:   redisplaying_p = 0;
  294:   specbind (intern ("debugger-may-continue"),
  295:             debug_while_redisplaying ? Qnil : Qt);
  296:   specbind (Qinhibit_redisplay, Qnil);
  297:   specbind (Qdebug_on_error, Qnil);
  298: 
  299: #if 0 /* Binding this prevents execution of Lisp code during
  300:          redisplay, which necessarily leads to display problems.  */
  301:   specbind (Qinhibit_eval_during_redisplay, Qt);
  302: #endif
  303: 
  304:   val = apply1 (Vdebugger, arg);
  305: 
  306:   /* Interrupting redisplay and resuming it later is not safe under
  307:      all circumstances.  So, when the debugger returns, abort the
  308:      interrupted redisplay by going back to the top-level.  */
  309:   if (debug_while_redisplaying)
  310:     Ftop_level ();
  311: 
  312:   return unbind_to (count, val);
  313: }
  314: 
  315: void
  316: do_debug_on_call (code)
  317:      Lisp_Object code;
  318: {
  319:   debug_on_next_call = 0;
  320:   backtrace_list->debug_on_exit = 1;
  321:   call_debugger (Fcons (code, Qnil));
  322: }
  323: ^L
  324: /* NOTE!!! Every function that can call EVAL must protect its args
  325:    and temporaries from garbage collection while it needs them.
  326:    The definition of `For' shows what you have to do.  */
  327: 
  328: DEFUN ("or", For, Sor, 0, UNEVALLED, 0,
  329:        doc: /* Eval args until one of them yields non-nil, then return that value.
  330: The remaining args are not evalled at all.
  331: If all args return nil, return nil.
  332: usage: (or CONDITIONS ...)  */)
  333:      (args)
  334:      Lisp_Object args;
  335: {
  336:   register Lisp_Object val = Qnil;
  337:   struct gcpro gcpro1;
  338: 
  339:   GCPRO1 (args);
  340: 
  341:   while (CONSP (args))
  342:     {
  343:       val = Feval (XCAR (args));
  344:       if (!NILP (val))
  345:         break;
  346:       args = XCDR (args);
  347:     }
  348: 
  349:   UNGCPRO;
  350:   return val;
  351: }
  352: 
  353: DEFUN ("and", Fand, Sand, 0, UNEVALLED, 0,
  354:        doc: /* Eval args until one of them yields nil, then return nil.
  355: The remaining args are not evalled at all.
  356: If no arg yields nil, return the last arg's value.
  357: usage: (and CONDITIONS ...)  */)
  358:      (args)
  359:      Lisp_Object args;
  360: {
  361:   register Lisp_Object val = Qt;
  362:   struct gcpro gcpro1;
  363: 
  364:   GCPRO1 (args);
  365: 
  366:   while (CONSP (args))
  367:     {
  368:       val = Feval (XCAR (args));
  369:       if (NILP (val))
  370:         break;
  371:       args = XCDR (args);
  372:     }
  373: 
  374:   UNGCPRO;
  375:   return val;
  376: }
  377: 
  378: DEFUN ("if", Fif, Sif, 2, UNEVALLED, 0,
  379:        doc: /* If COND yields non-nil, do THEN, else do ELSE...
  380: Returns the value of THEN or the value of the last of the ELSE's.
  381: THEN must be one expression, but ELSE... can be zero or more expressions.
  382: If COND yields nil, and there are no ELSE's, the value is nil.
  383: usage: (if COND THEN ELSE...)  */)
  384:      (args)
  385:      Lisp_Object args;
  386: {
  387:   register Lisp_Object cond;
  388:   struct gcpro gcpro1;
  389: 
  390:   GCPRO1 (args);
  391:   cond = Feval (Fcar (args));
  392:   UNGCPRO;
  393: 
  394:   if (!NILP (cond))
  395:     return Feval (Fcar (Fcdr (args)));
  396:   return Fprogn (Fcdr (Fcdr (args)));
  397: }
  398: 
  399: DEFUN ("cond", Fcond, Scond, 0, UNEVALLED, 0,
  400:        doc: /* Try each clause until one succeeds.
  401: Each clause looks like (CONDITION BODY...).  CONDITION is evaluated
  402: and, if the value is non-nil, this clause succeeds:
  403: then the expressions in BODY are evaluated and the last one's
  404: value is the value of the cond-form.
  405: If no clause succeeds, cond returns nil.
  406: If a clause has one element, as in (CONDITION),
  407: CONDITION's value if non-nil is returned from the cond-form.
  408: usage: (cond CLAUSES...)  */)
  409:      (args)
  410:      Lisp_Object args;
  411: {
  412:   register Lisp_Object clause, val;
  413:   struct gcpro gcpro1;
  414: 
  415:   val = Qnil;
  416:   GCPRO1 (args);
  417:   while (!NILP (args))
  418:     {
  419:       clause = Fcar (args);
  420:       val = Feval (Fcar (clause));
  421:       if (!NILP (val))
  422:         {
  423:           if (!EQ (XCDR (clause), Qnil))
  424:             val = Fprogn (XCDR (clause));
  425:           break;
  426:         }
  427:       args = XCDR (args);
  428:     }
  429:   UNGCPRO;
  430: 
  431:   return val;
  432: }
  433: 
  434: DEFUN ("progn", Fprogn, Sprogn, 0, UNEVALLED, 0,
  435:        doc: /* Eval BODY forms sequentially and return value of last one.
  436: usage: (progn BODY ...)  */)
  437:      (args)
  438:      Lisp_Object args;
  439: {
  440:   register Lisp_Object val = Qnil;
  441:   struct gcpro gcpro1;
  442: 
  443:   GCPRO1 (args);
  444: 
  445:   while (CONSP (args))
  446:     {
  447:       val = Feval (XCAR (args));
  448:       args = XCDR (args);
  449:     }
  450: 
  451:   UNGCPRO;
  452:   return val;
  453: }
  454: 
  455: DEFUN ("prog1", Fprog1, Sprog1, 1, UNEVALLED, 0,
  456:        doc: /* Eval FIRST and BODY sequentially; value from FIRST.
  457: The value of FIRST is saved during the evaluation of the remaining args,
  458: whose values are discarded.
  459: usage: (prog1 FIRST BODY...)  */)
  460:      (args)
  461:      Lisp_Object args;
  462: {
  463:   Lisp_Object val;
  464:   register Lisp_Object args_left;
  465:   struct gcpro gcpro1, gcpro2;
  466:   register int argnum = 0;
  467: 
  468:   if (NILP(args))
  469:     return Qnil;
  470: 
  471:   args_left = args;
  472:   val = Qnil;
  473:   GCPRO2 (args, val);
  474: 
  475:   do
  476:     {
  477:       if (!(argnum++))
  478:         val = Feval (Fcar (args_left));
  479:       else
  480:         Feval (Fcar (args_left));
  481:       args_left = Fcdr (args_left);
  482:     }
  483:   while (!NILP(args_left));
  484: 
  485:   UNGCPRO;
  486:   return val;
  487: }
  488: 
  489: DEFUN ("prog2", Fprog2, Sprog2, 2, UNEVALLED, 0,
  490:        doc: /* Eval FORM1, FORM2 and BODY sequentially; value from FORM2.
  491: The value of FORM2 is saved during the evaluation of the
  492: remaining args, whose values are discarded.
  493: usage: (prog2 FORM1 FORM2 BODY...)  */)
  494:      (args)
  495:      Lisp_Object args;
  496: {
  497:   Lisp_Object val;
  498:   register Lisp_Object args_left;
  499:   struct gcpro gcpro1, gcpro2;
  500:   register int argnum = -1;
  501: 
  502:   val = Qnil;
  503: 
  504:   if (NILP (args))
  505:     return Qnil;
  506: 
  507:   args_left = args;
  508:   val = Qnil;
  509:   GCPRO2 (args, val);
  510: 
  511:   do
  512:     {
  513:       if (!(argnum++))
  514:         val = Feval (Fcar (args_left));
  515:       else
  516:         Feval (Fcar (args_left));
  517:       args_left = Fcdr (args_left);
  518:     }
  519:   while (!NILP (args_left));
  520: 
  521:   UNGCPRO;
  522:   return val;
  523: }
  524: 
  525: DEFUN ("setq", Fsetq, Ssetq, 0, UNEVALLED, 0,
  526:        doc: /* Set each SYM to the value of its VAL.
  527: The symbols SYM are variables; they are literal (not evaluated).
  528: The values VAL are expressions; they are evaluated.
  529: Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
  530: The second VAL is not computed until after the first SYM is set, and so on;
  531: each VAL can use the new value of variables set earlier in the `setq'.
  532: The return value of the `setq' form is the value of the last VAL.
  533: usage: (setq SYM VAL SYM VAL ...)  */)
  534:      (args)
  535:      Lisp_Object args;
  536: {
  537:   register Lisp_Object args_left;
  538:   register Lisp_Object val, sym;
  539:   struct gcpro gcpro1;
  540: 
  541:   if (NILP(args))
  542:     return Qnil;
  543: 
  544:   args_left = args;
  545:   GCPRO1 (args);
  546: 
  547:   do
  548:     {
  549:       val = Feval (Fcar (Fcdr (args_left)));
  550:       sym = Fcar (args_left);
  551:       Fset (sym, val);
  552:       args_left = Fcdr (Fcdr (args_left));
  553:     }
  554:   while (!NILP(args_left));
  555: 
  556:   UNGCPRO;
  557:   return val;
  558: }
  559: 
  560: DEFUN ("quote", Fquote, Squote, 1, UNEVALLED, 0,
  561:        doc: /* Return the argument, without evaluating it.  `(quote x)' yields `x'.
  562: usage: (quote ARG)  */)
  563:      (args)
  564:      Lisp_Object args;
  565: {
  566:   return Fcar (args);
  567: }
  568: 
  569: DEFUN ("function", Ffunction, Sfunction, 1, UNEVALLED, 0,
  570:        doc: /* Like `quote', but preferred for objects which are functions.
  571: In byte compilation, `function' causes its argument to be compiled.
  572: `quote' cannot do that.
  573: usage: (function ARG)  */)
  574:      (args)
  575:      Lisp_Object args;
  576: {
  577:   return Fcar (args);
  578: }
  579: 
  580: 
  581: DEFUN ("interactive-p", Finteractive_p, Sinteractive_p, 0, 0, 0,
  582:        doc: /* Return t if the function was run directly by user input.
  583: This means that the function was called with `call-interactively'
  584: \(which includes being called as the binding of a key)
  585: and input is currently coming from the keyboard (not in keyboard macro),
  586: and Emacs is not running in batch mode (`noninteractive' is nil).
  587: 
  588: The only known proper use of `interactive-p' is in deciding whether to
  589: display a helpful message, or how to display it.  If you're thinking
  590: of using it for any other purpose, it is quite likely that you're
  591: making a mistake.  Think: what do you want to do when the command is
  592: called from a keyboard macro?
  593: 
  594: If you want to test whether your function was called with
  595: `call-interactively', the way to do that is by adding an extra
  596: optional argument, and making the `interactive' spec specify non-nil
  597: unconditionally for that argument.  (`p' is a good way to do this.)  */)
  598:      ()
  599: {
  600:   return (INTERACTIVE && interactive_p (1)) ? Qt : Qnil;
  601: }
  602: 
  603: 
  604: DEFUN ("called-interactively-p", Fcalled_interactively_p, Scalled_interactively_p, 0, 0, 0,
  605:        doc: /* Return t if the function using this was called with `call-interactively'.
  606: This is used for implementing advice and other function-modifying
  607: features of Emacs.
  608: 
  609: The cleanest way to test whether your function was called with
  610: `call-interactively' is by adding an extra optional argument,
  611: and making the `interactive' spec specify non-nil unconditionally
  612: for that argument.  (`p' is a good way to do this.)  */)
  613:      ()
  614: {
  615:   return interactive_p (1) ? Qt : Qnil;
  616: }
  617: 
  618: 
  619: /*  Return 1 if function in which this appears was called using
  620:     call-interactively.
  621: 
  622:     EXCLUDE_SUBRS_P non-zero means always return 0 if the function
  623:     called is a built-in.  */
  624: 
  625: int
  626: interactive_p (exclude_subrs_p)
  627:      int exclude_subrs_p;
  628: {
  629:   struct backtrace *btp;
  630:   Lisp_Object fun;
  631: 
  632:   btp = backtrace_list;
  633: 
  634:   /* If this isn't a byte-compiled function, there may be a frame at
  635:      the top for Finteractive_p.  If so, skip it.  */
  636:   fun = Findirect_function (*btp->function, Qnil);
  637:   if (SUBRP (fun) && (XSUBR (fun) == &Sinteractive_p
  638:                       || XSUBR (fun) == &Scalled_interactively_p))
  639:     btp = btp->next;
  640: 
  641:   /* If we're running an Emacs 18-style byte-compiled function, there
  642:      may be a frame for Fbytecode at the top level.  In any version of
  643:      Emacs there can be Fbytecode frames for subexpressions evaluated
  644:      inside catch and condition-case.  Skip past them.
  645: 
  646:      If this isn't a byte-compiled function, then we may now be
  647:      looking at several frames for special forms.  Skip past them.  */
  648:   while (btp
  649:          && (EQ (*btp->function, Qbytecode)
  650:              || btp->nargs == UNEVALLED))
  651:     btp = btp->next;
  652: 
  653:   /* btp now points at the frame of the innermost function that isn't
  654:      a special form, ignoring frames for Finteractive_p and/or
  655:      Fbytecode at th