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
)))
172 fun doFile (fname
, (provideC
, provideT
, provideV
, require
)) =
174 val file
= Parse
.parse fname
175 val (((provideC
', provideT
'), provideV
'),
176 require
') = fileSig file
178 (mergeProvide
"context" fname (provideC
, provideC
'),
179 mergeProvide
"type" fname (provideT
, provideT
'),
180 mergeProvide
"value" fname (provideV
, provideV
'),
181 SM
.insert (require
, fname
, require
'))
184 val (provideC
, provideT
, provideV
, require
) =
185 foldl
doFile (SM
.empty
, SM
.empty
, SM
.empty
, SM
.empty
) fnames
187 val require
= SM
.mapi (fn (fname
, ((rc
, rt
), rv
)) =>
189 fun consider (kind
, provide
) =
190 SS
.foldl (fn (name
, need
) =>
191 case SM
.find (provide
, name
) of
192 NONE
=> (ErrorMsg
.error NONE
201 SS
.add (need
, fname
'))
203 val need
= consider ("context", provideC
)
205 val need
= consider ("type", provideT
)
207 val need
= consider ("value", provideV
)
213 fun loop (ready
, waiting
, order
) =
214 case SS
.find (fn _
=> true) ready
of
216 if SM
.numItems waiting
= 0 then
219 (ErrorMsg
.error NONE
"Cyclic dependency in source files";
223 val (ready
', waiting
') =
224 SM
.foldli (fn (fname
, requires
, (ready
', waiting
')) =>
226 val requires
' = SS
.delete (requires
, next
)
227 handle NotFound
=> requires
229 if SS
.numItems requires
' = 0 then
230 (SS
.add (ready
', fname
),
234 SM
.insert (waiting
', fname
, requires
'))
236 (SS
.delete (ready
, next
), SM
.empty
) waiting
238 loop (ready
', waiting
', next
:: order
)
241 val (ready
, waiting
) =
242 SM
.foldli (fn (fname
, requires
, (ready
, waiting
)) =>
243 if SS
.numItems requires
= 0 then
244 (SS
.add (ready
, fname
),
248 SM
.insert (waiting
, fname
, requires
)))
249 (SS
.empty
, SM
.empty
) require
251 (*SM
.appi (fn (name
, fname
) => print ("Context " ^ name ^
" in " ^ fname ^
"\n")) provideC
;
252 SM
.appi (fn (name
, fname
) => print ("Type " ^ name ^
" in " ^ fname ^
"\n")) provideT
;
253 SM
.appi (fn (name
, fname
) => print ("Value " ^ name ^
" in " ^ fname ^
"\n")) provideV
;*)
255 (*SM
.appi (fn (fname
, requires
) =>
258 SS
.app (fn fname
' => (print
" "; print fname
')) requires
;
259 print
"\n")) require
;*)
261 ({provideC
= provideC
,
263 provideV
= provideV
},
264 loop (ready
, waiting
, []))
267 type providers
= {provideC
: string SM
.map
,
268 provideT
: string SM
.map
,
269 provideV
: string SM
.map
}
271 fun providesContext (p
: providers
, s
) = SM
.find (#provideC p
, s
)
272 fun providesType (p
: providers
, s
) = SM
.find (#provideT p
, s
)
273 fun providesValue (p
: providers
, s
) = SM
.find (#provideV p
, s
)