1 (* HCoop
Domtool (http
://hcoop
.sourceforge
.net
/)
2 * Copyright (c
) 2006, Adam Chlipala
4 * This program is free software
; you can redistribute it
and/or
5 * modify it under the terms
of the GNU General Public License
6 * as published by the Free Software Foundation
; either version
2
7 * of the License
, or (at your option
) any later version
.
9 * This program is distributed
in the hope that it will be useful
,
10 * but WITHOUT ANY WARRANTY
; without even the implied warranty
of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
. See the
12 * GNU General Public License for more details
.
14 * You should have received a copy
of the GNU General Public License
15 * along
with this program
; if not
, write to the Free Software
16 * Foundation
, Inc
., 51 Franklin Street
, Fifth Floor
, Boston
, MA
02110-1301, USA
.
19 (* Topological sorting
of source files to take dependencies into account
*)
21 structure Order
:> ORDER
= struct
25 structure SS
= StringSet
26 structure SM
= StringMap
28 fun predNeeded
G (p
, _
) =
32 if Env
.lookupContext G s
then
36 | CPrefix p
=> predNeeded G p
37 | CNot p
=> predNeeded G p
38 |
CAnd (p1
, p2
) => SS
.union (predNeeded G p1
, predNeeded G p2
)
40 fun unionCT ((c1
, t1
), (c2
, t2
)) = (SS
.union (c1
, c2
), SS
.union (t1
, t2
))
42 fun typNeeded
G (t
, _
) =
45 if Env
.lookupType G s
then
48 (SS
.empty
, SS
.singleton s
)
49 | TList t
=> typNeeded G t
50 |
TArrow (t1
, t2
) => unionCT (typNeeded G t1
, typNeeded G t2
)
51 |
TAction (p
, d
, r
) =>
53 val recordNeeded
= SM
.foldl
54 (fn (t
, ss
) => unionCT (ss
, typNeeded G t
))
56 recordNeeded (recordNeeded (predNeeded G p
, SS
.empty
) d
) r
58 |
TNested (p
, t
) => unionCT ((predNeeded G p
, SS
.empty
),
61 | TError
=> raise Fail
"TError during dependency analysis"
62 | TUnif _
=> raise Fail
"TUnif during dependency analysis"
64 val empty
= ((SS
.empty
, SS
.empty
), SS
.empty
)
66 fun unionCTE (((c1
, t1
), v1
), ((c2
, t2
), v2
)) =
71 val dt
= (TError
, ErrorMsg
.dummyLoc
)
73 fun expNeeded
G (e
, _
) =
76 if Env
.lookupType G
"int" then
81 | EString _
=> ((SS
.empty
,
82 if Env
.lookupType G
"string" then
85 SS
.singleton
"string"),
87 | EList es
=> foldl (fn (e
, ss
) => unionCTE (ss
, expNeeded G e
))
92 val G
' = Env
.bindVal
G (x
, dt
, NONE
)
95 NONE
=> expNeeded G
' e
96 | SOME t
=> unionCTE ((typNeeded G t
, SS
.empty
),
100 (case Env
.lookupVal G x
of
101 NONE
=> ((SS
.empty
, SS
.empty
), SS
.singleton x
)
103 |
EApp (e1
, e2
) => unionCTE (expNeeded G e1
, expNeeded G e2
)
106 |
ESet (_
, e
) => expNeeded G e
107 |
EGet (x
, _
, e
) => expNeeded (Env
.bindVal
G (x
, dt
, NONE
)) e
108 | ESeq es
=> foldl (fn (e
, ss
) => unionCTE (ss
, expNeeded G e
))
110 |
ELocal (e1
, e2
) => unionCTE (expNeeded G e1
, expNeeded G e2
)
111 |
EWith (e1
, e2
) => unionCTE (expNeeded G e1
, expNeeded G e2
)
113 fun declNeeded
G (d
, _
, _
) =
115 DExternType name
=> (Env
.bindType G name
, empty
)
116 |
DExternVal (name
, t
) => (Env
.bindVal
G (name
, dt
, NONE
),
117 (typNeeded G t
, SS
.empty
))
118 |
DVal (name
, to
, e
) => (Env
.bindVal
G (name
, dt
, NONE
),
120 NONE
=> expNeeded G e
121 | SOME t
=> unionCTE ((typNeeded G t
, SS
.empty
),
123 | DContext name
=> (Env
.bindContext G name
, empty
)
125 fun fileSig (_
, ds
, eo
) =
127 val (G
', needed
) = foldl
128 (fn (d
, (G
, needed
)) =>
130 val (G
', needed
') = declNeeded G d
132 (G
', unionCTE (needed
, needed
'))
134 (Env
.empty
, empty
) ds
139 | SOME e
=> unionCTE (needed
,
142 (((Env
.contexts G
', Env
.types G
'), Env
.vals G
'),
146 fun printSig ((cs
, ts
), vs
) =
148 SS
.app (fn s
=> (print
" "; print s
; print
";")) cs
;
150 SS
.app (fn s
=> (print
" "; print s
; print
";")) ts
;
152 SS
.app (fn s
=> (print
" "; print s
; print
";")) vs
;
155 fun mergeProvide kind
fname (m1
, m2
) =
156 SS
.foldl (fn (name
, provide
) =>
157 (case SM
.find (provide
, name
) of
159 | SOME fname
' => ErrorMsg
.error
NONE (String.concat
["Files ",
167 SM
.insert (provide
, name
, fname
)))
174 val file
= Parse
.parse fname
175 val (provide
, require
) = fileSig file
179 print
"\nPROVIDE:\n";
181 print
"\nREQUIRE:\n";
185 fun doFile (fname
, (provideC
, provideT
, provideV
, require
)) =
187 val file
= Parse
.parse fname
188 val (((provideC
', provideT
'), provideV
'),
189 require
') = fileSig file
191 (mergeProvide
"context" fname (provideC
, provideC
'),
192 mergeProvide
"type" fname (provideT
, provideT
'),
193 mergeProvide
"value" fname (provideV
, provideV
'),
194 SM
.insert (require
, fname
, require
'))
197 val (provideC
, provideT
, provideV
, require
) =
198 foldl
doFile (SM
.empty
, SM
.empty
, SM
.empty
, SM
.empty
) fnames
200 val require
= SM
.mapi (fn (fname
, ((rc
, rt
), rv
)) =>
202 fun consider (kind
, provide
) =
203 SS
.foldl (fn (name
, need
) =>
204 case SM
.find (provide
, name
) of
205 NONE
=> (ErrorMsg
.error NONE
214 SS
.add (need
, fname
'))
216 val need
= consider ("context", provideC
)
218 val need
= consider ("type", provideT
)
220 val need
= consider ("value", provideV
)
226 fun loop (ready
, waiting
, order
) =
227 case SS
.find (fn _
=> true) ready
of
229 if SM
.numItems waiting
= 0 then
232 (ErrorMsg
.error NONE
"Cyclic dependency in source files";
236 val (ready
', waiting
') =
237 SM
.foldli (fn (fname
, requires
, (ready
', waiting
')) =>
239 val requires
' = SS
.delete (requires
, next
)
240 handle NotFound
=> requires
242 if SS
.numItems requires
' = 0 then
243 (SS
.add (ready
', fname
),
247 SM
.insert (waiting
', fname
, requires
'))
249 (SS
.delete (ready
, next
), SM
.empty
) waiting
251 loop (ready
', waiting
', next
:: order
)
254 val (ready
, waiting
) =
255 SM
.foldli (fn (fname
, requires
, (ready
, waiting
)) =>
256 if SS
.numItems requires
= 0 then
257 (SS
.add (ready
, fname
),
261 SM
.insert (waiting
, fname
, requires
)))
262 (SS
.empty
, SM
.empty
) require
264 (*SM
.appi (fn (name
, fname
) => print ("Context " ^ name ^
" in " ^ fname ^
"\n")) provideC
;
265 SM
.appi (fn (name
, fname
) => print ("Type " ^ name ^
" in " ^ fname ^
"\n")) provideT
;
266 SM
.appi (fn (name
, fname
) => print ("Value " ^ name ^
" in " ^ fname ^
"\n")) provideV
;*)
268 (*SM
.appi (fn (fname
, requires
) =>
271 SS
.app (fn fname
' => (print
" "; print fname
')) requires
;
272 print
"\n")) require
;*)
274 loop (ready
, waiting
, [])