Reduce toplevel environment decls and allow them in user config

[hcoop/domtool2.git] / src / eval.sml

diff --git a/src/eval.sml b/src/eval.sml
index 1fec487..898a4a2 100644 (file)
--- a/src/eval.sml
+++ b/src/eval.sml
@@ -24,10 +24,12 @@ open Ast
 
 structure SM = StringMap
 
-fun lookup (evs, ev) =
+fun lookup ((root, evs), ev) =
     case SM.find (evs, ev) of
-       NONE => raise Fail ("Couldn't find an environment variable "
-                           ^ ev ^ " that type-checking has guaranteed")
+       NONE => (case SM.find (root, ev) of
+                    NONE => raise Fail ("Couldn't find an environment variable "
+                                        ^ ev ^ " that type-checking has guaranteed")
+                  | SOME v => v)
       | SOME v => v
 
 fun printEvs (name, evs) =
@@ -56,17 +58,22 @@ fun findPrimitive e =
        (name, rev args)
     end
 
-fun exec' evs (eAll as (e, _)) =
+fun exec' (evsAll as (root, evs)) (eAll as (e, _)) =
     case e of
        ESkip => SM.empty
       | ESet (ev, e) => SM.insert (SM.empty, ev, e)
-      | EGet (x, _, ev, e) => exec' evs (Reduce.subst x (lookup (evs, ev)) e)
+      | EGet (x, _, ev, e) =>
+       let
+           val e' = Reduce.subst x (lookup (evsAll, ev)) e
+       in
+           exec' evsAll (Reduce.reduceExp Env.empty e')
+       end
       | ESeq es =>
        let
            val (new, _) =
                foldl (fn (e, (new, keep)) =>
                          let
-                             val new' = exec' keep e
+                             val new' = exec' (root, keep) e
                          in
                              (conjoin (new, new'),
                               conjoin (keep, new'))
@@ -76,9 +83,9 @@ fun exec' evs (eAll as (e, _)) =
        end
       | ELocal (e1, e2) =>
        let
-           val evs' = exec' evs e1
+           val evs' = exec' evsAll e1
        in
-           exec' (conjoin (evs, evs')) e2
+           exec' (root, (conjoin (evs, evs'))) e2
        end
       | EWith (e1, e2) =>
        let
@@ -88,8 +95,8 @@ fun exec' evs (eAll as (e, _)) =
                NONE => raise Fail "Unbound primitive container"
              | SOME (action, cleanup) =>
                let
-                   val evs' = action (evs, args)
-                   val evs'' = exec' evs e2
+                   val evs' = action (conjoin (root, evs), args)
+                   val evs'' = exec' evsAll e2
                in
                    cleanup ();
                    evs'
@@ -102,7 +109,7 @@ fun exec' evs (eAll as (e, _)) =
        in
            case Env.action prim of
                NONE => raise Fail "Unbound primitive action"
-             | SOME action => action (evs, List.map (Reduce.reduceExp Env.empty) args)
+             | SOME action => action (conjoin (root, evs), List.map (Reduce.reduceExp Env.empty) args)
        end
 
 fun exec evs e =
@@ -113,4 +120,6 @@ fun exec evs e =
        Env.post ()
     end
 
+val exec' = fn evs as (root, evs')  => fn e => conjoin (evs', exec' evs e)
+
 end