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/paths/abspath.sml
ViewVC logotype

Diff of /sml/trunk/src/cm/paths/abspath.sml

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

revision 353, Thu Jun 24 09:43:28 1999 UTC revision 369, Sun Jul 4 12:55:20 1999 UTC
# Line 7  Line 7 
7   *)   *)
8  signature ABSPATH = sig  signature ABSPATH = sig
9    
10        exception Format        (* if something is seriously wrong with a pickle *)
11        exception BadAnchor of string       (* if anchor cannot be resolved *)
12    
13      type context      type context
14      type t      type t
15      type ord_key = t      type ord_key = t
16    
     val revalidateCwd : unit -> unit  
17      val newEra : unit -> unit      val newEra : unit -> unit
18        val revalidateCwd : unit -> unit
19    
20      val cwdContext: unit -> context      val cwdContext: unit -> context
21      val sameDirContext: t -> context      val sameDirContext: t -> context
22    
23      val name : t -> string      val osstring : t -> string
24        val descr : t -> string
25      val compare : t * t -> order      val compare : t * t -> order
26      val contextOf : t -> context      val contextOf : t -> context
27      val specOf : t -> string      val specOf : t -> string
# Line 25  Line 29 
29    
30      (* Replace the anchor context in the path argument with the      (* Replace the anchor context in the path argument with the
31       * given context. Returns NONE if there was no anchor context. *)       * given context. Returns NONE if there was no anchor context. *)
32      val reAnchor : t * string -> t option      val reAnchoredName : t * string -> string option
33    
34      val native : { context: context, spec: string } -> t      val native : { context: context, spec: string } -> t
35      val standard : PathConfig.mode -> { context: context, spec: string } -> t      val standard : PathConfig.mode -> { context: context, spec: string } -> t
# Line 33  Line 37 
37      (* the second path argument is the path of the group spec that      (* the second path argument is the path of the group spec that
38       * pickling is based upon. *)       * pickling is based upon. *)
39      val pickle : (bool -> unit) -> t * t -> string list      val pickle : (bool -> unit) -> t * t -> string list
40      val unpickle : PathConfig.mode -> string list * t -> t option      val unpickle : PathConfig.mode -> string list * t -> t
   
     val joinDirFile : { dir: t, file: string } -> t  
     val splitDirFile : t -> { dir: t, file: string }  
     val dir : t -> t  
     val file : t -> string  
41    
     val exists : t -> bool  
42      val tstamp : t -> TStamp.t      val tstamp : t -> TStamp.t
     val setTime : t * TStamp.t -> unit  
     val delete : t -> unit  
   
     (* The open?Out functions automagically create any necessary directories  
      * and announce this activity. *)  
     val openTextIn : t -> TextIO.instream  
     val openTextOut : t -> TextIO.outstream  
     val openBinIn : t -> BinIO.instream  
     val openBinOut : t -> BinIO.outstream  
43  end  end
44    
45  structure AbsPath :> ABSPATH = struct  structure AbsPath :> ABSPATH = struct
# Line 59  Line 48 
48      structure F = OS.FileSys      structure F = OS.FileSys
49      val impossible = GenericVC.ErrorMsg.impossible      val impossible = GenericVC.ErrorMsg.impossible
50    
51        exception Format
52        exception BadAnchor of string
53    
54      (* unique file id that can handle absent files *)      (* unique file id that can handle absent files *)
55      datatype id =      datatype id =
56          PRESENT of F.file_id          PRESENT of F.file_id
# Line 102  Line 94 
94      type ord_key = t      type ord_key = t
95    
96      local      local
         val elabStamp = ref (ref ())  
97          val cwdInfoCache : cwdinfo option ref = ref NONE          val cwdInfoCache : cwdinfo option ref = ref NONE
98          fun cwdInfo () =          fun cwdInfo () =
99              case !cwdInfoCache of              case !cwdInfoCache of
# Line 121  Line 112 
112          val cwdId = #id o cwdInfo          val cwdId = #id o cwdInfo
113      in      in
114          (* start a new era (i.e., invalidate all previous elaborations) *)          (* start a new era (i.e., invalidate all previous elaborations) *)
115          fun newEra () = elabStamp := ref ()          val newEra = Era.newEra
116    
117          (* make sure the cwd is consistent *)          (* make sure the cwd is consistent *)
118          fun revalidateCwd () =          fun revalidateCwd () =
# Line 139  Line 130 
130                  end                  end
131    
132          fun cwdContext () =          fun cwdContext () =
133              THEN_CWD { stamp = cwdStamp (), name = cwdName (), id = cwdId () }              (revalidateCwd ();
134                 THEN_CWD { stamp = cwdStamp (),
135                            name = cwdName (),
136                            id = cwdId () })
137    
138          fun sameDirContext p = DIR_OF p          fun sameDirContext p = DIR_OF p
139    
140          fun mkElab (cache, name) = let          fun mkElab (cache, name) = let
141              val e : elaboration =              val e : elaboration =
142                  { stamp = !elabStamp, name = name, id = ref NONE }                  { stamp = Era.thisEra (), name = name, id = ref NONE }
143          in          in
144              cache := SOME e; e              cache := SOME e; e
145          end          end
146    
147          fun validElab NONE = NONE          fun validElab NONE = NONE
148            | validElab (SOME (e as { stamp, name, id })) =            | validElab (SOME (e as { stamp, name, id })) =
149              if stamp = !elabStamp then SOME e else NONE              if Era.isThisEra stamp then SOME e else NONE
150    
151          val rootName = P.toString { isAbs = true, arcs = [], vol = "" }          val rootName = P.toString { isAbs = true, arcs = [], vol = "" }
152          val rootId = ref (NONE: id option)          val rootId = ref (NONE: id option)
# Line 160  Line 154 
154          fun elabContext c =          fun elabContext c =
155              case c of              case c of
156                  THEN_CWD { stamp, name, id } =>                  THEN_CWD { stamp, name, id } =>
157                      { stamp = !elabStamp, id = ref (SOME id),                      { stamp = Era.thisEra (), id = ref (SOME id),
158                        name = if stamp = cwdStamp () orelse name = cwdName ()                        name = if stamp = cwdStamp () orelse name = cwdName ()
159                               then P.currentArc else name }                               then P.currentArc else name }
160                | CONFIG_ANCHOR { fetch, cache, config_name } =>                | CONFIG_ANCHOR { fetch, cache, config_name } =>
# Line 172  Line 166 
166                  in                  in
167                      { name = P.dir name, stamp = stamp, id = ref NONE }                      { name = P.dir name, stamp = stamp, id = ref NONE }
168                  end                  end
169                | ROOT => { stamp = !elabStamp, name = rootName, id = rootId }                | ROOT => { stamp = Era.thisEra (),
170                              name = rootName, id = rootId }
171    
172          and elab (PATH { context, spec, cache }) =          and elab (PATH { context, spec, cache }) =
173              case validElab (!cache) of              case validElab (!cache) of
174                  SOME e => e                  SOME e => e
175                | NONE => let                | NONE => mkElab (cache,
176                      val name = P.mkCanonical                                  P.mkCanonical (P.concat
177                          (P.concat (#name (elabContext context),                                           (#name (elabContext context), spec)))
                                    spec))  
                 in  
                     mkElab (cache, name)  
                 end  
178    
179          (* get the file id (calls elab, so don't cache externally!) *)          (* get the file id (calls elab, so don't cache externally!) *)
180          fun id p = let          fun id p = let
# Line 199  Line 190 
190          end          end
191    
192          (* get the name as a string (calls elab, so don't cache externally!) *)          (* get the name as a string (calls elab, so don't cache externally!) *)
193          fun name p = #name (elab p)          fun osstring p = #name (elab p)
194    
195          (* get the context back *)          (* get the context back *)
196          fun contextOf (PATH { context = c, ... }) = c          fun contextOf (PATH { context = c, ... }) = c
# Line 271  Line 262 
262    
263          fun unpickle mode (l, gpath) = let          fun unpickle mode (l, gpath) = let
264              fun u_p (s :: l) =              fun u_p (s :: l) =
265                  Option.map                  PATH { spec = s, context = u_c l, cache = ref NONE }
266                     (fn c => PATH { spec = s, context = c, cache = ref NONE })                | u_p [] = raise Format
267                  (u_c l)              and u_c ["r"] = ROOT
268                | u_p [] = NONE                | u_c ["c"] = DIR_OF gpath
             and u_c ["r"] = SOME ROOT  
               | u_c ["c"] = SOME (DIR_OF gpath)  
269                | u_c [n, "a"] =                | u_c [n, "a"] =
270                  (case PathConfig.configAnchor mode n of                  (case PathConfig.configAnchor mode n of
271                       NONE => NONE                       NONE => raise BadAnchor n
272                     | SOME fetch =>                     | SOME fetch =>
273                           SOME (CONFIG_ANCHOR { config_name = n,                           CONFIG_ANCHOR { config_name = n,
274                                                 fetch = fetch,                                                 fetch = fetch,
275                                                 cache = ref NONE }))                                           cache = ref NONE })
276                | u_c l = Option.map DIR_OF (u_p l)                | u_c l = DIR_OF (u_p l)
277          in          in
278              u_p l              u_p l
279          end          end
280    
281          (* . and .. are not permitted as file parameter *)          fun tstamp p = TStamp.fmodTime (osstring p)
         fun joinDirFile { dir = PATH { context, spec, ... }, file } =  
             if file = P.currentArc orelse file = P.parentArc then  
                 impossible "AbsPath.joinDirFile: . or .."  
             else fresh (context, P.joinDirFile { dir = spec, file = file })  
282    
283          (* splitDirFile never walks past a context.          fun descr (PATH { spec, context, ... }) = let
284           * Moreover, it is an error to split something that ends in "..". *)              fun dir (x, l) =
285          fun splitDirFile (PATH { context, spec, ... }) = let                  case P.dir x of
286              fun loop "" =                      "" => l
287                  impossible "AbsPath.splitDirFile: tried to split a context"                    | d => d :: "/" :: l
288                | loop spec = let              fun d_c (CONFIG_ANCHOR { config_name = n, ... }, l) =
289                      val { dir, file } = P.splitDirFile spec                  "$" :: n :: "/" :: l
290                  in                | d_c (DIR_OF (PATH { spec, context, ... }), l) =
291                      if file = P.currentArc then loop dir                  d_c (context, dir (spec, l))
292                      else if file = P.parentArc then                | d_c (THEN_CWD _, l) = "./" :: l
293                          impossible "AbsPath.splitDirFile: <path>/.."                | d_c (ROOT, l) = "/" :: l
                     else (dir, file)  
                 end  
             val (dir, file) = loop spec  
             val dir = if dir = "" then P.currentArc else dir  
294          in          in
295              { dir = fresh (context, dir), file = file }              concat (d_c (context, [spec]))
296          end          end
297    
298          val dir = #dir o splitDirFile          fun reAnchoredName (p, dirstring) = let
         val file = #file o splitDirFile  
   
         fun fileExists n = F.access (n, []) handle _ => false  
         fun fileModTime n = F.modTime n handle _ => Time.zeroTime  
   
         val exists = fileExists o name  
   
         fun tstamp p = let  
             val n = name p  
         in  
             if fileExists n then TStamp.TSTAMP (fileModTime n)  
             else TStamp.NOTSTAMP  
         end  
   
         fun setTime (p, TStamp.NOTSTAMP) = ()  
           | setTime (p, TStamp.TSTAMP t) = F.setTime (name p, SOME t)  
   
         fun delete p = F.remove (name p) handle _ => ()  
   
         fun openOut fileopener ap = let  
             val p = name ap  
             fun generic (maker, pmaker, p) =  
                 maker p  
                 handle exn => let  
                     val { dir, ... } = P.splitDirFile p  
                 in  
                     if dir = "" orelse fileExists dir then raise exn  
                     else (pmaker dir; maker p)  
                 end  
             fun makedirs dir = generic (F.mkDir, makedirs, dir)  
             fun advertisemakedirs dir =  
                 (Say.vsay ["[creating directory ", dir, " ...]\n"];  
                  makedirs dir)  
         in  
             generic (fileopener, advertisemakedirs, p)  
         end  
   
         val openTextIn = TextIO.openIn o name  
         val openBinIn = BinIO.openIn o name  
         val openTextOut = openOut TextIO.openOut  
         val openBinOut = openOut BinIO.openOut  
     end  
   
     fun reAnchor (p, dirstring) = let  
299          fun path (PATH { context, spec, ... }) = let          fun path (PATH { context, spec, ... }) = let
300              fun mk c = PATH { context = c, spec = spec, cache = ref NONE }                  fun mk c = P.concat (c, spec)
301          in          in
302              Option.map mk (ctxt context)              Option.map mk (ctxt context)
303          end          end
304          and ctxt (CONFIG_ANCHOR { config_name = n, ... }) =          and ctxt (CONFIG_ANCHOR { config_name = n, ... }) =
305              SOME (CONFIG_ANCHOR { config_name = n,                  SOME (P.concat (dirstring, n))
306                                    fetch = fn () => P.concat (dirstring, n),                | ctxt (DIR_OF p) = Option.map P.dir (path p)
307                                    cache = ref NONE })                | ctxt (THEN_CWD _) = (Say.say ["."]; NONE)
308            | ctxt (DIR_OF p) = Option.map DIR_OF (path p)                | ctxt ROOT = (Say.say ["/"]; NONE)
           | ctxt (THEN_CWD _) = NONE  
           | ctxt ROOT = NONE  
309      in      in
310          path p              Option.map P.mkCanonical (path p)
311            end
312      end      end
313  end  end

Legend:
Removed from v.353  
changed lines
  Added in v.369

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