/[emacs]/emacs/src/eval.c
ViewVC logotype

Diff of /emacs/src/eval.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.189.2.1 by miles, Wed Jun 12 01:50:05 2002 UTC revision 1.189.2.2 by miles, Fri Apr 4 06:20:58 2003 UTC
# Line 1  Line 1 
1  /* Evaluator for GNU Emacs Lisp interpreter.  /* Evaluator for GNU Emacs Lisp interpreter.
2     Copyright (C) 1985, 86, 87, 93, 94, 95, 99, 2000, 2001, 2002     Copyright (C) 1985, 86, 87, 93, 94, 95, 99, 2000, 2001, 2002, 2003
3       Free Software Foundation, Inc.       Free Software Foundation, Inc.
4    
5  This file is part of GNU Emacs.  This file is part of GNU Emacs.
# Line 77  struct catchtag Line 77  struct catchtag
77    int lisp_eval_depth;    int lisp_eval_depth;
78    int pdlcount;    int pdlcount;
79    int poll_suppress_count;    int poll_suppress_count;
80      int interrupt_input_blocked;
81    struct byte_stack *byte_stack;    struct byte_stack *byte_stack;
82  };  };
83    
# Line 87  struct catchtag *catchlist; Line 88  struct catchtag *catchlist;
88  int gcpro_level;  int gcpro_level;
89  #endif  #endif
90    
91  Lisp_Object Qautoload, Qmacro, Qexit, Qinteractive, Qcommandp, Qdefun;  Lisp_Object Qautoload, Qmacro, Qexit, Qinteractive, Qcommandp, Qdefun, Qdefvar;
92  Lisp_Object Qinhibit_quit, Vinhibit_quit, Vquit_flag;  Lisp_Object Qinhibit_quit, Vinhibit_quit, Vquit_flag;
93  Lisp_Object Qand_rest, Qand_optional;  Lisp_Object Qand_rest, Qand_optional;
94  Lisp_Object Qdebug_on_error;  Lisp_Object Qdebug_on_error;
# Line 242  call_debugger (arg) Line 243  call_debugger (arg)
243       Lisp_Object arg;       Lisp_Object arg;
244  {  {
245    int debug_while_redisplaying;    int debug_while_redisplaying;
246    int count = specpdl_ptr - specpdl;    int count = SPECPDL_INDEX ();
247    Lisp_Object val;    Lisp_Object val;
248      
249    if (lisp_eval_depth + 20 > max_lisp_eval_depth)    if (lisp_eval_depth + 20 > max_lisp_eval_depth)
250      max_lisp_eval_depth = lisp_eval_depth + 20;      max_lisp_eval_depth = lisp_eval_depth + 20;
251      
252    if (specpdl_size + 40 > max_specpdl_size)    if (specpdl_size + 40 > max_specpdl_size)
253      max_specpdl_size = specpdl_size + 40;      max_specpdl_size = specpdl_size + 40;
254      
255  #ifdef HAVE_X_WINDOWS  #ifdef HAVE_X_WINDOWS
256    if (display_hourglass_p)    if (display_hourglass_p)
257      cancel_hourglass ();      cancel_hourglass ();
# Line 271  call_debugger (arg) Line 272  call_debugger (arg)
272           redisplay, which necessarily leads to display problems.  */           redisplay, which necessarily leads to display problems.  */
273    specbind (Qinhibit_eval_during_redisplay, Qt);    specbind (Qinhibit_eval_during_redisplay, Qt);
274  #endif  #endif
275      
276    val = apply1 (Vdebugger, arg);    val = apply1 (Vdebugger, arg);
277    
278    /* Interrupting redisplay and resuming it later is not safe under    /* Interrupting redisplay and resuming it later is not safe under
# Line 553  usage: (setq SYM VAL SYM VAL ...)  */) Line 554  usage: (setq SYM VAL SYM VAL ...)  */)
554    UNGCPRO;    UNGCPRO;
555    return val;    return val;
556  }  }
557        
558  DEFUN ("quote", Fquote, Squote, 1, UNEVALLED, 0,  DEFUN ("quote", Fquote, Squote, 1, UNEVALLED, 0,
559         doc: /* Return the argument, without evaluating it.  `(quote x)' yields `x'.         doc: /* Return the argument, without evaluating it.  `(quote x)' yields `x'.
560  usage: (quote ARG)  */)  usage: (quote ARG)  */)
# Line 562  usage: (quote ARG)  */) Line 563  usage: (quote ARG)  */)
563  {  {
564    return Fcar (args);    return Fcar (args);
565  }  }
566        
567  DEFUN ("function", Ffunction, Sfunction, 1, UNEVALLED, 0,  DEFUN ("function", Ffunction, Sfunction, 1, UNEVALLED, 0,
568         doc: /* Like `quote', but preferred for objects which are functions.         doc: /* Like `quote', but preferred for objects which are functions.
569  In byte compilation, `function' causes its argument to be compiled.  In byte compilation, `function' causes its argument to be compiled.
# Line 624  interactive_p (exclude_subrs_p) Line 625  interactive_p (exclude_subrs_p)
625      btp = btp->next;      btp = btp->next;
626    
627    /* If we're running an Emacs 18-style byte-compiled function, there    /* If we're running an Emacs 18-style byte-compiled function, there
628       may be a frame for Fbytecode.  Now, given the strictest       may be a frame for Fbytecode at the top level.  In any version of
629       definition, this function isn't really being called       Emacs there can be Fbytecode frames for subexpressions evaluated
630       interactively, but because that's the way Emacs 18 always builds       inside catch and condition-case.  Skip past them.
      byte-compiled functions, we'll accept it for now.  */  
   if (EQ (*btp->function, Qbytecode))  
     btp = btp->next;  
631    
632    /* If this isn't a byte-compiled function, then we may now be       If this isn't a byte-compiled function, then we may now be
633       looking at several frames for special forms.  Skip past them.  */       looking at several frames for special forms.  Skip past them.  */
634    while (btp &&    while (btp
635           btp->nargs == UNEVALLED)           && (EQ (*btp->function, Qbytecode)
636                 || btp->nargs == UNEVALLED))
637      btp = btp->next;      btp = btp->next;
638    
639    /* btp now points at the frame of the innermost function that isn't    /* btp now points at the frame of the innermost function that isn't
# Line 644  interactive_p (exclude_subrs_p) Line 643  interactive_p (exclude_subrs_p)
643    fun = Findirect_function (*btp->function);    fun = Findirect_function (*btp->function);
644    if (exclude_subrs_p && SUBRP (fun))    if (exclude_subrs_p && SUBRP (fun))
645      return 0;      return 0;
646      
647    /* btp points to the frame of a Lisp function that called interactive-p.    /* btp points to the frame of a Lisp function that called interactive-p.
648       Return t if that function was called interactively.  */       Return t if that function was called interactively.  */
649    if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively))    if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively))
# Line 670  usage: (defun NAME ARGLIST [DOCSTRING] B Line 669  usage: (defun NAME ARGLIST [DOCSTRING] B
669      defn = Fcons (Qclosure, Fcons (Vinternal_interpreter_environment, defn));      defn = Fcons (Qclosure, Fcons (Vinternal_interpreter_environment, defn));
670    if (!NILP (Vpurify_flag))    if (!NILP (Vpurify_flag))
671      defn = Fpurecopy (defn);      defn = Fpurecopy (defn);
672      if (CONSP (XSYMBOL (fn_name)->function)
673          && EQ (XCAR (XSYMBOL (fn_name)->function), Qautoload))
674        LOADHIST_ATTACH (Fcons (Qt, fn_name));
675    Ffset (fn_name, defn);    Ffset (fn_name, defn);
676    LOADHIST_ATTACH (fn_name);    LOADHIST_ATTACH (fn_name);
677    return fn_name;    return fn_name;
# Line 677  usage: (defun NAME ARGLIST [DOCSTRING] B Line 679  usage: (defun NAME ARGLIST [DOCSTRING] B
679    
680  DEFUN ("defmacro", Fdefmacro, Sdefmacro, 2, UNEVALLED, 0,  DEFUN ("defmacro", Fdefmacro, Sdefmacro, 2, UNEVALLED, 0,
681         doc: /* Define NAME as a macro.         doc: /* Define NAME as a macro.
682  The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).  The actual definition looks like
683     (macro lambda ARGLIST [DOCSTRING] [DECL] BODY...).
684  When the macro is called, as in (NAME ARGS...),  When the macro is called, as in (NAME ARGS...),
685  the function (lambda ARGLIST BODY...) is applied to  the function (lambda ARGLIST BODY...) is applied to
686  the list ARGS... as it appears in the expression,  the list ARGS... as it appears in the expression,
687  and the result should be a form to be evaluated instead of the original.  and the result should be a form to be evaluated instead of the original.
688  usage: (defmacro NAME ARGLIST [DOCSTRING] BODY...)  */)  
689    DECL is a declaration, optional, which can specify how to indent
690    calls to this macro and how Edebug should handle it.  It looks like this:
691      (declare SPECS...)
692    The elements can look like this:
693      (indent INDENT)
694            Set NAME's `lisp-indent-function' property to INDENT.
695    
696      (edebug DEBUG)
697            Set NAME's `edebug-form-spec' property to DEBUG.  (This is
698            equivalent to writing a `def-edebug-spec' for the macro.)
699    usage: (defmacro NAME ARGLIST [DOCSTRING] [DECL] BODY...)  */)
700       (args)       (args)
701       Lisp_Object args;       Lisp_Object args;
702  {  {
# Line 711  usage: (defmacro NAME ARGLIST [DOCSTRING Line 725  usage: (defmacro NAME ARGLIST [DOCSTRING
725            call2 (Vmacro_declaration_function, fn_name, Fcar (tail));            call2 (Vmacro_declaration_function, fn_name, Fcar (tail));
726            UNGCPRO;            UNGCPRO;
727          }          }
728          
729        tail = Fcdr (tail);        tail = Fcdr (tail);
730      }      }
731    
# Line 727  usage: (defmacro NAME ARGLIST [DOCSTRING Line 741  usage: (defmacro NAME ARGLIST [DOCSTRING
741    
742    if (!NILP (Vpurify_flag))    if (!NILP (Vpurify_flag))
743      defn = Fpurecopy (defn);      defn = Fpurecopy (defn);
744      if (CONSP (XSYMBOL (fn_name)->function)
745          && EQ (XCAR (XSYMBOL (fn_name)->function), Qautoload))
746        LOADHIST_ATTACH (Fcons (Qt, fn_name));
747    Ffset (fn_name, defn);    Ffset (fn_name, defn);
748    LOADHIST_ATTACH (fn_name);    LOADHIST_ATTACH (fn_name);
749    return fn_name;    return fn_name;
750  }  }
751    
752    
753  DEFUN ("defvaralias", Fdefvaralias, Sdefvaralias, 2, 2, 0,  DEFUN ("defvaralias", Fdefvaralias, Sdefvaralias, 2, 3, 0,
754         doc: /* Make SYMBOL a variable alias for symbol ALIASED.         doc: /* Make SYMBOL a variable alias for symbol ALIASED.
755  Setting the value of SYMBOL will subsequently set the value of ALIASED,  Setting the value of SYMBOL will subsequently set the value of ALIASED,
756  and getting the value of SYMBOL will return the value ALIASED has.  and getting the value of SYMBOL will return the value ALIASED has.
757  ALIASED nil means remove the alias; SYMBOL is unbound after that.  */)  ALIASED nil means remove the alias; SYMBOL is unbound after that.
758       (symbol, aliased)  Third arg DOCSTRING, if non-nil, is documentation for SYMBOL.  */)
759       Lisp_Object symbol, aliased;       (symbol, aliased, docstring)
760         Lisp_Object symbol, aliased, docstring;
761  {  {
762    struct Lisp_Symbol *sym;    struct Lisp_Symbol *sym;
763      
764    CHECK_SYMBOL (symbol);    CHECK_SYMBOL (symbol);
765    CHECK_SYMBOL (aliased);    CHECK_SYMBOL (aliased);
766    
# Line 754  ALIASED nil means remove the alias; SYMB Line 772  ALIASED nil means remove the alias; SYMB
772    sym->declared_special = 1;    sym->declared_special = 1;
773    sym->value = aliased;    sym->value = aliased;
774    sym->constant = SYMBOL_CONSTANT_P (aliased);    sym->constant = SYMBOL_CONSTANT_P (aliased);
775    LOADHIST_ATTACH (symbol);    LOADHIST_ATTACH (Fcons (Qdefvar, symbol));
776        if (!NILP (docstring))
777        Fput (symbol, Qvariable_documentation, docstring);
778    
779    return aliased;    return aliased;
780  }  }
781    
# Line 798  usage: (defvar SYMBOL &optional INITVALU Line 818  usage: (defvar SYMBOL &optional INITVALU
818              tem = Fpurecopy (tem);              tem = Fpurecopy (tem);
819            Fput (sym, Qvariable_documentation, tem);            Fput (sym, Qvariable_documentation, tem);
820          }          }
821        LOADHIST_ATTACH (sym);        LOADHIST_ATTACH (Fcons (Qdefvar, sym));
822      }      }
823    else    else
824      /* A (defvar <var>) should not take precedence in the load-history over      /* Simple (defvar <var>) should not count as a definition at all.
825         an earlier (defvar <var> <val>), so only add to history if the default         It could get in the way of other definitions, and unloading this
826         value is still unbound.  */         package could try to make the variable unbound.  */
827      if (NILP (tem))      ;
       LOADHIST_ATTACH (sym);  
828            
829    if (SYMBOLP (sym))    if (SYMBOLP (sym))
830      XSYMBOL (sym)->declared_special = 1;      XSYMBOL (sym)->declared_special = 1;
# Line 842  usage: (defconst SYMBOL INITVALUE [DOCST Line 861  usage: (defconst SYMBOL INITVALUE [DOCST
861          tem = Fpurecopy (tem);          tem = Fpurecopy (tem);
862        Fput (sym, Qvariable_documentation, tem);        Fput (sym, Qvariable_documentation, tem);
863      }      }
864    LOADHIST_ATTACH (sym);    LOADHIST_ATTACH (Fcons (Qdefvar, sym));
865    return sym;    return sym;
866  }  }
867    
# Line 851  DEFUN ("user-variable-p", Fuser_variable Line 870  DEFUN ("user-variable-p", Fuser_variable
870  \(The alternative is a variable used internally in a Lisp program.)  \(The alternative is a variable used internally in a Lisp program.)
871  Determined by whether the first character of the documentation  Determined by whether the first character of the documentation
872  for the variable is `*' or if the variable is customizable (has a non-nil  for the variable is `*' or if the variable is customizable (has a non-nil
873  value of any of `custom-type', `custom-loads' or `standard-value'  value of `standard-value' or of `custom-autoload' on its property list).  */)
 on its property list).  */)  
874       (variable)       (variable)
875       Lisp_Object variable;       Lisp_Object variable;
876  {  {
877    Lisp_Object documentation;    Lisp_Object documentation;
878      
879    if (!SYMBOLP (variable))    if (!SYMBOLP (variable))
880        return Qnil;        return Qnil;
881    
# Line 865  on its property list).  */) Line 883  on its property list).  */)
883    if (INTEGERP (documentation) && XINT (documentation) < 0)    if (INTEGERP (documentation) && XINT (documentation) < 0)
884      return Qt;      return Qt;
885    if (STRINGP (documentation)    if (STRINGP (documentation)
886        && ((unsigned char) XSTRING (documentation)->data[0] == '*'))        && ((unsigned char) SREF (documentation, 0) == '*'))
887      return Qt;      return Qt;
888    /* If it is (STRING . INTEGER), a negative integer means a user variable.  */    /* If it is (STRING . INTEGER), a negative integer means a user variable.  */
889    if (CONSP (documentation)    if (CONSP (documentation)
# Line 873  on its property list).  */) Line 891  on its property list).  */)
891        && INTEGERP (XCDR (documentation))        && INTEGERP (XCDR (documentation))
892        && XINT (XCDR (documentation)) < 0)        && XINT (XCDR (documentation)) < 0)
893      return Qt;      return Qt;
894    /* Customizable?  */    /* Customizable?  See `custom-variable-p'. */
895    if ((!NILP (Fget (variable, intern ("custom-type"))))    if ((!NILP (Fget (variable, intern ("standard-value"))))
896        || (!NILP (Fget (variable, intern ("custom-loads"))))        || (!NILP (Fget (variable, intern ("custom-autoload")))))
       || (!NILP (Fget (variable, intern ("standard-value")))))  
897      return Qt;      return Qt;
898    return Qnil;    return Qnil;
899  }    }
900    
901  DEFUN ("let*", FletX, SletX, 1, UNEVALLED, 0,  DEFUN ("let*", FletX, SletX, 1, UNEVALLED, 0,
902         doc: /* Bind variables according to VARLIST then eval BODY.         doc: /* Bind variables according to VARLIST then eval BODY.
# Line 892  usage: (let* VARLIST BODY...)  */) Line 909  usage: (let* VARLIST BODY...)  */)
909       Lisp_Object args;       Lisp_Object args;
910  {  {
911    Lisp_Object varlist, var, val, elt, lexenv;    Lisp_Object varlist, var, val, elt, lexenv;
912    int count = specpdl_ptr - specpdl;    int count = SPECPDL_INDEX ();
913    struct gcpro gcpro1, gcpro2, gcpro3;    struct gcpro gcpro1, gcpro2, gcpro3;
914    
915    GCPRO3 (args, elt, varlist);    GCPRO3 (args, elt, varlist);
# Line 952  usage: (let VARLIST BODY...)  */) Line 969  usage: (let VARLIST BODY...)  */)
969  {  {
970    Lisp_Object *temps, tem, lexenv;    Lisp_Object *temps, tem, lexenv;
971    register Lisp_Object elt, varlist;    register Lisp_Object elt, varlist;
972    int count = specpdl_ptr - specpdl;    int count = SPECPDL_INDEX ();
973    register int argnum;    register int argnum;
974    struct gcpro gcpro1, gcpro2;    struct gcpro gcpro1, gcpro2;
975    
# Line 1156  internal_catch (tag, func, arg) Line 1173  internal_catch (tag, func, arg)
1173    c.backlist = backtrace_list;    c.backlist = backtrace_list;
1174    c.handlerlist = handlerlist;    c.handlerlist = handlerlist;
1175    c.lisp_eval_depth = lisp_eval_depth;    c.lisp_eval_depth = lisp_eval_depth;
1176    c.pdlcount = specpdl_ptr - specpdl;    c.pdlcount = SPECPDL_INDEX ();
1177    c.poll_suppress_count = poll_suppress_count;    c.poll_suppress_count = poll_suppress_count;
1178      c.interrupt_input_blocked = interrupt_input_blocked;
1179    c.gcpro = gcprolist;    c.gcpro = gcprolist;
1180    c.byte_stack = byte_stack_list;    c.byte_stack = byte_stack_list;
1181    catchlist = &c;    catchlist = &c;
# Line 1199  unwind_to_catch (catch, value) Line 1217  unwind_to_catch (catch, value)
1217    
1218    /* Restore the polling-suppression count.  */    /* Restore the polling-suppression count.  */
1219    set_poll_suppress_count (catch->poll_suppress_count);    set_poll_suppress_count (catch->poll_suppress_count);
1220      interrupt_input_blocked = catch->interrupt_input_blocked;
1221    
1222    do    do
1223      {      {
# Line 1222  unwind_to_catch (catch, value) Line 1241  unwind_to_catch (catch, value)
1241  #endif  #endif
1242    backtrace_list = catch->backlist;    backtrace_list = catch->backlist;
1243    lisp_eval_depth = catch->lisp_eval_depth;    lisp_eval_depth = catch->lisp_eval_depth;
1244      
1245    _longjmp (catch->jmp, 1);    _longjmp (catch->jmp, 1);
1246  }  }
1247    
# Line 1257  usage: (unwind-protect BODYFORM UNWINDFO Line 1276  usage: (unwind-protect BODYFORM UNWINDFO
1276       Lisp_Object args;       Lisp_Object args;
1277  {  {
1278    Lisp_Object val;    Lisp_Object val;
1279    int count = specpdl_ptr - specpdl;    int count = SPECPDL_INDEX ();
1280    
1281    record_unwind_protect (0, Fcdr (args));    record_unwind_protect (0, Fcdr (args));
1282    val = Feval (Fcar (args));    val = Feval (Fcar (args));
1283    return unbind_to (count, val);      return unbind_to (count, val);
1284  }  }
1285    
1286  /* Chain of condition handlers currently in effect.  /* Chain of condition handlers currently in effect.
# Line 1323  usage: (condition-case VAR BODYFORM HAND Line 1342  usage: (condition-case VAR BODYFORM HAND
1342    c.backlist = backtrace_list;    c.backlist = backtrace_list;
1343    c.handlerlist = handlerlist;    c.handlerlist = handlerlist;
1344    c.lisp_eval_depth = lisp_eval_depth;    c.lisp_eval_depth = lisp_eval_depth;
1345    c.pdlcount = specpdl_ptr - specpdl;    c.pdlcount = SPECPDL_INDEX ();
1346    c.poll_suppress_count = poll_suppress_count;    c.poll_suppress_count = poll_suppress_count;
1347      c.interrupt_input_blocked = interrupt_input_blocked;
1348    c.gcpro = gcprolist;    c.gcpro = gcprolist;
1349    c.byte_stack = byte_stack_list;    c.byte_stack = byte_stack_list;
1350    if (_setjmp (c.jmp))    if (_setjmp (c.jmp))
# Line 1341  usage: (condition-case VAR BODYFORM HAND Line 1361  usage: (condition-case VAR BODYFORM HAND
1361      }      }
1362    c.next = catchlist;    c.next = catchlist;
1363    catchlist = &c;    catchlist = &c;
1364      
1365    h.var = var;    h.var = var;
1366    h.handler = handlers;    h.handler = handlers;
1367    h.next = handlerlist;    h.next = handlerlist;
# Line 1374  internal_condition_case (bfun, handlers, Line 1394  internal_condition_case (bfun, handlers,
1394    struct catchtag c;    struct catchtag c;
1395    struct handler h;    struct handler h;
1396    
1397  #if 0 /* Can't do this check anymore because realize_basic_faces has  #if 0 /* We now handle interrupt_input_blocked properly.
1398           to BLOCK_INPUT, and can call Lisp.  What's really needed is a           What we still do not handle is exiting a signal handler.  */
          flag indicating that we're currently handling a signal.  */  
   /* Since Fsignal resets this to 0, it had better be 0 now  
      or else we have a potential bug.  */  
   if (interrupt_input_blocked != 0)  
1399      abort ();      abort ();
1400  #endif  #endif
1401    
# Line 1388  internal_condition_case (bfun, handlers, Line 1404  internal_condition_case (bfun, handlers,
1404    c.backlist = backtrace_list;    c.backlist = backtrace_list;
1405    c.handlerlist = handlerlist;    c.handlerlist = handlerlist;
1406    c.lisp_eval_depth = lisp_eval_depth;    c.lisp_eval_depth = lisp_eval_depth;
1407    c.pdlcount = specpdl_ptr - specpdl;    c.pdlcount = SPECPDL_INDEX ();
1408    c.poll_suppress_count = poll_suppress_count;    c.poll_suppress_count = poll_suppress_count;
1409      c.interrupt_input_blocked = interrupt_input_blocked;
1410    c.gcpro = gcprolist;    c.gcpro = gcprolist;
1411    c.byte_stack = byte_stack_list;    c.byte_stack = byte_stack_list;
1412    if (_setjmp (c.jmp))    if (_setjmp (c.jmp))
# Line 1410  internal_condition_case (bfun, handlers, Line 1427  internal_condition_case (bfun, handlers,
1427    return val;    return val;
1428  }  }
1429    
1430  /* Like internal_condition_case but call HFUN with ARG as its argument.  */  /* Like internal_condition_case but call BFUN with ARG as its argument.  */
1431    
1432  Lisp_Object  Lisp_Object
1433  internal_condition_case_1 (bfun, arg, handlers, hfun)  internal_condition_case_1 (bfun, arg, handlers, hfun)
# Line 1428  internal_condition_case_1 (bfun, arg, ha Line 1445  internal_condition_case_1 (bfun, arg, ha
1445    c.backlist = backtrace_list;    c.backlist = backtrace_list;
1446    c.handlerlist = handlerlist;    c.handlerlist = handlerlist;
1447    c.lisp_eval_depth = lisp_eval_depth;    c.lisp_eval_depth = lisp_eval_depth;
1448    c.pdlcount = specpdl_ptr - specpdl;    c.pdlcount = SPECPDL_INDEX ();
1449    c.poll_suppress_count = poll_suppress_count;    c.poll_suppress_count = poll_suppress_count;
1450      c.interrupt_input_blocked = interrupt_input_blocked;
1451    c.gcpro = gcprolist;    c.gcpro = gcprolist;
1452    c.byte_stack = byte_stack_list;    c.byte_stack = byte_stack_list;
1453    if (_setjmp (c.jmp))    if (_setjmp (c.jmp))
# Line 1451  internal_condition_case_1 (bfun, arg, ha Line 1469  internal_condition_case_1 (bfun, arg, ha
1469  }  }
1470    
1471    
1472  /* Like internal_condition_case but call HFUN with NARGS as first,  /* Like internal_condition_case but call BFUN with NARGS as first,
1473     and ARGS as second argument.  */     and ARGS as second argument.  */
1474    
1475  Lisp_Object  Lisp_Object
# Line 1471  internal_condition_case_2 (bfun, nargs, Line 1489  internal_condition_case_2 (bfun, nargs,
1489    c.backlist = backtrace_list;    c.backlist = backtrace_list;
1490    c.handlerlist = handlerlist;    c.handlerlist = handlerlist;
1491    c.lisp_eval_depth = lisp_eval_depth;    c.lisp_eval_depth = lisp_eval_depth;
1492    c.pdlcount = specpdl_ptr - specpdl;    c.pdlcount = SPECPDL_INDEX ();
1493    c.poll_suppress_count = poll_suppress_count;    c.poll_suppress_count = poll_suppress_count;
1494      c.interrupt_input_blocked = interrupt_input_blocked;
1495    c.gcpro = gcprolist;    c.gcpro = gcprolist;
1496    c.byte_stack = byte_stack_list;    c.byte_stack = byte_stack_list;
1497    if (_setjmp (c.jmp))    if (_setjmp (c.jmp))
# Line 1514  See also the function `condition-case'. Line 1533  See also the function `condition-case'.
1533       Lisp_Object error_symbol, data;       Lisp_Object error_symbol, data;
1534  {  {
1535    /* When memory is full, ERROR-SYMBOL is nil,    /* When memory is full, ERROR-SYMBOL is nil,
1536       and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).  */       and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
1537         That is a special case--don't do this in other situations.  */
1538    register struct handler *allhandlers = handlerlist;    register struct handler *allhandlers = handlerlist;
1539    Lisp_Object conditions;    Lisp_Object conditions;
1540    extern int gc_in_progress;    extern int gc_in_progress;
# Line 1528  See also the function `condition-case'. Line 1548  See also the function `condition-case'.
1548    if (gc_in_progress || waiting_for_input)    if (gc_in_progress || waiting_for_input)
1549      abort ();      abort ();
1550    
   TOTALLY_UNBLOCK_INPUT;  
   
1551    if (NILP (error_symbol))    if (NILP (error_symbol))
1552      real_error_symbol = Fcar (data);      real_error_symbol = Fcar (data);
1553    else    else
1554      real_error_symbol = error_symbol;      real_error_symbol = error_symbol;
1555    
1556    #if 0 /* rms: I don't know why this was here,
1557             but it is surely wrong for an error that is handled.  */
1558  #ifdef HAVE_X_WINDOWS  #ifdef HAVE_X_WINDOWS
1559    if (display_hourglass_p)    if (display_hourglass_p)
1560      cancel_hourglass ();      cancel_hourglass ();
1561  #endif  #endif
1562    #endif
1563    
1564    /* This hook is used by edebug.  */    /* This hook is used by edebug.  */
1565    if (! NILP (Vsignal_hook_function))    if (! NILP (Vsignal_hook_function)
1566          && ! NILP (error_symbol))
1567      call2 (Vsignal_hook_function, error_symbol, data);      call2 (Vsignal_hook_function, error_symbol, data);
1568    
1569    conditions = Fget (real_error_symbol, Qerror_conditions);    conditions = Fget (real_error_symbol, Qerror_conditions);
1570    
1571    /* Remember from where signal was called.  Skip over the frame for    /* Remember from where signal was called.  Skip over the frame for
1572       `signal' itself.  If a frame for `error' follows, skip that,       `signal' itself.  If a frame for `error' follows, skip that,
1573       too.  */       too.  Don't do this when ERROR_SYMBOL is nil, because that
1574         is a memory-full error.  */
1575    Vsignaling_function = Qnil;    Vsignaling_function = Qnil;
1576    if (backtrace_list)    if (backtrace_list && !NILP (error_symbol))
1577      {      {
1578        bp = backtrace_list->next;        bp = backtrace_list->next;
1579        if (bp && bp->function && EQ (*bp->function, Qerror))        if (bp && bp->function && EQ (*bp->function, Qerror))
# Line 1562  See also the function `condition-case'. Line 1585  See also the function `condition-case'.
1585    for (; handlerlist; handlerlist = handlerlist->next)    for (; handlerlist; handlerlist = handlerlist->next)
1586      {      {
1587        register Lisp_Object clause;        register Lisp_Object clause;
1588          
1589        if (lisp_eval_depth + 20 > max_lisp_eval_depth)        if (lisp_eval_depth + 20 > max_lisp_eval_depth)
1590          max_lisp_eval_depth = lisp_eval_depth + 20;          max_lisp_eval_depth = lisp_eval_depth + 20;
1591      
1592        if (specpdl_size + 40 > max_specpdl_size)        if (specpdl_size + 40 > max_specpdl_size)
1593          max_specpdl_size = specpdl_size + 40;          max_specpdl_size = specpdl_size + 40;
1594      
1595        clause = find_handler_clause (handlerlist->handler, conditions,        clause = find_handler_clause (handlerlist->handler, conditions,
1596                                      error_symbol, data, &debugger_value);                                      error_symbol, data, &debugger_value);
1597    
 #if 0 /* Most callers are not prepared to handle gc if this returns.  
          So, since this feature is not very useful, take it out.  */  
       /* If have called debugger and user wants to continue,  
          just return nil.  */  
       if (EQ (clause, Qlambda))  
         return debugger_value;  
 #else  
1598        if (EQ (clause, Qlambda))        if (EQ (clause, Qlambda))
1599          {          {
1600            /* We can't return values to code which signaled an error, but we            /* We can't return values to code which signaled an error, but we
# Line 1588  See also the function `condition-case'. Line 1604  See also the function `condition-case'.
1604            else            else
1605              error ("Cannot return from the debugger in an error");              error ("Cannot return from the debugger in an error");
1606          }          }
 #endif  
1607    
1608        if (!NILP (clause))        if (!NILP (clause))
1609          {          {
# Line 1617  See also the function `condition-case'. Line 1632  See also the function `condition-case'.
1632      data = Fcons (error_symbol, data);      data = Fcons (error_symbol, data);
1633    
1634    string = Ferror_message_string (data);    string = Ferror_message_string (data);
1635    fatal ("%s", XSTRING (string)->data, 0);    fatal ("%s", SDATA (string), 0);
1636  }  }
1637    
1638  /* Return nonzero iff LIST is a non-nil atom or  /* Return nonzero iff LIST is a non-nil atom or
# Line 1666  skip_debugger (conditions, data) Line 1681  skip_debugger (conditions, data)
1681                error_message = Ferror_message_string (data);                error_message = Ferror_message_string (data);
1682                first_string = 0;                first_string = 0;
1683              }              }
1684              
1685            if (fast_string_match (XCAR (tail), error_message) >= 0)            if (fast_string_match (XCAR (tail), error_message) >= 0)
1686              return 1;              return 1;
1687          }          }
# Line 1707  find_handler_clause (handlers, condition Line 1722  find_handler_clause (handlers, condition
1722        || !NILP (Vdebug_on_signal)) /* This says call debugger even if        || !NILP (Vdebug_on_signal)) /* This says call debugger even if
1723                                        there is a handler.  */                                        there is a handler.  */
1724      {      {
1725        int count = specpdl_ptr - specpdl;        int count = SPECPDL_INDEX ();
1726        int debugger_called = 0;        int debugger_called = 0;
1727        Lisp_Object sig_symbol, combined_data;        Lisp_Object sig_symbol, combined_data;
1728        /* This is set to 1 if we are handling a memory-full error,        /* This is set to 1 if we are handling a memory-full error,
# Line 1975  void Line 1990  void
1990  do_autoload (fundef, funname)  do_autoload (fundef, funname)
1991       Lisp_Object fundef, funname;       Lisp_Object fundef, funname;
1992  {  {
1993    int count = specpdl_ptr - specpdl;    int count = SPECPDL_INDEX ();
1994    Lisp_Object fun, queue, first, second;    Lisp_Object fun, queue, first, second;
1995    struct gcpro gcpro1, gcpro2, gcpro3;    struct gcpro gcpro1, gcpro2, gcpro3;
1996    
# Line 1983  do_autoload (fundef, funname) Line 1998  do_autoload (fundef, funname)
1998       of what files are preloaded and when.  */       of what files are preloaded and when.  */
1999    if (! NILP (Vpurify_flag))    if (! NILP (Vpurify_flag))
2000      error ("Attempt to autoload %s while preparing to dump",      error ("Attempt to autoload %s while preparing to dump",
2001             XSTRING (SYMBOL_NAME (funname))->data);             SDATA (SYMBOL_NAME (funname)));
2002    
2003    fun = funname;    fun = funname;
2004    CHECK_SYMBOL (funname);    CHECK_SYMBOL (funname);
# Line 1991  do_autoload (fundef, funname) Line 2006  do_autoload (fundef, funname)
2006    
2007    /* Preserve the match data.  */    /* Preserve the match data.  */
2008    record_unwind_protect (Fset_match_data, Fmatch_data (Qnil, Qnil));    record_unwind_protect (Fset_match_data, Fmatch_data (Qnil, Qnil));
2009      
2010    /* Value saved here is to be restored into Vautoload_queue.  */    /* Value saved here is to be restored into Vautoload_queue.  */
2011    record_unwind_protect (un_autoload, Vautoload_queue);    record_unwind_protect (un_autoload, Vautoload_queue);
2012    Vautoload_queue = Qt;    Vautoload_queue = Qt;
# Line 2022  do_autoload (fundef, funname) Line 2037  do_autoload (fundef, funname)
2037    
2038    if (!NILP (Fequal (fun, fundef)))    if (!NILP (Fequal (fun, fundef)))
2039      error ("Autoloading failed to define function %s",      error ("Autoloading failed to define function %s",
2040             XSTRING (SYMBOL_NAME (funname))->data);             SDATA (SYMBOL_NAME (funname)));
2041    UNGCPRO;    UNGCPRO;
2042  }  }
2043    
# Line 2039  DEFUN ("eval", Feval, Seval, 1, 1, 0, Line 2054  DEFUN ("eval", Feval, Seval, 1, 1, 0,
2054    
2055    if (handling_signal)    if (handling_signal)
2056      abort ();      abort ();
2057      
2058    if (SYMBOLP (form))    if (SYMBOLP (form))
2059      {      {
2060        if (!NILP (Vinternal_interpreter_environment)        if (!NILP (Vinternal_interpreter_environment)
# Line 2240  DEFUN ("eval", Feval, Seval, 1, 1, 0, Line 2255  DEFUN ("eval", Feval, Seval, 1, 1, 0,
2255    if (backtrace.debug_on_exit)    if (backtrace.debug_on_exit)
2256      val = call_debugger (Fcons (Qexit, Fcons (val, Qnil)));      val = call_debugger (Fcons (Qexit, Fcons (val, Qnil)));
2257    backtrace_list = backtrace.next;    backtrace_list = backtrace.next;
2258    
2259    #ifdef HAVE_CARBON
2260      mac_check_for_quit_char();
2261    #endif
2262    return val;    return val;
2263  }  }
2264    
# Line 2262  usage: (apply FUNCTION &rest ARGUMENTS) Line 2281  usage: (apply FUNCTION &rest ARGUMENTS)
2281    funcall_args = 0;    funcall_args = 0;
2282    spread_arg = args [nargs - 1];    spread_arg = args [nargs - 1];
2283    CHECK_LIST (spread_arg);    CHECK_LIST (spread_arg);
2284      
2285    numargs = XINT (Flength (spread_arg));    numargs = XINT (Flength (spread_arg));
2286    
2287    if (numargs == 0)    if (numargs == 0)
# Line 2357  usage: (run-hooks &rest HOOKS)  */) Line 2376  usage: (run-hooks &rest HOOKS)  */)
2376    
2377    return Qnil;    return Qnil;
2378  }  }
2379          
2380  DEFUN ("run-hook-with-args", Frun_hook_with_args,  DEFUN ("run-hook-with-args", Frun_hook_with_args,
2381         Srun_hook_with_args, 1, MANY, 0,         Srun_hook_with_args, 1, MANY, 0,
2382         doc: /* Run HOOK with the specified arguments ARGS.         doc: /* Run HOOK with the specified arguments ARGS.
# Line 2600  call1 (fn, arg1) Line 2619  call1 (fn, arg1)
2619  {  {
2620    struct gcpro gcpro1;    struct gcpro gcpro1;
2621  #ifdef NO_ARG_ARRAY  #ifdef NO_ARG_ARRAY
2622    Lisp_Object args[2];      Lisp_Object args[2];
2623    
2624    args[0] = fn;    args[0] = fn;
2625    args[1] = arg1;    args[1] = arg1;
# Line 2897  usage: (funcall FUNCTION &rest ARGUMENTS Line 2916  usage: (funcall FUNCTION &rest ARGUMENTS
2916          default:          default:
2917    
2918            /* If a subr takes more than 8 arguments without using MANY            /* If a subr takes more than 8 arguments without using MANY
2919               or UNEVALLED, we need to extend this function to support it.               or UNEVALLED, we need to extend this function to support it.
2920               Until this is done, there is no way to call the function.  */               Until this is done, there is no way to call the function.  */
2921            abort ();            abort ();
2922          }          }
# Line 3009  funcall_lambda (fun, nargs, arg_vector, Line 3028  funcall_lambda (fun, nargs, arg_vector,
3028       Lisp_Object lexenv;       Lisp_Object lexenv;
3029  {  {
3030    Lisp_Object val, syms_left, next;    Lisp_Object val, syms_left, next;
3031    int count = specpdl_ptr - specpdl;    int count = SPECPDL_INDEX ();
3032    int i, optional, rest;    int i, optional, rest;
3033    
3034    if (COMPILEDP (fun)    if (COMPILEDP (fun)
# Line 3052  funcall_lambda (fun, nargs, arg_vector, Line 3071  funcall_lambda (fun, nargs, arg_vector,
3071    for (; CONSP (syms_left); syms_left = XCDR (syms_left))    for (; CONSP (syms_left); syms_left = XCDR (syms_left))
3072      {      {
3073        QUIT;        QUIT;
3074          
3075        next = XCAR (syms_left);        next = XCAR (syms_left);
3076        while (!SYMBOLP (next))        while (!SYMBOLP (next))
3077          next = Fsignal (Qinvalid_function, Fcons (fun, Qnil));          next = Fsignal (Qinvalid_function, Fcons (fun, Qnil));
3078          
3079        if (EQ (next, Qand_rest))        if (EQ (next, Qand_rest))
3080          rest = 1;          rest = 1;
3081        else if (EQ (next, Qand_optional))        else if (EQ (next, Qand_optional))
# Line 3113  funcall_lambda (fun, nargs, arg_vector, Line 3132  funcall_lambda (fun, nargs, arg_vector,
3132                              AREF (fun, COMPILED_STACK_DEPTH),                              AREF (fun, COMPILED_STACK_DEPTH),
3133                              Qnil, 0, 0);                              Qnil, 0, 0);
3134      }      }
3135      
3136    return unbind_to (count, val);    return unbind_to (count, val);
3137  }  }
3138    
# Line 3132  DEFUN ("fetch-bytecode", Ffetch_bytecode Line 3151  DEFUN ("fetch-bytecode", Ffetch_bytecode
3151          {          {
3152            tem = AREF (object, COMPILED_BYTECODE);            tem = AREF (object, COMPILED_BYTECODE);
3153            if (CONSP (tem) && STRINGP (XCAR (tem)))            if (CONSP (tem) && STRINGP (XCAR (tem)))
3154              error ("Invalid byte code in %s", XSTRING (XCAR (tem))->data);              error ("Invalid byte code in %s", SDATA (XCAR (tem)));
3155            else            else
3156              error ("Invalid byte code");              error ("Invalid byte code");
3157          }          }
# Line 3145  DEFUN ("fetch-bytecode", Ffetch_bytecode Line 3164  DEFUN ("fetch-bytecode", Ffetch_bytecode
3164  void  void
3165  grow_specpdl ()  grow_specpdl ()
3166  {  {
3167    register int count = specpdl_ptr - specpdl;    register int count = SPECPDL_INDEX ();
3168    if (specpdl_size >= max_specpdl_size)    if (specpdl_size >= max_specpdl_size)
3169      {      {
3170        if (max_specpdl_size < 400)        if (max_specpdl_size < 400)
# Line 3191  specbind (symbol, value) Line 3210  specbind (symbol, value)
3210    else    else
3211      {      {
3212        Lisp_Object valcontents;        Lisp_Object valcontents;
3213          
3214        ovalue = find_symbol_value (symbol);        ovalue = find_symbol_value (symbol);
3215        specpdl_ptr->func = 0;        specpdl_ptr->func = 0;
3216        specpdl_ptr->old_value = ovalue;        specpdl_ptr->old_value = ovalue;
# Line 3205  specbind (symbol, value) Line 3224  specbind (symbol, value)
3224            Lisp_Object where, current_buffer;            Lisp_Object where, current_buffer;
3225    
3226            current_buffer = Fcurrent_buffer ();            current_buffer = Fcurrent_buffer ();
3227              
3228            /* For a local variable, record both the symbol and which            /* For a local variable, record both the symbol and which
3229               buffer's or frame's value we are saving.  */               buffer's or frame's value we are saving.  */
3230            if (!NILP (Flocal_variable_p (symbol, Qnil)))            if (!NILP (Flocal_variable_p (symbol, Qnil)))
# Line 3297  unbind_to (count, value) Line 3316  unbind_to (count, value)
3316              Fset_default (symbol, specpdl_ptr->old_value);              Fset_default (symbol, specpdl_ptr->old_value);
3317            else if (BUFFERP (where))            else if (BUFFERP (where))
3318              set_internal (symbol, specpdl_ptr->old_value, XBUFFER (where), 1);              set_internal (symbol, specpdl_ptr->old_value, XBUFFER (where), 1);
3319            else            else
3320              set_internal (symbol, specpdl_ptr->old_value, NULL, 1);              set_internal (symbol, specpdl_ptr->old_value, NULL, 1);
3321          }          }
3322        else        else
# Line 3311  unbind_to (count, value) Line 3330  unbind_to (count, value)
3330              set_internal (specpdl_ptr->symbol, specpdl_ptr->old_value, 0, 1);              set_internal (specpdl_ptr->symbol, specpdl_ptr->old_value, 0, 1);
3331          }          }
3332      }      }
3333      
3334    if (NILP (Vquit_flag) && quitf)    if (NILP (Vquit_flag) && quitf)
3335      Vquit_flag = Qt;      Vquit_flag = Qt;
3336    
# Line 3509  before making `inhibit-quit' nil.  */); Line 3528  before making `inhibit-quit' nil.  */);
3528    
3529    Qdeclare = intern ("declare");    Qdeclare = intern ("declare");
3530    staticpro (&Qdeclare);    staticpro (&Qdeclare);
3531      
3532    /* Note that the process handling also uses Qexit, but we don't want    /* Note that the process handling also uses Qexit, but we don't want
3533       to staticpro it twice, so we just do it here.  */       to staticpro it twice, so we just do it here.  */
3534    Qexit = intern ("exit");    Qexit = intern ("exit");
# Line 3524  before making `inhibit-quit' nil.  */); Line 3543  before making `inhibit-quit' nil.  */);
3543    Qdefun = intern ("defun");    Qdefun = intern ("defun");
3544    staticpro (&Qdefun);    staticpro (&Qdefun);
3545    
3546      Qdefvar = intern ("defvar");
3547      staticpro (&Qdefvar);
3548    
3549    Qand_rest = intern ("&rest");    Qand_rest = intern ("&rest");
3550    staticpro (&Qand_rest);    staticpro (&Qand_rest);
3551    

Legend:
Removed from v.1.189.2.1  
changed lines
  Added in v.1.189.2.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26