/[guile]/guile/guile-core/libguile/eval.c
ViewVC logotype

Diff of /guile/guile-core/libguile/eval.c

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

revision 1.255 by dirk, Fri Mar 1 00:19:20 2002 UTC revision 1.256 by dirk, Sat Mar 2 09:53:51 2002 UTC
# Line 1571  scm_unmemocopy (SCM x, SCM env) Line 1571  scm_unmemocopy (SCM x, SCM env)
1571  int  int
1572  scm_badargsp (SCM formals, SCM args)  scm_badargsp (SCM formals, SCM args)
1573  {  {
1574    while (SCM_NIMP (formals))    while (!SCM_NULLP (formals))
1575      {      {
1576        if (!SCM_CONSP (formals))        if (!SCM_CONSP (formals))
1577          return 0;          return 0;
1578        if (SCM_IMP(args))        if (SCM_NULLP (args))
1579          return 1;          return 1;
1580        formals = SCM_CDR (formals);        formals = SCM_CDR (formals);
1581        args = SCM_CDR (args);        args = SCM_CDR (args);
# Line 1845  deval_args (SCM l, SCM env, SCM proc, SC Line 1845  deval_args (SCM l, SCM env, SCM proc, SC
1845        env = scm_top_level_env (p); \        env = scm_top_level_env (p); \
1846    } while (0)    } while (0)
1847    
 #ifndef DEVAL  
 #define CHECK_EQVISH(A,B)       (SCM_EQ_P ((A), (B)) || (!SCM_FALSEP (scm_eqv_p ((A), (B)))))  
 #endif /* DEVAL */  
1848    
1849  /* This is the evaluator.  Like any real monster, it has three heads:  /* This is the evaluator.  Like any real monster, it has three heads:
1850   *   *
# Line 1926  SCM_CEVAL (SCM x, SCM env) Line 1923  SCM_CEVAL (SCM x, SCM env)
1923        scm_report_stack_overflow ();        scm_report_stack_overflow ();
1924      }      }
1925  #endif  #endif
1926    
1927  #ifdef DEVAL  #ifdef DEVAL
1928    goto start;    goto start;
1929  #endif  #endif
1930    
1931  loopnoap:  loopnoap:
1932    PREP_APPLY (SCM_UNDEFINED, SCM_EOL);    PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
1933  loop:  loop:
# Line 1951  loop: Line 1950  loop:
1950        SCM_SET_OVERFLOW (debug);        SCM_SET_OVERFLOW (debug);
1951        debug.info -= 2;        debug.info -= 2;
1952      }      }
1953    
1954  start:  start:
1955    debug.info->e.exp = x;    debug.info->e.exp = x;
1956    debug.info->e.env = env;    debug.info->e.env = env;
# Line 1999  dispatch: Line 1999  dispatch:
1999        x = scm_cons (x, SCM_UNDEFINED);        x = scm_cons (x, SCM_UNDEFINED);
2000        RETURN (*scm_lookupcar (x, env, 1));        RETURN (*scm_lookupcar (x, env, 1));
2001    
2002      case SCM_BIT8(SCM_IM_AND):      case SCM_BIT8 (SCM_IM_AND):
2003        x = SCM_CDR (x);        x = SCM_CDR (x);
2004        while (!SCM_NULLP (SCM_CDR (x)))        while (!SCM_NULLP (SCM_CDR (x)))
2005          {          {
2006            if (SCM_FALSEP (t.arg1 = EVALCAR (x, env)) || SCM_NILP (t.arg1))            SCM condition = EVALCAR (x, env);
2007              if (SCM_FALSEP (condition) || SCM_NILP (condition))
2008              RETURN (SCM_BOOL_F);              RETURN (SCM_BOOL_F);
2009            else            else
2010              x = SCM_CDR (x);              x = SCM_CDR (x);
# Line 2011  dispatch: Line 2012  dispatch:
2012        PREP_APPLY (SCM_UNDEFINED, SCM_EOL);        PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
2013        goto carloop;        goto carloop;
2014    
2015      case SCM_BIT8(SCM_IM_BEGIN):      case SCM_BIT8 (SCM_IM_BEGIN):
2016        if (SCM_NULLP (SCM_CDR (x)))        if (SCM_NULLP (SCM_CDR (x)))
2017          RETURN (SCM_UNSPECIFIED);          RETURN (SCM_UNSPECIFIED);
2018    
# Line 2046  dispatch: Line 2047  dispatch:
2047      nontoplevel_begin:      nontoplevel_begin:
2048        while (!SCM_NULLP (SCM_CDR (x)))        while (!SCM_NULLP (SCM_CDR (x)))
2049          {          {
2050            if (SCM_IMP (SCM_CAR (x)))            SCM form = SCM_CAR (x);
2051              if (SCM_IMP (form))
2052              {              {
2053                if (SCM_ISYMP (SCM_CAR (x)))                if (SCM_ISYMP (form))
2054                  {                  {
2055                    x = scm_m_expand_body (x, env);                    x = scm_m_expand_body (x, env);
2056                    goto nontoplevel_begin;                    goto nontoplevel_begin;
2057                  }                  }
2058                else                else
2059                  SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (x));                  SCM_VALIDATE_NON_EMPTY_COMBINATION (form);
2060              }              }
2061            else            else
2062              SCM_CEVAL (SCM_CAR (x), env);              SCM_CEVAL (form, env);
2063            x = SCM_CDR (x);            x = SCM_CDR (x);
2064          }          }
2065                
2066      carloop:                    /* scm_eval car of last form in list */      carloop:
2067        if (SCM_IMP (SCM_CAR (x)))        {
2068          {          /* scm_eval last form in list */
2069            x = SCM_CAR (x);          SCM last_form = SCM_CAR (x);
           RETURN (SCM_EVALIM (x, env));  
         }  
   
       if (SCM_SYMBOLP (SCM_CAR (x)))  
         RETURN (*scm_lookupcar (x, env, 1));  
2070    
2071        x = SCM_CAR (x);          if (SCM_CONSP (last_form))
2072        goto loop;                /* tail recurse */            {
2073                /* This is by far the most frequent case. */
2074                x = last_form;
2075                goto loop;          /* tail recurse */
2076              }
2077            else if (SCM_IMP (last_form))
2078              RETURN (SCM_EVALIM (last_form, env));
2079            else if (SCM_VARIABLEP (last_form))
2080              RETURN (SCM_VARIABLE_REF (last_form));
2081            else if (SCM_SYMBOLP (last_form))
2082              RETURN (*scm_lookupcar (x, env, 1));
2083            else
2084              RETURN (last_form);
2085          }
2086    
2087    
2088      case SCM_BIT8(SCM_IM_CASE):      case SCM_BIT8(SCM_IM_CASE):
2089        x = SCM_CDR (x);        x = SCM_CDR (x);
2090        t.arg1 = EVALCAR (x, env);        {
2091        while (SCM_NIMP (x = SCM_CDR (x)))          SCM key = EVALCAR (x, env);
2092          {          x = SCM_CDR (x);
2093            proc = SCM_CAR (x);          while (!SCM_NULLP (x))
2094            if (SCM_EQ_P (scm_sym_else, SCM_CAR (proc)))            {
2095              {              SCM clause = SCM_CAR (x);
2096                x = SCM_CDR (proc);              SCM labels = SCM_CAR (clause);
2097                PREP_APPLY (SCM_UNDEFINED, SCM_EOL);              if (SCM_EQ_P (labels, scm_sym_else))
2098                goto begin;                {
2099              }                  x = SCM_CDR (clause);
2100            proc = SCM_CAR (proc);                  PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
2101            while (SCM_NIMP (proc))                  goto begin;
2102              {                }
2103                if (CHECK_EQVISH (SCM_CAR (proc), t.arg1))              while (!SCM_NULLP (labels))
2104                  {                {
2105                    x = SCM_CDAR (x);                  SCM label = SCM_CAR (labels);
2106                    PREP_APPLY (SCM_UNDEFINED, SCM_EOL);                  if (SCM_EQ_P (label, key) || !SCM_FALSEP (scm_eqv_p (label, key)))
2107                    goto begin;                    {
2108                  }                      x = SCM_CDR (clause);
2109                proc = SCM_CDR (proc);                      PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
2110              }                      goto begin;
2111          }                    }
2112                    labels = SCM_CDR (labels);
2113                  }
2114                x = SCM_CDR (x);
2115              }
2116          }
2117        RETURN (SCM_UNSPECIFIED);        RETURN (SCM_UNSPECIFIED);
2118    
2119    
# Line 2119  dispatch: Line 2134  dispatch:
2134                x = SCM_CDR (proc);                x = SCM_CDR (proc);
2135                if (SCM_NULLP (x))                if (SCM_NULLP (x))
2136                  RETURN (t.arg1);                  RETURN (t.arg1);
2137                if (!SCM_EQ_P (scm_sym_arrow, SCM_CAR (x)))                else if (!SCM_EQ_P (SCM_CAR (x), scm_sym_arrow))
2138                  {                  {
2139                    PREP_APPLY (SCM_UNDEFINED, SCM_EOL);                    PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
2140                    goto begin;                    goto begin;
2141                  }                  }
2142                proc = SCM_CDR (x);                proc = SCM_CDR (x);
2143                proc = EVALCAR (proc, env);                proc = EVALCAR (proc, env);
2144                SCM_ASRTGO (SCM_NIMP (proc), badfun);                SCM_ASRTGO (!SCM_IMP (proc), badfun);
2145                PREP_APPLY (proc, scm_list_1 (t.arg1));                PREP_APPLY (proc, scm_list_1 (t.arg1));
2146                ENTER_APPLY;                ENTER_APPLY;
2147                if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1))                if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1))
# Line 2142  dispatch: Line 2157  dispatch:
2157        x = SCM_CDR (x);        x = SCM_CDR (x);
2158        proc = SCM_CADR (x); /* inits */        proc = SCM_CADR (x); /* inits */
2159        t.arg1 = SCM_EOL;         /* values */        t.arg1 = SCM_EOL;         /* values */
2160        while (SCM_NIMP (proc))        while (!SCM_NULLP (proc))
2161          {          {
2162            t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);            t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
2163            proc = SCM_CDR (proc);            proc = SCM_CDR (proc);

Legend:
Removed from v.1.255  
changed lines
  Added in v.1.256

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