From 24248d627b677abd0a21092f71c445b0934f2bdc Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 24 Feb 2008 20:10:15 +0000 Subject: [PATCH] Saving environment variables across file executions --- src/autodoc.sml | 2 +- src/defaults.sig | 2 +- src/defaults.sml | 25 ++++++++++++--- src/domtool.grm | 5 ++- src/eval.sml | 2 ++ src/main-client.sml | 2 +- src/main.sig | 6 ++-- src/main.sml | 76 +++++++++++++++++++++++++++------------------ 8 files changed, 77 insertions(+), 43 deletions(-) diff --git a/src/autodoc.sml b/src/autodoc.sml index c64180d..bdf2527 100644 --- a/src/autodoc.sml +++ b/src/autodoc.sml @@ -36,7 +36,7 @@ fun check' G fname = if !ErrorMsg.anyErrors then G else - Tycheck.checkFile G (Defaults.tInit ()) prog + Tycheck.checkFile G (Defaults.tInit prog) prog end fun autodoc {outdir, infiles} = diff --git a/src/defaults.sig b/src/defaults.sig index c380705..7dbe773 100644 --- a/src/defaults.sig +++ b/src/defaults.sig @@ -21,6 +21,6 @@ signature DEFAULTS = sig val registerDefault : string * Ast.typ * (unit -> Ast.exp) -> unit - val tInit : unit -> Ast.typ + val tInit : Ast.file -> Ast.typ val eInit : unit -> Env.env_vars end diff --git a/src/defaults.sml b/src/defaults.sml index 43dced5..8ca63f7 100644 --- a/src/defaults.sml +++ b/src/defaults.sml @@ -35,10 +35,27 @@ fun registerDefault (name, t, v) = defaultV := SM.insert (!defaultV, name, v)) | SOME _ => raise Fail "Duplicate default environment variable" -fun tInit () = (TAction ((CRoot, dmy), - !defaultT, - StringMap.empty), - dmy) +fun allSets (e, _) = + case e of + ESkip => true + | ESet _ => true + | ESeq es => List.all allSets es + | _ => false + +val dmy = ErrorMsg.dummyLoc + +fun bodyType (_, _, SOME e) = + if allSets e then + (CPrefix (CRoot, dmy), dmy) + else + (CRoot, dmy) + | bodyType _ = (CRoot, dmy) + +fun tInit p = + (TAction (bodyType p, + !defaultT, + StringMap.empty), + dmy) fun eInit () = SM.map (fn f => f ()) (!defaultV) diff --git a/src/domtool.grm b/src/domtool.grm index 0cc4fbd..13ee80b 100644 --- a/src/domtool.grm +++ b/src/domtool.grm @@ -79,7 +79,7 @@ open Ast %% -file : docOpt decls expOpt (docOpt, decls, expOpt) +file : docOpt decls expOpt SEMIopt (docOpt, decls, expOpt) decls : ([]) | decl decls (decl :: decls) @@ -96,8 +96,7 @@ docOpt : (NONE) | DOC (SOME DOC) expOpt : (NONE) - | exp (SOME (ELocal (exp, (ESkip, (expleft, expright))), - (expleft, expright))) + | exp (SOME exp) exp : apps (apps) diff --git a/src/eval.sml b/src/eval.sml index c41f796..08fd7f5 100644 --- a/src/eval.sml +++ b/src/eval.sml @@ -118,4 +118,6 @@ fun exec evs e = Env.post () end +val exec' = fn evs => fn e => conjoin (evs, exec' evs e) + end diff --git a/src/main-client.sml b/src/main-client.sml index 8d5f012..ef083b4 100644 --- a/src/main-client.sml +++ b/src/main-client.sml @@ -33,7 +33,7 @@ fun domtoolRoot () = val (doit, doitDir, args) = case CommandLine.arguments () of - "-tc" :: args => (fn fname => (Main.setupUser (); ignore (Main.check fname)), + "-tc" :: args => (fn fname => (Main.setupUser (); ignore (Main.check (Main.basis ()) fname)), Main.checkDir, args) | args => (Main.request, diff --git a/src/main.sig b/src/main.sig index 53f019d..29f41b1 100644 --- a/src/main.sig +++ b/src/main.sig @@ -23,14 +23,14 @@ signature MAIN = sig val init : unit -> unit val setupUser : unit -> string - val check : string -> Env.env * Ast.exp option + val check : Env.env -> string -> Env.env * Ast.exp option val check' : Env.env -> string -> Env.env val checkDir : string -> unit val basis : unit -> Env.env - val reduce : string -> Ast.exp option - val eval : string -> unit + val reduce : Env.env -> string -> (Env.env * Ast.exp) option + val eval : Env.env -> Env.env_vars -> string -> Env.env * Env.env_vars val request : string -> unit val requestDir : string -> unit diff --git a/src/main.sml b/src/main.sml index eaee4fc..a0f402d 100644 --- a/src/main.sml +++ b/src/main.sml @@ -25,16 +25,29 @@ open Ast MsgTypes Print structure SM = StringMap fun init () = Acl.read Config.aclFile - + +fun isLib fname = OS.Path.file fname = "lib.dtl" + +fun wrapFile (fname, file) = + case (isLib fname, file) of + (true, (comment, ds, SOME e)) => + let + val (_, loc) = e + in + (comment, ds, SOME (ELocal (e, (ESkip, loc)), loc)) + end + | _ => file + fun check' G fname = let val prog = Parse.parse fname + val prog = wrapFile (fname, prog) in if !ErrorMsg.anyErrors then G else (Option.app (Unused.check G) (#3 prog); - Tycheck.checkFile G (Defaults.tInit ()) prog) + Tycheck.checkFile G (Defaults.tInit prog) prog) end fun basis () = @@ -64,12 +77,12 @@ fun basis () = before Tycheck.disallowExterns ()) end -fun check fname = +(* val b = basis () *) + +fun check G fname = let val _ = ErrorMsg.reset () val _ = Env.preTycheck () - - val b = basis () in if !ErrorMsg.anyErrors then raise ErrorMsg.Error @@ -78,17 +91,18 @@ fun check fname = val _ = Tycheck.disallowExterns () val _ = ErrorMsg.reset () val prog = Parse.parse fname + val prog = wrapFile (fname, prog) in if !ErrorMsg.anyErrors then raise ErrorMsg.Error else let - val G' = Tycheck.checkFile b (Defaults.tInit ()) prog + val G' = Tycheck.checkFile G (Defaults.tInit prog) prog in if !ErrorMsg.anyErrors then raise ErrorMsg.Error else - (Option.app (Unused.check b) (#3 prog); + (Option.app (Unused.check G) (#3 prog); (G', #3 prog)) end end @@ -150,9 +164,9 @@ fun checkDir dname = (setupUser (); checkDir' dname) -fun reduce fname = +fun reduce G fname = let - val (G, body) = check fname + val (G, body) = check G fname in if !ErrorMsg.anyErrors then NONE @@ -166,28 +180,25 @@ fun reduce fname = [PD.string "Result:", PD.space 1, p_exp body']))*) - SOME body' + SOME (G, body') end | _ => NONE end -fun eval fname = - case reduce fname of - (SOME body') => - if !ErrorMsg.anyErrors then - raise ErrorMsg.Error - else - Eval.exec (Defaults.eInit ()) body' - | NONE => () +(*(Defaults.eInit ())*) -fun eval' fname = - case reduce fname of - (SOME body') => +fun eval G evs fname = + case reduce G fname of + SOME (G, body') => if !ErrorMsg.anyErrors then raise ErrorMsg.Error else - ignore (Eval.exec' (Defaults.eInit ()) body') - | NONE => () + let + val evs' = Eval.exec' evs body' + in + (G, evs') + end + | NONE => (G, evs) val dispatcher = Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort @@ -232,7 +243,7 @@ fun requestSlaveBio () = fun request fname = let - val (user, bio) = requestBio (fn () => ignore (check fname)) + val (user, bio) = requestBio (fn () => ignore (check (basis ()) fname)) val inf = TextIO.openIn fname @@ -1017,6 +1028,9 @@ fun regenerateEither tc checker context = val files = loop [] val (_, files) = Order.order (SOME b) files + + fun checker' (file, (G, evs)) = + checker G evs file in if !ErrorMsg.anyErrors then (ErrorMsg.reset (); @@ -1024,7 +1038,7 @@ fun regenerateEither tc checker context = ok := false) else (); - app checker files + ignore (foldl checker' (basis (), Defaults.eInit ()) files) end else if String.isSuffix "_admin" user then () @@ -1065,8 +1079,10 @@ fun regenerateEither tc checker context = !ok end -val regenerate = regenerateEither false eval' -val regenerateTc = regenerateEither true (ignore o check) +val regenerate = regenerateEither false eval +val regenerateTc = regenerateEither true + (fn G => fn evs => fn file => + (#1 (check G file), evs)) fun rmuser user = let @@ -1165,17 +1181,17 @@ fun service () = val outname = OS.FileSys.tmpName () - fun doOne code = + fun doOne (code, (G, evs)) = let val outf = TextIO.openOut outname in TextIO.output (outf, code); TextIO.closeOut outf; - eval' outname + eval G evs outname end in doIt (fn () => (Env.pre (); - app doOne codes; + ignore (foldl doOne (basis (), Defaults.eInit ()) codes); Env.post (); Msg.send (bio, MsgOk); ("Configuration complete.", NONE))) -- 2.20.1