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 310, Wed Jun 2 07:28:27 1999 UTC revision 311, Wed Jun 2 09:08:48 1999 UTC
# Line 9  Line 9 
9      structure DG = DependencyGraph      structure DG = DependencyGraph
10      structure GG = GroupGraph      structure GG = GroupGraph
11      structure EM = GenericVC.ErrorMsg      structure EM = GenericVC.ErrorMsg
12        structure PP = PrettyPrint
13        structure SM = GenericVC.SourceMap
14      structure GP = GeneralParams      structure GP = GeneralParams
15      structure E = GenericVC.Environment      structure E = GenericVC.Environment
16    
17      type statenvgetter = GP.info -> DG.bnode -> E.staticEnv      type statenvgetter = GP.info -> DG.bnode -> E.staticEnv
18        type recomp = GG.group * GP.info -> bool
19  in  in
20    
21  signature STABILIZE = sig  signature STABILIZE = sig
# Line 22  Line 25 
25          AbsPath.t -> GG.group option          AbsPath.t -> GG.group option
26    
27      val stabilize :      val stabilize :
28          GP.info ->          GP.info -> { group: GG.group, anyerrors: bool ref } ->
         { group: GG.group, gpath: AbsPath.t, anyerrors: bool ref } ->  
29          GG.group option          GG.group option
30  end  end
31    
32  functor StabilizeFn (val bn2statenv : statenvgetter) :> STABILIZE = struct  functor StabilizeFn (val bn2statenv : statenvgetter
33                         val recomp: recomp) :> STABILIZE = struct
34    
35      datatype pitem =      datatype pitem =
36          PSS of SymbolSet.set          PSS of SymbolSet.set
# Line 77  Line 80 
80          handle e as Interrupt.Interrupt => raise e          handle e as Interrupt.Interrupt => raise e
81               | _ => ()               | _ => ()
82    
83      fun stabilize gp { group = g as GG.GROUP grec, gpath, anyerrors } =      fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let
         case #stableinfo grec of  
             GG.STABLE _ => SOME g  
           | GG.NONSTABLE granted => let  
84    
85            fun doit granted = let
86                  val bname = AbsPath.name o SmlInfo.binpath                  val bname = AbsPath.name o SmlInfo.binpath
87                  val bsz = OS.FileSys.fileSize o bname                  val bsz = OS.FileSys.fileSize o bname
88                  fun cpb s i = let                  fun cpb s i = let
# Line 99  Line 100 
100    
101                  val exports = #exports grec                  val exports = #exports grec
102                  val islib = #islib grec                  val islib = #islib grec
103                  val required = StringSet.difference (#required grec,              val required = StringSet.difference (#required grec, granted)
                                                      granted)  
104                  val grouppath = #grouppath grec                  val grouppath = #grouppath grec
105                  val subgroups = #subgroups grec                  val subgroups = #subgroups grec
106    
# Line 194  Line 194 
194                      fun esc #"\\" = "\\\\"                      fun esc #"\\" = "\\\\"
195                        | esc #"\"" = "\\\""                        | esc #"\"" = "\\\""
196                        | esc c = String.str c                        | esc c = String.str c
   
197                  in                  in
198                      String.translate esc s :: "\"" :: k m                      String.translate esc s :: "\"" :: k m
199                  end                  end
# Line 216  Line 215 
215    
216                  fun w_primitive p k m = String.str (Primitive.toIdent p) :: k m                  fun w_primitive p k m = String.str (Primitive.toIdent p) :: k m
217    
218                  fun w_abspath_raw p k m =              fun w_abspath_raw p k m = w_list w_string (AbsPath.pickle p) k m
                     w_list w_string (AbsPath.pickle p) k m  
219    
220                  val w_abspath = w_share w_abspath_raw PAP                  val w_abspath = w_share w_abspath_raw PAP
221    
# Line 252  Line 250 
250                      fun k0 m = []                      fun k0 m = []
251                      val m0 = (0, Map.empty)                      val m0 = (0, Map.empty)
252                  in                  in
253                      concat                  concat (w_exports exports
                        (w_exports exports  
254                             (w_bool islib                             (w_bool islib
255                                (w_privileges required                                (w_privileges required
256                                      (w_list w_sg subgroups k0))) m0)                                      (w_list w_sg subgroups k0))) m0)
# Line 318  Line 315 
315                  val memberlist = rev (!members)                  val memberlist = rev (!members)
316    
317                  val policy = #fnpolicy (#param gp)                  val policy = #fnpolicy (#param gp)
318                val gpath = #grouppath grec
319                  val spath = FilenamePolicy.mkStablePath policy gpath                  val spath = FilenamePolicy.mkStablePath policy gpath
320                  fun delete () = deleteFile (AbsPath.name spath)                  fun delete () = deleteFile (AbsPath.name spath)
321                  val outs = AbsPath.openBinOut spath                  val outs = AbsPath.openBinOut spath
# Line 336  Line 334 
334                                                      raise e)                                                      raise e)
335                       | exn => (BinIO.closeOut outs; NONE)                       | exn => (BinIO.closeOut outs; NONE)
336              end              end
337        in
338            case #stableinfo grec of
339                GG.STABLE _ => SOME g
340              | GG.NONSTABLE granted =>
341                    if not (recomp (g, gp)) then
342                        (anyerrors := true; NONE)
343                    else let
344                        fun notStable (GG.GROUP { stableinfo, ... }) =
345                            case stableinfo of
346                                GG.STABLE _ => false
347                              | GG.NONSTABLE _ => true
348                    in
349                        case List.filter notStable (#subgroups grec) of
350                            [] => doit granted
351                          | l => let
352                                val grammar = case l of [_] => " is" | _ => "s are"
353                                fun ppb pps = let
354                                    fun loop [] = ()
355                                      | loop (GG.GROUP { grouppath, ... } :: t) =
356                                        (PP.add_string pps
357                                            (AbsPath.name grouppath);
358                                         PP.add_newline pps;
359                                         loop t)
360                                in
361                                    PP.add_newline pps;
362                                    PP.add_string pps
363                                        (concat ["because the following sub-group",
364                                                 grammar, " not stable:"]);
365                                    PP.add_newline pps;
366                                    loop l
367                                end
368                                val errcons = #errcons gp
369                                val gname = AbsPath.name (#grouppath grec)
370                            in
371                                EM.errorNoFile (errcons, anyerrors) SM.nullRegion
372                                   EM.COMPLAIN
373                                   (gname ^ " cannot be stabilized")
374                                   ppb;
375                                NONE
376                            end
377                    end
378        end
379    
380      fun loadStable (gp, getGroup, anyerrors) group = let      fun loadStable (gp, getGroup, anyerrors) group = let
381    
382          fun bn2env n = Statenv2DAEnv.cvtMemo (fn () => bn2statenv gp n)          fun bn2env n = Statenv2DAEnv.cvtMemo (fn () => bn2statenv gp n)
383    
384          val grpSrcInfo = (#errcons gp, anyerrors)          val errcons = #errcons gp
385            val grpSrcInfo = (errcons, anyerrors)
386            val gname = AbsPath.name group
387            fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
388                EM.COMPLAIN (concat (gname :: ": " :: l)) EM.nullErrorBody
389    
390          exception Format          exception Format
391    
392          val policy = #fnpolicy (#param gp)          val policy = #fnpolicy (#param gp)
393          val spath = FilenamePolicy.mkStablePath policy group          val spath = FilenamePolicy.mkStablePath policy group
394          val _ = Say.vsay ["[checking stable ", AbsPath.name group, "]\n"]          val _ = Say.vsay ["[checking stable ", gname, "]\n"]
395          val s = AbsPath.openBinIn spath          val s = AbsPath.openBinIn spath
396    
397          fun getGroup' p =          fun getGroup' p =
398              case getGroup p of              case getGroup p of
399                  SOME g => g                  SOME g => g
400                | NONE => raise Format                | NONE =>
401                        (error ["unable to find ", AbsPath.name p];
402                         raise Format)
403    
404          (* for getting sharing right... *)          (* for getting sharing right... *)
405          val m = ref IntBinaryMap.empty          val m = ref IntBinaryMap.empty

Legend:
Removed from v.310  
changed lines
  Added in v.311

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