Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/cm/paths/srcpath.sml
ViewVC logotype

Annotation of /sml/trunk/src/cm/paths/srcpath.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 736 - (view) (download)

1 : blume 354 (*
2 : blume 666 * Operations over abstract names for CM source files.
3 : blume 354 *
4 : blume 666 * Copyright (c) 2000 by Lucent Technologies, Bell Laboratories
5 : blume 354 *
6 : blume 666 * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7 : blume 354 *)
8 :     signature SRCPATH = sig
9 : blume 367
10 : blume 666 exception Format
11 : blume 367
12 : blume 666 type file
13 :     type dir
14 :     type env
15 :     type anchor = string
16 :     type prefile
17 : blume 354
18 : blume 666 type rebindings = { anchor: anchor, value: prefile } list
19 : blume 354
20 : blume 666 type ord_key = file
21 :    
22 :     (* path comparison *)
23 :     val compare : file * file -> order
24 :    
25 :     (* re-establish stability of ordering *)
26 : blume 354 val sync : unit -> unit
27 :    
28 : blume 666 (* forget all known path names *)
29 :     val clear : unit -> unit
30 :    
31 :     (* re-validate current working directory *)
32 : blume 366 val revalidateCwd : unit -> unit
33 :    
34 : blume 735 (* register a "client" module that wishes to be notified when
35 :     * the CWD changes *)
36 :     val addClientToBeNotified : (string -> unit) -> unit
37 :    
38 :     (* make sure all such clients get notified about the a CWD during
39 :     * next validation *)
40 : blume 666 val scheduleNotification : unit -> unit
41 : blume 464
42 : blume 666 (* new "empty" env *)
43 :     val newEnv : unit -> env
44 : blume 354
45 : blume 666 (* destructive updates to anchor settings (for configuration) *)
46 :     val set_anchor : env * anchor * string option -> unit (* native syntax! *)
47 :     val get_anchor : env * anchor -> string option
48 :     val reset_anchors : env -> unit
49 : blume 366
50 : blume 735 (* process a specification file; must sync afterwards!
51 :     * The function argument is used for issuing warnings. *)
52 :     val processSpecFile :
53 :     { env : env, specfile : string, say : string list -> unit }
54 :     -> TextIO.instream -> unit
55 : blume 354
56 : blume 666 (* non-destructive bindings for anchors (for anchor scoping) *)
57 :     val bind: env -> rebindings -> env
58 : blume 354
59 : blume 666 (* make abstract paths *)
60 :     val native : { err: string -> unit } ->
61 :     { context: dir, spec: string } -> prefile
62 :     val standard : { err: string -> unit, env: env } ->
63 :     { context: dir, spec: string } -> prefile
64 : blume 457
65 : blume 666 (* check that there is at least one arc in after the path's context *)
66 :     val file : prefile -> file
67 : blume 354
68 : blume 666 (* To be able to pickle a file, turn it into a prefile first... *)
69 :     val pre : file -> prefile
70 :    
71 :     (* directory paths (contexts) *)
72 :     val cwd : unit -> dir
73 :     val dir : file -> dir
74 :    
75 :     (* get info out of abstract paths *)
76 :     val osstring : file -> string
77 :     val osstring' : file -> string (* use relative path if shorter *)
78 :    
79 :     (* expand root anchors using given function *)
80 :     val osstring_reanchored : (anchor -> string) -> file -> string option
81 :    
82 :     (* get path relative to the file's context; this will produce an
83 :     * absolute path if the original spec was not relative (i.e., if
84 :     * it was anchored or absolute) *)
85 :     val osstring_relative : file -> string
86 :    
87 :     (* get name of dir *)
88 :     val osstring_dir : dir -> string
89 :    
90 : blume 678 (* get name of prefile *)
91 :     val osstring_prefile : prefile -> string
92 :    
93 : blume 666 (* get a human-readable (well, sort of) description *)
94 :     val descr : file -> string
95 :    
96 :     (* get a time stamp *)
97 :     val tstamp : file -> TStamp.t
98 :    
99 :     (* portable encodings that avoid whitespace *)
100 :     val encode : file -> string
101 :     val decode : env -> string -> file
102 :    
103 : blume 735 (* check whether encoding (result of "encode") is absolute
104 :     * (i.e., not anchored and not relative) *)
105 :     val encodingIsAbsolute : string -> bool
106 :    
107 : blume 666 val pickle : { warn: bool * string -> unit } ->
108 :     { file: prefile, relativeTo: file } -> string list
109 :    
110 :     val unpickle : env -> { pickled: string list, relativeTo: file } -> prefile
111 : blume 354 end
112 :    
113 :     structure SrcPath :> SRCPATH = struct
114 :    
115 : blume 666 exception Format
116 : blume 367
117 : blume 666 structure P = OS.Path
118 :     structure F = OS.FileSys
119 :     structure I = FileId
120 : blume 735 structure StringMap = RedBlackMapFn (struct type ord_key = string
121 :     val compare = String.compare
122 :     end)
123 : blume 354
124 : blume 735 fun impossible s = raise Fail ("impossible error in SrcPath: " ^ s)
125 : blume 354
126 : blume 666 type anchor = string
127 : blume 354
128 : blume 666 type stableid = int
129 : blume 354
130 : blume 666 (* A pre-path is similar to the result of P.fromString except that
131 :     * we keep the list of arcs in reversed order. This makes adding
132 :     * and removing arcs at the end easier. *)
133 :     type prepath = { revarcs: string list, vol: string, isAbs: bool }
134 : blume 354
135 : blume 666 type elab = { pp: prepath, valid: unit -> bool }
136 : blume 354
137 : blume 666 type anchorval = unit -> elab
138 :    
139 :     type env =
140 :     { get_free: anchor -> elab,
141 :     set_free: anchor * prepath option -> unit,
142 :     is_set: anchor -> bool,
143 :     reset: unit -> unit,
144 :     bound: anchorval StringMap.map }
145 :     datatype dir =
146 :     CWD of { name: string, pp: prepath }
147 :     | ANCHOR of { name: anchor, look: unit -> elab }
148 :     | ROOT of string
149 :     | DIR of file0
150 :    
151 :     and file0 =
152 :     PATH of { context: dir,
153 :     arcs: string list, (* at least one arc! *)
154 :     elab: elab ref,
155 :     id: I.id option ref }
156 :    
157 :     type file = file0 * stableid
158 :    
159 :     type prefile = { context: dir, arcs: string list, err: string -> unit }
160 :    
161 :     type rebindings = { anchor: anchor, value: prefile } list
162 :    
163 :     type ord_key = file
164 :    
165 :     fun mk_look (e: env, a) () =
166 :     case StringMap.find (#bound e, a) of
167 :     SOME f => f ()
168 :     | NONE => #get_free e a
169 :    
170 :     (* stable comparison *)
171 :     fun compare (f1: file, f2: file) = Int.compare (#2 f1, #2 f2)
172 :    
173 :     val null_pp : prepath = { revarcs = [], vol = "", isAbs = false }
174 :     val bogus_elab : elab = { pp = null_pp, valid = fn _ => false }
175 :    
176 :     fun string2pp n = let
177 :     val { arcs, vol, isAbs } = P.fromString n
178 :     in
179 :     { revarcs = rev arcs, vol = vol, isAbs = isAbs }
180 :     end
181 :    
182 :     val cwd_info =
183 :     let val n = F.getDir ()
184 :     in ref { name = n, pp = string2pp n }
185 :     end
186 :     val cwd_notify = ref true
187 :    
188 :     fun absElab (arcs, vol) =
189 :     { pp = { revarcs = rev arcs, vol = vol, isAbs = true },
190 :     valid = fn () => true }
191 :    
192 :     fun unintern (f: file) = #1 f
193 :    
194 :     fun encode0 bracket (p: file0) = let
195 :     fun needesc c = not (Char.isPrint c) orelse Char.contains "/:\\$%" c
196 :     fun esc c =
197 :     "\\" ^ StringCvt.padLeft #"0" 3 (Int.toString (Char.ord c))
198 :     fun tc c = if needesc c then esc c else String.str c
199 :     val ta = String.translate tc
200 :     val (dot, dotdot) = let
201 :     val ta' = String.translate esc
202 :     in
203 :     (ta' ".", ta' "..")
204 :     end
205 :     fun arc a =
206 :     if a = P.currentArc then "."
207 :     else if a = P.parentArc then ".."
208 :     else if a = "." then dot
209 :     else if a = ".." then dotdot
210 :     else ta a
211 : blume 736 fun e_p (PATH { arcs = [], context, ... }, _, a) =
212 :     e_c (context, a, NONE)
213 :     | e_p (PATH { arcs, context, ... }, ctxt, a) =
214 :     let val l = map arc arcs
215 :     val a0 = List.hd l
216 :     val l' = rev l
217 :     val l'' = if ctxt andalso bracket then
218 :     concat ["(", List.hd l', ")"] :: List.tl l'
219 :     else l'
220 :     val a' = foldl (fn (x, l) => arc x :: "/" :: l)
221 :     (arc (List.hd l'') :: a) (List.tl l'')
222 :     in e_c (context, a', SOME a0)
223 : blume 666 end
224 : blume 736 and e_c (ROOT "", a, _) = concat ("/" :: a)
225 :     | e_c (ROOT vol, a, _) = concat ("%" :: ta vol :: "/" :: a)
226 :     | e_c (CWD _, a, _) = concat a
227 :     | e_c (ANCHOR x, a, NONE) = concat ("$" :: ta (#name x) :: "/" :: a)
228 :     | e_c (ANCHOR x, a, SOME a1) = let
229 :     val a0 = ta (#name x)
230 :     in
231 :     concat (if bracket andalso a0 = a1 then "$/" :: a
232 :     else "$" :: a0 :: "/" :: a)
233 :     end
234 :     | e_c (DIR p, a, _) = e_p (p, true, ":" :: a)
235 : blume 666 in
236 :     e_p (p, false, [])
237 :     end
238 :    
239 :     val encode = encode0 false o unintern
240 :    
241 : blume 735 val clients = ref ([] : (string -> unit) list)
242 :     fun addClientToBeNotified c = clients := c :: !clients
243 :    
244 : blume 666 fun revalidateCwd () = let
245 :     val { name = n, pp } = !cwd_info
246 :     val n' = F.getDir ()
247 :     val pp' = string2pp n'
248 :     in
249 :     if n = n' then ()
250 :     else (cwd_info := { name = n', pp = pp' };
251 :     cwd_notify := true);
252 :     if !cwd_notify then
253 :     let val p = PATH { arcs = rev (#revarcs pp),
254 :     context = ROOT (#vol pp),
255 :     elab = ref bogus_elab, id = ref NONE }
256 : blume 735 val ep = encode0 false p
257 : blume 354 in
258 : blume 735 app (fn c => c ep) (!clients);
259 : blume 666 cwd_notify := false
260 : blume 354 end
261 : blume 666 else ()
262 :     end
263 : blume 354
264 : blume 666 fun scheduleNotification () = cwd_notify := true
265 : blume 354
266 : blume 666 fun dirPP { revarcs = _ :: revarcs, vol, isAbs } =
267 :     { revarcs = revarcs, vol = vol, isAbs = isAbs }
268 :     | dirPP _ = impossible "dirPP"
269 : blume 354
270 : blume 666 fun dirElab { pp, valid } = { pp = dirPP pp, valid = valid }
271 :    
272 :     fun augPP arcs { revarcs, vol, isAbs } =
273 :     { revarcs = List.revAppend (arcs, revarcs), vol = vol, isAbs = isAbs }
274 :    
275 :     fun augElab arcs { pp, valid } = { pp = augPP arcs pp, valid = valid }
276 :    
277 :     fun elab_dir (CWD { name, pp }) =
278 :     let fun valid () = name = #name (!cwd_info)
279 :     in
280 :     if valid () then { pp = null_pp, valid = valid }
281 :     else { pp = pp, valid = fn () => true }
282 :     end
283 :     | elab_dir (ANCHOR { name, look }) = look ()
284 :     | elab_dir (ROOT vol) = absElab ([], vol)
285 :     | elab_dir (DIR p) = dirElab (elab_file p)
286 :    
287 :     and elab_file (PATH { context, arcs, elab, id }) =
288 :     let val e as { pp, valid } = !elab
289 :     in
290 :     if valid () then e
291 :     else let val e' = augElab arcs (elab_dir context)
292 :     in elab := e'; id := NONE; e'
293 :     end
294 :     end
295 :    
296 :     fun pp2name { revarcs, vol, isAbs } =
297 :     P.toString { arcs = rev revarcs, vol = vol, isAbs = isAbs }
298 :    
299 :     fun idOf (p as PATH { id, ... }) =
300 :     let val { pp, ... } = elab_file p
301 :     in
302 :     case !id of
303 :     SOME i => i
304 :     | NONE => let
305 :     val i = I.fileId (pp2name pp)
306 :     in
307 :     id := SOME i; i
308 :     end
309 :     end
310 :    
311 :     fun compare0 (f1, f2) = I.compare (idOf f1, idOf f2)
312 :    
313 : blume 735 structure F0M = RedBlackMapFn (type ord_key = file0 val compare = compare0)
314 : blume 666
315 :     local
316 :     val known = ref (F0M.empty: int F0M.map)
317 :     val next = ref 0
318 :     in
319 :     fun clear () = known := F0M.empty
320 :    
321 :     fun intern f =
322 :     case F0M.find (!known, f) of
323 :     SOME i => (f, i)
324 :     | NONE => let
325 :     val i = !next
326 :     in
327 :     next := i + 1;
328 :     known := F0M.insert (!known, f, i);
329 :     (f, i)
330 :     end
331 :    
332 :     fun sync () = let
333 :     val km = !known
334 :     fun inval (PATH { id, ... }, _) = id := NONE
335 :     fun reinsert (k, v, m) = F0M.insert (m, k, v)
336 :     in
337 :     F0M.appi inval km;
338 :     known := F0M.foldli reinsert F0M.empty km
339 :     end
340 :     end
341 :    
342 :     val dir0 = DIR
343 :     val dir = dir0 o unintern
344 :    
345 :     fun cwd () = (revalidateCwd (); CWD (!cwd_info))
346 :    
347 :     val osstring = pp2name o #pp o elab_file o unintern
348 :    
349 : blume 678 fun osstring_prefile { context, arcs, err } =
350 :     pp2name (#pp (augElab arcs (elab_dir context)))
351 :    
352 : blume 666 val descr = encode0 true o unintern
353 :    
354 : blume 671 fun osstring_dir d =
355 :     case pp2name (#pp (elab_dir d)) of
356 :     "" => P.currentArc
357 :     | s => s
358 : blume 666
359 :     fun osstring' f = let
360 :     val oss = osstring f
361 :     in
362 :     if P.isAbsolute oss then
363 :     let val ross =
364 :     P.mkRelative { path = oss, relativeTo = #name (!cwd_info) }
365 :     in
366 :     if size ross < size oss then ross else oss
367 :     end
368 :     else oss
369 :     end
370 :    
371 :     fun newEnv () = let
372 :     val freeMap = ref StringMap.empty
373 :     fun fetch a =
374 :     case StringMap.find (!freeMap, a) of
375 :     SOME x => x
376 :     | NONE => let
377 :     val validity = ref true
378 :     val pp = { revarcs = [concat ["$Undef<", a, ">"]],
379 :     vol = "", isAbs = false }
380 :     val x = (pp, validity)
381 :     in
382 :     freeMap := StringMap.insert (!freeMap, a, x);
383 :     x
384 :     end
385 :     fun get_free a = let
386 :     val (pp, validity) = fetch a
387 :     in
388 :     { pp = pp, valid = fn () => !validity }
389 :     end
390 :     fun set_free (a, ppo) = let
391 :     val (_, validity) = fetch a
392 :     in
393 :     validity := false; (* invalidate earlier elabs *)
394 :     freeMap :=
395 :     (case ppo of
396 :     NONE => #1 (StringMap.remove (!freeMap, a))
397 :     | SOME pp => StringMap.insert (!freeMap, a, (pp, ref true)))
398 :     end
399 :     fun is_set a = StringMap.inDomain (!freeMap, a)
400 :     fun reset () = let
401 :     fun invalidate (_, validity) = validity := false
402 :     in
403 :     StringMap.app invalidate (!freeMap);
404 :     freeMap := StringMap.empty
405 :     end
406 :     in
407 :     { get_free = get_free, set_free = set_free, is_set = is_set,
408 :     reset = reset, bound = StringMap.empty } : env
409 :     end
410 :    
411 :     fun get_anchor (e: env, a) =
412 :     if #is_set e a then SOME (pp2name (#pp (#get_free e a))) else NONE
413 :    
414 :     fun set0 mkAbsolute (e: env, a, so) = let
415 :     fun name2pp s = string2pp (if P.isAbsolute s then s else mkAbsolute s)
416 :     in
417 : blume 676 #set_free e (a, Option.map name2pp so)
418 : blume 666 end
419 :    
420 :     fun set_anchor x =
421 :     set0 (fn n => P.mkAbsolute { path = n, relativeTo = F.getDir () }) x
422 : blume 676 before sync ()
423 : blume 666
424 :     fun reset_anchors (e: env) = (#reset e (); sync ())
425 :    
426 : blume 735 fun processSpecFile { env = e, specfile = f, say } = let
427 : blume 666 val d = P.dir (F.fullPath f)
428 :     fun set x = set0 (fn n => P.mkAbsolute { path = n, relativeTo = d }) x
429 :     fun work s = let
430 :     fun loop () = let
431 :     val line = TextIO.inputLine s
432 :     in
433 :     if line = "" then ()
434 :     else if String.sub (line, 0) = #"#" then loop ()
435 :     else case String.tokens Char.isSpace line of
436 :     [a, d] => (set (e, a, SOME d); loop ())
437 : blume 676 | ["-"] => (#reset e (); loop ())
438 :     | [a] => (set (e, a, NONE); loop ())
439 : blume 666 | [] => loop ()
440 : blume 735 | _ => (say [f, ": malformed line (ignored)\n"];
441 : blume 666 loop ())
442 :     end
443 :     in
444 :     loop ()
445 :     end
446 :     in
447 : blume 735 work
448 : blume 666 end
449 :    
450 :     datatype stdspec =
451 :     RELATIVE of string list
452 :     | ABSOLUTE of string list
453 :     | ANCHORED of anchor * string list
454 :    
455 :     fun parseStdspec err s = let
456 :     fun delim #"/" = true
457 :     | delim #"\\" = true
458 :     | delim _ = false
459 :     fun transl ".." = P.parentArc
460 :     | transl "." = P.currentArc
461 :     | transl arc = arc
462 :     val impossible = fn s => impossible ("AbsPath.parseStdspec: " ^ s)
463 :     in
464 :     case map transl (String.fields delim s) of
465 :     [""] => impossible "zero-length name"
466 :     | [] => impossible "no fields"
467 :     | "" :: arcs => ABSOLUTE arcs
468 :     | arcs as (["$"] | "$" :: "" :: _) =>
469 :     (err (concat ["invalid zero-length anchor name in: `", s, "'"]);
470 :     RELATIVE arcs)
471 :     | "$" :: (arcs as (arc1 :: _)) => ANCHORED (arc1, arcs)
472 :     | arcs as (arc1 :: arcn) =>
473 :     if String.sub (arc1, 0) <> #"$" then RELATIVE arcs
474 :     else ANCHORED (String.extract (arc1, 1, NONE), arcn)
475 :     end
476 :    
477 :     fun bind env l = let
478 :     fun b ({ anchor, value = { arcs, context, err } }, e: env) =
479 :     { get_free = #get_free e, set_free = #set_free e,
480 :     reset = #reset e, is_set = #is_set e,
481 :     bound = StringMap.insert
482 :     (#bound e, anchor,
483 :     fn () => augElab arcs (elab_dir context)) }
484 :     in
485 :     foldl b env l
486 :     end
487 :    
488 :     fun file0 ({ context, arcs, err }: prefile) =
489 :     PATH { context = context, elab = ref bogus_elab, id = ref NONE,
490 :     arcs = (case arcs of
491 :     [] => (err (concat
492 :     ["path needs at least one arc relative to `",
493 :     pp2name (#pp (elab_dir context)), "'"]);
494 :     ["<bogus>"])
495 :     | _ => arcs) }
496 :    
497 :     val file = intern o file0
498 :     fun pre0 (PATH { arcs, context, ... }) =
499 :     { arcs = arcs, context = context, err = fn (_: string) => () }
500 :     val pre = pre0 o unintern
501 :    
502 :     fun prefile (c, l, e) = { context = c, arcs = l, err = e }
503 :    
504 :     (* env argument is not used -- it's just there for uniformity *)
505 :     fun native { err } { context, spec } =
506 :     case P.fromString spec of
507 :     { arcs, vol, isAbs = true } => prefile (ROOT vol, arcs, err)
508 :     | { arcs, ... } => prefile (context, arcs, err)
509 :    
510 :     fun standard { env, err } { context, spec } =
511 :     case parseStdspec err spec of
512 :     RELATIVE l => prefile (context, l, err)
513 :     | ABSOLUTE l => prefile (ROOT "", l, err)
514 :     | ANCHORED (a, l) =>
515 :     prefile (ANCHOR { name = a, look = mk_look (env, a) }, l, err)
516 :    
517 :     fun osstring_reanchored anchor f = let
518 :     fun path (PATH { context, arcs, ... }) =
519 :     Option.map (augPP arcs) (ctxt context)
520 :     and ctxt (CWD _) = NONE
521 :     | ctxt (ROOT _) = NONE
522 :     | ctxt (DIR p) = Option.map dirPP (path p)
523 :     | ctxt (ANCHOR { name, ... }) = SOME (string2pp (anchor name))
524 :     in
525 :     Option.map pp2name (path (unintern f))
526 :     end
527 :    
528 :     fun osstring_relative (p as (PATH { arcs, context, ... }, _)) =
529 :     case context of
530 :     DIR _ => P.toString { arcs = arcs, vol = "", isAbs = false }
531 :     | _ => osstring p
532 :    
533 :     fun tstamp f = TStamp.fmodTime (osstring f)
534 :    
535 :     fun pickle { warn } { file = (f: prefile), relativeTo = (gf, _) } = let
536 :     val warn =
537 :     fn flag =>
538 :     warn (flag,
539 :     (* HACK! We are cheating here, turning the prefile into
540 :     * a file even when there are no arcs. This is ok
541 :     * because of (bracket = false) for encode0. *)
542 :     encode0 false (PATH { arcs = #arcs f,
543 :     context = #context f,
544 :     elab = ref bogus_elab,
545 :     id = ref NONE }))
546 :     fun p_p p = p_pf (pre0 p)
547 :     and p_pf { arcs, context, err } =
548 :     P.toString { arcs = arcs, vol = "", isAbs = false } :: p_c context
549 :     and p_c (ROOT vol) = (warn true; [vol, "r"])
550 :     | p_c (CWD _) = impossible "pickle: CWD"
551 :     | p_c (ANCHOR { name, ... }) = [name, "a"]
552 :     | p_c (DIR p) = if compare0 (p, gf) = EQUAL then (warn false; ["c"])
553 :     else p_p p
554 :     in
555 :     p_pf f
556 :     end
557 :    
558 :     fun unpickle env { pickled, relativeTo } = let
559 :     fun u_pf (s :: l) =
560 :     (case P.fromString s of
561 :     { arcs, vol = "", isAbs = false } =>
562 :     prefile (u_c l, arcs, fn _ => raise Format)
563 :     | _ => raise Format)
564 :     | u_pf _ = raise Format
565 :     and u_p l = file0 (u_pf l)
566 :     and u_c [vol, "r"] = ROOT vol
567 :     | u_c ["c"] = dir relativeTo
568 :     | u_c [n, "a"] = ANCHOR { name = n, look = mk_look (env, n) }
569 :     | u_c l = DIR (u_p l)
570 :     in
571 :     u_pf pickled
572 :     end
573 :    
574 :     fun decode env s = let
575 :     fun isChar (c1: char) c2 = c1 = c2
576 :     fun unesc s = let
577 :     val dc = Char.chr o valOf o Int.fromString o implode
578 :     fun loop ([], r) = String.implode (rev r)
579 :     | loop (#"\\" :: d0 :: d1 :: d2 :: l, r) =
580 :     (loop (l, dc [d0, d1, d2] :: r)
581 :     handle _ => loop (l, d2 :: d1 :: d0 :: #"\\" :: r))
582 :     | loop (c :: l, r) = loop (l, c :: r)
583 :     in
584 :     loop (String.explode s, [])
585 :     end
586 :     fun arc "." = P.currentArc
587 :     | arc ".." = P.parentArc
588 :     | arc a = unesc a
589 :     fun file (c, l) =
590 :     file0 (prefile (c, l, fn s => raise Fail ("SrcPath.decode: " ^ s)))
591 :     fun addseg (seg, p) =
592 :     file (dir0 p, map arc (String.fields (isChar #"/") seg))
593 :     fun doseg0 s =
594 :     case String.fields (isChar #"/") s of
595 :     [] => impossible "decode: no fields in segment 0"
596 :     | arc0 :: arcs => let
597 :     val arcs = map arc arcs
598 :     fun xtr () = unesc (String.extract (arc0, 1, NONE))
599 :     in
600 :     if arc0 = "" then file (ROOT "", arcs)
601 :     else
602 :     case String.sub (arc0, 0) of
603 :     #"%" => file (ROOT (xtr ()), arcs)
604 :     | #"$" => let
605 :     val n = xtr ()
606 :     in
607 :     file (ANCHOR { name = n,
608 :     look = mk_look (env, n) }, arcs)
609 :     end
610 :     | _ => file (cwd (), arc arc0 :: arcs)
611 :     end
612 :     in
613 :     case String.fields (isChar #":") s of
614 :     [] => impossible "decode: no segments"
615 :     | seg0 :: segs => intern (foldl addseg (doseg0 seg0) segs)
616 :     end
617 : blume 735
618 :     fun encodingIsAbsolute s =
619 :     (case String.sub (s, 0) of (#"/" | #"%") => true | _ => false)
620 :     handle _ => false
621 : blume 354 end

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