/[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.330 by dirk, Sat Oct 18 14:49:54 2003 UTC revision 1.331 by dirk, Sat Oct 18 17:24:09 2003 UTC
# Line 1487  static const char s_set_x[] = "set!"; Line 1487  static const char s_set_x[] = "set!";
1487  SCM_GLOBAL_SYMBOL (scm_sym_set_x, s_set_x);  SCM_GLOBAL_SYMBOL (scm_sym_set_x, s_set_x);
1488    
1489  SCM  SCM
1490  scm_m_set_x (SCM xorig, SCM env SCM_UNUSED)  scm_m_set_x (SCM expr, SCM env SCM_UNUSED)
1491  {  {
1492    SCM x = SCM_CDR (xorig);    SCM variable;
1493    SCM_ASSYNT (scm_ilength (x) == 2, s_expression, s_set_x);  
1494    SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x)), s_variable, s_set_x);    const SCM cdr_expr = SCM_CDR (expr);
1495    return scm_cons (SCM_IM_SET_X, x);    ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1496      ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
1497      variable = SCM_CAR (cdr_expr);
1498      ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr);
1499    
1500      SCM_SETCAR (expr, SCM_IM_SET_X);
1501      return expr;
1502  }  }
1503    
1504    
# Line 1504  SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_at Line 1510  SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_at
1510  SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1);  SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1);
1511    
1512  SCM  SCM
1513  scm_m_apply (SCM xorig, SCM env SCM_UNUSED)  scm_m_apply (SCM expr, SCM env SCM_UNUSED)
1514  {  {
1515    SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, s_expression, s_atapply);    const SCM cdr_expr = SCM_CDR (expr);
1516    return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig));    ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1517  }    ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_missing_expression, expr);
   
   
 /* (@bind ((var exp) ...) body ...)  
1518    
1519    This will assign the values of the `exp's to the global variables    SCM_SETCAR (expr, SCM_IM_APPLY);
1520    named by `var's (symbols, not evaluated), creating them if they    return expr;
1521    don't exist, executes body, and then restores the previous values of  }
   the `var's.  Additionally, whenever control leaves body, the values  
   of the `var's are saved and restored when control returns.  It is an  
   error when a symbol appears more than once among the `var's.  
   All `exp's are evaluated before any `var' is set.  
   
   Think of this as `let' for dynamic scope.  
   
   It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).  
1522    
   XXX - also implement `@bind*'.  
 */  
1523    
1524  SCM_SYNTAX (s_atbind, "@bind", scm_i_makbimacro, scm_m_atbind);  SCM_SYNTAX (s_atbind, "@bind", scm_i_makbimacro, scm_m_atbind);
1525    
1526    /* FIXME: The following explanation should go into the documentation: */
1527    /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
1528     * the global variables named by `var's (symbols, not evaluated), creating
1529     * them if they don't exist, executes body, and then restores the previous
1530     * values of the `var's.  Additionally, whenever control leaves body, the
1531     * values of the `var's are saved and restored when control returns.  It is an
1532     * error when a symbol appears more than once among the `var's.  All `init's
1533     * are evaluated before any `var' is set.
1534     *
1535     * Think of this as `let' for dynamic scope.
1536     */
1537    
1538    /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
1539     * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
1540     *
1541     * FIXME - also implement `@bind*'.
1542     */
1543  SCM  SCM
1544  scm_m_atbind (SCM xorig, SCM env)  scm_m_atbind (SCM expr, SCM env)
1545  {  {
1546    SCM x = SCM_CDR (xorig);    SCM bindings;
1547    SCM top_level = scm_env_top_level (env);    SCM rvariables;
1548    SCM vars = SCM_EOL, var;    SCM inits;
1549    SCM exps = SCM_EOL;    SCM variable_idx;
1550    
1551    SCM_ASSYNT (scm_ilength (x) > 1, s_expression, s_atbind);    const SCM top_level = scm_env_top_level (env);
1552    
1553    x = SCM_CAR (x);    const SCM cdr_expr = SCM_CDR (expr);
1554    while (SCM_NIMP (x))    ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
1555      ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
1556      bindings = SCM_CAR (cdr_expr);
1557      check_bindings (bindings, expr);
1558      transform_bindings (bindings, expr, &rvariables, &inits);
1559    
1560      for (variable_idx = rvariables;
1561           !SCM_NULLP (variable_idx);
1562           variable_idx = SCM_CDR (variable_idx))
1563      {      {
1564        SCM rest;        /* The first call to scm_sym2var will look beyond the current module,
1565        SCM sym_exp = SCM_CAR (x);         * while the second call wont.  */
1566        SCM_ASSYNT (scm_ilength (sym_exp) == 2, s_bindings, s_atbind);        const SCM variable = SCM_CAR (variable_idx);
1567        SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp)), s_bindings, s_atbind);        SCM new_variable = scm_sym2var (variable, top_level, SCM_BOOL_F);
1568        x = SCM_CDR (x);        if (SCM_FALSEP (new_variable))
1569        for (rest = x; SCM_NIMP (rest); rest = SCM_CDR (rest))          new_variable = scm_sym2var (variable, top_level, SCM_BOOL_T);
1570          if (SCM_EQ_P (SCM_CAR (sym_exp), SCM_CAAR (rest)))        SCM_SETCAR (variable_idx, new_variable);
           scm_misc_error (s_atbind, s_duplicate_bindings, SCM_EOL);  
       /* The first call to scm_sym2var will look beyond the current  
          module, while the second call wont. */  
       var = scm_sym2var (SCM_CAR (sym_exp), top_level, SCM_BOOL_F);  
       if (SCM_FALSEP (var))  
         var = scm_sym2var (SCM_CAR (sym_exp), top_level, SCM_BOOL_T);  
       vars = scm_cons (var, vars);  
       exps = scm_cons (SCM_CADR (sym_exp), exps);  
1571      }      }
1572    return scm_cons (SCM_IM_BIND,  
1573                     scm_cons (scm_cons (scm_reverse_x (vars, SCM_EOL), exps),    SCM_SETCAR (expr, SCM_IM_BIND);
1574                               SCM_CDDR (xorig)));    SCM_SETCAR (cdr_expr, scm_cons (rvariables, inits));
1575      return expr;
1576  }  }
1577    
1578    
# Line 3169  dispatch: Line 3180  dispatch:
3180              x = SCM_CDR (x);              x = SCM_CDR (x);
3181              vars = SCM_CAAR (x);              vars = SCM_CAAR (x);
3182              exps = SCM_CDAR (x);              exps = SCM_CDAR (x);
   
3183              vals = SCM_EOL;              vals = SCM_EOL;
3184                while (!SCM_NULLP (exps))
             while (SCM_NIMP (exps))  
3185                {                {
3186                  vals = scm_cons (EVALCAR (exps, env), vals);                  vals = scm_cons (EVALCAR (exps, env), vals);
3187                  exps = SCM_CDR (exps);                  exps = SCM_CDR (exps);
# Line 3206  dispatch: Line 3215  dispatch:
3215              proc = EVALCAR (x, env);  /* proc is the consumer. */              proc = EVALCAR (x, env);  /* proc is the consumer. */
3216              arg1 = SCM_APPLY (producer, SCM_EOL, SCM_EOL);              arg1 = SCM_APPLY (producer, SCM_EOL, SCM_EOL);
3217              if (SCM_VALUESP (arg1))              if (SCM_VALUESP (arg1))
3218                arg1 = scm_struct_ref (arg1, SCM_INUM0);                {
3219                    /* The list of arguments is not copied.  Rather, it is assumed
3220                     * that this has been done by the 'values' procedure.  */
3221                    arg1 = scm_struct_ref (arg1, SCM_INUM0);
3222                  }
3223              else              else
3224                arg1 = scm_list_1 (arg1);                {
3225                    arg1 = scm_list_1 (arg1);
3226                  }
3227              PREP_APPLY (proc, arg1);              PREP_APPLY (proc, arg1);
3228              goto apply_proc;              goto apply_proc;
3229            }            }
# Line 3221  dispatch: Line 3236  dispatch:
3236      default:      default:
3237        proc = x;        proc = x;
3238        goto evapply;        goto evapply;
3239    
3240      case scm_tc7_vector:      case scm_tc7_vector:
3241      case scm_tc7_wvect:      case scm_tc7_wvect:
3242  #if SCM_HAVE_ARRAYS  #if SCM_HAVE_ARRAYS

Legend:
Removed from v.1.330  
changed lines
  Added in v.1.331

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