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

Parent Directory | 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