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 352, Wed Jun 23 09:27:27 1999 UTC revision 353, Thu Jun 24 09:43:28 1999 UTC
# Line 15  Line 15 
15      val newEra : unit -> unit      val newEra : unit -> unit
16    
17      val cwdContext: unit -> context      val cwdContext: unit -> context
18      val relativeContext: t -> context      val sameDirContext: t -> context
19    
20      val name : t -> string      val name : t -> string
21      val compare : t * t -> order      val compare : t * t -> order
22      val context : t -> context      val contextOf : t -> context
23      val spec : t -> string      val specOf : t -> string
24      val contextName : context -> string      val contextName : context -> string
25    
26      (* Replace the anchor context in the path argument with the      (* Replace the anchor context in the path argument with the
27       * given context. Returns NONE if there was no anchor context. *)       * given context. Returns NONE if there was no anchor context. *)
28      val reAnchor : t * context -> t option      val reAnchor : t * string -> t option
29    
30      val native : { context: context, spec: string } -> t      val native : { context: context, spec: string } -> t
31      val standard : PathConfig.mode -> { context: context, spec: string } -> t      val standard : PathConfig.mode -> { context: context, spec: string } -> t
32    
33        (* the second path argument is the path of the group spec that
34         * pickling is based upon. *)
35      val pickle : (bool -> unit) -> t * t -> string list      val pickle : (bool -> unit) -> t * t -> string list
36      val unpickle : PathConfig.mode -> string list * t -> t option      val unpickle : PathConfig.mode -> string list * t -> t option
37    
# Line 85  Line 87 
87      type cwdinfo = { stamp: unit ref, name: string, id: id }      type cwdinfo = { stamp: unit ref, name: string, id: id }
88    
89      datatype context =      datatype context =
90          CUR of cwdinfo          THEN_CWD of cwdinfo
91        | CONFIG_ANCHOR of { fetch: unit -> string,        | CONFIG_ANCHOR of { fetch: unit -> string,
92                             cache: elaboration option ref,                             cache: elaboration option ref,
93                             config_name: string }                             config_name: string }
94        | RELATIVE of t        | DIR_OF of t
95        | ROOT        | ROOT
96    
97      and t =      and t =
# Line 117  Line 119 
119          val cwdStamp = #stamp o cwdInfo          val cwdStamp = #stamp o cwdInfo
120          val cwdName = #name o cwdInfo          val cwdName = #name o cwdInfo
121          val cwdId = #id o cwdInfo          val cwdId = #id o cwdInfo
         fun invalidateCwdInfo () = cwdInfoCache := NONE  
122      in      in
123          (* start a new era (i.e., invalidate all previous elaborations) *)          (* start a new era (i.e., invalidate all previous elaborations) *)
124          fun newEra () = elabStamp := ref ()          fun newEra () = elabStamp := ref ()
# Line 138  Line 139 
139                  end                  end
140    
141          fun cwdContext () =          fun cwdContext () =
142              CUR { stamp = cwdStamp (), name = cwdName (), id = cwdId () }              THEN_CWD { stamp = cwdStamp (), name = cwdName (), id = cwdId () }
143    
144          fun relativeContext (p as PATH { context, spec, ... }) =          fun sameDirContext p = DIR_OF p
             if spec = OS.Path.currentArc then context else RELATIVE p  
145    
146          fun mkElab (cache, name) = let          fun mkElab (cache, name) = let
147              val e : elaboration =              val e : elaboration =
# Line 155  Line 155 
155              if stamp = !elabStamp then SOME e else NONE              if stamp = !elabStamp then SOME e else NONE
156    
157          val rootName = P.toString { isAbs = true, arcs = [], vol = "" }          val rootName = P.toString { isAbs = true, arcs = [], vol = "" }
158            val rootId = ref (NONE: id option)
159    
160          fun elabContext c =          fun elabContext c =
161              case c of              case c of
162                  CUR { stamp, name, id } =>                  THEN_CWD { stamp, name, id } =>
163                      { stamp = !elabStamp, id = ref (SOME id),                      { stamp = !elabStamp, id = ref (SOME id),
164                        name = if stamp = cwdStamp () orelse                        name = if stamp = cwdStamp () orelse name = cwdName ()
                                 name = cwdName ()  
165                               then P.currentArc else name }                               then P.currentArc else name }
166                | CONFIG_ANCHOR { fetch, cache, config_name } =>                | CONFIG_ANCHOR { fetch, cache, config_name } =>
167                      (case validElab (!cache) of                      (case validElab (!cache) of
168                           SOME e => e                           SOME e => e
169                         | NONE => mkElab (cache, fetch ()))                         | NONE => mkElab (cache, fetch ()))
170                | RELATIVE p => elab p                | DIR_OF p => let
171                | ROOT => mkElab (ref NONE, rootName)                      val { name, stamp, ... } = elab p
172                    in
173                        { name = P.dir name, stamp = stamp, id = ref NONE }
174                    end
175                  | ROOT => { stamp = !elabStamp, name = rootName, id = rootId }
176    
177          and elab (PATH { context, spec, cache }) =          and elab (PATH { context, spec, cache }) =
178              (case validElab (!cache) of              case validElab (!cache) of
179                   SOME e => e                   SOME e => e
180                 | NONE => let                 | NONE => let
181                       val name =                      val name = P.mkCanonical
                          if P.isAbsolute spec then spec  
                          else P.mkCanonical  
182                               (P.concat (#name (elabContext context),                               (P.concat (#name (elabContext context),
183                                          spec))                                          spec))
184                   in                   in
185                       mkElab (cache, name)                       mkElab (cache, name)
186                   end)                  end
187    
188          (* get the file id (calls elab, so don't cache externally!) *)          (* get the file id (calls elab, so don't cache externally!) *)
189          fun id p = let          fun id p = let
# Line 200  Line 202 
202          fun name p = #name (elab p)          fun name p = #name (elab p)
203    
204          (* get the context back *)          (* get the context back *)
205          fun context (PATH { context = c, ... }) = c          fun contextOf (PATH { context = c, ... }) = c
206          fun contextName c = #name (elabContext c)          fun contextName c = #name (elabContext c)
207    
208          (* get the spec back *)          (* get the spec back *)
209          fun spec (PATH { spec = s, ... }) = s          fun specOf (PATH { spec = s, ... }) = s
210    
211          (* compare pathnames efficiently *)          (* compare pathnames efficiently *)
212          fun compare (p1, p2) = compareId (id p1, id p2)          fun compare (p1, p2) = compareId (id p1, id p2)
# Line 227  Line 229 
229                | delim #"\\" = true              (* accept DOS-style, too *)                | delim #"\\" = true              (* accept DOS-style, too *)
230                | delim _ = false                | delim _ = false
231    
232              fun transl ".." = OS.Path.parentArc              fun transl ".." = P.parentArc
233                | transl "." = OS.Path.currentArc                | transl "." = P.currentArc
234                | transl arc = arc                | transl arc = arc
235    
236              fun mk (arcs, context) =              fun mk (arcs, context) =
# Line 237  Line 239 
239                                      arcs = map transl arcs })                                      arcs = map transl arcs })
240          in          in
241              case String.fields delim spec of              case String.fields delim spec of
242                  "" :: arcs => mk (arcs, ROOT)                  [""] => impossible "AbsPath.standard: zero-length name"
243                | [] => mk ([], context) (* shouldn't happen *)                | "" :: arcs => mk (arcs, ROOT)
244                  | [] => impossible "AbsPath.standard: no fields"
245                | arcs as (arc1 :: _) =>                | arcs as (arc1 :: _) =>
246                      (case PathConfig.configAnchor mode arc1 of                      (case PathConfig.configAnchor mode arc1 of
247                           NONE => mk (arcs, context)                           NONE => mk (arcs, context)
# Line 253  Line 256 
256          end          end
257    
258          (* make a pickle-string *)          (* make a pickle-string *)
259          fun pickle warn (path, gdir) = let          fun pickle warn (path, gpath) = let
260              val warned = ref false              fun p_p (PATH { spec, context, ... }) =
261              fun warn_once abs =                  spec :: p_c context
262                  if !warned then () else (warned := true; warn abs)              and p_c ROOT = (warn true; ["r"])
263              fun check_abs spec =                | p_c (THEN_CWD _) = impossible "AbsPath.pickle: THEN_CWD"
264                  if OS.Path.isAbsolute spec then warn_once true else ()                | p_c (CONFIG_ANCHOR { config_name = n, ... }) = [n, "a"]
265              fun p_p (p as PATH { context, spec, ... }) =                | p_c (DIR_OF p) =
266                  if compare (p, gdir) = EQUAL then (warn_once false; ["r"])                  if compare (p, gpath) = EQUAL then (warn false; ["c"])
267                  else (check_abs spec; spec :: p_c context)                  else p_p p
             and p_c (CONFIG_ANCHOR { config_name = n, ... }) = [n, "a"]  
               | p_c (RELATIVE p) = p_p p  
               | p_c _ = impossible "AbsPath.pickle"  
268          in          in
269              p_p path              p_p path
270          end          end
271    
272          fun unpickle mode (l, gdir) = let          fun unpickle mode (l, gpath) = let
273              exception Format              fun u_p (s :: l) =
274              fun u_p ["r"] = gdir                  Option.map
275                | u_p (h :: t) =                     (fn c => PATH { spec = s, context = c, cache = ref NONE })
276                  PATH { context = u_c t, spec = h, cache = ref NONE }                  (u_c l)
277                | u_p [] = raise Format                | u_p [] = NONE
278              and u_c [n, "a"] =              and u_c ["r"] = SOME ROOT
279                  | u_c ["c"] = SOME (DIR_OF gpath)
280                  | u_c [n, "a"] =
281                  (case PathConfig.configAnchor mode n of                  (case PathConfig.configAnchor mode n of
282                       NONE => raise Format                       NONE => NONE
283                     | SOME fetch => CONFIG_ANCHOR { fetch = fetch,                     | SOME fetch =>
284                                                     cache = ref NONE,                           SOME (CONFIG_ANCHOR { config_name = n,
285                                                     config_name = n })                                                 fetch = fetch,
286                | u_c l = RELATIVE (u_p l)                                                 cache = ref NONE }))
287                  | u_c l = Option.map DIR_OF (u_p l)
288          in          in
289              SOME (u_p l) handle Format => NONE              u_p l
290          end          end
291    
292          (* . and .. are not permitted as file parameter *)          (* . and .. are not permitted as file parameter *)
# Line 327  Line 330 
330          end          end
331    
332          fun setTime (p, TStamp.NOTSTAMP) = ()          fun setTime (p, TStamp.NOTSTAMP) = ()
333            | setTime (p, TStamp.TSTAMP t) = OS.FileSys.setTime (name p, SOME t)            | setTime (p, TStamp.TSTAMP t) = F.setTime (name p, SOME t)
334    
335          fun delete p = OS.FileSys.remove (name p) handle _ => ()          fun delete p = F.remove (name p) handle _ => ()
336    
337          fun openOut fileopener ap = let          fun openOut fileopener ap = let
338              val p = name ap              val p = name ap
# Line 355  Line 358 
358          val openBinOut = openOut BinIO.openOut          val openBinOut = openOut BinIO.openOut
359      end      end
360    
361      fun reAnchor (p, c) = let      fun reAnchor (p, dirstring) = let
362          fun ctxt (CONFIG_ANCHOR { config_name, ... }) =          fun path (PATH { context, spec, ... }) = let
363              SOME (relativeContext (native { context = c, spec = config_name }))              fun mk c = PATH { context = c, spec = spec, cache = ref NONE }
364            | ctxt (RELATIVE t) = Option.map RELATIVE (path t)          in
365            | ctxt (CUR _) = NONE              Option.map mk (ctxt context)
366            end
367            and ctxt (CONFIG_ANCHOR { config_name = n, ... }) =
368                SOME (CONFIG_ANCHOR { config_name = n,
369                                      fetch = fn () => P.concat (dirstring, n),
370                                      cache = ref NONE })
371              | ctxt (DIR_OF p) = Option.map DIR_OF (path p)
372              | ctxt (THEN_CWD _) = NONE
373            | ctxt ROOT = NONE            | ctxt ROOT = NONE
         and path (PATH { context, spec, ... }) = let  
             fun p c = PATH { context = c, spec = spec, cache = ref NONE }  
         in  
             Option.map p (ctxt context)  
         end  
374      in      in
375          path p          path p
376      end      end

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

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