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/branches/rt-transition/cm/paths/srcpath.sml
ViewVC logotype

Annotation of /sml/branches/rt-transition/cm/paths/srcpath.sml

Parent Directory Parent Directory | Revision Log Revision Log


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

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