From 254d5faaae330b43f04ad7f39fb4340457d78776 Mon Sep 17 00:00:00 2001 From: Clinton Ebadi Date: Sat, 26 Apr 2014 21:19:29 -0400 Subject: [PATCH] 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. --- src/env.sig | 2 +- src/env.sml | 7 +++++-- src/eval.sig | 4 ++-- src/eval.sml | 28 +++++++++++++++------------- src/main.sml | 8 +++++--- 5 files changed, 28 insertions(+), 21 deletions(-) diff --git a/src/env.sig b/src/env.sig index c8371a8..d67c9f4 100644 --- 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 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 diff --git a/src/env.sml b/src/env.sml index 3b08094..4b5be9d 100644 --- 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 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 = diff --git a/src/eval.sig b/src/eval.sig index 3d05210..557e8c1 100644 --- a/src/eval.sig +++ b/src/eval.sig @@ -20,7 +20,7 @@ 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 diff --git a/src/eval.sml b/src/eval.sml index 08fd7f5..898a4a2 100644 --- 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,22 +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) => let - val e' = Reduce.subst x (lookup (evs, ev)) e + val e' = Reduce.subst x (lookup (evsAll, ev)) e 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 - val new' = exec' keep e + val new' = exec' (root, keep) e in (conjoin (new, new'), conjoin (keep, new')) @@ -81,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 @@ -93,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' @@ -107,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 = @@ -118,6 +120,6 @@ fun exec evs e = 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 diff --git a/src/main.sml b/src/main.sml index fe93791..cc35c62 100644 --- a/src/main.sml +++ b/src/main.sml @@ -194,6 +194,8 @@ fun reduce G fname = (*(Defaults.eInit ())*) +val toplevel = Env.initialDynEnvVals Reduce.reduceExp + 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 - val evs' = Eval.exec' evs body' + val evs' = Eval.exec' (toplevel G, evs) body' in (G, evs') end @@ -1150,7 +1152,7 @@ fun regenerateEither tc checker context = 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 @@ -1317,7 +1319,7 @@ fun service () = 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); -- 2.20.1