Annotation of /sml/trunk/src/cm/stable/stabilize.sml

Parent Directory | Revision Log

---

Revision 393 - (view) (download)

1 :	blume	309	(*
2 :			* Reading, generating, and writing stable groups.
3 :			*
4 :			* (C) 1999 Lucent Technologies, Bell Laboratories
5 :			*
6 :			* Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7 :			*)
8 :			local
9 :	blume	304	structure DG = DependencyGraph
10 :	blume	306	structure GG = GroupGraph
11 :			structure EM = GenericVC.ErrorMsg
12 :	blume	311	structure PP = PrettyPrint
13 :			structure SM = GenericVC.SourceMap
14 :	blume	309	structure GP = GeneralParams
15 :			structure E = GenericVC.Environment
16 :	blume	357	structure Pid = GenericVC.PersStamps
17 :	blume	310
18 :			type statenvgetter = GP.info -> DG.bnode -> E.staticEnv
19 :	blume	314	type recomp = GP.info -> GG.group -> bool
20 :	blume	357	type pid = Pid.persstamp
21 :	blume	309	in
22 :	blume	304
23 :	blume	309	signature STABILIZE = sig
24 :
25 :			val loadStable :
26 :	blume	354	GP.info * (SrcPath.t -> GG.group option) * bool ref ->
27 :			SrcPath.t -> GG.group option
28 :	blume	309
29 :			val stabilize :
30 :	blume	311	GP.info -> { group: GG.group, anyerrors: bool ref } ->
31 :	blume	310	GG.group option
32 :	blume	309	end
33 :
34 :	blume	311	functor StabilizeFn (val bn2statenv : statenvgetter
35 :	blume	363	val transfer_state : SmlInfo.info * BinInfo.info -> unit
36 :	blume	357	val recomp : recomp) :> STABILIZE = struct
37 :	blume	309
38 :	blume	385	structure SSMap = BinaryMapFn
39 :			(struct
40 :			type ord_key = SymbolSet.set
41 :			val compare = SymbolSet.compare
42 :			end)
43 :
44 :	blume	384	structure SNMap = BinaryMapFn
45 :			(struct
46 :			type ord_key = DG.snode
47 :			fun compare (DG.SNODE n, DG.SNODE n') =
48 :			SmlInfo.compare (#smlinfo n, #smlinfo n')
49 :	blume	304	end)
50 :
51 :	blume	385	type 'a maps = { ss: 'a SSMap.map, sn: 'a SNMap.map }
52 :	blume	384
53 :	blume	385	val initMap = { ss = SSMap.empty, sn = SNMap.empty }
54 :	blume	393
55 :			structure PU = PickleUtilFn (type 'a map = 'a maps val emptyMap = initMap)
56 :			structure PSym = PickleSymbolFn (structure PU = PU)
57 :			structure UU = UnpickleUtil
58 :
59 :			infix 3 $
60 :			infixr 4 &
61 :			val op & = PU.&
62 :			val % = PU.%
63 :
64 :			(* type info *)
65 :			val (BN, SN, SBN, SS, SI, FSBN, IMPEXP, SHM) = (1, 2, 3, 4, 5, 6, 7, 8)
66 :
67 :	blume	385	val SSs = { find = fn (m: 'a maps, k) => SSMap.find (#ss m, k),
68 :			insert = fn ({ ss, sn }, k, v) =>
69 :			{ sn = sn, ss = SSMap.insert (ss, k, v) } }
70 :			val SNs = { find = fn (m: 'a maps, k) => SNMap.find (#sn m, k),
71 :			insert = fn ({ ss, sn }, k, v) =>
72 :			{ ss = ss, sn = SNMap.insert (sn, k, v) } }
73 :
74 :	blume	308	fun genStableInfoMap (exports, group) = let
75 :			(* find all the exported bnodes that are in the same group: *)
76 :			fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let
77 :			val i = #bininfo b
78 :			in
79 :	blume	354	if SrcPath.compare (BinInfo.group i, group) = EQUAL then
80 :	blume	308	IntBinaryMap.insert (m, BinInfo.offset i, n)
81 :			else m
82 :			end
83 :			| add (_, m) = m
84 :			in
85 :			SymbolMap.foldl add IntBinaryMap.empty exports
86 :			end
87 :
88 :	blume	311	fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let
89 :	blume	304
90 :	blume	323	val primconf = #primconf (#param gp)
91 :			val policy = #fnpolicy (#param gp)
92 :
93 :	blume	340	val grouppath = #grouppath grec
94 :
95 :	blume	348	fun doit wrapped = let
96 :	blume	312
97 :	blume	314	val _ =
98 :	blume	348	if StringSet.isEmpty wrapped then ()
99 :	blume	314	else
100 :			Say.say ("$Stabilize: wrapping the following privileges:\n"
101 :	blume	312	:: map (fn s => (" " ^ s ^ "\n"))
102 :	blume	348	(StringSet.listItems wrapped))
103 :	blume	312
104 :	blume	354	val bname = SmlInfo.binname
105 :	blume	311	val bsz = OS.FileSys.fileSize o bname
106 :	blume	345
107 :	blume	311	fun cpb s i = let
108 :	blume	360	val N = 4096
109 :	blume	345	fun copy ins = let
110 :			fun cp () =
111 :			if BinIO.endOfStream ins then ()
112 :	blume	360	else (BinIO.output (s, BinIO.inputN (ins, N));
113 :			cp ())
114 :	blume	345	in
115 :			cp ()
116 :			end
117 :	blume	311	in
118 :	blume	345	SafeIO.perform { openIt = fn () => BinIO.openIn (bname i),
119 :			closeIt = BinIO.closeIn,
120 :			work = copy,
121 :			cleanup = fn () => () }
122 :	blume	311	end
123 :	blume	310
124 :	blume	311	val grpSrcInfo = (#errcons gp, anyerrors)
125 :	blume	308
126 :	blume	311	val exports = #exports grec
127 :	blume	348	val required = StringSet.difference (#required grec, wrapped)
128 :	blume	340	val sublibs = #sublibs grec
129 :	blume	304
130 :	blume	311	(* The format of a stable archive is the following:
131 :			* - It starts with the size s of the pickled dependency
132 :			* graph. This size itself is written as four-byte string.
133 :			* - The pickled dependency graph. This graph contains
134 :			* integer offsets of the binfiles for the individual ML
135 :			* members. These offsets need to be adjusted by adding
136 :			* s + 4. The pickled dependency graph also contains integer
137 :			* offsets relative to other stable groups. These offsets
138 :			* need no further adjustment.
139 :			* - Individual binfile contents (concatenated).
140 :			*)
141 :	blume	304
142 :	blume	340	(* Here we build a mapping that maps each BNODE to a number
143 :			* representing the sub-library that it came from and a
144 :			* representative symbol that can be used to find the BNODE
145 :			* within the exports of that library *)
146 :			fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n)), _), m) =
147 :			StableMap.insert (m, #bininfo n, (i, sy))
148 :			| oneB i (_, _, m) = m
149 :	blume	380	fun oneSL ((g as GG.GROUP { exports, ... }), (m, i)) =
150 :	blume	340	(SymbolMap.foldli (oneB i) m exports, i + 1)
151 :			val inverseMap = #1 (foldl oneSL (StableMap.empty, 0) sublibs)
152 :	blume	330
153 :	blume	311	val members = ref []
154 :			val (registerOffset, getOffset) = let
155 :			val dict = ref SmlInfoMap.empty
156 :			val cur = ref 0
157 :			fun reg (i, sz) = let
158 :			val os = !cur
159 :	blume	306	in
160 :	blume	311	cur := os + sz;
161 :			dict := SmlInfoMap.insert (!dict, i, os);
162 :			members := i :: (!members);
163 :			os
164 :	blume	306	end
165 :	blume	311	fun get i = valOf (SmlInfoMap.find (!dict, i))
166 :			in
167 :			(reg, get)
168 :			end
169 :	blume	304
170 :	blume	384	val int = PU.w_int
171 :	blume	393	val symbol = PSym.w_symbol
172 :	blume	384	val share = PU.ah_share
173 :			val option = PU.w_option
174 :			val list = PU.w_list
175 :			val string = PU.w_string
176 :			val bool = PU.w_bool
177 :			val int = PU.w_int
178 :	blume	304
179 :	blume	385	fun symbolset ss = let
180 :			val op $ = PU.$ SS
181 :			fun raw_ss ss = "s" $ list symbol (SymbolSet.listItems ss)
182 :			in
183 :			share SSs raw_ss ss
184 :			end
185 :	blume	304
186 :	blume	384	val filter = option symbolset
187 :	blume	304
188 :	blume	387	fun shm (Sharing.SHARE true) = %SHM "a"
189 :			| shm (Sharing.SHARE false) = %SHM "b"
190 :			| shm Sharing.DONTSHARE = %SHM "c"
191 :	blume	304
192 :	blume	384	fun si i = let
193 :	blume	340	(* FIXME: this is not a technical flaw, but perhaps one
194 :			* that deserves fixing anyway: If we only look at spec,
195 :			* then we are losing information about sub-grouping
196 :			* within libraries. However, the spec in BinInfo.info
197 :			* is only used for diagnostics and has no impact on the
198 :			* operation of CM itself. *)
199 :	blume	354	val spec = SrcPath.specOf (SmlInfo.sourcepath i)
200 :	blume	311	val locs = SmlInfo.errorLocation gp i
201 :			val offset = registerOffset (i, bsz i)
202 :	blume	387	val sh_mode = SmlInfo.sh_mode i
203 :	blume	385	val op $ = PU.$ SI
204 :	blume	311	in
205 :	blume	387	"s" $ string spec & string locs & int offset & shm sh_mode
206 :	blume	311	end
207 :	blume	306
208 :	blume	384	fun primitive p =
209 :			string (String.str (Primitive.toIdent primconf p))
210 :	blume	306
211 :	blume	340	fun warn_relabs p abs = let
212 :			val relabs = if abs then "absolute" else "relative"
213 :	blume	330	fun ppb pps =
214 :			(PP.add_newline pps;
215 :	blume	354	PP.add_string pps (SrcPath.descr p);
216 :	blume	330	PP.add_newline pps;
217 :			PP.add_string pps
218 :			"(This means that in order to be able to use the result of stabilization";
219 :			PP.add_newline pps;
220 :	blume	340	PP.add_string pps "the library must be in the same ";
221 :	blume	330	PP.add_string pps relabs;
222 :			PP.add_string pps " location as it is now.)";
223 :			PP.add_newline pps)
224 :			in
225 :			EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
226 :			EM.WARN
227 :	blume	354	(concat [SrcPath.descr grouppath,
228 :	blume	340	": library referred to by ", relabs,
229 :			" pathname:"])
230 :	blume	330	ppb
231 :			end
232 :	blume	306
233 :	blume	384	fun abspath p = let
234 :			val pp = SrcPath.pickle (warn_relabs p) (p, grouppath)
235 :			in
236 :			list string pp
237 :			end
238 :	blume	306
239 :	blume	384	val op $ = PU.$ BN
240 :			fun bn (DG.PNODE p) = "1" $ primitive p
241 :			| bn (DG.BNODE { bininfo = i, ... }) = let
242 :	blume	340	val (n, sy) = valOf (StableMap.find (inverseMap, i))
243 :			in
244 :	blume	384	"2" $ int n & symbol sy
245 :	blume	340	end
246 :	blume	306
247 :	blume	385	fun sn n = let
248 :			fun raw_sn (DG.SNODE n) =
249 :			"a" $ si (#smlinfo n) & list sn (#localimports n) &
250 :			list fsbn (#globalimports n)
251 :	blume	384	in
252 :	blume	385	share SNs raw_sn n
253 :			end
254 :	blume	306
255 :	blume	385	and sbn x = let
256 :			val op $ = PU.$ SBN
257 :			in
258 :			case x of
259 :			DG.SB_BNODE n => "a" $ bn n
260 :			| DG.SB_SNODE n => "b" $ sn n
261 :			end
262 :
263 :			and fsbn (f, n) = let
264 :			val op $ = PU.$ FSBN
265 :			in
266 :			"f" $ filter f & sbn n
267 :			end
268 :	blume	370
269 :	blume	385	fun impexp (s, (n, _)) = let
270 :			val op $ = PU.$ IMPEXP
271 :			in
272 :			"i" $ symbol s & fsbn n
273 :	blume	384	end
274 :	blume	307
275 :	blume	384	fun w_exports e = list impexp (SymbolMap.listItemsi e)
276 :	blume	306
277 :	blume	384	fun privileges p = list string (StringSet.listItems p)
278 :	blume	306
279 :	blume	384	fun group () = let
280 :			fun sg (GG.GROUP { grouppath, ... }) = abspath grouppath
281 :	blume	311	in
282 :	blume	340	(* Pickle the sublibs first because we need to already
283 :	blume	330	* have them back when we unpickle BNODEs. *)
284 :	blume	384	list sg sublibs & w_exports exports & privileges required
285 :	blume	311	end
286 :	blume	308
287 :	blume	393	val pickle = PU.pickle (group ())
288 :	blume	311	val sz = size pickle
289 :			val offset_adjustment = sz + 4
290 :	blume	308
291 :	blume	361	fun mkStableGroup mksname = let
292 :	blume	311	val m = ref SmlInfoMap.empty
293 :			fun sn (DG.SNODE (n as { smlinfo, ... })) =
294 :			case SmlInfoMap.find (!m, smlinfo) of
295 :			SOME n => n
296 :			| NONE => let
297 :	blume	371	val li = map sn (#localimports n)
298 :			val gi = map fsbn (#globalimports n)
299 :	blume	311	val sourcepath = SmlInfo.sourcepath smlinfo
300 :	blume	340	(* FIXME: see the comment near the other
301 :	blume	354	* occurence of SrcPath.spec... *)
302 :			val spec = SrcPath.specOf sourcepath
303 :	blume	311	val offset =
304 :			getOffset smlinfo + offset_adjustment
305 :	blume	387	val sh_mode = SmlInfo.sh_mode smlinfo
306 :	blume	311	val locs = SmlInfo.errorLocation gp smlinfo
307 :			val error = EM.errorNoSource grpSrcInfo locs
308 :			val i = BinInfo.new { group = grouppath,
309 :	blume	361	mkStablename = mksname,
310 :	blume	311	spec = spec,
311 :			offset = offset,
312 :	blume	387	sh_mode = sh_mode,
313 :	blume	311	error = error }
314 :			val n = DG.BNODE { bininfo = i,
315 :			localimports = li,
316 :			globalimports = gi }
317 :			in
318 :	blume	363	transfer_state (smlinfo, i);
319 :	blume	311	m := SmlInfoMap.insert (!m, smlinfo, n);
320 :			n
321 :			end
322 :	blume	308
323 :	blume	311	and sbn (DG.SB_SNODE n) = sn n
324 :			| sbn (DG.SB_BNODE n) = n
325 :	blume	308
326 :	blume	311	and fsbn (f, n) = (f, sbn n)
327 :	blume	308
328 :	blume	311	fun impexp ((f, n), e) = ((f, DG.SB_BNODE (sbn n)), e)
329 :	blume	308
330 :	blume	311	val exports = SymbolMap.map impexp (#exports grec)
331 :			val simap = genStableInfoMap (exports, grouppath)
332 :			in
333 :			GG.GROUP { exports = exports,
334 :	blume	348	kind = GG.STABLELIB simap,
335 :	blume	311	required = required,
336 :			grouppath = grouppath,
337 :	blume	348	sublibs = sublibs }
338 :	blume	311	end
339 :	blume	308
340 :	blume	311	fun writeInt32 (s, i) = let
341 :			val a = Word8Array.array (4, 0w0)
342 :			val _ = Pack32Big.update (a, 0, LargeWord.fromInt i)
343 :			in
344 :			BinIO.output (s, Word8Array.extract (a, 0, NONE))
345 :			end
346 :			val memberlist = rev (!members)
347 :
348 :			val gpath = #grouppath grec
349 :	blume	361	fun mksname () = FilenamePolicy.mkStableName policy gpath
350 :	blume	345	fun work outs =
351 :	blume	354	(Say.vsay ["[stabilizing ", SrcPath.descr gpath, "]\n"];
352 :	blume	311	writeInt32 (outs, sz);
353 :			BinIO.output (outs, Byte.stringToBytes pickle);
354 :			app (cpb outs) memberlist;
355 :	blume	361	mkStableGroup mksname)
356 :	blume	311	in
357 :	blume	361	SOME (SafeIO.perform { openIt = AutoDir.openBinOut o mksname,
358 :	blume	345	closeIt = BinIO.closeOut,
359 :			work = work,
360 :	blume	354	cleanup = fn () =>
361 :	blume	361	(OS.FileSys.remove (mksname ())
362 :			handle _ => ()) })
363 :	blume	345	handle exn => NONE
364 :	blume	311	end
365 :			in
366 :	blume	348	case #kind grec of
367 :			GG.STABLELIB _ => SOME g
368 :			| GG.NOLIB => EM.impossible "stabilize: no library"
369 :			| GG.LIB wrapped =>
370 :	blume	314	if not (recomp gp g) then
371 :	blume	311	(anyerrors := true; NONE)
372 :			else let
373 :	blume	380	fun notStable (GG.GROUP { kind, ... }) =
374 :	blume	353	case kind of GG.STABLELIB _ => false | _ => true
375 :	blume	308	in
376 :	blume	340	case List.filter notStable (#sublibs grec) of
377 :	blume	348	[] => doit wrapped
378 :	blume	311	| l => let
379 :			val grammar = case l of [_] => " is" | _ => "s are"
380 :			fun ppb pps = let
381 :			fun loop [] = ()
382 :	blume	380	| loop (GG.GROUP { grouppath, ... } :: t) =
383 :	blume	311	(PP.add_string pps
384 :	blume	354	(SrcPath.descr grouppath);
385 :	blume	311	PP.add_newline pps;
386 :			loop t)
387 :			in
388 :			PP.add_newline pps;
389 :			PP.add_string pps
390 :			(concat ["because the following sub-group",
391 :			grammar, " not stable:"]);
392 :			PP.add_newline pps;
393 :			loop l
394 :			end
395 :			val errcons = #errcons gp
396 :	blume	354	val gdescr = SrcPath.descr (#grouppath grec)
397 :	blume	311	in
398 :			EM.errorNoFile (errcons, anyerrors) SM.nullRegion
399 :			EM.COMPLAIN
400 :	blume	354	(gdescr ^ " cannot be stabilized")
401 :	blume	311	ppb;
402 :			NONE
403 :			end
404 :	blume	308	end
405 :	blume	311	end
406 :	blume	310
407 :			fun loadStable (gp, getGroup, anyerrors) group = let
408 :	blume	306
409 :	blume	355	val es2bs = GenericVC.CoerceEnv.es2bs
410 :			fun bn2env n =
411 :			Statenv2DAEnv.cvtMemo (fn () => es2bs (bn2statenv gp n))
412 :	blume	308
413 :	blume	311	val errcons = #errcons gp
414 :			val grpSrcInfo = (errcons, anyerrors)
415 :	blume	354	val gdescr = SrcPath.descr group
416 :	blume	311	fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
417 :	blume	367	EM.COMPLAIN (concat ("(stable) " :: gdescr :: ": " :: l))
418 :			EM.nullErrorBody
419 :	blume	309
420 :	blume	384	exception Format = UU.Format
421 :	blume	306
422 :	blume	318	val pcmode = #pcmode (#param gp)
423 :	blume	310	val policy = #fnpolicy (#param gp)
424 :	blume	323	val primconf = #primconf (#param gp)
425 :	blume	361	fun mksname () = FilenamePolicy.mkStableName policy group
426 :	blume	310
427 :	blume	345	fun work s = let
428 :	blume	310
429 :	blume	345	fun getGroup' p =
430 :			case getGroup p of
431 :			SOME g => g
432 :	blume	354	| NONE => (error ["unable to find ", SrcPath.descr p];
433 :	blume	345	raise Format)
434 :	blume	306
435 :	blume	345	(* for getting sharing right... *)
436 :			val m = ref IntBinaryMap.empty
437 :			val next = ref 0
438 :	blume	304
439 :	blume	357	val pset = ref PidSet.empty
440 :
441 :	blume	345	fun bytesIn n = let
442 :			val bv = BinIO.inputN (s, n)
443 :			in
444 :			if n = Word8Vector.length bv then bv
445 :			else raise Format
446 :			end
447 :	blume	304
448 :	blume	345	val sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
449 :	blume	384	val pickle = Byte.bytesToString (bytesIn sz)
450 :	blume	345	val offset_adjustment = sz + 4
451 :
452 :	blume	391	val session = UU.mkSession (UU.stringGetter pickle)
453 :	blume	304
454 :	blume	384	fun list m r = UU.r_list session m r
455 :			fun option m r = UU.r_option session m r
456 :			val int = UU.r_int session
457 :			fun share m r = UU.share session m r
458 :	blume	387	fun nonshare r = UU.nonshare session r
459 :	blume	384	val string = UU.r_string session
460 :	blume	393	val symbol = UnpickleSymbol.r_symbol (session, string)
461 :	blume	384	val bool = UU.r_bool session
462 :	blume	304
463 :	blume	384	val stringListM = UU.mkMap ()
464 :			val symbolListM = UU.mkMap ()
465 :			val stringListM = UU.mkMap ()
466 :	blume	385	val ssM = UU.mkMap ()
467 :	blume	384	val ssoM = UU.mkMap ()
468 :			val boolOptionM = UU.mkMap ()
469 :	blume	385	val siM = UU.mkMap ()
470 :	blume	384	val sgListM = UU.mkMap ()
471 :			val snM = UU.mkMap ()
472 :			val snListM = UU.mkMap ()
473 :			val bnM = UU.mkMap ()
474 :			val sbnM = UU.mkMap ()
475 :	blume	385	val fsbnM = UU.mkMap ()
476 :	blume	384	val fsbnListM = UU.mkMap ()
477 :	blume	385	val impexpM = UU.mkMap ()
478 :	blume	384	val impexpListM = UU.mkMap ()
479 :	blume	304
480 :	blume	384	val stringlist = list stringListM string
481 :	blume	304
482 :	blume	384	fun abspath () =
483 :			SrcPath.unpickle pcmode (stringlist (), group)
484 :	blume	367	handle SrcPath.Format => raise Format
485 :			| SrcPath.BadAnchor a =>
486 :			(error ["configuration anchor \"", a, "\" undefined"];
487 :			raise Format)
488 :	blume	304
489 :	blume	384	val symbollist = list symbolListM symbol
490 :	blume	367
491 :	blume	385	fun symbolset () = let
492 :			fun s #"s" = SymbolSet.addList (SymbolSet.empty, symbollist ())
493 :			| s _ = raise Format
494 :			in
495 :			share ssM s
496 :			end
497 :	blume	305
498 :	blume	384	val filter = option ssoM symbolset
499 :	blume	305
500 :	blume	384	fun primitive () =
501 :			valOf (Primitive.fromIdent primconf
502 :			(String.sub (string (), 0)))
503 :			handle _ => raise Format
504 :	blume	305
505 :	blume	387	fun shm () = let
506 :			fun s #"a" = Sharing.SHARE true
507 :			| s #"b" = Sharing.SHARE false
508 :			| s #"c" = Sharing.DONTSHARE
509 :			| s _ = raise Format
510 :			in
511 :			nonshare s
512 :			end
513 :	blume	305
514 :	blume	384	fun si () = let
515 :	blume	385	fun s #"s" =
516 :			let val spec = string ()
517 :			val locs = string ()
518 :			val offset = int () + offset_adjustment
519 :	blume	387	val sh_mode = shm ()
520 :	blume	385	val error = EM.errorNoSource grpSrcInfo locs
521 :			in
522 :			BinInfo.new { group = group,
523 :			mkStablename = mksname,
524 :			error = error,
525 :			spec = spec,
526 :			offset = offset,
527 :	blume	387	sh_mode = sh_mode }
528 :	blume	385	end
529 :			| s _ = raise Format
530 :	blume	345	in
531 :	blume	385	share siM s
532 :	blume	345	end
533 :	blume	306
534 :	blume	384	fun sg () = getGroup' (abspath ())
535 :	blume	345
536 :	blume	384	val sublibs = list sgListM sg ()
537 :	blume	307
538 :	blume	384	fun bn () = let
539 :			fun bn' #"1" = DG.PNODE (primitive ())
540 :			| bn' #"2" = let
541 :			val n = int ()
542 :			val sy = symbol ()
543 :	blume	380	val GG.GROUP { exports = slexp, ... } =
544 :	blume	340	List.nth (sublibs, n) handle _ => raise Format
545 :	blume	330	in
546 :	blume	340	case SymbolMap.find (slexp, sy) of
547 :	blume	330	SOME ((_, DG.SB_BNODE (n as DG.BNODE _)), _) => n
548 :			| _ => raise Format
549 :			end
550 :	blume	384	| bn' _ = raise Format
551 :			in
552 :			share bnM bn'
553 :			end
554 :	blume	306
555 :	blume	330	(* this is the place where what used to be an
556 :			* SNODE changes to a BNODE! *)
557 :	blume	384	fun sn () = let
558 :			fun sn' #"a" =
559 :			DG.BNODE { bininfo = si (),
560 :			localimports = snlist (),
561 :			globalimports = fsbnlist () }
562 :			| sn' _ = raise Format
563 :			in
564 :			share snM sn'
565 :			end
566 :	blume	306
567 :	blume	384	and snlist () = list snListM sn ()
568 :	blume	306
569 :	blume	330	(* this one changes from farsbnode to plain farbnode *)
570 :	blume	384	and sbn () = let
571 :			fun sbn' #"a" = bn ()
572 :			| sbn' #"b" = sn ()
573 :			| sbn' _ = raise Format
574 :			in
575 :			share sbnM sbn'
576 :			end
577 :	blume	306
578 :	blume	385	and fsbn () = let
579 :			fun f #"f" = (filter (), sbn ())
580 :			| f _ = raise Format
581 :			in
582 :			share fsbnM f
583 :			end
584 :	blume	306
585 :	blume	384	and fsbnlist () = list fsbnListM fsbn ()
586 :
587 :			fun impexp () = let
588 :	blume	385	fun ie #"i" =
589 :			let val sy = symbol ()
590 :			val (f, n) = fsbn () (* really reads farbnodes! *)
591 :			val e = bn2env n
592 :			(* put a filter in front to avoid having the FCTENV
593 :			* being queried needlessly (this avoids spurious
594 :			* module loadings) *)
595 :			val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)
596 :			in
597 :			(* coerce to farsbnodes *)
598 :			(sy, ((f, DG.SB_BNODE n), e'))
599 :			end
600 :			| ie _ = raise Format
601 :	blume	330	in
602 :	blume	385	share impexpM ie
603 :	blume	330	end
604 :
605 :	blume	384	val impexplist = list impexpListM impexp
606 :
607 :	blume	330	fun r_exports () =
608 :	blume	384	foldl SymbolMap.insert' SymbolMap.empty (impexplist ())
609 :	blume	330
610 :	blume	384	val stringlist = list stringListM string
611 :	blume	330
612 :	blume	384	fun privileges () =
613 :			StringSet.addList (StringSet.empty, stringlist ())
614 :
615 :	blume	306	val exports = r_exports ()
616 :	blume	384	val required = privileges ()
617 :	blume	308	val simap = genStableInfoMap (exports, group)
618 :	blume	306	in
619 :			GG.GROUP { exports = exports,
620 :	blume	348	kind = GG.STABLELIB simap,
621 :	blume	306	required = required,
622 :	blume	308	grouppath = group,
623 :	blume	348	sublibs = sublibs }
624 :	blume	306	end
625 :	blume	304	in
626 :	blume	361	SOME (SafeIO.perform { openIt = BinIO.openIn o mksname,
627 :	blume	345	closeIt = BinIO.closeIn,
628 :			work = work,
629 :			cleanup = fn () => () })
630 :			handle Format => NONE
631 :	blume	346	| IO.Io _ => NONE
632 :	blume	345	end
633 :	blume	304	end
634 :	blume	309
635 :			end (* local *)

---

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