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 1632 - (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 : mblume 1632 val { share = s, setup, split, noguid, locl, controllers } =
220 :     sparams
221 : blume 537 val i =
222 : blume 1137 SmlInfo.info (split, noguid)
223 :     gp { sourcepath = p, group = group,
224 :     sh_spec = s, setup = setup,
225 : mblume 1632 locl = locl, controllers = controllers }
226 : blume 537 val exports =
227 :     case SmlInfo.exports gp i of
228 :     NONE => SS.empty
229 :     | SOME ex => (if SS.isEmpty ex then
230 :     w0 ("no module exports from " ^
231 :     SrcPath.descr p)
232 :     else ();
233 :     ex)
234 : blume 986 fun addLD (s, m) = SM.insert (m, s, i)
235 :     val ld = SS.foldl addLD SM.empty exports
236 : blume 537 in
237 : blume 986 COLLECTION { imports = SM.empty,
238 :     smlfiles = [(i, exports)],
239 : blume 537 localdefs = ld,
240 :     subgroups = [],
241 : blume 642 sources = SrcPathMap.empty,
242 : blume 537 reqpriv = StringSet.empty }
243 :     end
244 :     val collections = map g_coll cmfiles @ map s_coll smlfiles
245 :     fun combine (c1, c2) = sequential (c2, c1, e0)
246 : blume 274 in
247 : blume 986 foldl combine (empty msources) collections
248 : blume 270 end
249 :    
250 : blume 986 fun build (COLLECTION c, filter, gp, perv_fsbnode) =
251 :     BuildDepend.build (c, filter, gp, perv_fsbnode)
252 : blume 587 | build (ERRORCOLLECTION, _, _, _) =
253 : blume 986 (SM.empty, StringSet.empty, SS.empty)
254 : blume 280
255 : blume 838 fun mkIndex (gp, g, COLLECTION c) = Index.mkIndex (gp, g, c)
256 :     | mkIndex _ = ()
257 :    
258 : blume 294 fun subgroups (COLLECTION { subgroups = sg, ... }) = sg
259 : blume 587 | subgroups ERRORCOLLECTION = []
260 : blume 294
261 : blume 642 fun sources (COLLECTION { sources = s, ... }) = s
262 :     | sources ERRORCOLLECTION = SrcPathMap.empty
263 :    
264 : blume 336 local
265 :     fun symenv_look (gp: GeneralParams.info) (c: collection) s =
266 : blume 433 #get (#symval (#param gp) s) ()
267 : blume 336 in
268 :     fun num_look gp c s = getOpt (symenv_look gp c s, 0)
269 :     fun cm_look gp c s = isSome (symenv_look gp c s)
270 :     end
271 : blume 269
272 : blume 283 fun ml_look (COLLECTION { imports, localdefs, ... }) s =
273 : blume 986 isSome (SM.find (imports, s)) orelse
274 :     isSome (SM.find (localdefs, s))
275 : blume 587 | ml_look ERRORCOLLECTON _ = true
276 : blume 771
277 : blume 986 fun smlexports (ERRORCOLLECTION, _, _) = SS.empty
278 :     | smlexports (COLLECTION { smlfiles, ... }, NONE, _) =
279 :     foldl (fn ((i, s), s') =>
280 :     if SmlInfo.is_local i then s' else SS.union (s, s'))
281 :     SS.empty smlfiles
282 :     | smlexports (COLLECTION { smlfiles, ... }, SOME p, error) = let
283 :     fun samepath (i, _) =
284 :     SrcPath.compare (SmlInfo.sourcepath i, p) = EQUAL
285 :     in
286 :     case List.find samepath smlfiles of
287 :     SOME (_, e) => e
288 :     | NONE => (error ("no such source file: " ^ SrcPath.descr p);
289 :     SS.empty)
290 :     end
291 : blume 840
292 : blume 986 local
293 :     fun samepathas p (p', _, _) = SrcPath.compare (p, p') = EQUAL
294 :    
295 :     fun addDomain (m, s) = SS.addList (s, SM.listKeys m)
296 :     fun domainOf m = addDomain (m, SS.empty)
297 :     in
298 :     fun libraryexports (ERRORCOLLECTION, _, _, _, _) = SS.empty
299 :     | libraryexports (COLLECTION { subgroups, ... }, p, error,
300 :     hasoptions, elab) = let
301 :     fun err m = (error m; SS.empty)
302 :     in
303 :     case List.find (samepathas p) subgroups of
304 :     SOME (_, GG.GROUP { kind = GG.LIB _, exports, ... }, _) =>
305 :     (if hasoptions then
306 :     err (SrcPath.descr p ^
307 :     " cannot have options because it is already\
308 :     \ listed as a member")
309 :     else domainOf exports)
310 :     | SOME _ => err (SrcPath.descr p ^
311 :     " is a subgroup, not a library")
312 :     | NONE =>
313 :     (case elab () of
314 :     ERRORCOLLECTION => SS.empty
315 :     | COLLECTION { smlfiles = [],
316 :     subgroups = [(_, GG.GROUP
317 :     { kind = GG.LIB _, exports, ... }, _)],
318 :     ... } =>
319 :     domainOf exports
320 :     | COLLECTION { smlfiles, subgroups, ... } =>
321 :     (app (fn (p, _, _) => print (SrcPath.descr p ^ "\n"))
322 :     subgroups;
323 :     app (fn (i, _) => print (SmlInfo.descr i ^ "\n"))
324 :     smlfiles;
325 :     err "precisely one library must be named here"))
326 :     end
327 :    
328 :     fun groupexports (ERRORCOLLECTION, _, _) = SS.empty
329 :     | groupexports (COLLECTION { subgroups, ... }, NONE, _) = let
330 :     fun sgexp ((_, GG.GROUP { kind = GG.NOLIB _, exports, ... },
331 :     _), s) =
332 :     addDomain (exports, s)
333 :     | sgexp (_, s) = s
334 :     in
335 :     foldl sgexp SS.empty subgroups
336 :     end
337 :     | groupexports (COLLECTION { subgroups, ... }, SOME p, error) =
338 :     (case List.find (samepathas p) subgroups of
339 :     SOME (_, GG.GROUP { kind = GG.NOLIB _, exports, ... }, _) =>
340 :     domainOf exports
341 :     | SOME _ => (error (SrcPath.descr p ^
342 :     " is a library, not a subgroup");
343 :     SS.empty)
344 :     | NONE => (error ("no such subgroup: " ^ SrcPath.descr p);
345 :     SS.empty))
346 :     end
347 :    
348 : blume 840 fun is_errorcollection ERRORCOLLECTION = true
349 :     | is_errorcollection (COLLECTION _) = false
350 : blume 267 end

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