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

Parent Directory | Revision Log

---

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

---

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