Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/trunk/src/cm/stable/stabilize.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 651, Thu Jun 1 18:34:03 2000 UTC revision 652, Tue Jun 6 02:14:56 2000 UTC
# Line 115  Line 115 
115           * position of its exporting sub-library and a representative           * position of its exporting sub-library and a representative
116           * symbol that can be used to find the BNODE within the           * symbol that can be used to find the BNODE within the
117           * exports of that library. *)           * exports of that library. *)
118          fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n, _)), _), m) =          fun oneB i (sy, (nth, _, _), m) =
119                case nth () of
120                    (_, DG.SB_BNODE (DG.BNODE n, _)) =>
121              StableMap.insert (m, #bininfo n, (i, sy))              StableMap.insert (m, #bininfo n, (i, sy))
122            | oneB _ (_, _, m) = m                | _ => m
123          fun oneSL ((_, g as GG.GROUP { exports, ... }), (m, i)) =          fun oneSL (g as GG.GROUP { exports, ... }, (m, i)) =
124              (SymbolMap.foldli (oneB i) m exports, i + 1)              (SymbolMap.foldli (oneB i) m exports, i + 1)
125            | oneSL (_, (m, i)) = (m, i + 1)            | oneSL (_, (m, i)) = (m, i + 1)
126          val (im, _) = foldl oneSL (StableMap.empty, 0) sublibs          fun oneSL' ((_, gth), a) = oneSL (gth (), a)
127            val (im, _) = foldl oneSL' (StableMap.empty, 0) sublibs
128          fun look i =          fun look i =
129              case StableMap.find (im, i) of              case StableMap.find (im, i) of
130                  SOME p => p                  SOME p => p
# Line 297  Line 300 
300                  fun xsg #"s" =                  fun xsg #"s" =
301                      let val p = abspath ()                      let val p = abspath ()
302                          val vo = option versionOptM version ()                          val vo = option versionOptM version ()
303                            fun gth () = getGroup' (p, vo)
304                      in                      in
305                          (p, getGroup' (p, vo))                          (p, Memoize.memoize gth)
306                      end                      end
307                    | xsg _ = raise Format                    | xsg _ = raise Format
308              in              in
# Line 310  Line 314 
314                      val sublibs = list sgListM sg ()                      val sublibs = list sgListM sg ()
315    
316                      fun getSublib i =                      fun getSublib i =
317                          (case #2 (List.nth (sublibs, i)) of                          (case #2 (List.nth (sublibs, i)) () of
318                               GG.GROUP x => x                               GG.GROUP x => x
319                             | GG.ERRORGROUP =>                             | GG.ERRORGROUP =>
320                                 EM.impossible "loadStable: ERRORGROUP")                                 EM.impossible "loadStable: ERRORGROUP")
# Line 321  Line 325 
325                              val { exports, ... } = getSublib pos                              val { exports, ... } = getSublib pos
326                          in                          in
327                              case SymbolMap.find (exports, sy) of                              case SymbolMap.find (exports, sy) of
328                                  SOME ((_, DG.SB_BNODE (_, x)), _) =>                                  SOME (nth, _, _) =>
329                                      (case nth () of
330                                           (_, DG.SB_BNODE (_, x)) =>
331                                  StabModmap.addEnv (#statenv x ())                                  StabModmap.addEnv (#statenv x ())
332                                | _ => raise Format                                       | _ => raise Format)
333                                  | NONE => raise Format
334                          end                          end
335    
336                      val { symenv, statenv, symbol, symbollist } =                      val { symenv, statenv, symbol, symbollist } =
# Line 400  Line 407 
407                                  val { exports = slexp, ... } = getSublib pos                                  val { exports = slexp, ... } = getSublib pos
408                              in                              in
409                                  case SymbolMap.find (slexp, sy) of                                  case SymbolMap.find (slexp, sy) of
410                                      SOME ((_, DG.SB_BNODE(n, _)), _) => n                                      SOME (nth, _, _) =>
411                                    | _ => raise Format                                        (case nth () of
412                                               (_, DG.SB_BNODE (n, _)) => n
413                                             | _ => raise Format)
414                                      | NONE => raise Format
415                              end                              end
416                            | sbn' #"3" = sn ()                            | sbn' #"3" = sn ()
417                            | sbn' _ = raise Format                            | sbn' _ = raise Format
# Line 418  Line 428 
428    
429                      and fsbnlist () = list fsbnListM fsbn ()                      and fsbnlist () = list fsbnListM fsbn ()
430    
431                        val lazy_fsbn = UU.r_lazy session fsbn
432    
433                      fun impexp () = let                      fun impexp () = let
434                          fun ie #"i" =                          fun ie #"i" =
435                              let val sy = symbol ()                              let val sy = symbol ()
436                                  (* really reads farbnodes! *)                                  (* really reads farbnodes! *)
437                                  val (f, n) = fsbn ()                                  val nth = lazy_fsbn ()
438                                  val ge = lazy_statenv ()                                  val ge = lazy_statenv ()
439                                    val sye = lazy_symenv ()
440                                    val statpid = pid ()
441                                    val sympid = pid ()
442                                    val allsyms = symbolset ()
443                                    fun ieth () = let
444                                        val (f, n) = nth ()
445                                  val ii = { statenv = ge,                                  val ii = { statenv = ge,
446                                             symenv = lazy_symenv (),                                                 symenv = sye,
447                                             statpid = pid (),                                                 statpid = statpid,
448                                             sympid = pid () }                                                 sympid = sympid }
449                                    in
450                                        (f, DG.SB_BNODE (n, ii))
451                                    end
452                                  val e = Statenv2DAEnv.cvtMemo ge                                  val e = Statenv2DAEnv.cvtMemo ge
453                                  (* put a filter in front to avoid having the                                  (* put a filter in front to avoid having
454                                   * FCTENV being queried needlessly (this                                   * the FCTENV being queried needlessly
455                                   * avoids spurious module loadings) *)                                   * (avoids spurious module loadings) *)
456                                  val e' =                                  val e' = DAEnv.FILTER
457                                      DAEnv.FILTER (SymbolSet.singleton sy, e)                                               (SymbolSet.singleton sy, e)
458                              in                              in
459                                  (sy, ((f, DG.SB_BNODE (n, ii)), e'))                                  (sy, (Memoize.memoize ieth, e', allsyms))
460                              end                              end
461                            | ie _ = raise Format                            | ie _ = raise Format
462                      in                      in
# Line 497  Line 518 
518              val sublibs = #sublibs grec              val sublibs = #sublibs grec
519              val exports = #exports grec              val exports = #exports grec
520    
521                fun force f = f ()
522    
523              val libstamp =              val libstamp =
524                  libStampOf (grouppath,                  libStampOf (grouppath,
525                              map (#2 o #1) (SymbolMap.listItems exports),                              map (#2 o force o #1)
526                                    (SymbolMap.listItems exports),
527                              sublibs)                              sublibs)
528    
529              fun writeBFC s i = BF.write { stream = s,              fun writeBFC s i = BF.write { stream = s,
# Line 619  Line 643 
643    
644                  and fsbn (_, n) k s = sbn n k s                  and fsbn (_, n) k s = sbn n k s
645    
646                  fun impexp (n, _) k s = fsbn n k s                  fun impexp (nth, _, _) k s = fsbn (nth ()) k s
647    
648                  val bnodes =                  val bnodes =
649                      lst impexp (SymbolMap.listItems exports)                      lst impexp (SymbolMap.listItems exports)
# Line 724  Line 748 
748                  "f" $ [filter f, sbn n]                  "f" $ [filter f, sbn n]
749              end              end
750    
751                val lazy_fsbn = PU.w_lazy fsbn
752    
753              (* Here is the place where we need to write interface info. *)              (* Here is the place where we need to write interface info. *)
754              fun impexp (s, (n, _)) = let              fun impexp (s, (nth, _, allsyms)) = let
755                  val op $ = PU.$ IMPEXP                  val op $ = PU.$ IMPEXP
756                  val { statenv, symenv, statpid, sympid } =                  val { statenv, symenv, statpid, sympid } =
757                      case n of                      case nth () of
758                          (_, DG.SB_BNODE (_, ii)) => ii                          (_, DG.SB_BNODE (_, ii)) => ii
759                        | (_, DG.SB_SNODE (DG.SNODE { smlinfo, ... })) =>                        | (_, DG.SB_SNODE (DG.SNODE { smlinfo, ... })) =>
760                              getII smlinfo                              getII smlinfo
761              in              in
762                  "i" $ [symbol s, fsbn n,                  "i" $ [symbol s,
763                           lazy_fsbn nth,
764                         lazy_env statenv,                         lazy_env statenv,
765                         lazy_symenv symenv,                         lazy_symenv symenv,
766                         pid statpid,                         pid statpid,
767                         pid sympid]                         pid sympid,
768                           symbolset allsyms]
769              end              end
770    
771              fun w_exports e = let              fun w_exports e = let
# Line 758  Line 786 
786                  "v" $ [string (Version.toString v)]                  "v" $ [string (Version.toString v)]
787              end              end
788    
789              fun sg (p, g) = let              fun sg (p, gth) = let
790                  val op $ = PU.$ SG                  val op $ = PU.$ SG
791                  val vo = case g of GG.GROUP { kind = GG.LIB { version, ... },                  val vo = case gth () of
792                                                ... } => version                               GG.GROUP { kind = GG.LIB x, ... } => #version x
793                                   | _ => NONE                                   | _ => NONE
794              in              in
795                  "s" $ [abspath p, option version vo]                  "s" $ [abspath p, option version vo]
# Line 794  Line 822 
822              fun refetchStableGroup () = let              fun refetchStableGroup () = let
823                  fun getGroup (p, _) = let                  fun getGroup (p, _) = let
824                      fun theSublib (q, _) = SrcPath.compare (p, q) = EQUAL                      fun theSublib (q, _) = SrcPath.compare (p, q) = EQUAL
825                        fun force f = f ()
826                  in                  in
827                      Option.map #2 (List.find theSublib sublibs)                      Option.map (force o #2) (List.find theSublib sublibs)
828                  end                  end
829              in              in
830                  loadStable gp { getGroup = getGroup, anyerrors = anyerrors }                  loadStable gp { getGroup = getGroup, anyerrors = anyerrors }
# Line 848  Line 877 
877               (case recomp gp g of               (case recomp gp g of
878                    NONE => (anyerrors := true; NONE)                    NONE => (anyerrors := true; NONE)
879                  | SOME bfc_acc => let                  | SOME bfc_acc => let
880                        fun notStable (_, GG.GROUP { kind =                        fun notStable (_, gth) =
881                              case gth () of
882                                  GG.GROUP { kind =
883                                                     GG.LIB { kind = GG.STABLE _,                                                     GG.LIB { kind = GG.STABLE _,
884                                                              ... }, ... }) =                                                    ... }, ... } =>
885                            false                            false
886                          | notStable _ = true                              | _ => true
887                    in                    in
888                      case List.filter notStable (#sublibs grec) of                      case List.filter notStable (#sublibs grec) of
889                          [] => doit (wrapped, bfc_acc, version)                          [] => doit (wrapped, bfc_acc, version)

Legend:
Removed from v.651  
changed lines
  Added in v.652

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