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

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