+(* HCoop Domtool (http://hcoop.sourceforge.net/)
+ * Copyright (c) 2006, Adam Chlipala
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+ *)
+
+(* Topological sorting of source files to take dependencies into account *)
+
+structure Order :> ORDER = struct
+
+open Ast
+
+structure SS = StringSet
+structure SM = StringMap
+
+fun predNeeded G (p, _) =
+ case p of
+ CRoot => SS.empty
+ | CConst s =>
+ if Env.lookupContext G s then
+ SS.empty
+ else
+ SS.singleton s
+ | CPrefix p => predNeeded G p
+ | CNot p => predNeeded G p
+ | CAnd (p1, p2) => SS.union (predNeeded G p1, predNeeded G p2)
+
+fun unionCT ((c1, t1), (c2, t2)) = (SS.union (c1, c2), SS.union (t1, t2))
+
+fun typNeeded G (t, _) =
+ case t of
+ TBase s =>
+ if Env.lookupType G s then
+ (SS.empty, SS.empty)
+ else
+ (SS.empty, SS.singleton s)
+ | TList t => typNeeded G t
+ | TArrow (t1, t2) => unionCT (typNeeded G t1, typNeeded G t2)
+ | TAction (p, d, r) =>
+ let
+ val recordNeeded = SM.foldl
+ (fn (t, ss) => unionCT (ss, typNeeded G t))
+ in
+ recordNeeded (recordNeeded (predNeeded G p, SS.empty) d) r
+ end
+ | TNested (p, t) => unionCT ((predNeeded G p, SS.empty),
+ typNeeded G t)
+
+ | TError => raise Fail "TError during dependency analysis"
+ | TUnif _ => raise Fail "TUnif during dependency analysis"
+
+val empty = ((SS.empty, SS.empty), SS.empty)
+
+fun unionCTE (((c1, t1), v1), ((c2, t2), v2)) =
+ ((SS.union (c1, c2),
+ SS.union (t1, t2)),
+ SS.union (v1, v2))
+
+val dt = (TError, ErrorMsg.dummyLoc)
+
+fun expNeeded G (e, _) =
+ case e of
+ EInt _ => ((SS.empty,
+ if Env.lookupType G "int" then
+ SS.empty
+ else
+ SS.singleton "int"),
+ SS.empty)
+ | EString _ => ((SS.empty,
+ if Env.lookupType G "string" then
+ SS.empty
+ else
+ SS.singleton "string"),
+ SS.empty)
+ | EList es => foldl (fn (e, ss) => unionCTE (ss, expNeeded G e))
+ empty es
+
+ | ELam (x, to, e) =>
+ let
+ val G' = Env.bindVal G (x, dt, NONE)
+ in
+ case to of
+ NONE => expNeeded G' e
+ | SOME t => unionCTE ((typNeeded G t, SS.empty),
+ expNeeded G' e)
+ end
+ | EVar x =>
+ (case Env.lookupVal G x of
+ NONE => ((SS.empty, SS.empty), SS.singleton x)
+ | _ => empty)
+ | EApp (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
+
+ | ESkip => empty
+ | ESet (_, e) => expNeeded G e
+ | EGet (x, _, e) => 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)
+
+fun declNeeded G (d, _, _) =
+ case d of
+ DExternType name => (Env.bindType G name, empty)
+ | DExternVal (name, t) => (Env.bindVal G (name, dt, NONE),
+ (typNeeded G t, SS.empty))
+ | DVal (name, to, e) => (Env.bindVal G (name, dt, NONE),
+ 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) =
+ let
+ val (G', needed) = foldl
+ (fn (d, (G, needed)) =>
+ let
+ val (G', needed') = declNeeded G d
+ in
+ (G', unionCTE (needed, needed'))
+ end)
+ (Env.empty, empty) ds
+
+ val needed =
+ case eo of
+ NONE => needed
+ | SOME e => unionCTE (needed,
+ expNeeded G' e)
+ in
+ (((Env.contexts G', Env.types G'), Env.vals G'),
+ needed)
+ end
+
+fun printSig ((cs, ts), vs) =
+ (print "Contexts:";
+ SS.app (fn s => (print " "; print s; print ";")) cs;
+ print "\n Types:";
+ SS.app (fn s => (print " "; print s; print ";")) ts;
+ print "\n Values:";
+ SS.app (fn s => (print " "; print s; print ";")) vs;
+ print "\n")
+
+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]);
+ SM.insert (provide, name, fname)))
+ m1 m2
+
+fun order fnames =
+ let
+ fun doFile fname =
+ let
+ val file = Parse.parse fname
+ val (provide, require) = fileSig file
+ in
+ print "\nFile ";
+ print fname;
+ print "\nPROVIDE:\n";
+ printSig provide;
+ print "\nREQUIRE:\n";
+ printSig require
+ end
+
+ fun doFile (fname, (provideC, provideT, provideV, require)) =
+ let
+ val file = Parse.parse fname
+ val (((provideC', provideT'), provideV'),
+ require') = fileSig file
+ in
+ (mergeProvide "context" fname (provideC, provideC'),
+ mergeProvide "type" fname (provideT, provideT'),
+ mergeProvide "value" fname (provideV, provideV'),
+ SM.insert (require, fname, require'))
+ end
+
+ val (provideC, provideT, provideV, require) =
+ foldl doFile (SM.empty, SM.empty, SM.empty, SM.empty) fnames
+
+ val require = SM.mapi (fn (fname, ((rc, rt), rv)) =>
+ let
+ fun consider (kind, provide) =
+ SS.foldl (fn (name, need) =>
+ case SM.find (provide, name) of
+ NONE => (ErrorMsg.error NONE
+ ("File "
+ ^ fname
+ ^ " uses undefined "
+ ^ kind
+ ^ " "
+ ^ name);
+ need)
+ | SOME fname' =>
+ SS.add (need, fname'))
+
+ val need = consider ("context", provideC)
+ SS.empty rc
+ val need = consider ("type", provideT)
+ need rt
+ val need = consider ("value", provideV)
+ need rv
+ in
+ need
+ end) require
+
+ fun loop (ready, waiting, order) =
+ case SS.find (fn _ => true) ready of
+ NONE =>
+ if SM.numItems waiting = 0 then
+ rev order
+ else
+ (ErrorMsg.error NONE "Cyclic dependency in source files";
+ order)
+ | SOME next =>
+ let
+ val (ready', waiting') =
+ SM.foldli (fn (fname, requires, (ready', waiting')) =>
+ let
+ val requires' = SS.delete (requires, next)
+ handle NotFound => requires
+ in
+ if SS.numItems requires' = 0 then
+ (SS.add (ready', fname),
+ waiting')
+ else
+ (ready',
+ SM.insert (waiting', fname, requires'))
+ end)
+ (SS.delete (ready, next), SM.empty) waiting
+ in
+ loop (ready', waiting', next :: order)
+ end
+
+ val (ready, waiting) =
+ SM.foldli (fn (fname, requires, (ready, waiting)) =>
+ if SS.numItems requires = 0 then
+ (SS.add (ready, fname),
+ waiting)
+ else
+ (ready,
+ SM.insert (waiting, fname, requires)))
+ (SS.empty, SM.empty) require
+ 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;*)
+
+ loop (ready, waiting, [])
+ end
+
+end
HCoop / hcoop / domtool2.git / commitdiff