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
, loc
) =
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
),
101 val G
' = Env
.bindVal
G (x
, (TAction (p
, StringMap
.empty
, StringMap
.empty
), loc
), NONE
)
103 unionCTE (((predNeeded G p
, SS
.empty
), SS
.empty
),
107 (case Env
.lookupVal G x
of
108 NONE
=> ((SS
.empty
, SS
.empty
), SS
.singleton x
)
110 |
EApp (e1
, e2
) => unionCTE (expNeeded G e1
, expNeeded G e2
)
113 |
ESet (_
, e
) => expNeeded G e
114 |
EGet (x
, topt
, _
, e
) =>
116 NONE
=> expNeeded (Env
.bindVal
G (x
, dt
, NONE
)) e
117 | SOME t
=> unionCTE ((typNeeded G t
, SS
.empty
),
118 expNeeded (Env
.bindVal
G (x
, dt
, NONE
)) e
))
119 | ESeq es
=> foldl (fn (e
, ss
) => unionCTE (ss
, expNeeded G e
))
121 |
ELocal (e1
, e2
) => unionCTE (expNeeded G e1
, expNeeded G e2
)
122 |
EWith (e1
, e2
) => unionCTE (expNeeded G e1
, expNeeded G e2
)
123 |
EIf (e1
, e2
, e3
) => unionCTE (expNeeded G e1
,
124 unionCTE (expNeeded G e2
,
127 fun declNeeded
G (d
, _
, _
) =
129 DExternType name
=> (Env
.bindType G name
, empty
)
130 |
DExternVal (name
, t
) => (Env
.bindVal
G (name
, dt
, NONE
),
131 (typNeeded G t
, SS
.empty
))
132 |
DVal (name
, to
, e
) => (Env
.bindVal
G (name
, dt
, NONE
),
134 NONE
=> expNeeded G e
135 | SOME t
=> unionCTE ((typNeeded G t
, SS
.empty
),
137 | DContext name
=> (Env
.bindContext G name
, empty
)
139 fun fileSig (_
, ds
, eo
) =
141 val (G
', needed
) = foldl
142 (fn (d
, (G
, needed
)) =>
144 val (G
', needed
') = declNeeded G d
146 (G
', unionCTE (needed
, needed
'))
148 (Env
.empty
, empty
) ds
153 | SOME e
=> unionCTE (needed
,
156 (((Env
.contexts G
', Env
.types G
'), Env
.vals G
'),
160 fun printSig ((cs
, ts
), vs
) =
162 SS
.app (fn s
=> (print
" "; print s
; print
";")) cs
;
164 SS
.app (fn s
=> (print
" "; print s
; print
";")) ts
;
166 SS
.app (fn s
=> (print
" "; print s
; print
";")) vs
;
169 val allNaughty
= ref
false
170 val naughtyFiles
= ref SS
.empty
171 fun addNaughty fname
= naughtyFiles
:= SS
.add (!naughtyFiles
, fname
)
173 fun mergeProvide kind
fname (m1
, m2
) =
174 SS
.foldl (fn (name
, provide
) =>
175 (case SM
.find (provide
, name
) of
180 ErrorMsg
.error
NONE (String.concat
["Files ",
188 SM
.insert (provide
, name
, fname
)))
191 fun order basisOpt fnames
=
193 val () = allNaughty
:= false
194 val () = naughtyFiles
:= SS
.empty
196 fun doFile (fname
, (provideC
, provideT
, provideV
, require
)) =
198 val file
= Parse
.parse fname
199 val (((provideC
', provideT
'), provideV
'),
200 require
') = fileSig file
202 (mergeProvide
"context" fname (provideC
, provideC
'),
203 mergeProvide
"type" fname (provideT
, provideT
'),
204 mergeProvide
"value" fname (provideV
, provideV
'),
205 SM
.insert (require
, fname
, require
'))
208 val (provideC
, provideT
, provideV
, require
) =
209 foldl
doFile (SM
.empty
, SM
.empty
, SM
.empty
, SM
.empty
) fnames
211 val require
= SM
.mapi (fn (fname
, ((rc
, rt
), rv
)) =>
213 fun consider (kind
, provide
, lastChance
) =
214 SS
.foldl (fn (name
, need
) =>
215 case SM
.find (provide
, name
) of
217 if lastChance name
then
230 SS
.add (need
, fname
'))
232 val need
= consider ("context", provideC
,
234 NONE
=> (fn _
=> false)
235 | SOME b
=> Env
.lookupContext b
)
237 val need
= consider ("type", provideT
,
239 NONE
=> (fn _
=> false)
240 | SOME b
=> Env
.lookupType b
)
242 val need
= consider ("value", provideV
,
244 NONE
=> (fn _
=> false)
245 | SOME b
=> (fn name
=> Option
.isSome (Env
.lookupVal b name
)))
251 fun loop (ready
, waiting
, order
) =
252 case SS
.find (fn _
=> true) ready
of
254 if SM
.numItems waiting
= 0 then
258 ErrorMsg
.error NONE
"Cyclic dependency in source files";
262 val (ready
', waiting
') =
263 SM
.foldli (fn (fname
, requires
, (ready
', waiting
')) =>
265 val requires
' = SS
.delete (requires
, next
)
266 handle NotFound
=> requires
268 if SS
.numItems requires
' = 0 then
269 (SS
.add (ready
', fname
),
273 SM
.insert (waiting
', fname
, requires
'))
275 (SS
.delete (ready
, next
), SM
.empty
) waiting
277 loop (ready
', waiting
', next
:: order
)
280 val (ready
, waiting
) =
281 SM
.foldli (fn (fname
, requires
, (ready
, waiting
)) =>
282 if SS
.numItems requires
= 0 then
283 (SS
.add (ready
, fname
),
287 SM
.insert (waiting
, fname
, requires
)))
288 (SS
.empty
, SM
.empty
) require
290 val ordered
= loop (ready
, waiting
, [])
291 val provider
= {provideC
= provideC
,
297 else if SS
.isEmpty (!naughtyFiles
) then
300 order
basisOpt (List.filter (fn fname
=> not (SS
.member (!naughtyFiles
, fname
))) fnames
)
303 val order
= fn basisOpt
=> fn fnames
=>
305 val (providers
, fnames
) = order basisOpt fnames
307 val (hasLib
, fnames
) = foldl (fn (fname
, (hasLib
, fnames
)) =>
308 if OS
.Path
.file fname
= "lib.dtl" then
311 (hasLib
, fname
:: fnames
))
314 val fnames
= rev fnames
315 val fnames
= case hasLib
of
317 | SOME hasLib
=> hasLib
:: fnames
322 type providers
= {provideC
: string SM
.map
,
323 provideT
: string SM
.map
,
324 provideV
: string SM
.map
}
326 fun providesContext (p
: providers
, s
) = SM
.find (#provideC p
, s
)
327 fun providesType (p
: providers
, s
) = SM
.find (#provideT p
, s
)
328 fun providesValue (p
: providers
, s
) = SM
.find (#provideV p
, s
)