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 269, Mon May 10 13:34:43 1999 UTC revision 270, Tue May 11 07:45:42 1999 UTC
# Line 7  Line 7 
7   *)   *)
8  signature ABSPATH = sig  signature ABSPATH = sig
9    
10        type context
11      type t      type t
12    
13      val revalidateCwd : unit -> unit      val revalidateCwd : unit -> unit
14    
15        val cwdContext: unit -> context
16        val configContext: (unit -> string) -> context
17        val relativeContext: t -> context
18    
19      val name : t -> string      val name : t -> string
20      val compare : t * t -> order      val compare : t * t -> order
21    
22      val native : { context: t, spec: string } -> t      val native : { context: context, spec: string } -> t
23      val standard : { context: t, spec: string } -> t      val standard : { context: context, spec: string } -> t
24    
25      val joinDirFile : { dir: t, file: string } -> t      val joinDirFile : { dir: t, file: string } -> t
26      val splitDirFile : t -> { dir: t, file: string }      val splitDirFile : t -> { dir: t, file: string }
# Line 39  Line 44 
44        | compareId (PRESENT _, ABSENT _) = GREATER        | compareId (PRESENT _, ABSENT _) = GREATER
45        | compareId (ABSENT s, ABSENT s') = String.compare (s, s')        | compareId (ABSENT s, ABSENT s') = String.compare (s, s')
46    
47      fun getId f = PRESENT (F.fileId f) handle _ => ABSENT f      fun getId f = (PRESENT (F.fileId f) handle _ => ABSENT f)
48    
49      type elaboration = { stamp : unit ref,      type elaboration = { stamp : unit ref,
50                           name : string,                           name : string,
# Line 54  Line 59 
59       *)       *)
60    
61      type cwdinfo = { stamp: unit ref, name: string, id: id }      type cwdinfo = { stamp: unit ref, name: string, id: id }
62      datatype t =  
63        datatype context =
64          CUR of cwdinfo          CUR of cwdinfo
65        | CONFIG_ANCHOR of { fetch: unit -> string,        | CONFIG_ANCHOR of { fetch: unit -> string,
66                             cache: elaboration option ref }                             cache: elaboration option ref }
67        | SPEC of { context: t,        | RELATIVE of t
68    
69        and  t =
70            PATH of { context: context,
71                    spec: string,                    spec: string,
72                    cache: elaboration option ref }                    cache: elaboration option ref }
73    
# Line 100  Line 109 
109                      else ()                      else ()
110                  end                  end
111    
112          (* elaborate a path -- uses internal caching, don't cache          fun cwdContext () =
113           * results externally! *)              CUR { stamp = cwdStamp (), name = cwdName (), id = cwdId () }
114          fun elab p = let  
115            fun configContext fetch =
116                CONFIG_ANCHOR { fetch = fetch, cache = ref NONE }
117    
118            fun relativeContext p = RELATIVE p
119    
120              fun mkElab (cache, name) = let              fun mkElab (cache, name) = let
121                  val e = { stamp = !elabStamp, name = name, id = ref NONE }              val e : elaboration =
122                    { stamp = !elabStamp, name = name, id = ref NONE }
123              in              in
124                  cache := SOME e; e                  cache := SOME e; e
125              end              end
126              fun resolve_anchor { fetch, cache } = mkElab (cache, fetch ())  
127              fun resolve_spec { context, spec, cache } = let          fun validElab NONE = NONE
128              | validElab (SOME (e as { stamp, name, id })) =
129                if stamp = !elabStamp then SOME e else NONE
130    
131            fun elabContext c =
132                case c of
133                    CUR { stamp, name, id } =>
134                        { stamp = !elabStamp, id = ref (SOME id),
135                          name = if stamp = cwdStamp () orelse
136                                    name = cwdName ()
137                                 then P.currentArc else name }
138                  | CONFIG_ANCHOR { fetch, cache } =>
139                        (case validElab (!cache) of
140                             SOME e => e
141                           | NONE => mkElab (cache, fetch ()))
142                  | RELATIVE p => elab p
143    
144            and elab (PATH { context, spec, cache }) =
145                (case validElab (!cache) of
146                     SOME e => e
147                   | NONE => let
148                  val name =                  val name =
149                      if P.isAbsolute spec then spec                      if P.isAbsolute spec then spec
150                      else P.mkCanonical (P.concat (#name (elab context), spec))                           else P.mkCanonical
151                                 (P.concat (#name (elabContext context),
152                                            spec))
153              in              in
154                  mkElab (cache, name)                  mkElab (cache, name)
155              end                   end)
         in  
             case p of  
                 CUR { stamp, name, id } =>  
                     { stamp = !elabStamp, id = ref (SOME id),  
                       name = if stamp = cwdStamp ()  
                                    orelse name = cwdName () then  
                                  P.currentArc  
                             else name }  
               | CONFIG_ANCHOR (a as { cache = ref NONE, ... }) =>  
                     resolve_anchor a  
               | CONFIG_ANCHOR (a as { cache = ref (SOME (e as { stamp, ... })),  
                                       ... }) =>  
                     if stamp = !elabStamp then e else resolve_anchor a  
               | SPEC (s as { cache = ref NONE, ... }) =>  
                     resolve_spec s  
               | SPEC (s as { cache = ref (SOME (e as { stamp, ... })), ...}) =>  
                     if stamp = !elabStamp then e else resolve_spec s  
         end  
156    
157          (* get the file id (calls elab, so don't cache externally!) *)          (* get the file id (calls elab, so don't cache externally!) *)
158          fun id p = let          fun id p = let
# Line 155  Line 174 
174          fun compare (p1, p2) = compareId (id p1, id p2)          fun compare (p1, p2) = compareId (id p1, id p2)
175    
176          fun fresh (context, spec) =          fun fresh (context, spec) =
177              SPEC { context = context, spec = spec, cache = ref NONE }              PATH { context = context, spec = spec, cache = ref NONE }
178    
179          (* make an abstract path from a native string *)          (* make an abstract path from a native string *)
180          fun native { spec, context } = fresh (context, spec)          fun native { spec, context } = fresh (context, spec)
# Line 191  Line 210 
210          end          end
211    
212          (* . and .. are not permitted as file parameter *)          (* . and .. are not permitted as file parameter *)
213          fun joinDirFile { dir, file } =          fun joinDirFile { dir = PATH { context, spec, ... }, file } =
214              if file = P.currentArc orelse file = P.parentArc then              if file = P.currentArc orelse file = P.parentArc then
215                  raise Fail "AbsPath.joinDirFile: . or .."                  raise Fail "AbsPath.joinDirFile: . or .."
216              else case dir of              else fresh (context, P.joinDirFile { dir = spec, file = file })
                 (CUR _ | CONFIG_ANCHOR _) => fresh (dir, file)  
               | SPEC { context, spec, ... } =>  
                     fresh (context, P.joinDirFile { dir = spec, file = file })  
217    
218          (* splitDirFile never walks past a context.          (* splitDirFile never walks past a context.
219           * Moreover, it is an error to split something that ends in "..". *)           * Moreover, it is an error to split something that ends in "..". *)
220          fun splitDirFile (x as (CUR _ | CONFIG_ANCHOR _)) =          fun splitDirFile (PATH { context, spec, ... }) = let
             raise Fail "AbsPath.splitDirFile: CUR or CONFIG_ANCHOR"  
           | splitDirFile (SPEC { context, spec, ... }) = let  
221                  fun loop "" =                  fun loop "" =
222                      raise Fail "AbsPath.splitDirFile: tried to split context"                  raise Fail "AbsPath.splitDirFile: tried to split a context"
223                    | loop spec = let                    | loop spec = let
224                          val { dir, file } = P.splitDirFile spec                          val { dir, file } = P.splitDirFile spec
225                      in                      in
# Line 215  Line 229 
229                          else (dir, file)                          else (dir, file)
230                      end                      end
231                  val (dir, file) = loop spec                  val (dir, file) = loop spec
232                  val dir = if dir = "" then context else fresh (context, dir)              val dir = if dir = "" then P.currentArc else dir
233              in              in
234                  { dir = dir, file = file }              { dir = fresh (context, dir), file = file }
235              end              end
236    
237          val dir = #dir o splitDirFile          val dir = #dir o splitDirFile

Legend:
Removed from v.269  
changed lines
  Added in v.270

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