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/stable/stabilize.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


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

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