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/smlfile/smlinfo.sml
ViewVC logotype

Diff of /sml/trunk/src/cm/smlfile/smlinfo.sml

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

revision 1136, Tue Mar 12 19:44:02 2002 UTC revision 1137, Tue Mar 12 22:28:55 2002 UTC
# Line 21  Line 21 
21      type attribs =      type attribs =
22          { split: splitrequest,          { split: splitrequest,
23            is_rts: bool,            is_rts: bool,
24              noguid: bool,
25            explicit_core_sym: Symbol.symbol option,            explicit_core_sym: Symbol.symbol option,
26            extra_compenv: StaticEnv.staticEnv option }            extra_compenv: StaticEnv.staticEnv option }
27    
# Line 48  Line 49 
49       * now which means that the file used to be in another group). *)       * now which means that the file used to be in another group). *)
50      val newGeneration : unit -> unit      val newGeneration : unit -> unit
51    
52      val info : splitrequest -> GeneralParams.info -> info_args -> info      val info : splitrequest * bool -> GeneralParams.info -> info_args -> info
53    
54      val info' : attribs -> GeneralParams.info -> info_args -> info      val info' : attribs -> GeneralParams.info -> info_args -> info
55    
# Line 68  Line 69 
69      val lastseen : info -> TStamp.t      val lastseen : info -> TStamp.t
70      val setup : info -> string option * string option      val setup : info -> string option * string option
71      val is_local : info -> bool      val is_local : info -> bool
72        val setguid : info * string -> unit
73        val guid : info -> string
74    
75      (* forget a parse tree that we are done with *)      (* forget a parse tree that we are done with *)
76      val forgetParsetree : info -> unit      val forgetParsetree : info -> unit
# Line 109  Line 112 
112    
113      type attribs = { split: splitrequest,      type attribs = { split: splitrequest,
114                       is_rts: bool,                       is_rts: bool,
115                         noguid: bool,
116                       explicit_core_sym: Symbol.symbol option,                       explicit_core_sym: Symbol.symbol option,
117                       extra_compenv: StaticEnv.staticEnv option }                       extra_compenv: StaticEnv.staticEnv option }
118    
# Line 128  Line 132 
132                    lastseen: TStamp.t ref,                    lastseen: TStamp.t ref,
133                    parsetree: (ast * source) option ref,                    parsetree: (ast * source) option ref,
134                    skeleton: Skeleton.decl option ref,                    skeleton: Skeleton.decl option ref,
135                    sh_mode: Sharing.mode ref }                    sh_mode: Sharing.mode ref,
136                      setguid: string -> unit,
137                      guid: unit -> string }
138    
139      datatype info =      datatype info =
140          INFO of { sourcepath: SrcPath.file,          INFO of { sourcepath: SrcPath.file,
# Line 204  Line 210 
210      fun validate (sourcepath, PERS pir) = let      fun validate (sourcepath, PERS pir) = let
211          (* don't use "..." pattern to have the compiler catch later          (* don't use "..." pattern to have the compiler catch later
212           * additions to the type! *)           * additions to the type! *)
213          val { group, lastseen, parsetree, skeleton, sh_mode, generation } = pir          val { group, lastseen, parsetree, skeleton,
214                  sh_mode, generation, guid, setguid } = pir
215          val ts = !lastseen          val ts = !lastseen
216          val nts = SrcPath.tstamp sourcepath          val nts = SrcPath.tstamp sourcepath
217      in      in
# Line 222  Line 229 
229          val policy = #fnpolicy (#param gp)          val policy = #fnpolicy (#param gp)
230          fun mkSkelname () = FNP.mkSkelName policy sourcepath          fun mkSkelname () = FNP.mkSkelName policy sourcepath
231          fun mkBinname () = FNP.mkBinName policy sourcepath          fun mkBinname () = FNP.mkBinName policy sourcepath
232            fun mkguidname () = FNP.mkGUidName policy sourcepath
233          val groupreg = #groupreg gp          val groupreg = #groupreg gp
234            val (getguid, setguid) =
235                if #noguid attribs then (fn () => "", fn _ => ())
236                else let
237                    val guid_cache = ref NONE
238                    fun frombin () =
239                        SafeIO.perform { openIt =
240                                           fn () => BinIO.openIn (mkBinname ()),
241                                         closeIt = BinIO.closeIn,
242                                         work = SOME o Binfile.readGUid,
243                                         cleanup = fn _ => () }
244                        handle IO.Io _ => NONE
245                    fun fromfile () =
246                        SafeIO.perform { openIt =
247                                           fn () => TextIO.openIn (mkguidname ()),
248                                         closeIt = TextIO.closeIn,
249                                         work = SOME o TextIO.inputAll,
250                                         cleanup = fn _ => () }
251                        handle IO.Io _ => NONE
252                    fun tofile g = let
253                        val gf = mkguidname ()
254                    in
255                        SafeIO.perform { openIt = fn () => AutoDir.openTextOut gf,
256                                         closeIt = TextIO.closeOut,
257                                         work = fn s => TextIO.output (s, g),
258                                         cleanup = fn _ => OS.FileSys.remove gf }
259                    end
260                    fun setguid g = (guid_cache := SOME g; tofile g)
261                    fun saveguid g = (setguid g; g)
262                    fun getguid () = let
263                        fun newguid () =
264                            concat ["guid-", SrcPath.descr sourcepath, "-",
265                                    Time.toString (Time.now ()), "\n"]
266                    in
267                        case !guid_cache of
268                            SOME g => g
269                          | NONE =>
270                            (case frombin () of
271                                 SOME g => saveguid g
272                               | NONE =>
273                                 (case fromfile () of
274                                      SOME g => g
275                                    | NONE => saveguid (newguid ())))
276                    end
277                in
278                    (getguid, setguid)
279                end
280    
281          fun newpersinfo () = let          fun newpersinfo () = let
282              val ts = SrcPath.tstamp sourcepath              val ts = SrcPath.tstamp sourcepath
283              val pi = PERS { group = gr, lastseen = ref ts,              val pi = PERS { group = gr, lastseen = ref ts,
284                              parsetree = ref NONE, skeleton = ref NONE,                              parsetree = ref NONE, skeleton = ref NONE,
285                              sh_mode = ref (Sharing.SHARE false),                              sh_mode = ref (Sharing.SHARE false),
286                              generation = ref (now ()) }                              generation = ref (now ()),
287                                setguid = setguid,
288                                guid = getguid }
289          in          in
290              knownInfo := SrcPathMap.insert (!knownInfo, sourcepath, pi);              knownInfo := SrcPathMap.insert (!knownInfo, sourcepath, pi);
291              pi              pi
# Line 267  Line 324 
324                 locl = locl }                 locl = locl }
325      end      end
326    
327      fun info split = info' { split = split, extra_compenv = NONE,      fun info (split, noguid) =
328                               is_rts = false, explicit_core_sym = NONE }          info' { split = split, extra_compenv = NONE,
329                    is_rts = false, noguid = noguid,
330                    explicit_core_sym = NONE }
331    
332      (* the following functions are only concerned with getting the data,      (* the following functions are only concerned with getting the data,
333       * not with checking time stamps *)       * not with checking time stamps *)
# Line 392  Line 451 
451      in      in
452          EM.matchErrorString (GroupReg.lookup (#groupreg gp) group) reg          EM.matchErrorString (GroupReg.lookup (#groupreg gp) group) reg
453      end      end
454    
455        fun guid (INFO { persinfo = PERS { guid = g, ... }, ... }) = g ()
456    
457        fun setguid (INFO { persinfo = PERS { setguid = sg, ... }, ... }, g) = sg g
458  end  end

Legend:
Removed from v.1136  
changed lines
  Added in v.1137

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