1 (* HCoop
Domtool (http
://hcoop
.sourceforge
.net
/)
2 * Copyright (c
) 2006, Adam Chlipala
3 * Copyright (c
) 2014 Clinton Ebadi
<clinton@unknownlamer
.org
>
5 * This program is free software
; you can redistribute it
and/or
6 * modify it under the terms
of the GNU General Public License
7 * as published by the Free Software Foundation
; either version
2
8 * of the License
, or (at your option
) any later version
.
10 * This program is distributed
in the hope that it will be useful
,
11 * but WITHOUT ANY WARRANTY
; without even the implied warranty
of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
. See the
13 * GNU General Public License for more details
.
15 * You should have received a copy
of the GNU General Public License
16 * along
with this program
; if not
, write to the Free Software
17 * Foundation
, Inc
., 51 Franklin Street
, Fifth Floor
, Boston
, MA
02110-1301, USA
.
20 (* Topological sorting
of source files to take dependencies into account
*)
22 structure Order
:> ORDER
= struct
26 structure SS
= StringSet
27 structure SM
= StringMap
29 fun predNeeded
G (p
, _
) =
33 if Env
.lookupContext G s
then
37 | CPrefix p
=> predNeeded G p
38 | CNot p
=> predNeeded G p
39 |
CAnd (p1
, p2
) => SS
.union (predNeeded G p1
, predNeeded G p2
)
41 fun unionCT ((c1
, t1
), (c2
, t2
)) = (SS
.union (c1
, c2
), SS
.union (t1
, t2
))
43 fun typNeeded
G (t
, _
) =
46 if Env
.lookupType G s
then
49 (SS
.empty
, SS
.singleton s
)
50 | TList t
=> typNeeded G t
51 |
TArrow (t1
, t2
) => unionCT (typNeeded G t1
, typNeeded G t2
)
52 |
TAction (p
, d
, r
) =>
54 val recordNeeded
= SM
.foldl
55 (fn (t
, ss
) => unionCT (ss
, typNeeded G t
))
57 recordNeeded (recordNeeded (predNeeded G p
, SS
.empty
) d
) r
59 |
TNested (p
, t
) => unionCT ((predNeeded G p
, SS
.empty
),
62 | TError
=> raise Fail
"TError during dependency analysis"
63 | TUnif _
=> raise Fail
"TUnif during dependency analysis"
65 val empty
= ((SS
.empty
, SS
.empty
), SS
.empty
)
67 fun unionCTE (((c1
, t1
), v1
), ((c2
, t2
), v2
)) =
72 val dt
= (TError
, ErrorMsg
.dummyLoc
)
74 fun expNeeded
G (e
, loc
) =
77 if Env
.lookupType G
"int" then
82 | EString _
=> ((SS
.empty
,
83 if Env
.lookupType G
"string" then
86 SS
.singleton
"string"),
88 | EList es
=> foldl (fn (e
, ss
) => unionCTE (ss
, expNeeded G e
))
93 val G
' = Env
.bindVal
G (x
, dt
, NONE
)
96 NONE
=> expNeeded G
' e
97 | SOME t
=> unionCTE ((typNeeded G t
, SS
.empty
),
102 val G
' = Env
.bindVal
G (x
, (TAction (p
, StringMap
.empty
, StringMap
.empty
), loc
), NONE
)
104 unionCTE (((predNeeded G p
, SS
.empty
), SS
.empty
),
108 (case Env
.lookupVal G x
of
109 NONE
=> ((SS
.empty
, SS
.empty
), SS
.singleton x
)
111 |
EApp (e1
, e2
) => unionCTE (expNeeded G e1
, expNeeded G e2
)
114 |
ESet (_
, e
) => expNeeded G e
115 |
EGet (x
, topt
, _
, e
) =>
117 NONE
=> expNeeded (Env
.bindVal
G (x
, dt
, NONE
)) e
118 | SOME t
=> unionCTE ((typNeeded G t
, SS
.empty
),
119 expNeeded (Env
.bindVal
G (x
, dt
, NONE
)) e
))
120 | ESeq es
=> foldl (fn (e
, ss
) => unionCTE (ss
, expNeeded G e
))
122 |
ELocal (e1
, e2
) => unionCTE (expNeeded G e1
, expNeeded G e2
)
123 |
EWith (e1
, e2
) => unionCTE (expNeeded G e1
, expNeeded G e2
)
124 |
EIf (e1
, e2
, e3
) => unionCTE (expNeeded G e1
,
125 unionCTE (expNeeded G e2
,
128 fun declNeeded
G (d
, _
, _
) =
130 DExternType name
=> (Env
.bindType G name
, empty
)
131 |
DExternVal (name
, t
) => (Env
.bindVal
G (name
, dt
, NONE
),
132 (typNeeded G t
, SS
.empty
))
133 |
DVal (name
, to
, e
) => (Env
.bindVal
G (name
, dt
, NONE
),
135 NONE
=> expNeeded G e
136 | SOME t
=> unionCTE ((typNeeded G t
, SS
.empty
),
138 |
DEnv (name
, to
, e
) => (Env
.bindInitialDynEnvVal
G (name
, dt
, (Ast
.ESkip
, ErrorMsg
.dummyLoc
)),
140 NONE
=> expNeeded G e
141 | SOME t
=> unionCTE ((typNeeded G t
, SS
.empty
),
143 | DContext name
=> (Env
.bindContext G name
, empty
)
145 fun fileSig (_
, ds
, eo
) =
147 val (G
', needed
) = foldl
148 (fn (d
, (G
, needed
)) =>
150 val (G
', needed
') = declNeeded G d
152 (G
', unionCTE (needed
, needed
'))
154 (Env
.empty
, empty
) ds
159 | SOME e
=> unionCTE (needed
,
162 (((Env
.contexts G
', Env
.types G
'), Env
.vals G
'),
166 fun printSig ((cs
, ts
), vs
) =
168 SS
.app (fn s
=> (print
" "; print s
; print
";")) cs
;
170 SS
.app (fn s
=> (print
" "; print s
; print
";")) ts
;
172 SS
.app (fn s
=> (print
" "; print s
; print
";")) vs
;
175 val allNaughty
= ref
false
176 val naughtyFiles
= ref SS
.empty
177 fun addNaughty fname
= naughtyFiles
:= SS
.add (!naughtyFiles
, fname
)
179 fun mergeProvide kind
fname (m1
, m2
) =
180 SS
.foldl (fn (name
, provide
) =>
181 (case SM
.find (provide
, name
) of
186 ErrorMsg
.error
NONE (String.concat
["Files ",
194 SM
.insert (provide
, name
, fname
)))
197 fun order basisOpt fnames
=
199 val () = allNaughty
:= false
200 val () = naughtyFiles
:= SS
.empty
202 fun doFile (fname
, (provideC
, provideT
, provideV
, require
)) =
204 val file
= Parse
.parse fname
205 val (((provideC
', provideT
'), provideV
'),
206 require
') = fileSig file
208 (mergeProvide
"context" fname (provideC
, provideC
'),
209 mergeProvide
"type" fname (provideT
, provideT
'),
210 mergeProvide
"value" fname (provideV
, provideV
'),
211 SM
.insert (require
, fname
, require
'))
214 val (provideC
, provideT
, provideV
, require
) =
215 foldl
doFile (SM
.empty
, SM
.empty
, SM
.empty
, SM
.empty
) fnames
217 val require
= SM
.mapi (fn (fname
, ((rc
, rt
), rv
)) =>
219 fun consider (kind
, provide
, lastChance
) =
220 SS
.foldl (fn (name
, need
) =>
221 case SM
.find (provide
, name
) of
223 if lastChance name
then
236 SS
.add (need
, fname
'))
238 val need
= consider ("context", provideC
,
240 NONE
=> (fn _
=> false)
241 | SOME b
=> Env
.lookupContext b
)
243 val need
= consider ("type", provideT
,
245 NONE
=> (fn _
=> false)
246 | SOME b
=> Env
.lookupType b
)
248 val need
= consider ("value", provideV
,
250 NONE
=> (fn _
=> false)
251 | SOME b
=> (fn name
=> Option
.isSome (Env
.lookupVal b name
)))
257 fun loop (ready
, waiting
, order
) =
258 case SS
.find (fn _
=> true) ready
of
260 if SM
.numItems waiting
= 0 then
264 ErrorMsg
.error NONE
"Cyclic dependency in source files";
268 val (ready
', waiting
') =
269 SM
.foldli (fn (fname
, requires
, (ready
', waiting
')) =>
271 val requires
' = SS
.delete (requires
, next
)
272 handle NotFound
=> requires
274 if SS
.numItems requires
' = 0 then
275 (SS
.add (ready
', fname
),
279 SM
.insert (waiting
', fname
, requires
'))
281 (SS
.delete (ready
, next
), SM
.empty
) waiting
283 loop (ready
', waiting
', next
:: order
)
286 val (ready
, waiting
) =
287 SM
.foldli (fn (fname
, requires
, (ready
, waiting
)) =>
288 if SS
.numItems requires
= 0 then
289 (SS
.add (ready
, fname
),
293 SM
.insert (waiting
, fname
, requires
)))
294 (SS
.empty
, SM
.empty
) require
296 val ordered
= loop (ready
, waiting
, [])
297 val provider
= {provideC
= provideC
,
303 else if SS
.isEmpty (!naughtyFiles
) then
306 order
basisOpt (List.filter (fn fname
=> not (SS
.member (!naughtyFiles
, fname
))) fnames
)
309 val order
= fn basisOpt
=> fn fnames
=>
311 val (providers
, fnames
) = order basisOpt fnames
313 val (hasLib
, fnames
) = foldl (fn (fname
, (hasLib
, fnames
)) =>
314 if OS
.Path
.file fname
= "lib.dtl" then
317 (hasLib
, fname
:: fnames
))
320 val fnames
= rev fnames
321 val fnames
= case hasLib
of
323 | SOME hasLib
=> hasLib
:: fnames
328 type providers
= {provideC
: string SM
.map
,
329 provideT
: string SM
.map
,
330 provideV
: string SM
.map
}
332 fun providesContext (p
: providers
, s
) = SM
.find (#provideC p
, s
)
333 fun providesType (p
: providers
, s
) = SM
.find (#provideT p
, s
)
334 fun providesValue (p
: providers
, s
) = SM
.find (#provideV p
, s
)