(* HCoop Domtool (http://hcoop.sourceforge.net/)
* Copyright (c) 2006, Adam Chlipala
+ * Copyright (c) 2014 Clinton Ebadi <clinton@unknownlamer.org>
*
* This program is free software; you can redistribute it and/or
* modify it under the terms of the GNU General Public License
val dt = (TError, ErrorMsg.dummyLoc)
-fun expNeeded G (e, _) =
+fun expNeeded G (e, loc) =
case e of
EInt _ => ((SS.empty,
if Env.lookupType G "int" then
| SOME t => unionCTE ((typNeeded G t, SS.empty),
expNeeded G' e)
end
+ | EALam (x, p, e) =>
+ let
+ val G' = Env.bindVal G (x, (TAction (p, StringMap.empty, StringMap.empty), loc), NONE)
+ in
+ unionCTE (((predNeeded G p, SS.empty), SS.empty),
+ expNeeded G' e)
+ end
| EVar x =>
(case Env.lookupVal G x of
NONE => ((SS.empty, SS.empty), SS.singleton x)
| ESkip => empty
| ESet (_, e) => expNeeded G e
- | EGet (x, _, e) => expNeeded (Env.bindVal G (x, dt, NONE)) e
+ | EGet (x, topt, _, e) =>
+ (case topt of
+ NONE => expNeeded (Env.bindVal G (x, dt, NONE)) e
+ | SOME t => unionCTE ((typNeeded G t, SS.empty),
+ expNeeded (Env.bindVal G (x, dt, NONE)) e))
| ESeq es => foldl (fn (e, ss) => unionCTE (ss, expNeeded G e))
empty es
| ELocal (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
| EWith (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
+ | EIf (e1, e2, e3) => unionCTE (expNeeded G e1,
+ unionCTE (expNeeded G e2,
+ expNeeded G e3))
fun declNeeded G (d, _, _) =
case d of
NONE => expNeeded G e
| SOME t => unionCTE ((typNeeded G t, SS.empty),
expNeeded G e))
+ | DEnv (name, to, e) => (Env.bindInitialDynEnvVal G (name, dt, (Ast.ESkip, ErrorMsg.dummyLoc)),
+ case to of
+ NONE => expNeeded G e
+ | SOME t => unionCTE ((typNeeded G t, SS.empty),
+ expNeeded G e))
| DContext name => (Env.bindContext G name, empty)
fun fileSig (_, ds, eo) =
SS.app (fn s => (print " "; print s; print ";")) vs;
print "\n")
+val allNaughty = ref false
+val naughtyFiles = ref SS.empty
+fun addNaughty fname = naughtyFiles := SS.add (!naughtyFiles, fname)
+
fun mergeProvide kind fname (m1, m2) =
SS.foldl (fn (name, provide) =>
(case SM.find (provide, name) of
NONE => ()
- | SOME fname' => ErrorMsg.error NONE (String.concat ["Files ",
- fname',
- " and ",
- fname,
- " both provide ",
- kind,
- " ",
- name]);
+ | SOME fname' =>
+ (addNaughty fname;
+ addNaughty fname';
+ ErrorMsg.error NONE (String.concat ["Files ",
+ fname',
+ " and ",
+ fname,
+ " both provide ",
+ kind,
+ " ",
+ name]));
SM.insert (provide, name, fname)))
m1 m2
-fun order fnames =
+fun order basisOpt fnames =
let
+ val () = allNaughty := false
+ val () = naughtyFiles := SS.empty
+
fun doFile (fname, (provideC, provideT, provideV, require)) =
let
val file = Parse.parse fname
val require = SM.mapi (fn (fname, ((rc, rt), rv)) =>
let
- fun consider (kind, provide) =
+ fun consider (kind, provide, lastChance) =
SS.foldl (fn (name, need) =>
case SM.find (provide, name) of
- NONE => (ErrorMsg.error NONE
- ("File "
- ^ fname
- ^ " uses undefined "
- ^ kind
- ^ " "
- ^ name);
- need)
+ NONE =>
+ if lastChance name then
+ need
+ else
+ (addNaughty fname;
+ ErrorMsg.error NONE
+ ("File "
+ ^ fname
+ ^ " uses undefined "
+ ^ kind
+ ^ " "
+ ^ name);
+ need)
| SOME fname' =>
SS.add (need, fname'))
- val need = consider ("context", provideC)
+ val need = consider ("context", provideC,
+ case basisOpt of
+ NONE => (fn _ => false)
+ | SOME b => Env.lookupContext b)
SS.empty rc
- val need = consider ("type", provideT)
+ val need = consider ("type", provideT,
+ case basisOpt of
+ NONE => (fn _ => false)
+ | SOME b => Env.lookupType b)
need rt
- val need = consider ("value", provideV)
+ val need = consider ("value", provideV,
+ case basisOpt of
+ NONE => (fn _ => false)
+ | SOME b => (fn name => Option.isSome (Env.lookupVal b name)))
need rv
in
need
if SM.numItems waiting = 0 then
rev order
else
- (ErrorMsg.error NONE "Cyclic dependency in source files";
+ (allNaughty := true;
+ ErrorMsg.error NONE "Cyclic dependency in source files";
order)
| SOME next =>
let
(ready,
SM.insert (waiting, fname, requires)))
(SS.empty, SM.empty) require
+
+ val ordered = loop (ready, waiting, [])
+ val provider = {provideC = provideC,
+ provideT = provideT,
+ provideV = provideV}
in
- (*SM.appi (fn (name, fname) => print ("Context " ^ name ^ " in " ^ fname ^ "\n")) provideC;
- SM.appi (fn (name, fname) => print ("Type " ^ name ^ " in " ^ fname ^ "\n")) provideT;
- SM.appi (fn (name, fname) => print ("Value " ^ name ^ " in " ^ fname ^ "\n")) provideV;*)
-
- (*SM.appi (fn (fname, requires) =>
- (print fname;
- print " requires:";
- SS.app (fn fname' => (print " "; print fname')) requires;
- print "\n")) require;*)
-
- ({provideC = provideC,
- provideT = provideT,
- provideV = provideV},
- loop (ready, waiting, []))
+ if !allNaughty then
+ (provider, [])
+ else if SS.isEmpty (!naughtyFiles) then
+ (provider, ordered)
+ else
+ order basisOpt (List.filter (fn fname => not (SS.member (!naughtyFiles, fname))) fnames)
end
+val order = fn basisOpt => fn fnames =>
+ let
+ val (providers, fnames) = order basisOpt fnames
+
+ val (hasLib, fnames) = foldl (fn (fname, (hasLib, fnames)) =>
+ if OS.Path.file fname = "lib.dtl" then
+ (SOME fname, fnames)
+ else
+ (hasLib, fname :: fnames))
+ (NONE, []) fnames
+
+ val fnames = rev fnames
+ val fnames = case hasLib of
+ NONE => fnames
+ | SOME hasLib => hasLib :: fnames
+ in
+ (providers, fnames)
+ end
+
type providers = {provideC : string SM.map,
provideT : string SM.map,
provideV : string SM.map}
HCoop / hcoop / domtool2.git / blobdiff