[uim-commit] r2892 - branches/r5rs/sigscheme

[yamaken at freedesktop.org]

Author: yamaken
Date: 2006-01-10 15:06:17 -0800 (Tue, 10 Jan 2006)
New Revision: 2892

Modified:
   branches/r5rs/sigscheme/env.c
   branches/r5rs/sigscheme/sigschemeinternal.h
   branches/r5rs/sigscheme/syntax.c
Log:
* sigscheme/sigschemeinternal.h
  - (scm_replace_environment, scm_update_environment): New function
    decl
* sigscheme/env.c
  - (scm_replace_environment, scm_update_environment): New function
  - (scm_add_environment): Optimize
* sigscheme/syntax.c
  - (scm_s_letrec): Make environment modification abstract
  - (scm_s_do): Make efficient


Modified: branches/r5rs/sigscheme/env.c
===================================================================
--- branches/r5rs/sigscheme/env.c	2006-01-10 21:56:36 UTC (rev 2891)
+++ branches/r5rs/sigscheme/env.c	2006-01-10 23:06:17 UTC (rev 2892)
@@ -122,6 +122,53 @@
     return CONS(frame, env);
 }
 
+/**
+ * Replace entire content of newest frame of an env
+ *
+ * The environment must be replaced with returned one in caller side even if
+ * this implementation returns identical to the one passed. This rule is
+ * required to be compatible with future alternative implementations.
+ */
+ScmObj
+scm_replace_environment(ScmObj formals, ScmObj actuals, ScmObj env)
+{
+    ScmObj frame;
+    DECLARE_INTERNAL_FUNCTION("scm_replace_environment");
+
+    SCM_ASSERT(scm_valid_environment_extensionp(formals, actuals));
+    SCM_ASSERT(VALID_ENVP(env));
+    SCM_ASSERT(CONSP(env));
+
+    frame = CAR(env);
+    SET_CAR(frame, formals);
+    SET_CDR(frame, actuals);
+
+    return env;
+}
+
+/**
+ * Replace all actuals of newest frame of an env
+ *
+ * The environment must be replaced with returned one in caller side even if
+ * this implementation returns identical to the one passed. This rule is
+ * required to be compatible with future alternative implementations.
+ */
+ScmObj
+scm_update_environment(ScmObj actuals, ScmObj env)
+{
+    ScmObj frame;
+    DECLARE_INTERNAL_FUNCTION("scm_update_environment");
+
+    SCM_ASSERT(VALID_ENVP(env));
+    SCM_ASSERT(CONSP(env));
+
+    frame = CAR(env);
+    SCM_ASSERT(scm_valid_environment_extensionp(CAR(frame), actuals));
+    SET_CDR(frame, actuals);
+
+    return env;
+}
+
 /** Add a binding to newest frame of an env */
 ScmObj
 scm_add_environment(ScmObj var, ScmObj val, ScmObj env)
@@ -140,9 +187,8 @@
         frame = CAR(env);
         formals = CONS(var, CAR(frame));
         actuals = CONS(val, CDR(frame));
-        frame = CONS(formals, actuals);
-
-        SET_CAR(env, frame);
+        SET_CAR(frame, formals);
+        SET_CDR(frame, actuals);
     } else {
         SCM_ASSERT(scm_false);
     }

Modified: branches/r5rs/sigscheme/sigschemeinternal.h
===================================================================
--- branches/r5rs/sigscheme/sigschemeinternal.h	2006-01-10 21:56:36 UTC (rev 2891)
+++ branches/r5rs/sigscheme/sigschemeinternal.h	2006-01-10 23:06:17 UTC (rev 2892)
@@ -502,6 +502,8 @@
 
 /* env.c */
 ScmObj scm_extend_environment(ScmObj formals, ScmObj actuals, ScmObj env);
+ScmObj scm_replace_environment(ScmObj formals, ScmObj actuals, ScmObj env);
+ScmObj scm_update_environment(ScmObj actuals, ScmObj env);
 ScmObj scm_add_environment(ScmObj var, ScmObj val, ScmObj env);
 ScmRef scm_lookup_environment(ScmObj var, ScmObj env);
 

Modified: branches/r5rs/sigscheme/syntax.c
===================================================================
--- branches/r5rs/sigscheme/syntax.c	2006-01-10 21:56:36 UTC (rev 2891)
+++ branches/r5rs/sigscheme/syntax.c	2006-01-10 23:06:17 UTC (rev 2892)
@@ -760,7 +760,7 @@
 ScmObj
 scm_s_letrec(ScmObj bindings, ScmObj body, ScmEvalState *eval_state)
 {
-    ScmObj binding, frame, formals, actuals, var, val;
+    ScmObj binding, formals, actuals, var, val;
     DECLARE_FUNCTION("letrec", syntax_variadic_tailrec_1);
 
     /*========================================================================
@@ -774,9 +774,8 @@
         goto err;
 
     /* extend env by placeholder frame for subsequent lambda evaluations */
-    /* FIXME: direct env object manipulation */
-    frame = CONS(SCM_NULL, SCM_NULL);
-    eval_state->env = CONS(frame, eval_state->env);
+    eval_state->env
+        = scm_extend_environment(SCM_NULL, SCM_NULL, eval_state->env);
 
     formals = SCM_NULL;
     actuals = SCM_NULL;
@@ -794,8 +793,8 @@
         goto err;
 
     /* fill the placeholder frame */
-    SET_CAR(frame, formals);
-    SET_CDR(frame, actuals);
+    eval_state->env
+        = scm_replace_environment(formals, actuals, eval_state->env);
 
     return scm_s_begin(body, eval_state);
 
@@ -836,13 +835,13 @@
          ScmEvalState *eval_state)
 {
     ScmQueue stepq;
-    ScmObj env, orig_env, rest, rest_commands, val, termp;
+    ScmObj env, rest, rest_commands, val, termp;
     ScmObj formals, actuals, steps;
     ScmObj binding, var, init, step;
     ScmObj test, exps, command;
     DECLARE_FUNCTION("do", syntax_variadic_tailrec_2);
 
-    env = orig_env = eval_state->env;
+    env = eval_state->env;
 
     /*
      * (do ((<variable1> <init1> <step1>)
@@ -891,7 +890,7 @@
     /* iteration phase */
     rest_commands = commands;
     /* extend env by <init>s */
-    env = scm_extend_environment(formals, actuals, orig_env);
+    env = scm_extend_environment(formals, actuals, env);
     while (termp = EVAL(test, env), FALSEP(termp)) {
         rest_commands = commands;
         FOR_EACH (command, rest_commands)
@@ -906,7 +905,7 @@
             val = EVAL(step, env);
             actuals = CONS(val, actuals);
         }
-        env = scm_extend_environment(formals, actuals, orig_env);
+        env = scm_update_environment(actuals, env);
     }
 #if SCM_STRICT_ARGCHECK
     /* no iteration occurred */