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 297, Thu May 27 08:29:19 1999 UTC revision 304, Mon May 31 09:10:08 1999 UTC
# Line 14  Line 14 
14      val newEra : unit -> unit      val newEra : unit -> unit
15    
16      val cwdContext: unit -> context      val cwdContext: unit -> context
17      val configContext: (unit -> string) -> context      val configContext: (unit -> string) * string -> context
18      val relativeContext: t -> context      val relativeContext: t -> context
19    
20      val name : t -> string      val name : t -> string
# Line 22  Line 22 
22      val context : t -> context      val context : t -> context
23      val spec : t -> string      val spec : t -> string
24      val contextName : context -> string      val contextName : context -> string
25        val pickle : t -> string
26        val pickleSpec : t -> string
27    
28      val native : { context: context, spec: string } -> t      val native : { context: context, spec: string } -> t
29      val standard : { context: context, spec: string } -> t      val standard : { context: context, spec: string } -> t
30        val unpickle : string -> t
31        val unpickleSpec : { context: context, pickledSpec: string } -> t
32    
33      val joinDirFile : { dir: t, file: string } -> t      val joinDirFile : { dir: t, file: string } -> t
34      val splitDirFile : t -> { dir: t, file: string }      val splitDirFile : t -> { dir: t, file: string }
# Line 78  Line 82 
82      datatype context =      datatype context =
83          CUR of cwdinfo          CUR of cwdinfo
84        | CONFIG_ANCHOR of { fetch: unit -> string,        | CONFIG_ANCHOR of { fetch: unit -> string,
85                             cache: elaboration option ref }                             cache: elaboration option ref,
86                               config_name: string }
87        | RELATIVE of t        | RELATIVE of t
88    
89      and  t =      and  t =
90          PATH of { context: context,          PATH of { context: context,
91                    spec: string,                    spec: string,
92                      native: bool,
93                    cache: elaboration option ref }                    cache: elaboration option ref }
94    
95      local      local
# Line 127  Line 133 
133          fun cwdContext () =          fun cwdContext () =
134              CUR { stamp = cwdStamp (), name = cwdName (), id = cwdId () }              CUR { stamp = cwdStamp (), name = cwdName (), id = cwdId () }
135    
136          fun configContext fetch =          fun configContext (f, n) =
137              CONFIG_ANCHOR { fetch = fetch, cache = ref NONE }              CONFIG_ANCHOR { fetch = f, cache = ref NONE, config_name = n }
138    
139          fun relativeContext p = RELATIVE p          fun relativeContext p = RELATIVE p
140    
# Line 150  Line 156 
156                        name = if stamp = cwdStamp () orelse                        name = if stamp = cwdStamp () orelse
157                                  name = cwdName ()                                  name = cwdName ()
158                               then P.currentArc else name }                               then P.currentArc else name }
159                | CONFIG_ANCHOR { fetch, cache } =>                | CONFIG_ANCHOR { fetch, cache, config_name } =>
160                      (case validElab (!cache) of                      (case validElab (!cache) of
161                           SOME e => e                           SOME e => e
162                         | NONE => mkElab (cache, fetch ()))                         | NONE => mkElab (cache, fetch ()))
163                | RELATIVE p => elab p                | RELATIVE p => elab p
164    
165          and elab (PATH { context, spec, cache }) =          and elab (PATH { context, spec, cache, native }) =
166              (case validElab (!cache) of              (case validElab (!cache) of
167                   SOME e => e                   SOME e => e
168                 | NONE => let                 | NONE => let
# Line 192  Line 198 
198          (* get the spec back *)          (* get the spec back *)
199          fun spec (PATH { spec = s, ... }) = s          fun spec (PATH { spec = s, ... }) = s
200    
201            (* make a pickle-string *)
202            fun pickle (PATH { context, spec, cache, native }) = Dummy.f ()
203            fun pickleSpec (PATH _) = Dummy.f ()
204            fun unpickle s = Dummy.f ()
205            fun unpickleSpec { context, pickledSpec } = Dummy.f ()
206    
207          (* compare pathnames efficiently *)          (* compare pathnames efficiently *)
208          fun compare (p1, p2) = compareId (id p1, id p2)          fun compare (p1, p2) = compareId (id p1, id p2)
209    
210          fun fresh (context, spec) =          fun fresh (context, spec, native) =
211              PATH { context = context, spec = spec, cache = ref NONE }              PATH { context = context, spec = spec, cache = ref NONE,
212                       native = native }
213    
214          (* make an abstract path from a native string *)          (* make an abstract path from a native string *)
215          fun native { spec, context } = fresh (context, spec)          fun native { spec, context } = fresh (context, spec, true)
216    
217          (* make an abstract path from a standard string *)          (* make an abstract path from a standard string *)
218          fun standard { spec, context } = let          fun standard { spec, context } = let
# Line 214  Line 227 
227              fun mk (isAbs, arcs, context) =              fun mk (isAbs, arcs, context) =
228                  fresh (context,                  fresh (context,
229                         P.toString { isAbs = isAbs, vol = "",                         P.toString { isAbs = isAbs, vol = "",
230                                      arcs = map transl arcs })                                      arcs = map transl arcs },
231                           false)
232          in          in
233              case String.fields delim spec of              case String.fields delim spec of
234                  "" :: arcs => mk (true, arcs, context)                  "" :: arcs => mk (true, arcs, context)
235                | [] => mk (false, [], context) (* shouldn't happen *)                | [] => mk (false, [], context) (* shouldn't happen *)
236                | [arc] => mk (false, [arc], context)                | [arc] => mk (false, [arc], context)
237                | arcs as (arc1 :: arcn) =>                | arcs as (arc1 :: _) =>
238                      (case PathConfig.configAnchor arc1 of                      (case PathConfig.configAnchor arc1 of
239                           NONE => mk (false, arcs, context)                           NONE => mk (false, arcs, context)
240                         | SOME fetch => let                         | SOME fetch => let
241                               val anchorcontext =                               val anchorcontext =
242                                   CONFIG_ANCHOR { fetch = fetch,                                   CONFIG_ANCHOR { fetch = fetch,
243                                                   cache = ref NONE }                                                   cache = ref NONE,
244                                                     config_name = arc1 }
245                           in                           in
246                               mk (false, arcn, anchorcontext)                               mk (false, arcs, anchorcontext)
247                           end)                           end)
248          end          end
249    
250          (* . and .. are not permitted as file parameter *)          (* . and .. are not permitted as file parameter *)
251          fun joinDirFile { dir = PATH { context, spec, ... }, file } =          fun joinDirFile { dir = PATH { context, spec, native, ... }, file } =
252              if file = P.currentArc orelse file = P.parentArc then              if file = P.currentArc orelse file = P.parentArc then
253                  raise Fail "AbsPath.joinDirFile: . or .."                  raise Fail "AbsPath.joinDirFile: . or .."
254              else fresh (context, P.joinDirFile { dir = spec, file = file })              else fresh (context, P.joinDirFile { dir = spec, file = file },
255                            native)
256    
257          (* splitDirFile never walks past a context.          (* splitDirFile never walks past a context.
258           * Moreover, it is an error to split something that ends in "..". *)           * Moreover, it is an error to split something that ends in "..". *)
259          fun splitDirFile (PATH { context, spec, ... }) = let          fun splitDirFile (PATH { context, spec, native, ... }) = let
260              fun loop "" =              fun loop "" =
261                  raise Fail "AbsPath.splitDirFile: tried to split a context"                  raise Fail "AbsPath.splitDirFile: tried to split a context"
262                | loop spec = let                | loop spec = let
# Line 254  Line 270 
270              val (dir, file) = loop spec              val (dir, file) = loop spec
271              val dir = if dir = "" then P.currentArc else dir              val dir = if dir = "" then P.currentArc else dir
272          in          in
273              { dir = fresh (context, dir), file = file }              { dir = fresh (context, dir, native), file = file }
274          end          end
275    
276          val dir = #dir o splitDirFile          val dir = #dir o splitDirFile

Legend:
Removed from v.297  
changed lines
  Added in v.304

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