51c32b45 |
1 | (* HCoop Domtool (http://hcoop.sourceforge.net/) |
2 | * Copyright (c) 2006, Adam Chlipala |
3 | * |
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. |
8 | * |
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. |
13 | * |
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. |
17 | *) |
18 | |
19 | (* Topological sorting of source files to take dependencies into account *) |
20 | |
21 | structure Order :> ORDER = struct |
22 | |
23 | open Ast |
24 | |
25 | structure SS = StringSet |
26 | structure SM = StringMap |
27 | |
28 | fun predNeeded G (p, _) = |
29 | case p of |
30 | CRoot => SS.empty |
31 | | CConst s => |
32 | if Env.lookupContext G s then |
33 | SS.empty |
34 | else |
35 | SS.singleton s |
36 | | CPrefix p => predNeeded G p |
37 | | CNot p => predNeeded G p |
38 | | CAnd (p1, p2) => SS.union (predNeeded G p1, predNeeded G p2) |
39 | |
40 | fun unionCT ((c1, t1), (c2, t2)) = (SS.union (c1, c2), SS.union (t1, t2)) |
41 | |
42 | fun typNeeded G (t, _) = |
43 | case t of |
44 | TBase s => |
45 | if Env.lookupType G s then |
46 | (SS.empty, SS.empty) |
47 | else |
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) => |
52 | let |
53 | val recordNeeded = SM.foldl |
54 | (fn (t, ss) => unionCT (ss, typNeeded G t)) |
55 | in |
56 | recordNeeded (recordNeeded (predNeeded G p, SS.empty) d) r |
57 | end |
58 | | TNested (p, t) => unionCT ((predNeeded G p, SS.empty), |
59 | typNeeded G t) |
60 | |
61 | | TError => raise Fail "TError during dependency analysis" |
62 | | TUnif _ => raise Fail "TUnif during dependency analysis" |
63 | |
64 | val empty = ((SS.empty, SS.empty), SS.empty) |
65 | |
66 | fun unionCTE (((c1, t1), v1), ((c2, t2), v2)) = |
67 | ((SS.union (c1, c2), |
68 | SS.union (t1, t2)), |
69 | SS.union (v1, v2)) |
70 | |
71 | val dt = (TError, ErrorMsg.dummyLoc) |
72 | |
bf9b0bc3 |
73 | fun expNeeded G (e, loc) = |
51c32b45 |
74 | case e of |
75 | EInt _ => ((SS.empty, |
76 | if Env.lookupType G "int" then |
77 | SS.empty |
78 | else |
79 | SS.singleton "int"), |
80 | SS.empty) |
81 | | EString _ => ((SS.empty, |
82 | if Env.lookupType G "string" then |
83 | SS.empty |
84 | else |
85 | SS.singleton "string"), |
86 | SS.empty) |
87 | | EList es => foldl (fn (e, ss) => unionCTE (ss, expNeeded G e)) |
88 | empty es |
89 | |
90 | | ELam (x, to, e) => |
91 | let |
92 | val G' = Env.bindVal G (x, dt, NONE) |
93 | in |
94 | case to of |
95 | NONE => expNeeded G' e |
96 | | SOME t => unionCTE ((typNeeded G t, SS.empty), |
97 | expNeeded G' e) |
98 | end |
bf9b0bc3 |
99 | | EALam (x, p, e) => |
100 | let |
101 | val G' = Env.bindVal G (x, (TAction (p, StringMap.empty, StringMap.empty), loc), NONE) |
102 | in |
103 | unionCTE (((predNeeded G p, SS.empty), SS.empty), |
104 | expNeeded G' e) |
105 | end |
51c32b45 |
106 | | EVar x => |
107 | (case Env.lookupVal G x of |
108 | NONE => ((SS.empty, SS.empty), SS.singleton x) |
109 | | _ => empty) |
110 | | EApp (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2) |
111 | |
112 | | ESkip => empty |
113 | | ESet (_, e) => expNeeded G e |
28cf1be3 |
114 | | EGet (x, topt, _, e) => |
115 | (case topt of |
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)) |
51c32b45 |
119 | | ESeq es => foldl (fn (e, ss) => unionCTE (ss, expNeeded G e)) |
120 | empty es |
121 | | ELocal (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2) |
122 | | EWith (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2) |
123 | |
124 | fun declNeeded G (d, _, _) = |
125 | case d of |
126 | DExternType name => (Env.bindType G name, empty) |
127 | | DExternVal (name, t) => (Env.bindVal G (name, dt, NONE), |
128 | (typNeeded G t, SS.empty)) |
129 | | DVal (name, to, e) => (Env.bindVal G (name, dt, NONE), |
130 | case to of |
131 | NONE => expNeeded G e |
132 | | SOME t => unionCTE ((typNeeded G t, SS.empty), |
133 | expNeeded G e)) |
134 | | DContext name => (Env.bindContext G name, empty) |
135 | |
136 | fun fileSig (_, ds, eo) = |
137 | let |
138 | val (G', needed) = foldl |
139 | (fn (d, (G, needed)) => |
140 | let |
141 | val (G', needed') = declNeeded G d |
142 | in |
143 | (G', unionCTE (needed, needed')) |
144 | end) |
145 | (Env.empty, empty) ds |
146 | |
147 | val needed = |
148 | case eo of |
149 | NONE => needed |
150 | | SOME e => unionCTE (needed, |
151 | expNeeded G' e) |
152 | in |
153 | (((Env.contexts G', Env.types G'), Env.vals G'), |
154 | needed) |
155 | end |
156 | |
157 | fun printSig ((cs, ts), vs) = |
158 | (print "Contexts:"; |
159 | SS.app (fn s => (print " "; print s; print ";")) cs; |
160 | print "\n Types:"; |
161 | SS.app (fn s => (print " "; print s; print ";")) ts; |
162 | print "\n Values:"; |
163 | SS.app (fn s => (print " "; print s; print ";")) vs; |
164 | print "\n") |
165 | |
1d16f0b6 |
166 | val allNaughty = ref false |
167 | val naughtyFiles = ref SS.empty |
168 | fun addNaughty fname = naughtyFiles := SS.add (!naughtyFiles, fname) |
169 | |
51c32b45 |
170 | fun mergeProvide kind fname (m1, m2) = |
171 | SS.foldl (fn (name, provide) => |
172 | (case SM.find (provide, name) of |
173 | NONE => () |
1d16f0b6 |
174 | | SOME fname' => |
175 | (addNaughty fname; |
176 | addNaughty fname'; |
177 | ErrorMsg.error NONE (String.concat ["Files ", |
178 | fname', |
179 | " and ", |
180 | fname, |
181 | " both provide ", |
182 | kind, |
183 | " ", |
184 | name])); |
51c32b45 |
185 | SM.insert (provide, name, fname))) |
186 | m1 m2 |
187 | |
c8a739af |
188 | fun order basisOpt fnames = |
51c32b45 |
189 | let |
1d16f0b6 |
190 | val () = allNaughty := false |
191 | val () = naughtyFiles := SS.empty |
192 | |
51c32b45 |
193 | fun doFile (fname, (provideC, provideT, provideV, require)) = |
194 | let |
195 | val file = Parse.parse fname |
196 | val (((provideC', provideT'), provideV'), |
197 | require') = fileSig file |
198 | in |
199 | (mergeProvide "context" fname (provideC, provideC'), |
200 | mergeProvide "type" fname (provideT, provideT'), |
201 | mergeProvide "value" fname (provideV, provideV'), |
202 | SM.insert (require, fname, require')) |
203 | end |
204 | |
205 | val (provideC, provideT, provideV, require) = |
206 | foldl doFile (SM.empty, SM.empty, SM.empty, SM.empty) fnames |
207 | |
208 | val require = SM.mapi (fn (fname, ((rc, rt), rv)) => |
209 | let |
c8a739af |
210 | fun consider (kind, provide, lastChance) = |
51c32b45 |
211 | SS.foldl (fn (name, need) => |
212 | case SM.find (provide, name) of |
c8a739af |
213 | NONE => |
214 | if lastChance name then |
215 | need |
216 | else |
1d16f0b6 |
217 | (addNaughty fname; |
218 | ErrorMsg.error NONE |
c8a739af |
219 | ("File " |
220 | ^ fname |
221 | ^ " uses undefined " |
222 | ^ kind |
223 | ^ " " |
224 | ^ name); |
225 | need) |
51c32b45 |
226 | | SOME fname' => |
227 | SS.add (need, fname')) |
228 | |
c8a739af |
229 | val need = consider ("context", provideC, |
230 | case basisOpt of |
231 | NONE => (fn _ => false) |
232 | | SOME b => Env.lookupContext b) |
51c32b45 |
233 | SS.empty rc |
c8a739af |
234 | val need = consider ("type", provideT, |
235 | case basisOpt of |
236 | NONE => (fn _ => false) |
237 | | SOME b => Env.lookupType b) |
51c32b45 |
238 | need rt |
c8a739af |
239 | val need = consider ("value", provideV, |
240 | case basisOpt of |
241 | NONE => (fn _ => false) |
242 | | SOME b => (fn name => Option.isSome (Env.lookupVal b name))) |
51c32b45 |
243 | need rv |
244 | in |
245 | need |
246 | end) require |
247 | |
248 | fun loop (ready, waiting, order) = |
249 | case SS.find (fn _ => true) ready of |
250 | NONE => |
251 | if SM.numItems waiting = 0 then |
252 | rev order |
253 | else |
1d16f0b6 |
254 | (allNaughty := true; |
255 | ErrorMsg.error NONE "Cyclic dependency in source files"; |
51c32b45 |
256 | order) |
257 | | SOME next => |
258 | let |
259 | val (ready', waiting') = |
260 | SM.foldli (fn (fname, requires, (ready', waiting')) => |
261 | let |
262 | val requires' = SS.delete (requires, next) |
263 | handle NotFound => requires |
264 | in |
265 | if SS.numItems requires' = 0 then |
266 | (SS.add (ready', fname), |
267 | waiting') |
268 | else |
269 | (ready', |
270 | SM.insert (waiting', fname, requires')) |
271 | end) |
272 | (SS.delete (ready, next), SM.empty) waiting |
273 | in |
274 | loop (ready', waiting', next :: order) |
275 | end |
276 | |
277 | val (ready, waiting) = |
278 | SM.foldli (fn (fname, requires, (ready, waiting)) => |
279 | if SS.numItems requires = 0 then |
280 | (SS.add (ready, fname), |
281 | waiting) |
282 | else |
283 | (ready, |
284 | SM.insert (waiting, fname, requires))) |
285 | (SS.empty, SM.empty) require |
51c32b45 |
286 | |
1d16f0b6 |
287 | val ordered = loop (ready, waiting, []) |
288 | val provider = {provideC = provideC, |
289 | provideT = provideT, |
290 | provideV = provideV} |
291 | in |
292 | if !allNaughty then |
293 | (provider, []) |
294 | else if SS.isEmpty (!naughtyFiles) then |
295 | (provider, ordered) |
296 | else |
297 | order basisOpt (List.filter (fn fname => not (SS.member (!naughtyFiles, fname))) fnames) |
51c32b45 |
298 | end |
299 | |
91c5a390 |
300 | type providers = {provideC : string SM.map, |
301 | provideT : string SM.map, |
302 | provideV : string SM.map} |
303 | |
304 | fun providesContext (p : providers, s) = SM.find (#provideC p, s) |
305 | fun providesType (p : providers, s) = SM.find (#provideT p, s) |
306 | fun providesValue (p : providers, s) = SM.find (#provideV p, s) |
307 | |
51c32b45 |
308 | end |