From 8061fadf3b4e8cb08c97fe61cb38476f66efa352 Mon Sep 17 00:00:00 2001
From: Clinton Ebadi <clinton@unknownlamer.org>
Date: Sat, 26 Apr 2014 22:11:24 -0400
Subject: [PATCH 1/1] 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.
---
 src/env.sig    |  2 +-
 src/env.sml    | 45 +++++++++++++++++++++++----------------------
 src/reduce.sml |  2 +-
 3 files changed, 25 insertions(+), 24 deletions(-)

diff --git a/src/env.sig b/src/env.sig
index d67c9f4..6668c5e 100644
--- 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
--- 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
--- 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
-- 
2.20.1