/[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.349 by mvo, Tue Nov 18 19:59:52 2003 UTC revision 1.350 by dirk, Fri Nov 21 23:21:34 2003 UTC
# Line 137  static const char s_missing_body_express Line 137  static const char s_missing_body_express
137   * expressions may be grouped arbitraryly with begin, but it is not allowed to   * expressions may be grouped arbitraryly with begin, but it is not allowed to
138   * mix definitions and expressions.  If a define form in a body mixes   * mix definitions and expressions.  If a define form in a body mixes
139   * definitions and expressions, a 'Mixed definitions and expressions' error is   * definitions and expressions, a 'Mixed definitions and expressions' error is
140   * signalled.   * signalled.  */
  */  
141  static const char s_mixed_body_forms[] = "Mixed definitions and expressions in";  static const char s_mixed_body_forms[] = "Mixed definitions and expressions in";
142    /* Definitions are only allowed on the top level and at the start of a body.
143     * If a definition is detected anywhere else, a 'Bad define placement' error
144     * is signalled.  */
145    static const char s_bad_define[] = "Bad define placement";
146    
147  /* Case or cond expressions must have at least one clause.  If a case or cond  /* Case or cond expressions must have at least one clause.  If a case or cond
148   * expression without any clauses is detected, a 'Missing clauses' error is   * expression without any clauses is detected, a 'Missing clauses' error is
# Line 746  scm_eval_car (SCM pair, SCM env) Line 749  scm_eval_car (SCM pair, SCM env)
749   * just the body itself, but prefixed with an ISYM that denotes to what kind   * just the body itself, but prefixed with an ISYM that denotes to what kind
750   * of outer construct this body belongs: (<ISYM> <expr> ...).  A lambda body   * of outer construct this body belongs: (<ISYM> <expr> ...).  A lambda body
751   * starts with SCM_IM_LAMBDA, for example, a body of a let starts with   * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
752   * SCM_IM_LET, etc.  The one exception is a body that belongs to a letrec that   * SCM_IM_LET, etc.
  * has been formed by rewriting internal defines: It starts with SCM_IM_DEFINE  
  * (instead of SCM_IM_LETREC).  
753   *   *
754   * It is assumed that the calling expression has already made sure that the   * It is assumed that the calling expression has already made sure that the
755   * body is a proper list.  */   * body is a proper list.  */
# Line 1197  canonicalize_define (const SCM expr) Line 1198  canonicalize_define (const SCM expr)
1198  SCM  SCM
1199  scm_m_define (SCM expr, SCM env)  scm_m_define (SCM expr, SCM env)
1200  {  {
1201    SCM canonical_definition;    ASSERT_SYNTAX (SCM_TOP_LEVEL (env), s_bad_define, expr);
   SCM cdr_canonical_definition;  
   SCM body;  
1202    
1203    canonical_definition = canonicalize_define (expr);    {
1204    cdr_canonical_definition = SCM_CDR (canonical_definition);      const SCM canonical_definition = canonicalize_define (expr);
1205    body = SCM_CDR (cdr_canonical_definition);      const SCM cdr_canonical_definition = SCM_CDR (canonical_definition);
1206        const SCM variable = SCM_CAR (cdr_canonical_definition);
1207    if (SCM_TOP_LEVEL (env))      const SCM body = SCM_CDR (cdr_canonical_definition);
1208      {      const SCM value = scm_eval_car (body, env);
1209        SCM var;  
1210        const SCM variable = SCM_CAR (cdr_canonical_definition);      SCM var;
1211        const SCM value = scm_eval_car (body, env);      if (SCM_REC_PROCNAMES_P)
1212        if (SCM_REC_PROCNAMES_P)        {
1213          {          SCM tmp = value;
1214            SCM tmp = value;          while (SCM_MACROP (tmp))
1215            while (SCM_MACROP (tmp))            tmp = SCM_MACRO_CODE (tmp);
1216              tmp = SCM_MACRO_CODE (tmp);          if (SCM_CLOSUREP (tmp)
1217            if (SCM_CLOSUREP (tmp)              /* Only the first definition determines the name. */
1218                /* Only the first definition determines the name. */              && SCM_FALSEP (scm_procedure_property (tmp, scm_sym_name)))
1219                && SCM_FALSEP (scm_procedure_property (tmp, scm_sym_name)))            scm_set_procedure_property_x (tmp, scm_sym_name, variable);
1220              scm_set_procedure_property_x (tmp, scm_sym_name, variable);        }
1221          }  
1222        var = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_T);      var = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_T);
1223        SCM_VARIABLE_SET (var, value);      SCM_VARIABLE_SET (var, value);
1224        return SCM_UNSPECIFIED;  
1225      }      return SCM_UNSPECIFIED;
1226    else    }
     {  
       SCM_SETCAR (canonical_definition, SCM_IM_DEFINE);  
       return canonical_definition;  
     }  
1227  }  }
1228    
1229    
# Line 2266  scm_unmemocar (SCM form, SCM env) Line 2261  scm_unmemocar (SCM form, SCM env)
2261  #endif  #endif
2262    
2263    
2264  static SCM  SCM
2265  unmemocopy (SCM x, SCM env)  scm_unmemocopy (SCM x, SCM env)
2266  {  {
2267    SCM ls, z;    SCM ls, z;
2268    SCM p;    SCM p;
# Line 2304  unmemocopy (SCM x, SCM env) Line 2299  unmemocopy (SCM x, SCM env)
2299          SCM names, inits, test, memoized_body, steps, bindings;          SCM names, inits, test, memoized_body, steps, bindings;
2300    
2301          x = SCM_CDR (x);          x = SCM_CDR (x);
2302          inits = scm_reverse (unmemocopy (SCM_CAR (x), env));          inits = scm_reverse (scm_unmemocopy (SCM_CAR (x), env));
2303          x = SCM_CDR (x);          x = SCM_CDR (x);
2304          names = SCM_CAR (x);          names = SCM_CAR (x);
2305          env = SCM_EXTEND_ENV (names, SCM_EOL, env);          env = SCM_EXTEND_ENV (names, SCM_EOL, env);
2306          x = SCM_CDR (x);          x = SCM_CDR (x);
2307          test = unmemocopy (SCM_CAR (x), env);          test = scm_unmemocopy (SCM_CAR (x), env);
2308          x = SCM_CDR (x);          x = SCM_CDR (x);
2309          memoized_body = SCM_CAR (x);          memoized_body = SCM_CAR (x);
2310          x = SCM_CDR (x);          x = SCM_CDR (x);
2311          steps = scm_reverse (unmemocopy (x, env));          steps = scm_reverse (scm_unmemocopy (x, env));
2312    
2313          /* build transformed binding list */          /* build transformed binding list */
2314          bindings = SCM_EOL;          bindings = SCM_EOL;
# Line 2349  unmemocopy (SCM x, SCM env) Line 2344  unmemocopy (SCM x, SCM env)
2344          x = SCM_CDR (x);          x = SCM_CDR (x);
2345          rnames = SCM_CAR (x);          rnames = SCM_CAR (x);
2346          x = SCM_CDR (x);          x = SCM_CDR (x);
2347          rinits = scm_reverse (unmemocopy (SCM_CAR (x), env));          rinits = scm_reverse (scm_unmemocopy (SCM_CAR (x), env));
2348          env = SCM_EXTEND_ENV (rnames, SCM_EOL, env);          env = SCM_EXTEND_ENV (rnames, SCM_EOL, env);
2349    
2350          bindings = build_binding_list (rnames, rinits);          bindings = build_binding_list (rnames, rinits);
# Line 2368  unmemocopy (SCM x, SCM env) Line 2363  unmemocopy (SCM x, SCM env)
2363          rnames = SCM_CAR (x);          rnames = SCM_CAR (x);
2364          env = SCM_EXTEND_ENV (rnames, SCM_EOL, env);          env = SCM_EXTEND_ENV (rnames, SCM_EOL, env);
2365          x = SCM_CDR (x);          x = SCM_CDR (x);
2366          rinits = scm_reverse (unmemocopy (SCM_CAR (x), env));          rinits = scm_reverse (scm_unmemocopy (SCM_CAR (x), env));
2367    
2368          bindings = build_binding_list (rnames, rinits);          bindings = build_binding_list (rnames, rinits);
2369          z = scm_cons (bindings, SCM_UNSPECIFIED);          z = scm_cons (bindings, SCM_UNSPECIFIED);
# Line 2388  unmemocopy (SCM x, SCM env) Line 2383  unmemocopy (SCM x, SCM env)
2383            }            }
2384          y = z = scm_acons (SCM_CAR (b),          y = z = scm_acons (SCM_CAR (b),
2385                             unmemocar (                             unmemocar (
2386          scm_cons (unmemocopy (SCM_CADR (b), env), SCM_EOL), env),          scm_cons (scm_unmemocopy (SCM_CADR (b), env), SCM_EOL), env),
2387                             SCM_UNSPECIFIED);                             SCM_UNSPECIFIED);
2388          env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);          env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
2389          b = SCM_CDDR (b);          b = SCM_CDDR (b);
# Line 2403  unmemocopy (SCM x, SCM env) Line 2398  unmemocopy (SCM x, SCM env)
2398            {            {
2399              SCM_SETCDR (z, scm_acons (SCM_CAR (b),              SCM_SETCDR (z, scm_acons (SCM_CAR (b),
2400                                        unmemocar (                                        unmemocar (
2401              scm_list_1 (unmemocopy (SCM_CADR (b), env)), env),              scm_list_1 (scm_unmemocopy (SCM_CADR (b), env)), env),
2402                                        SCM_UNSPECIFIED));                                        SCM_UNSPECIFIED));
2403              z = SCM_CDR (z);              z = SCM_CDR (z);
2404              env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);              env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
# Line 2435  unmemocopy (SCM x, SCM env) Line 2430  unmemocopy (SCM x, SCM env)
2430        z = SCM_CAR (x);        z = SCM_CAR (x);
2431        switch (SCM_ISYMNUM (z))        switch (SCM_ISYMNUM (z))
2432          {          {
         case (SCM_ISYMNUM (SCM_IM_DEFINE)):  
           {  
             SCM n;  
             x = SCM_CDR (x);  
             n = SCM_CAR (x);  
             z = scm_cons (n, SCM_UNSPECIFIED);  
             ls = scm_cons (scm_sym_define, z);  
             if (!SCM_NULLP (env))  
               env = scm_cons (scm_cons (scm_cons (n, SCM_CAAR (env)),  
                                         SCM_CDAR (env)),  
                               SCM_CDR (env));  
             break;  
           }  
2433          case (SCM_ISYMNUM (SCM_IM_APPLY)):          case (SCM_ISYMNUM (SCM_IM_APPLY)):
2434            ls = z = scm_cons (scm_sym_atapply, SCM_UNSPECIFIED);            ls = z = scm_cons (scm_sym_atapply, SCM_UNSPECIFIED);
2435            goto loop;            goto loop;
# Line 2472  unmemocopy (SCM x, SCM env) Line 2454  unmemocopy (SCM x, SCM env)
2454            /* appease the Sun compiler god: */ ;            /* appease the Sun compiler god: */ ;
2455          }          }
2456      default:      default:
2457        ls = z = unmemocar (scm_cons (unmemocopy (SCM_CAR (x), env),        ls = z = unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x), env),
2458                                      SCM_UNSPECIFIED),                                      SCM_UNSPECIFIED),
2459                            env);                            env);
2460      }      }
# Line 2483  loop: Line 2465  loop:
2465        SCM form = SCM_CAR (x);        SCM form = SCM_CAR (x);
2466        if (!SCM_ISYMP (form))        if (!SCM_ISYMP (form))
2467          {          {
2468            SCM copy = scm_cons (unmemocopy (form, env), SCM_UNSPECIFIED);            SCM copy = scm_cons (scm_unmemocopy (form, env), SCM_UNSPECIFIED);
2469            SCM_SETCDR (z, unmemocar (copy, env));            SCM_SETCDR (z, unmemocar (copy, env));
2470            z = SCM_CDR (z);            z = SCM_CDR (z);
2471          }          }
# Line 2500  loop: Line 2482  loop:
2482    return ls;    return ls;
2483  }  }
2484    
 SCM  
 scm_unmemocopy (SCM x, SCM env)  
 {  
   if (!SCM_NULLP (env))  
     /* Make a copy of the lowest frame to protect it from  
        modifications by SCM_IM_DEFINE */  
     return unmemocopy (x, scm_cons (SCM_CAR (env), SCM_CDR (env)));  
   else  
     return unmemocopy (x, env);  
 }  
   
2485    
2486  /*****************************************************************************/  /*****************************************************************************/
2487  /*****************************************************************************/  /*****************************************************************************/
# Line 3280  dispatch: Line 3251  dispatch:
3251          {          {
3252    
3253    
         case (SCM_ISYMNUM (SCM_IM_DEFINE)):  
           /* Top level defines are handled directly by the memoizer and thus  
            * will never generate memoized code with SCM_IM_DEFINE.  Internal  
            * defines which occur at valid positions will be transformed into  
            * letrec expressions.  Thus, whenever the executor detects  
            * SCM_IM_DEFINE, this must come from an internal definition at an  
            * illegal position.  */  
           scm_misc_error (NULL, "Bad define placement", SCM_EOL);  
   
   
3254          case (SCM_ISYMNUM (SCM_IM_APPLY)):          case (SCM_ISYMNUM (SCM_IM_APPLY)):
3255              /* Evaluate the procedure to be applied.  */
3256            x = SCM_CDR (x);            x = SCM_CDR (x);
3257            proc = EVALCAR (x, env);            proc = EVALCAR (x, env);
3258            PREP_APPLY (proc, SCM_EOL);            PREP_APPLY (proc, SCM_EOL);
3259    
3260              /* Evaluate the argument holding the list of arguments */
3261            x = SCM_CDR (x);            x = SCM_CDR (x);
3262            arg1 = EVALCAR (x, env);            arg1 = EVALCAR (x, env);
3263    
# Line 3349  dispatch: Line 3313  dispatch:
3313                {                {
3314                  arg1 = val;                  arg1 = val;
3315                  proc = SCM_CDR (x);                  proc = SCM_CDR (x);
3316                  proc = scm_eval_car (proc, env);                  proc = EVALCAR (proc, env);
3317                  PREP_APPLY (proc, scm_list_1 (arg1));                  PREP_APPLY (proc, scm_list_1 (arg1));
3318                  ENTER_APPLY;                  ENTER_APPLY;
3319                  goto evap1;                  goto evap1;
# Line 3679  dispatch: Line 3643  dispatch:
3643                SCM_SET_MACROEXP (debug);                SCM_SET_MACROEXP (debug);
3644  #endif  #endif
3645                arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x,                arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x,
3646                                    scm_cons (env, scm_listofnull));                                  scm_cons (env, scm_listofnull));
   
3647  #ifdef DEVAL  #ifdef DEVAL
3648                SCM_CLEAR_MACROEXP (debug);                SCM_CLEAR_MACROEXP (debug);
3649  #endif  #endif
# Line 4172  evapply: /* inputs: x, proc */ Line 4135  evapply: /* inputs: x, proc */
4135                arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env));                arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env));
4136                x = SCM_CDR(x);                x = SCM_CDR(x);
4137              }              }
4138            while (SCM_NIMP (x));            while (!SCM_NULLP (x));
4139            RETURN (arg1);            RETURN (arg1);
4140          case scm_tc7_rpsubr:          case scm_tc7_rpsubr:
4141            if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2)))            if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2)))
# Line 4185  evapply: /* inputs: x, proc */ Line 4148  evapply: /* inputs: x, proc */
4148                arg2 = arg1;                arg2 = arg1;
4149                x = SCM_CDR (x);                x = SCM_CDR (x);
4150              }              }
4151            while (SCM_NIMP (x));            while (!SCM_NULLP (x));
4152            RETURN (SCM_BOOL_T);            RETURN (SCM_BOOL_T);
4153          case scm_tc7_lsubr_2:          case scm_tc7_lsubr_2:
4154            RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_eval_args (x, env, proc)));            RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_eval_args (x, env, proc)));
# Line 5467  SCM_DEFINE (scm_primitive_eval, "primiti Line 5430  SCM_DEFINE (scm_primitive_eval, "primiti
5430  }  }
5431  #undef FUNC_NAME  #undef FUNC_NAME
5432    
5433    
5434  /* Eval does not take the second arg optionally.  This is intentional  /* Eval does not take the second arg optionally.  This is intentional
5435   * in order to be R5RS compatible, and to prepare for the new module   * in order to be R5RS compatible, and to prepare for the new module
5436   * system, where we would like to make the choice of evaluation   * system, where we would like to make the choice of evaluation
# Line 5482  change_environment (void *data) Line 5446  change_environment (void *data)
5446    scm_set_current_module (new_module);    scm_set_current_module (new_module);
5447  }  }
5448    
   
5449  static void  static void
5450  restore_environment (void *data)  restore_environment (void *data)
5451  {  {

Legend:
Removed from v.1.349  
changed lines
  Added in v.1.350

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