Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/cm/semant/members.sml
ViewVC logotype

Annotation of /sml/trunk/src/cm/semant/members.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 986 - (view) (download)

1 : blume 267 (*
2 :     * Collections of members in CM descriptions.
3 :     * Involves:
4 :     * - running tools
5 :     * - fully analyzing sub-groups and sub-libraries
6 :     * - parsing ML files and getting their export lists
7 :     *
8 :     * (C) 1999 Lucent Technologies, Bell Laboratories
9 :     *
10 :     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
11 :     *)
12 :     signature MEMBERCOLLECTION = sig
13 :    
14 : blume 278 type symbol = Symbol.symbol
15 : blume 270 type smlinfo = SmlInfo.info
16 : blume 283 type impexp = DependencyGraph.impexp
17 : blume 879 type region = SourceMap.region
18 : blume 666 type subgroups =
19 :     (SrcPath.file * GroupGraph.group * SrcPath.rebindings) list
20 : blume 269
21 : blume 267 type collection
22 :    
23 : blume 986 val emptycollection : collection
24 : blume 274
25 : blume 642 val implicit : GeneralParams.info -> GroupGraph.group -> collection
26 : blume 537
27 : blume 518 val expandOne :
28 : blume 632 { gp: GeneralParams.info,
29 : blume 666 rparse: SrcPath.file * Version.t option * SrcPath.rebindings ->
30 :     GroupGraph.group,
31 :     load_plugin: SrcPath.dir -> string -> bool }
32 : blume 587 -> { name: string,
33 : blume 756 mkpath: unit -> SrcPath.prefile,
34 : blume 666 group: SrcPath.file * region,
35 : blume 587 class: string option,
36 : blume 588 tooloptions: PrivateTools.toolopts option,
37 : blume 735 local_registry: PrivateTools.registry,
38 : blume 666 context: SrcPath.dir }
39 : blume 270 -> collection
40 : blume 275 val sequential : collection * collection * (string -> unit) -> collection
41 : blume 267
42 : blume 297 val build :
43 : blume 986 collection * SymbolSet.set * GeneralParams.info *
44 : blume 537 DependencyGraph.farsbnode (* pervasive env *)
45 : blume 733 -> impexp SymbolMap.map * GroupGraph.privileges * SymbolSet.set
46 : blume 280
47 : blume 838 val mkIndex : GeneralParams.info * SrcPath.file * collection -> unit
48 :    
49 : blume 666 val subgroups : collection -> subgroups
50 : blume 642 val sources : collection ->
51 :     { class: string, derived: bool } SrcPathMap.map
52 : blume 294
53 : blume 336 val num_look : GeneralParams.info -> collection -> string -> int
54 :     val cm_look : GeneralParams.info -> collection -> string -> bool
55 : blume 278 val ml_look : collection -> symbol -> bool
56 : blume 771
57 : blume 986 val smlexports :
58 :     collection * SrcPath.file option * (string -> unit) -> SymbolSet.set
59 :     val groupexports :
60 :     collection * SrcPath.file option * (string -> unit) -> SymbolSet.set
61 :     val libraryexports :
62 :     collection * SrcPath.file * (string -> unit)
63 :     * bool * (unit -> collection)
64 :     -> SymbolSet.set
65 :    
66 : blume 840 val is_errorcollection : collection -> bool
67 : blume 267 end
68 :    
69 :     structure MemberCollection :> MEMBERCOLLECTION = struct
70 :    
71 : blume 269 structure DG = DependencyGraph
72 : blume 879 structure EM = ErrorMsg
73 : blume 286 structure SS = SymbolSet
74 : blume 986 structure SM = SymbolMap
75 : blume 294 structure GG = GroupGraph
76 : blume 632 structure V = Version
77 : blume 267
78 : blume 270 type smlinfo = SmlInfo.info
79 : blume 275 type symbol = Symbol.symbol
80 : blume 283 type impexp = DG.impexp
81 : blume 879 type region = SourceMap.region
82 : blume 666 type subgroups = (SrcPath.file * GG.group * SrcPath.rebindings) list
83 : blume 267
84 : blume 269 datatype collection =
85 : blume 986 COLLECTION of
86 :     { imports: impexp SM.map,
87 :     smlfiles: (smlinfo * SymbolSet.set) list,
88 :     localdefs: smlinfo SM.map,
89 :     subgroups: subgroups,
90 :     sources: { class: string, derived: bool } SrcPathMap.map,
91 :     reqpriv: GG.privileges }
92 : blume 587 | ERRORCOLLECTION
93 : blume 269
94 : blume 986 fun empty sources =
95 :     COLLECTION { imports = SM.empty,
96 : blume 274 smlfiles = [],
97 : blume 986 localdefs = SM.empty,
98 : blume 301 subgroups = [],
99 : blume 642 sources = sources,
100 : blume 301 reqpriv = StringSet.empty }
101 : blume 274
102 : blume 986 val emptycollection = empty SrcPathMap.empty
103 : blume 642
104 :     fun implicit (gp: GeneralParams.info) init_group = let
105 : blume 587 val { grouppath, ... } =
106 :     case init_group of
107 :     GG.GROUP x => x
108 :     | GG.ERRORGROUP =>
109 :     EM.impossible "members.sml: implicit: bad init group"
110 : blume 642 val sm = SrcPathMap.singleton (grouppath,
111 :     { class = "cm", derived = false })
112 : blume 537 in
113 :     (* This is a collection that is an implicit member of every
114 :     * library -- the "init" group which exports the pervasive env. *)
115 : blume 986 COLLECTION { imports = SM.empty,
116 : blume 537 smlfiles = [],
117 : blume 986 localdefs = SM.empty,
118 : blume 666 subgroups = [(grouppath, init_group, [])],
119 : blume 642 sources = sm,
120 : blume 537 reqpriv = StringSet.empty }
121 :     end
122 :    
123 : blume 587 fun sequential (COLLECTION c1, COLLECTION c2, error) =
124 :     let fun describeSymbol (s, r) = let
125 :     val ns = Symbol.nameSpace s
126 :     in
127 :     Symbol.nameSpaceToString ns :: " " :: Symbol.name s :: r
128 :     end
129 : blume 652 fun i_error (s, x as (nth, e, allsyms), (nth', e', allsyms')) = let
130 :     val (f, sbn) = nth ()
131 :     val (f', sbn') = nth' ()
132 : blume 587 fun complain () =
133 :     error (concat (describeSymbol
134 :     (s, [" imported from ",
135 :     DG.describeSBN sbn,
136 :     " and also from ",
137 :     DG.describeSBN sbn'])))
138 :     fun union (NONE, _) = NONE
139 :     | union (_, NONE) = NONE
140 : blume 986 | union (SOME f, SOME f') = SOME (SS.union (f, f'))
141 : blume 587 in
142 :     if DG.sbeq (sbn, sbn') then
143 : blume 652 let val fsbn = (union (f, f'), sbn)
144 :     in
145 :     (fn () => fsbn, DAEnv.LAYER (e, e'),
146 : blume 986 SS.union (allsyms, allsyms'))
147 : blume 652 end
148 : blume 587 else (complain (); x)
149 :     end
150 : blume 986 val i_union = SM.unionWithi i_error
151 : blume 587 fun ld_error (s, f1, f2) =
152 :     (error (concat (describeSymbol
153 : blume 666 (s, [" defined in ", SmlInfo.descr f1,
154 :     " and also in ", SmlInfo.descr f2])));
155 : blume 587 f1)
156 : blume 986 val ld_union = SM.unionWithi ld_error
157 : blume 642 val s_union = SrcPathMap.unionWith #1
158 : blume 275 in
159 : blume 587 COLLECTION { imports = i_union (#imports c1, #imports c2),
160 :     smlfiles = #smlfiles c1 @ #smlfiles c2,
161 :     localdefs = ld_union (#localdefs c1, #localdefs c2),
162 :     subgroups = #subgroups c1 @ #subgroups c2,
163 : blume 642 sources = s_union (#sources c1, #sources c2),
164 : blume 587 reqpriv = StringSet.union (#reqpriv c1, #reqpriv c2) }
165 : blume 275 end
166 : blume 587 | sequential _ = ERRORCOLLECTION
167 : blume 269
168 : blume 632 fun expandOne { gp, rparse, load_plugin } arg = let
169 : blume 735 val { name, mkpath, group, class, tooloptions,
170 :     local_registry, context } = arg
171 : blume 336 val class = Option.map (String.map Char.toLower) class
172 : blume 299 val error = GroupReg.error (#groupreg gp) group
173 : blume 537 fun e0 s = error EM.COMPLAIN s EM.nullErrorBody
174 :     fun w0 s = error EM.WARN s EM.nullErrorBody
175 : blume 642 val { smlfiles, cmfiles, sources } =
176 : blume 537 PrivateTools.expand { error = e0,
177 : blume 735 local_registry = local_registry,
178 : blume 642 spec = { name = name,
179 :     mkpath = mkpath,
180 :     class = class,
181 :     opts = tooloptions,
182 :     derived = false },
183 : blume 537 context = context,
184 : blume 873 load_plugin = load_plugin,
185 :     sysinfo = { symval =
186 :     fn s => #get (#symval (#param gp) s) (),
187 :     archos = #archos (#param gp) } }
188 : blume 642 val msources = foldl SrcPathMap.insert' SrcPathMap.empty sources
189 : blume 986 fun g_coll (p, { version = v, rebindings = rb }) =
190 : blume 666 case rparse (p, v, rb) of
191 : blume 642 g as GG.GROUP { exports = i, kind, required, sources,
192 : blume 587 grouppath, sublibs } => let
193 : blume 986 val ver =
194 : blume 632 case kind of
195 : blume 986 GG.NOLIB _ => NONE
196 :     | GG.LIB l => #version l
197 : blume 587 in
198 : blume 632 case (v, ver) of
199 :     (NONE, _) => ()
200 :     | (SOME vrq, NONE) =>
201 :     e0 "library does not carry a version stamp"
202 :     | (SOME vrq, SOME ver) =>
203 :     (case V.compare (vrq, ver) of
204 :     GREATER => e0 "library is older than expected"
205 :     | EQUAL => ()
206 :     | LESS =>
207 :     (case V.compare (V.nextMajor vrq, ver) of
208 :     GREATER =>
209 :     w0 "library is slightly newer than expected"
210 :     | _ => e0 "library is newer than expected"));
211 : blume 986 COLLECTION { imports = i, smlfiles = [],
212 :     localdefs = SM.empty,
213 : blume 666 subgroups = [(p, g, rb)],
214 : blume 642 sources = SrcPathMap.empty,
215 : blume 587 reqpriv = required }
216 :     end
217 :     | GG.ERRORGROUP => ERRORCOLLECTION
218 : blume 986 fun s_coll (p, sparams) = let
219 :     val { share = s, setup, split, locl } = sparams
220 : blume 537 val i =
221 : blume 818 SmlInfo.info split gp { sourcepath = p, group = group,
222 : blume 986 sh_spec = s, setup = setup,
223 :     locl = locl }
224 : blume 537 val exports =
225 :     case SmlInfo.exports gp i of
226 :     NONE => SS.empty
227 :     | SOME ex => (if SS.isEmpty ex then
228 :     w0 ("no module exports from " ^
229 :     SrcPath.descr p)
230 :     else ();
231 :     ex)
232 : blume 986 fun addLD (s, m) = SM.insert (m, s, i)
233 :     val ld = SS.foldl addLD SM.empty exports
234 : blume 537 in
235 : blume 986 COLLECTION { imports = SM.empty,
236 :     smlfiles = [(i, exports)],
237 : blume 537 localdefs = ld,
238 :     subgroups = [],
239 : blume 642 sources = SrcPathMap.empty,
240 : blume 537 reqpriv = StringSet.empty }
241 :     end
242 :     val collections = map g_coll cmfiles @ map s_coll smlfiles
243 :     fun combine (c1, c2) = sequential (c2, c1, e0)
244 : blume 274 in
245 : blume 986 foldl combine (empty msources) collections
246 : blume 270 end
247 :    
248 : blume 986 fun build (COLLECTION c, filter, gp, perv_fsbnode) =
249 :     BuildDepend.build (c, filter, gp, perv_fsbnode)
250 : blume 587 | build (ERRORCOLLECTION, _, _, _) =
251 : blume 986 (SM.empty, StringSet.empty, SS.empty)
252 : blume 280
253 : blume 838 fun mkIndex (gp, g, COLLECTION c) = Index.mkIndex (gp, g, c)
254 :     | mkIndex _ = ()
255 :    
256 : blume 294 fun subgroups (COLLECTION { subgroups = sg, ... }) = sg
257 : blume 587 | subgroups ERRORCOLLECTION = []
258 : blume 294
259 : blume 642 fun sources (COLLECTION { sources = s, ... }) = s
260 :     | sources ERRORCOLLECTION = SrcPathMap.empty
261 :    
262 : blume 336 local
263 :     fun symenv_look (gp: GeneralParams.info) (c: collection) s =
264 : blume 433 #get (#symval (#param gp) s) ()
265 : blume 336 in
266 :     fun num_look gp c s = getOpt (symenv_look gp c s, 0)
267 :     fun cm_look gp c s = isSome (symenv_look gp c s)
268 :     end
269 : blume 269
270 : blume 283 fun ml_look (COLLECTION { imports, localdefs, ... }) s =
271 : blume 986 isSome (SM.find (imports, s)) orelse
272 :     isSome (SM.find (localdefs, s))
273 : blume 587 | ml_look ERRORCOLLECTON _ = true
274 : blume 771
275 : blume 986 fun smlexports (ERRORCOLLECTION, _, _) = SS.empty
276 :     | smlexports (COLLECTION { smlfiles, ... }, NONE, _) =
277 :     foldl (fn ((i, s), s') =>
278 :     if SmlInfo.is_local i then s' else SS.union (s, s'))
279 :     SS.empty smlfiles
280 :     | smlexports (COLLECTION { smlfiles, ... }, SOME p, error) = let
281 :     fun samepath (i, _) =
282 :     SrcPath.compare (SmlInfo.sourcepath i, p) = EQUAL
283 :     in
284 :     case List.find samepath smlfiles of
285 :     SOME (_, e) => e
286 :     | NONE => (error ("no such source file: " ^ SrcPath.descr p);
287 :     SS.empty)
288 :     end
289 : blume 840
290 : blume 986 local
291 :     fun samepathas p (p', _, _) = SrcPath.compare (p, p') = EQUAL
292 :    
293 :     fun addDomain (m, s) = SS.addList (s, SM.listKeys m)
294 :     fun domainOf m = addDomain (m, SS.empty)
295 :     in
296 :     fun libraryexports (ERRORCOLLECTION, _, _, _, _) = SS.empty
297 :     | libraryexports (COLLECTION { subgroups, ... }, p, error,
298 :     hasoptions, elab) = let
299 :     fun err m = (error m; SS.empty)
300 :     in
301 :     case List.find (samepathas p) subgroups of
302 :     SOME (_, GG.GROUP { kind = GG.LIB _, exports, ... }, _) =>
303 :     (if hasoptions then
304 :     err (SrcPath.descr p ^
305 :     " cannot have options because it is already\
306 :     \ listed as a member")
307 :     else domainOf exports)
308 :     | SOME _ => err (SrcPath.descr p ^
309 :     " is a subgroup, not a library")
310 :     | NONE =>
311 :     (case elab () of
312 :     ERRORCOLLECTION => SS.empty
313 :     | COLLECTION { smlfiles = [],
314 :     subgroups = [(_, GG.GROUP
315 :     { kind = GG.LIB _, exports, ... }, _)],
316 :     ... } =>
317 :     domainOf exports
318 :     | COLLECTION { smlfiles, subgroups, ... } =>
319 :     (app (fn (p, _, _) => print (SrcPath.descr p ^ "\n"))
320 :     subgroups;
321 :     app (fn (i, _) => print (SmlInfo.descr i ^ "\n"))
322 :     smlfiles;
323 :     err "precisely one library must be named here"))
324 :     end
325 :    
326 :     fun groupexports (ERRORCOLLECTION, _, _) = SS.empty
327 :     | groupexports (COLLECTION { subgroups, ... }, NONE, _) = let
328 :     fun sgexp ((_, GG.GROUP { kind = GG.NOLIB _, exports, ... },
329 :     _), s) =
330 :     addDomain (exports, s)
331 :     | sgexp (_, s) = s
332 :     in
333 :     foldl sgexp SS.empty subgroups
334 :     end
335 :     | groupexports (COLLECTION { subgroups, ... }, SOME p, error) =
336 :     (case List.find (samepathas p) subgroups of
337 :     SOME (_, GG.GROUP { kind = GG.NOLIB _, exports, ... }, _) =>
338 :     domainOf exports
339 :     | SOME _ => (error (SrcPath.descr p ^
340 :     " is a library, not a subgroup");
341 :     SS.empty)
342 :     | NONE => (error ("no such subgroup: " ^ SrcPath.descr p);
343 :     SS.empty))
344 :     end
345 :    
346 : blume 840 fun is_errorcollection ERRORCOLLECTION = true
347 :     | is_errorcollection (COLLECTION _) = false
348 : blume 267 end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0