Reduce toplevel environment decls and allow them in user config

The root of the dynamic environment is passed separately to Eval.exec'
to allow user config to re-declare dynamics (like regular vals). This
uncovered (and perpetuates) a bug with process DVal/DEnv:

  val foo = "foo";
  val bar = foo;
  val foo = "bar";

When bar is expanded, it now has the value "bar" instead of
"foo", which is wrong.

diff --git a/src/env.sig b/src/env.sig
index c8371a8..d67c9f4 100644 (file)
--- a/src/env.sig
+++ b/src/env.sig
@@ -95,7 +95,7 @@ signature ENV = sig
     val empty : env
 
     val initialDynEnvTypes : env -> Ast.typ Ast.StringMap.map
     val empty : env
 
     val initialDynEnvTypes : env -> Ast.typ Ast.StringMap.map

-    val initialDynEnvVals : env -> env_vars
+    val initialDynEnvVals : (env -> Ast.exp -> Ast.exp) -> env -> env_vars

 
     val bindType : env -> string -> env
     val bindVal : env -> string * Ast.typ * Ast.exp option -> env
 
     val bindType : env -> string -> env
     val bindVal : env -> string * Ast.typ * Ast.exp option -> env

diff --git a/src/env.sml b/src/env.sml
index 3b08094..4b5be9d 100644 (file)
--- a/src/env.sml
+++ b/src/env.sml
@@ -219,8 +219,11 @@ val empty : env = (SS.empty, SM.empty, SS.empty, SM.empty)
 fun initialDynEnvTypes (_, _, _, ds) =
     SM.map (fn (t, e) => t) ds
 
 fun initialDynEnvTypes (_, _, _, ds) =
     SM.map (fn (t, e) => t) ds
 

-fun initialDynEnvVals (_, _, _, ds) =
-    SM.map (fn (t, v) => v) 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 lookupType (ts, _, _, _) name = SS.member (ts, name)
 fun lookupVal (_, vs, _, _) name =
 
 fun lookupType (ts, _, _, _) name = SS.member (ts, name)
 fun lookupVal (_, vs, _, _) name =

diff --git a/src/eval.sig b/src/eval.sig
index 3d05210..557e8c1 100644 (file)
--- a/src/eval.sig
+++ b/src/eval.sig
@@ -20,7 +20,7 @@
 
 signature EVAL = sig
 
 
 signature EVAL = sig
 

-    val exec : Env.env_vars -> Ast.exp -> unit
-    val exec' : Env.env_vars -> Ast.exp -> Env.env_vars
+    val exec : (Env.env_vars * Env.env_vars) -> Ast.exp -> unit
+    val exec' : (Env.env_vars * Env.env_vars) -> Ast.exp -> Env.env_vars

     
 end
     
 end

diff --git a/src/eval.sml b/src/eval.sml
index 08fd7f5..898a4a2 100644 (file)
--- a/src/eval.sml
+++ b/src/eval.sml
@@ -24,10 +24,12 @@ open Ast
 
 structure SM = StringMap
 
 
 structure SM = StringMap
 

-fun lookup (evs, ev) =
+fun lookup ((root, evs), ev) =

     case SM.find (evs, ev) of
     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) =
       | SOME v => v
 
 fun printEvs (name, evs) =


@@ -56,22 +58,22 @@ fun findPrimitive e =
        (name, rev args)
     end
 
        (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) =>
        let
     case e of
        ESkip => SM.empty
       | ESet (ev, e) => SM.insert (SM.empty, ev, e)
       | EGet (x, _, ev, e) =>
        let

-           val e' = Reduce.subst x (lookup (evs, ev)) e
+           val e' = Reduce.subst x (lookup (evsAll, ev)) e

        in
        in

-           exec' evs (Reduce.reduceExp Env.empty e')
+           exec' evsAll (Reduce.reduceExp Env.empty e')

        end
       | ESeq es =>
        let
            val (new, _) =
                foldl (fn (e, (new, keep)) =>
                          let
        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'))
                          in
                              (conjoin (new, new'),
                               conjoin (keep, new'))


@@ -81,9 +83,9 @@ fun exec' evs (eAll as (e, _)) =
        end
       | ELocal (e1, e2) =>
        let
        end
       | ELocal (e1, e2) =>
        let

-           val evs' = exec' evs e1
+           val evs' = exec' evsAll e1

        in
        in

-           exec' (conjoin (evs, evs')) e2
+           exec' (root, (conjoin (evs, evs'))) e2

        end
       | EWith (e1, e2) =>
        let
        end
       | EWith (e1, e2) =>
        let


@@ -93,8 +95,8 @@ fun exec' evs (eAll as (e, _)) =
                NONE => raise Fail "Unbound primitive container"
              | SOME (action, cleanup) =>
                let
                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'
                in
                    cleanup ();
                    evs'


@@ -107,7 +109,7 @@ fun exec' evs (eAll as (e, _)) =
        in
            case Env.action prim of
                NONE => raise Fail "Unbound primitive action"
        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 =
        end
 
 fun exec evs e =


@@ -118,6 +120,6 @@ fun exec evs e =
        Env.post ()
     end
 
        Env.post ()
     end
 

-val exec' = fn evs => fn e => conjoin (evs, exec' evs e)
+val exec' = fn evs as (root, evs')  => fn e => conjoin (evs', exec' evs e)

 
 end
 
 end

diff --git a/src/main.sml b/src/main.sml
index fe93791..cc35c62 100644 (file)
--- a/src/main.sml
+++ b/src/main.sml
@@ -194,6 +194,8 @@ fun reduce G fname =
 
 (*(Defaults.eInit ())*)
 
 
 (*(Defaults.eInit ())*)
 

+val toplevel = Env.initialDynEnvVals Reduce.reduceExp
+

 fun eval G evs fname =
     case reduce G fname of
        (G, SOME body') =>
 fun eval G evs fname =
     case reduce G fname of
        (G, SOME body') =>


@@ -201,7 +203,7 @@ fun eval G evs fname =
            raise ErrorMsg.Error
        else
            let
            raise ErrorMsg.Error
        else
            let

-               val evs' = Eval.exec' evs body'
+               val evs' = Eval.exec' (toplevel G, evs) body'

            in
                (G, evs')
            end
            in
                (G, evs')
            end


@@ -1150,7 +1152,7 @@ fun regenerateEither tc checker context =
                        else
                            ();
                        let val basis' = basis () in
                        else
                            ();
                        let val basis' = basis () in

-                           ignore (foldl checker' (basis', Env.initialDynEnvVals basis') files)
+                           ignore (foldl checker' (basis', SM.empty) files)

                        end
                    end
                else if String.isSuffix "_admin" user then
                        end
                    end
                else if String.isSuffix "_admin" user then


@@ -1317,7 +1319,7 @@ fun service () =
                         in
                             doIt (fn () => (Env.pre ();
                                             let val basis' = basis () in
                         in
                             doIt (fn () => (Env.pre ();
                                             let val basis' = basis () in

-                                                ignore (foldl doOne (basis', Env.initialDynEnvVals basis') codes)
+                                                ignore (foldl doOne (basis', SM.empty) codes)

                                             end;
                                             Env.post ();
                                             Msg.send (bio, MsgOk);
                                             end;
                                             Env.post ();
                                             Msg.send (bio, MsgOk);