Evaluate `val' and `var' bindings in the environment in which they were defined

Until this change, you could create a program such as:

  val mine : your_domain = "mydomain.org";
  val not_mine = mine;
  val mine = "not-my-domain.org";

  dom not_mine with end;

And domtool would happily configure "not-mydomain.org" for you.

diff --git a/src/env.sig b/src/env.sig
index d67c9f4..6668c5e 100644 (file)
--- a/src/env.sig
+++ b/src/env.sig
@@ -104,7 +104,7 @@ signature ENV = sig
 
     val lookupType : env -> string -> bool
     val lookupVal : env -> string -> Ast.typ option
-    val lookupEquation : env -> string -> Ast.exp option
+    val lookupEquation : env -> string -> (Ast.exp * env) option
     val lookupContext : env -> string -> bool
     val lookupInitialDynEnvVal : env -> string -> Ast.typ option
 

diff --git a/src/env.sml b/src/env.sml
index 4b5be9d..be8438a 100644 (file)
--- a/src/env.sml
+++ b/src/env.sml
@@ -212,42 +212,43 @@ fun container_one name args (f, g) = registerContainer (name, one name args f, g
 fun containerV_none name (f, g) = registerContainer (name, noneV name f, g)
 fun containerV_one name args (f, g) = registerContainer (name, oneV name args f, g)
 
-type env = SS.set * (typ * exp option) SM.map * SS.set * (typ * exp) SM.map
-val empty : env = (SS.empty, SM.empty, SS.empty, SM.empty)
+datatype env = Env of SS.set * (typ * exp option * env) SM.map * SS.set * (typ * exp * env) SM.map
+val empty : env = Env (SS.empty, SM.empty, SS.empty, SM.empty)
 
 
-fun initialDynEnvTypes (_, _, _, ds) =
-    SM.map (fn (t, e) => t) ds
+fun initialDynEnvTypes (Env (_, _, _, ds)) =
+    SM.map (fn (t, _, _) => t) ds
 
 (* hack ahead: These are not reduced when declared and must be before
    starting evaluation. Pass in reduceExp, and force an awkward
    calling convention so no one thinks this is the Right Way (tm) *)
-fun initialDynEnvVals f (env as (_, _, _, ds)) =
-    SM.map (fn (t, v) => f env v) ds
+fun initialDynEnvVals f (Env (_, _, _, ds)) =
+    SM.map (fn (t, v, env) => f env v) ds
 
-fun lookupType (ts, _, _, _) name = SS.member (ts, name)
-fun lookupVal (_, vs, _, _) name =
+fun lookupType (Env (ts, _, _, _)) name = SS.member (ts, name)
+fun lookupVal (Env (_, vs, _, _)) name =
     case SM.find (vs, name) of
        NONE => NONE
-      | SOME (t, _) => SOME t
-fun lookupEquation (_, vs, _, _) name =
+      | SOME (t, _, _) => SOME t
+fun lookupEquation (Env (_, vs, _, _)) name =
     case SM.find (vs, name) of
        NONE => NONE
-      | SOME (_, eqo) => eqo
-fun lookupContext (_, _, cs, _) name = SS.member (cs, name)
-fun lookupInitialDynEnvVal (_, _, _, ds) name =
+      | SOME (_, NONE, _) => NONE
+      | SOME (_, SOME eq, env) => SOME (eq, env)
+fun lookupContext (Env (_, _, cs, _)) name = SS.member (cs, name)
+fun lookupInitialDynEnvVal (Env (_, _, _, ds)) name =
     case SM.find (ds, name) of
        NONE => NONE
-      | SOME (t, _) => SOME t
+      | SOME (t, _, _) => SOME t
 
-fun bindType (ts, vs, cs, ds) name = (SS.add (ts, name), vs, cs, ds)
-fun bindVal (ts, vs, cs, ds) (name, t, eqo) = (ts, SM.insert (vs, name, (t, eqo)), cs, ds)
-fun bindContext (ts, vs, cs, ds) name = (ts, vs, SS.add (cs, name), ds)
-fun bindInitialDynEnvVal (ts, vs, cs, ds) (name, t, eqn) = (ts, vs, cs, SM.insert (ds, name, (t, eqn)))
+fun bindType (Env (ts, vs, cs, ds)) name = Env (SS.add (ts, name), vs, cs, ds)
+fun bindVal (env as (Env (ts, vs, cs, ds))) (name, t, eqo) = Env (ts, SM.insert (vs, name, (t, eqo, env)), cs, ds)
+fun bindContext (Env (ts, vs, cs, ds)) name = Env (ts, vs, SS.add (cs, name), ds)
+fun bindInitialDynEnvVal (env as (Env (ts, vs, cs, ds))) (name, t, eqn) = Env (ts, vs, cs, SM.insert (ds, name, (t, eqn, env)))
 
-fun types (ts, _, _, _) = ts
-fun vals (_, vs, _, _) = SM.foldli (fn (name, _, vs) => SS.add (vs, name)) SS.empty vs
-fun contexts (_, _, cs, _) = cs
-fun dynamics (_, _, _, ds) = SM.foldli (fn (name, _, ds) => SS.add (ds, name)) SS.empty ds
+fun types (Env (ts, _, _, _)) = ts
+fun vals (Env (_, vs, _, _)) = SM.foldli (fn (name, _, vs) => SS.add (vs, name)) SS.empty vs
+fun contexts (Env (_, _, cs, _)) = cs
+fun dynamics (Env (_, _, _, ds)) = SM.foldli (fn (name, _, ds) => SS.add (ds, name)) SS.empty ds
 
 end

diff --git a/src/reduce.sml b/src/reduce.sml
index 9e538d6..7996580 100644 (file)
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -143,7 +143,7 @@ fun reduceExp G (eAll as (e, loc)) =
                | SOME f => case f [] of
                                NONE => eAll
                              | SOME e' => reduceExp G e')
-          | SOME e => reduceExp G e)
+          | SOME (e, G') => reduceExp G' e)
       | EApp (e1, e2) =>
        let
            val e1' = reduceExp G e1