/[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.336 by dirk, Sat Nov 1 07:26:44 2003 UTC revision 1.337 by dirk, Sat Nov 1 10:21:15 2003 UTC
# Line 672  SCM_GLOBAL_SYMBOL (scm_sym_exit_frame, " Line 672  SCM_GLOBAL_SYMBOL (scm_sym_exit_frame, "
672  SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace");  SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace");
673    
674    
675  /* Check that the body denoted by XORIG is valid and rewrite it into  /* Rewrite the body (which is given as the list of expressions forming the
676     its internal form.  The internal form of a body is just the body   * body) into its internal form.  The internal form of a body (<expr> ...) is
677     itself, but prefixed with an ISYM that denotes to what kind of   * just the body itself, but prefixed with an ISYM that denotes to what kind
678     outer construct this body belongs.  A lambda body starts with   * of outer construct this body belongs: (<ISYM> <expr> ...).  A lambda body
679     SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,   * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
680     etc.  The one exception is a body that belongs to a letrec that has   * SCM_IM_LET, etc.  The one exception is a body that belongs to a letrec that
681     been formed by rewriting internal defines: it starts with   * has been formed by rewriting internal defines: It starts with SCM_IM_DEFINE
682     SCM_IM_DEFINE. */   * (instead of SCM_IM_LETREC).
683     *
684  /* XXX - Besides controlling the rewriting of internal defines, the   * It is assumed that the calling expression has already made sure that the
685           additional ISYM could be used for improved error messages.   * body is a proper list.  */
          This is not done yet.  */  
   
686  static SCM  static SCM
687  scm_m_body (SCM op, SCM xorig, const char *what)  scm_m_body (SCM op, SCM exprs)
688  {  {
   SCM_ASSYNT (scm_ilength (xorig) >= 1, s_body, what);  
   
689    /* Don't add another ISYM if one is present already. */    /* Don't add another ISYM if one is present already. */
690    if (SCM_ISYMP (SCM_CAR (xorig)))    if (SCM_ISYMP (SCM_CAR (exprs)))
691      return xorig;      return exprs;
692      else
693    /* Retain possible doc string. */      return scm_cons (op, exprs);
   if (!SCM_CONSP (SCM_CAR (xorig)))  
     {  
       if (!SCM_NULLP (SCM_CDR (xorig)))  
         return scm_cons (SCM_CAR (xorig),  
                          scm_m_body (op, SCM_CDR (xorig), what));  
       return xorig;  
     }  
   
   return scm_cons (op, xorig);  
694  }  }
695    
696    
# Line 1101  scm_m_lambda (SCM expr, SCM env SCM_UNUS Line 1088  scm_m_lambda (SCM expr, SCM env SCM_UNUS
1088  {  {
1089    SCM formals;    SCM formals;
1090    SCM formals_idx;    SCM formals_idx;
1091      SCM cddr_expr;
1092      int documentation;
1093      SCM body;
1094      SCM new_body;
1095    
1096    const SCM cdr_expr = SCM_CDR (expr);    const SCM cdr_expr = SCM_CDR (expr);
1097    const long length = scm_ilength (cdr_expr);    const long length = scm_ilength (cdr_expr);
# Line 1136  scm_m_lambda (SCM expr, SCM env SCM_UNUS Line 1127  scm_m_lambda (SCM expr, SCM env SCM_UNUS
1127    ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx) || SCM_SYMBOLP (formals_idx),    ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx) || SCM_SYMBOLP (formals_idx),
1128                     s_bad_formal, formals_idx, expr);                     s_bad_formal, formals_idx, expr);
1129    
1130    return scm_cons2 (SCM_IM_LAMBDA, SCM_CAR (cdr_expr),    /* Memoize the body.  Keep a potential documentation string.  */
1131                      scm_m_body (SCM_IM_LAMBDA, SCM_CDR (cdr_expr), s_lambda));    /* Dirk:FIXME:: We should probably extract the documentation string to
1132       * some external database.  Otherwise it will slow down execution, since
1133       * the documentation string will have to be skipped with every execution
1134       * of the closure.  */
1135      cddr_expr = SCM_CDR (cdr_expr);
1136      documentation = (length >= 3 && SCM_STRINGP (SCM_CAR (cddr_expr)));
1137      body = documentation ? SCM_CDR (cddr_expr) : cddr_expr;
1138      new_body = scm_m_body (SCM_IM_LAMBDA, body);
1139    
1140      SCM_SETCAR (expr, SCM_IM_LAMBDA);
1141      if (documentation)
1142        SCM_SETCDR (cddr_expr, new_body);
1143      else
1144        SCM_SETCDR (cdr_expr, new_body);
1145      return expr;
1146  }  }
1147    
1148    
# Line 1220  memoize_named_let (const SCM expr, const Line 1225  memoize_named_let (const SCM expr, const
1225    
1226    {    {
1227      const SCM let_body = SCM_CDR (cddr_expr);      const SCM let_body = SCM_CDR (cddr_expr);
1228      const SCM lambda_body = scm_m_body (SCM_IM_LET, let_body, "let");      const SCM lambda_body = scm_m_body (SCM_IM_LET, let_body);
1229      const SCM lambda_tail = scm_cons (variables, lambda_body);      const SCM lambda_tail = scm_cons (variables, lambda_body);
1230      const SCM lambda_form = scm_cons_source (expr, scm_sym_lambda, lambda_tail);      const SCM lambda_form = scm_cons_source (expr, scm_sym_lambda, lambda_tail);
1231    
1232      const SCM rvar = scm_list_1 (name);      const SCM rvar = scm_list_1 (name);
1233      const SCM init = scm_list_1 (lambda_form);      const SCM init = scm_list_1 (lambda_form);
1234      const SCM body = scm_m_body (SCM_IM_LET, scm_list_1 (name), "let");      const SCM body = scm_m_body (SCM_IM_LET, scm_list_1 (name));
1235      const SCM letrec_tail = scm_cons (rvar, scm_cons (init, body));      const SCM letrec_tail = scm_cons (rvar, scm_cons (init, body));
1236      const SCM letrec_form = scm_cons_source (expr, SCM_IM_LETREC, letrec_tail);      const SCM letrec_form = scm_cons_source (expr, SCM_IM_LETREC, letrec_tail);
1237      return scm_cons_source (expr, letrec_form, inits);      return scm_cons_source (expr, letrec_form, inits);
# Line 1256  scm_m_let (SCM expr, SCM env) Line 1261  scm_m_let (SCM expr, SCM env)
1261    if (SCM_NULLP (bindings) || SCM_NULLP (SCM_CDR (bindings)))    if (SCM_NULLP (bindings) || SCM_NULLP (SCM_CDR (bindings)))
1262      {      {
1263        /* Special case: no bindings or single binding => let* is faster. */        /* Special case: no bindings or single binding => let* is faster. */
1264        const SCM body = scm_m_body (SCM_IM_LET, SCM_CDR (cdr_expr), s_let);        const SCM body = scm_m_body (SCM_IM_LET, SCM_CDR (cdr_expr));
1265        return scm_m_letstar (scm_cons2 (SCM_CAR (expr), bindings, body), env);        return scm_m_letstar (scm_cons2 (SCM_CAR (expr), bindings, body), env);
1266      }      }
1267    else    else
# Line 1267  scm_m_let (SCM expr, SCM env) Line 1272  scm_m_let (SCM expr, SCM env)
1272        transform_bindings (bindings, expr, &rvariables, &inits);        transform_bindings (bindings, expr, &rvariables, &inits);
1273    
1274        {        {
1275          const SCM new_body = scm_m_body (SCM_IM_LET, SCM_CDR (cdr_expr), "let");          const SCM new_body = scm_m_body (SCM_IM_LET, SCM_CDR (cdr_expr));
1276          const SCM new_tail = scm_cons2 (rvariables, inits, new_body);          const SCM new_tail = scm_cons2 (rvariables, inits, new_body);
1277          SCM_SETCAR (expr, SCM_IM_LET);          SCM_SETCAR (expr, SCM_IM_LET);
1278          SCM_SETCDR (expr, new_tail);          SCM_SETCDR (expr, new_tail);
# Line 1305  scm_m_letstar (SCM expr, SCM env SCM_UNU Line 1310  scm_m_letstar (SCM expr, SCM env SCM_UNU
1310      }      }
1311    new_bindings = scm_reverse_x (new_bindings, SCM_UNDEFINED);    new_bindings = scm_reverse_x (new_bindings, SCM_UNDEFINED);
1312    
1313    new_body = scm_m_body (SCM_IM_LETSTAR, SCM_CDR (cdr_expr), s_letstar);    new_body = scm_m_body (SCM_IM_LETSTAR, SCM_CDR (cdr_expr));
1314    return scm_cons2 (SCM_IM_LETSTAR, new_bindings, new_body);    return scm_cons2 (SCM_IM_LETSTAR, new_bindings, new_body);
1315  }  }
1316    
# Line 1326  scm_m_letrec (SCM expr, SCM env) Line 1331  scm_m_letrec (SCM expr, SCM env)
1331    if (SCM_NULLP (bindings))    if (SCM_NULLP (bindings))
1332      {      {
1333        /* no bindings, let* is executed faster */        /* no bindings, let* is executed faster */
1334        SCM body = scm_m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr), s_letrec);        SCM body = scm_m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr));
1335        return scm_m_letstar (scm_cons2 (SCM_CAR (expr), SCM_EOL, body), env);        return scm_m_letstar (scm_cons2 (SCM_CAR (expr), SCM_EOL, body), env);
1336      }      }
1337    else    else
# Line 1337  scm_m_letrec (SCM expr, SCM env) Line 1342  scm_m_letrec (SCM expr, SCM env)
1342    
1343        check_bindings (bindings, expr);        check_bindings (bindings, expr);
1344        transform_bindings (bindings, expr, &rvariables, &inits);        transform_bindings (bindings, expr, &rvariables, &inits);
1345        new_body = scm_m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr), "letrec");        new_body = scm_m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr));
1346        return scm_cons2 (SCM_IM_LETREC, rvariables, scm_cons (inits, new_body));        return scm_cons2 (SCM_IM_LETREC, rvariables, scm_cons (inits, new_body));
1347      }      }
1348  }  }
# Line 1841  scm_m_expand_body (SCM xorig, SCM env) Line 1846  scm_m_expand_body (SCM xorig, SCM env)
1846        SCM rvars, inits, body, letrec;        SCM rvars, inits, body, letrec;
1847        check_bindings (defs, xorig);        check_bindings (defs, xorig);
1848        transform_bindings (defs, xorig, &rvars, &inits);        transform_bindings (defs, xorig, &rvars, &inits);
1849        body = scm_m_body (SCM_IM_DEFINE, x, what);        body = scm_m_body (SCM_IM_DEFINE, x);
1850        letrec = scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body));        letrec = scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body));
1851        SCM_SETCAR (xorig, letrec);        SCM_SETCAR (xorig, letrec);
1852        SCM_SETCDR (xorig, SCM_EOL);        SCM_SETCDR (xorig, SCM_EOL);

Legend:
Removed from v.1.336  
changed lines
  Added in v.1.337

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