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

Parent Directory | Revision Log

---

Revision 348 - (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	310
17 :			type statenvgetter = GP.info -> DG.bnode -> E.staticEnv
18 :	blume	314	type recomp = GP.info -> GG.group -> bool
19 :	blume	309	in
20 :	blume	304
21 :	blume	309	signature STABILIZE = sig
22 :
23 :			val loadStable :
24 :	blume	310	GP.info * (AbsPath.t -> GG.group option) * bool ref ->
25 :			AbsPath.t -> GG.group option
26 :	blume	309
27 :			val stabilize :
28 :	blume	311	GP.info -> { group: GG.group, anyerrors: bool ref } ->
29 :	blume	310	GG.group option
30 :	blume	309	end
31 :
32 :	blume	311	functor StabilizeFn (val bn2statenv : statenvgetter
33 :			val recomp: recomp) :> STABILIZE = struct
34 :	blume	309
35 :	blume	307	datatype pitem =
36 :			PSS of SymbolSet.set
37 :			| PS of Symbol.symbol
38 :			| PSN of DG.snode
39 :	blume	304
40 :	blume	307	datatype uitem =
41 :			USS of SymbolSet.set
42 :			| US of Symbol.symbol
43 :			| UBN of DG.bnode
44 :	blume	304
45 :	blume	307	fun compare (PS s, PS s') = SymbolOrdKey.compare (s, s')
46 :			| compare (PS _, _) = GREATER
47 :			| compare (_, PS _) = LESS
48 :			| compare (PSS s, PSS s') = SymbolSet.compare (s, s')
49 :			| compare (PSS _, _) = GREATER
50 :			| compare (_, PSS _) = LESS
51 :			| compare (PSN (DG.SNODE n), PSN (DG.SNODE n')) =
52 :			SmlInfo.compare (#smlinfo n, #smlinfo n')
53 :
54 :	blume	304	structure Map =
55 :			BinaryMapFn (struct
56 :	blume	307	type ord_key = pitem
57 :	blume	304	val compare = compare
58 :			end)
59 :
60 :	blume	308	fun genStableInfoMap (exports, group) = let
61 :			(* find all the exported bnodes that are in the same group: *)
62 :			fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let
63 :			val i = #bininfo b
64 :			in
65 :			if AbsPath.compare (BinInfo.group i, group) = EQUAL then
66 :			IntBinaryMap.insert (m, BinInfo.offset i, n)
67 :			else m
68 :			end
69 :			| add (_, m) = m
70 :			in
71 :			SymbolMap.foldl add IntBinaryMap.empty exports
72 :			end
73 :
74 :	blume	345	fun deleteFile n = OS.FileSys.remove n handle _ => ()
75 :	blume	310
76 :	blume	311	fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let
77 :	blume	304
78 :	blume	323	val primconf = #primconf (#param gp)
79 :			val policy = #fnpolicy (#param gp)
80 :
81 :	blume	340	val grouppath = #grouppath grec
82 :			val groupdir = AbsPath.dir grouppath
83 :
84 :	blume	348	fun doit wrapped = let
85 :	blume	312
86 :	blume	314	val _ =
87 :	blume	348	if StringSet.isEmpty wrapped then ()
88 :	blume	314	else
89 :			Say.say ("$Stabilize: wrapping the following privileges:\n"
90 :	blume	312	:: map (fn s => (" " ^ s ^ "\n"))
91 :	blume	348	(StringSet.listItems wrapped))
92 :	blume	312
93 :	blume	311	val bname = AbsPath.name o SmlInfo.binpath
94 :			val bsz = OS.FileSys.fileSize o bname
95 :	blume	345
96 :	blume	311	fun cpb s i = let
97 :	blume	345	fun copy ins = let
98 :			fun cp () =
99 :			if BinIO.endOfStream ins then ()
100 :			else (BinIO.output (s, BinIO.input ins); cp ())
101 :			in
102 :			cp ()
103 :			end
104 :	blume	311	in
105 :	blume	345	SafeIO.perform { openIt = fn () => BinIO.openIn (bname i),
106 :			closeIt = BinIO.closeIn,
107 :			work = copy,
108 :			cleanup = fn () => () }
109 :	blume	311	end
110 :	blume	310
111 :	blume	311	val grpSrcInfo = (#errcons gp, anyerrors)
112 :	blume	308
113 :	blume	311	val exports = #exports grec
114 :	blume	348	val required = StringSet.difference (#required grec, wrapped)
115 :	blume	340	val sublibs = #sublibs grec
116 :	blume	304
117 :	blume	311	(* The format of a stable archive is the following:
118 :			* - It starts with the size s of the pickled dependency
119 :			* graph. This size itself is written as four-byte string.
120 :			* - The pickled dependency graph. This graph contains
121 :			* integer offsets of the binfiles for the individual ML
122 :			* members. These offsets need to be adjusted by adding
123 :			* s + 4. The pickled dependency graph also contains integer
124 :			* offsets relative to other stable groups. These offsets
125 :			* need no further adjustment.
126 :			* - Individual binfile contents (concatenated).
127 :			*)
128 :	blume	304
129 :	blume	340	(* Here we build a mapping that maps each BNODE to a number
130 :			* representing the sub-library that it came from and a
131 :			* representative symbol that can be used to find the BNODE
132 :			* within the exports of that library *)
133 :			fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n)), _), m) =
134 :			StableMap.insert (m, #bininfo n, (i, sy))
135 :			| oneB i (_, _, m) = m
136 :			fun oneSL ((_, g as GG.GROUP { exports, ... }), (m, i)) =
137 :			(SymbolMap.foldli (oneB i) m exports, i + 1)
138 :			val inverseMap = #1 (foldl oneSL (StableMap.empty, 0) sublibs)
139 :	blume	330
140 :	blume	311	val members = ref []
141 :			val (registerOffset, getOffset) = let
142 :			val dict = ref SmlInfoMap.empty
143 :			val cur = ref 0
144 :			fun reg (i, sz) = let
145 :			val os = !cur
146 :	blume	306	in
147 :	blume	311	cur := os + sz;
148 :			dict := SmlInfoMap.insert (!dict, i, os);
149 :			members := i :: (!members);
150 :			os
151 :	blume	306	end
152 :	blume	311	fun get i = valOf (SmlInfoMap.find (!dict, i))
153 :			in
154 :			(reg, get)
155 :			end
156 :	blume	304
157 :	blume	311	fun w_list w_item [] k m =
158 :			"0" :: k m
159 :			| w_list w_item [a] k m =
160 :			"1" :: w_item a k m
161 :			| w_list w_item [a, b] k m =
162 :			"2" :: w_item a (w_item b k) m
163 :			| w_list w_item [a, b, c] k m =
164 :			"3" :: w_item a (w_item b (w_item c k)) m
165 :			| w_list w_item [a, b, c, d] k m =
166 :			"4" :: w_item a (w_item b (w_item c (w_item d k))) m
167 :			| w_list w_item (a :: b :: c :: d :: e :: r) k m =
168 :			"5" :: w_item a (w_item b (w_item c (w_item d (w_item e
169 :			(w_list w_item r k))))) m
170 :	blume	304
171 :	blume	311	fun w_option w_item NONE k m = "n" :: k m
172 :			| w_option w_item (SOME i) k m = "s" :: w_item i k m
173 :	blume	304
174 :	blume	311	fun int_encode i = let
175 :			(* this is the same mechanism that's also used in
176 :			* TopLevel/batch/binfile.sml (maybe we should share it) *)
177 :			val n = Word32.fromInt i
178 :			val // = LargeWord.div
179 :			val %% = LargeWord.mod
180 :			val !! = LargeWord.orb
181 :			infix // %% !!
182 :			val toW8 = Word8.fromLargeWord
183 :			fun r (0w0, l) = Word8Vector.fromList l
184 :			| r (n, l) =
185 :			r (n // 0w128, toW8 ((n %% 0w128) !! 0w128) :: l)
186 :			in
187 :			Byte.bytesToString (r (n // 0w128, [toW8 (n %% 0w128)]))
188 :			end
189 :	blume	304
190 :	blume	311	fun w_int i k m = int_encode i :: k m
191 :	blume	304
192 :	blume	311	fun w_share w C v k (i, m) =
193 :			case Map.find (m, C v) of
194 :			SOME i' => "o" :: w_int i' k (i, m)
195 :			| NONE => "n" :: w v k (i + 1, Map.insert (m, C v, i))
196 :	blume	304
197 :	blume	311	fun w_symbol_raw s k m = let
198 :			val ns = case Symbol.nameSpace s of
199 :			Symbol.SIGspace => "'"
200 :			| Symbol.FCTspace => "("
201 :			| Symbol.FSIGspace => ")"
202 :			| Symbol.STRspace => ""
203 :			| _ => GenericVC.ErrorMsg.impossible "stabilize:w_symbol"
204 :			in
205 :			ns :: Symbol.name s :: "." :: k m
206 :			end
207 :	blume	304
208 :	blume	311	val w_symbol = w_share w_symbol_raw PS
209 :	blume	304
210 :	blume	311	val w_ss = w_share (w_list w_symbol o SymbolSet.listItems) PSS
211 :	blume	306
212 :	blume	311	val w_filter = w_option w_ss
213 :	blume	306
214 :	blume	311	fun w_string s k m = let
215 :			fun esc #"\\" = "\\\\"
216 :			| esc #"\"" = "\\\""
217 :			| esc c = String.str c
218 :			in
219 :			String.translate esc s :: "\"" :: k m
220 :			end
221 :	blume	306
222 :	blume	311	fun w_sharing NONE k m = "n" :: k m
223 :			| w_sharing (SOME true) k m = "t" :: k m
224 :			| w_sharing (SOME false) k m = "f" :: k m
225 :	blume	306
226 :	blume	311	fun w_si i k = let
227 :	blume	340	(* FIXME: this is not a technical flaw, but perhaps one
228 :			* that deserves fixing anyway: If we only look at spec,
229 :			* then we are losing information about sub-grouping
230 :			* within libraries. However, the spec in BinInfo.info
231 :			* is only used for diagnostics and has no impact on the
232 :			* operation of CM itself. *)
233 :	blume	311	val spec = AbsPath.spec (SmlInfo.sourcepath i)
234 :			val locs = SmlInfo.errorLocation gp i
235 :			val offset = registerOffset (i, bsz i)
236 :			in
237 :			w_string spec
238 :			(w_string locs
239 :			(w_int offset
240 :			(w_sharing (SmlInfo.share i) k)))
241 :			end
242 :	blume	306
243 :	blume	323	fun w_primitive p k m =
244 :			String.str (Primitive.toIdent primconf p) :: k m
245 :	blume	306
246 :	blume	340	fun warn_relabs p abs = let
247 :			val relabs = if abs then "absolute" else "relative"
248 :	blume	330	fun ppb pps =
249 :			(PP.add_newline pps;
250 :	blume	340	PP.add_string pps (AbsPath.name p);
251 :	blume	330	PP.add_newline pps;
252 :			PP.add_string pps
253 :			"(This means that in order to be able to use the result of stabilization";
254 :			PP.add_newline pps;
255 :	blume	340	PP.add_string pps "the library must be in the same ";
256 :	blume	330	PP.add_string pps relabs;
257 :			PP.add_string pps " location as it is now.)";
258 :			PP.add_newline pps)
259 :			in
260 :			EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
261 :			EM.WARN
262 :	blume	340	(concat [AbsPath.name grouppath,
263 :			": library referred to by ", relabs,
264 :			" pathname:"])
265 :	blume	330	ppb
266 :			end
267 :	blume	306
268 :	blume	330	fun w_abspath p k m =
269 :	blume	340	w_list w_string (AbsPath.pickle (warn_relabs p) (p, groupdir))
270 :			k m
271 :	blume	306
272 :	blume	311	fun w_bn (DG.PNODE p) k m = "p" :: w_primitive p k m
273 :	blume	340	| w_bn (DG.BNODE { bininfo = i, ... }) k m = let
274 :			val (n, sy) = valOf (StableMap.find (inverseMap, i))
275 :			in
276 :			"b" :: w_int n (w_symbol sy k) m
277 :			end
278 :	blume	306
279 :	blume	311	fun w_sn_raw (DG.SNODE n) k =
280 :			w_si (#smlinfo n)
281 :			(w_list w_sn (#localimports n)
282 :			(w_list w_fsbn (#globalimports n) k))
283 :	blume	306
284 :	blume	311	and w_sn n = w_share w_sn_raw PSN n
285 :	blume	307
286 :	blume	311	and w_sbn (DG.SB_BNODE n) k m = "b" :: w_bn n k m
287 :			| w_sbn (DG.SB_SNODE n) k m = "s" :: w_sn n k m
288 :	blume	306
289 :	blume	311	and w_fsbn (f, n) k = w_filter f (w_sbn n k)
290 :	blume	306
291 :	blume	311	fun w_impexp (s, (n, _)) k = w_symbol s (w_fsbn n k)
292 :	blume	306
293 :	blume	311	fun w_exports e = w_list w_impexp (SymbolMap.listItemsi e)
294 :	blume	306
295 :	blume	311	fun w_bool true k m = "t" :: k m
296 :			| w_bool false k m = "f" :: k m
297 :	blume	306
298 :	blume	311	fun w_privileges p = w_list w_string (StringSet.listItems p)
299 :	blume	306
300 :	blume	311	fun pickle_group () = let
301 :	blume	330	fun w_sg (p, _) = w_abspath p
302 :	blume	311	fun k0 m = []
303 :			val m0 = (0, Map.empty)
304 :			in
305 :	blume	340	(* Pickle the sublibs first because we need to already
306 :	blume	330	* have them back when we unpickle BNODEs. *)
307 :	blume	340	concat (w_list w_sg sublibs
308 :	blume	330	(w_exports exports
309 :	blume	348	(w_privileges required k0)) m0)
310 :	blume	311	end
311 :	blume	308
312 :	blume	311	val pickle = pickle_group ()
313 :			val sz = size pickle
314 :			val offset_adjustment = sz + 4
315 :	blume	308
316 :	blume	329	fun mkStableGroup spath = let
317 :	blume	311	val m = ref SmlInfoMap.empty
318 :			fun sn (DG.SNODE (n as { smlinfo, ... })) =
319 :			case SmlInfoMap.find (!m, smlinfo) of
320 :			SOME n => n
321 :			| NONE => let
322 :			val li = map sn (#localimports n)
323 :			val gi = map fsbn (#globalimports n)
324 :			val sourcepath = SmlInfo.sourcepath smlinfo
325 :	blume	340	(* FIXME: see the comment near the other
326 :			* occurence of AbsPath.spec... *)
327 :	blume	311	val spec = AbsPath.spec sourcepath
328 :			val offset =
329 :			getOffset smlinfo + offset_adjustment
330 :			val share = SmlInfo.share smlinfo
331 :			val locs = SmlInfo.errorLocation gp smlinfo
332 :			val error = EM.errorNoSource grpSrcInfo locs
333 :			val i = BinInfo.new { group = grouppath,
334 :	blume	329	stablepath = spath,
335 :	blume	311	spec = spec,
336 :			offset = offset,
337 :			share = share,
338 :			error = error }
339 :			val n = DG.BNODE { bininfo = i,
340 :			localimports = li,
341 :			globalimports = gi }
342 :			in
343 :			m := SmlInfoMap.insert (!m, smlinfo, n);
344 :			n
345 :			end
346 :	blume	308
347 :	blume	311	and sbn (DG.SB_SNODE n) = sn n
348 :			| sbn (DG.SB_BNODE n) = n
349 :	blume	308
350 :	blume	311	and fsbn (f, n) = (f, sbn n)
351 :	blume	308
352 :	blume	311	fun impexp ((f, n), e) = ((f, DG.SB_BNODE (sbn n)), e)
353 :	blume	308
354 :	blume	311	val exports = SymbolMap.map impexp (#exports grec)
355 :			val simap = genStableInfoMap (exports, grouppath)
356 :			in
357 :			GG.GROUP { exports = exports,
358 :	blume	348	kind = GG.STABLELIB simap,
359 :	blume	311	required = required,
360 :			grouppath = grouppath,
361 :	blume	348	sublibs = sublibs }
362 :	blume	311	end
363 :	blume	308
364 :	blume	311	fun writeInt32 (s, i) = let
365 :			val a = Word8Array.array (4, 0w0)
366 :			val _ = Pack32Big.update (a, 0, LargeWord.fromInt i)
367 :			in
368 :			BinIO.output (s, Word8Array.extract (a, 0, NONE))
369 :			end
370 :			val memberlist = rev (!members)
371 :
372 :			val gpath = #grouppath grec
373 :			val spath = FilenamePolicy.mkStablePath policy gpath
374 :			fun delete () = deleteFile (AbsPath.name spath)
375 :	blume	345	fun work outs =
376 :	blume	311	(Say.vsay ["[stabilizing ", AbsPath.name gpath, "]\n"];
377 :			writeInt32 (outs, sz);
378 :			BinIO.output (outs, Byte.stringToBytes pickle);
379 :			app (cpb outs) memberlist;
380 :	blume	345	mkStableGroup spath)
381 :	blume	311	in
382 :	blume	345	SOME (SafeIO.perform { openIt = fn () => AbsPath.openBinOut spath,
383 :			closeIt = BinIO.closeOut,
384 :			work = work,
385 :			cleanup = delete })
386 :			handle exn => NONE
387 :	blume	311	end
388 :			in
389 :	blume	348	case #kind grec of
390 :			GG.STABLELIB _ => SOME g
391 :			| GG.NOLIB => EM.impossible "stabilize: no library"
392 :			| GG.LIB wrapped =>
393 :	blume	314	if not (recomp gp g) then
394 :	blume	311	(anyerrors := true; NONE)
395 :			else let
396 :	blume	348	fun notStable (_, GG.GROUP { kind, ... }) =
397 :			case kind of GG.STABLELIB _ => true | _ => false
398 :	blume	308	in
399 :	blume	340	case List.filter notStable (#sublibs grec) of
400 :	blume	348	[] => doit wrapped
401 :	blume	311	| l => let
402 :			val grammar = case l of [_] => " is" | _ => "s are"
403 :			fun ppb pps = let
404 :			fun loop [] = ()
405 :	blume	330	| loop ((p, GG.GROUP { grouppath, ... })
406 :			:: t) =
407 :	blume	311	(PP.add_string pps
408 :			(AbsPath.name grouppath);
409 :	blume	330	PP.add_string pps " (";
410 :			PP.add_string pps (AbsPath.name p);
411 :			PP.add_string pps ")";
412 :	blume	311	PP.add_newline pps;
413 :			loop t)
414 :			in
415 :			PP.add_newline pps;
416 :			PP.add_string pps
417 :			(concat ["because the following sub-group",
418 :			grammar, " not stable:"]);
419 :			PP.add_newline pps;
420 :			loop l
421 :			end
422 :			val errcons = #errcons gp
423 :			val gname = AbsPath.name (#grouppath grec)
424 :			in
425 :			EM.errorNoFile (errcons, anyerrors) SM.nullRegion
426 :			EM.COMPLAIN
427 :			(gname ^ " cannot be stabilized")
428 :			ppb;
429 :			NONE
430 :			end
431 :	blume	308	end
432 :	blume	311	end
433 :	blume	310
434 :			fun loadStable (gp, getGroup, anyerrors) group = let
435 :	blume	306
436 :	blume	340	val groupdir = AbsPath.dir group
437 :	blume	310	fun bn2env n = Statenv2DAEnv.cvtMemo (fn () => bn2statenv gp n)
438 :	blume	308
439 :	blume	311	val errcons = #errcons gp
440 :			val grpSrcInfo = (errcons, anyerrors)
441 :			val gname = AbsPath.name group
442 :			fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
443 :			EM.COMPLAIN (concat (gname :: ": " :: l)) EM.nullErrorBody
444 :	blume	309
445 :	blume	306	exception Format
446 :
447 :	blume	318	val pcmode = #pcmode (#param gp)
448 :	blume	310	val policy = #fnpolicy (#param gp)
449 :	blume	323	val primconf = #primconf (#param gp)
450 :	blume	310	val spath = FilenamePolicy.mkStablePath policy group
451 :	blume	311	val _ = Say.vsay ["[checking stable ", gname, "]\n"]
452 :	blume	310
453 :	blume	345	fun work s = let
454 :	blume	310
455 :	blume	345	fun getGroup' p =
456 :			case getGroup p of
457 :			SOME g => g
458 :			| NONE => (error ["unable to find ", AbsPath.name p];
459 :			raise Format)
460 :	blume	306
461 :	blume	345	(* for getting sharing right... *)
462 :			val m = ref IntBinaryMap.empty
463 :			val next = ref 0
464 :	blume	304
465 :	blume	345	fun bytesIn n = let
466 :			val bv = BinIO.inputN (s, n)
467 :			in
468 :			if n = Word8Vector.length bv then bv
469 :			else raise Format
470 :			end
471 :	blume	304
472 :	blume	345	val sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
473 :			val pickle = bytesIn sz
474 :			val offset_adjustment = sz + 4
475 :
476 :			val rd = let
477 :			val pos = ref 0
478 :			fun rd () = let
479 :			val p = !pos
480 :			in
481 :			pos := p + 1;
482 :			Byte.byteToChar (Word8Vector.sub (pickle, p))
483 :			handle _ => raise Format
484 :			end
485 :	blume	306	in
486 :	blume	345	rd
487 :	blume	306	end
488 :	blume	304
489 :	blume	345	fun r_list r () =
490 :			case rd () of
491 :			#"0" => []
492 :			| #"1" => [r ()]
493 :			| #"2" => [r (), r ()]
494 :			| #"3" => [r (), r (), r ()]
495 :			| #"4" => [r (), r (), r (), r ()]
496 :			| #"5" => r () :: r () :: r () :: r () :: r () :: r_list r ()
497 :			| _ => raise Format
498 :	blume	304
499 :	blume	345	fun r_bool () =
500 :			case rd () of
501 :			#"t" => true
502 :			| #"f" => false
503 :			| _ => raise Format
504 :	blume	304
505 :	blume	345	fun r_option r_item () =
506 :			case rd () of
507 :			#"n" => NONE
508 :			| #"s" => SOME (r_item ())
509 :			| _ => raise Format
510 :	blume	304
511 :	blume	345	fun r_int () = let
512 :			fun loop n = let
513 :			val w8 = Byte.charToByte (rd ())
514 :			val n' =
515 :			n * 0w128 + Word8.toLargeWord (Word8.andb (w8, 0w127))
516 :			in
517 :			if Word8.andb (w8, 0w128) = 0w0 then n' else loop n'
518 :			end
519 :	blume	306	in
520 :	blume	345	LargeWord.toIntX (loop 0w0)
521 :	blume	306	end
522 :	blume	304
523 :	blume	345	fun r_share r_raw C unC () =
524 :	blume	306	case rd () of
525 :	blume	345	#"o" => (case IntBinaryMap.find (!m, r_int ()) of
526 :			SOME x => unC x
527 :			| NONE => raise Format)
528 :			| #"n" => let
529 :			val i = !next
530 :			val _ = next := i + 1
531 :			val v = r_raw ()
532 :			in
533 :			m := IntBinaryMap.insert (!m, i, C v);
534 :			v
535 :			end
536 :			| _ => raise Format
537 :	blume	304
538 :	blume	345	fun r_string () = let
539 :			fun loop l =
540 :	blume	306	case rd () of
541 :	blume	345	#"\"" => String.implode (rev l)
542 :			| #"\\" => loop (rd () :: l)
543 :			| c => loop (c :: l)
544 :	blume	306	in
545 :	blume	345	loop []
546 :	blume	306	end
547 :	blume	304
548 :	blume	345	fun r_abspath () =
549 :			case AbsPath.unpickle pcmode (r_list r_string (), groupdir) of
550 :			SOME p => p
551 :			| NONE => raise Format
552 :	blume	304
553 :	blume	345	val r_symbol = let
554 :			fun r_symbol_raw () = let
555 :			val (ns, first) =
556 :			case rd () of
557 :			#"`" => (Symbol.sigSymbol, rd ())
558 :			| #"(" => (Symbol.fctSymbol, rd ())
559 :			| #")" => (Symbol.fsigSymbol, rd ())
560 :			| c => (Symbol.strSymbol, c)
561 :			fun loop (#".", l) = String.implode (rev l)
562 :			| loop (c, l) = loop (rd (), c :: l)
563 :			in
564 :			ns (loop (first, []))
565 :			end
566 :			fun unUS (US x) = x
567 :			| unUS _ = raise Format
568 :			in
569 :			r_share r_symbol_raw US unUS
570 :			end
571 :	blume	305
572 :	blume	345	val r_ss = let
573 :			fun r_ss_raw () =
574 :			SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())
575 :			fun unUSS (USS s) = s
576 :			| unUSS _ = raise Format
577 :			in
578 :			r_share r_ss_raw USS unUSS
579 :			end
580 :	blume	305
581 :	blume	345	val r_filter = r_option r_ss
582 :	blume	305
583 :	blume	345	fun r_primitive () =
584 :			case Primitive.fromIdent primconf (rd ()) of
585 :			NONE => raise Format
586 :			| SOME p => p
587 :	blume	305
588 :	blume	345	fun r_sharing () =
589 :			case rd () of
590 :			#"n" => NONE
591 :			| #"t" => SOME true
592 :			| #"f" => SOME false
593 :			| _ => raise Format
594 :	blume	306
595 :	blume	345	fun r_si () = let
596 :			val spec = r_string ()
597 :			val locs = r_string ()
598 :			val offset = r_int () + offset_adjustment
599 :			val share = r_sharing ()
600 :			val error = EM.errorNoSource grpSrcInfo locs
601 :			in
602 :			BinInfo.new { group = group,
603 :			stablepath = spath,
604 :			error = error,
605 :			spec = spec,
606 :			offset = offset,
607 :			share = share }
608 :			end
609 :	blume	306
610 :	blume	345	fun r_sg () = let
611 :			val p = r_abspath ()
612 :			in
613 :			(p, getGroup' p)
614 :			end
615 :
616 :	blume	340	val sublibs = r_list r_sg ()
617 :	blume	307
618 :	blume	330	fun r_bn () =
619 :			case rd () of
620 :			#"p" => DG.PNODE (r_primitive ())
621 :			| #"b" => let
622 :	blume	340	val n = r_int ()
623 :	blume	330	val sy = r_symbol ()
624 :	blume	340	val (_, GG.GROUP { exports = slexp, ... }) =
625 :			List.nth (sublibs, n) handle _ => raise Format
626 :	blume	330	in
627 :	blume	340	case SymbolMap.find (slexp, sy) of
628 :	blume	330	SOME ((_, DG.SB_BNODE (n as DG.BNODE _)), _) => n
629 :			| _ => raise Format
630 :			end
631 :			| _ => raise Format
632 :	blume	306
633 :	blume	330	(* this is the place where what used to be an
634 :			* SNODE changes to a BNODE! *)
635 :			fun r_sn_raw () =
636 :			DG.BNODE { bininfo = r_si (),
637 :			localimports = r_list r_sn (),
638 :			globalimports = r_list r_fsbn () }
639 :	blume	306
640 :	blume	330	and r_sn () =
641 :			r_share r_sn_raw UBN (fn (UBN n) => n | _ => raise Format) ()
642 :	blume	306
643 :	blume	330	(* this one changes from farsbnode to plain farbnode *)
644 :			and r_sbn () =
645 :			case rd () of
646 :			#"b" => r_bn ()
647 :			| #"s" => r_sn ()
648 :			| _ => raise Format
649 :	blume	306
650 :	blume	330	and r_fsbn () = (r_filter (), r_sbn ())
651 :	blume	306
652 :	blume	330	fun r_impexp () = let
653 :			val sy = r_symbol ()
654 :			val (f, n) = r_fsbn () (* really reads farbnodes! *)
655 :			val e = bn2env n
656 :			(* put a filter in front to avoid having the FCTENV being
657 :			* queried needlessly (this avoids spurious module loadings) *)
658 :			val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)
659 :			in
660 :			(sy, ((f, DG.SB_BNODE n), e')) (* coerce to farsbnodes *)
661 :			end
662 :
663 :			fun r_exports () =
664 :			foldl SymbolMap.insert' SymbolMap.empty (r_list r_impexp ())
665 :
666 :			fun r_privileges () =
667 :			StringSet.addList (StringSet.empty, r_list r_string ())
668 :
669 :	blume	306	val exports = r_exports ()
670 :			val required = r_privileges ()
671 :	blume	308	val simap = genStableInfoMap (exports, group)
672 :	blume	306	in
673 :			GG.GROUP { exports = exports,
674 :	blume	348	kind = GG.STABLELIB simap,
675 :	blume	306	required = required,
676 :	blume	308	grouppath = group,
677 :	blume	348	sublibs = sublibs }
678 :	blume	306	end
679 :	blume	304	in
680 :	blume	345	SOME (SafeIO.perform { openIt = fn () => AbsPath.openBinIn spath,
681 :			closeIt = BinIO.closeIn,
682 :			work = work,
683 :			cleanup = fn () => () })
684 :			handle Format => NONE
685 :	blume	346	| IO.Io _ => NONE
686 :	blume	345	end
687 :	blume	304	end
688 :	blume	309
689 :			end (* local *)

---

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