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

Parent Directory | Revision Log | Patch

	revision 758, Fri Dec 22 04:12:36 2000 UTC	revision 759, Fri Dec 22 12:29:26 2000 UTC
#	Line 138	Line 138
138	* and removing arcs at the end easier. *)	* and removing arcs at the end easier. *)
139	type prepath = { revarcs: string list, vol: string, isAbs: bool }	type prepath = { revarcs: string list, vol: string, isAbs: bool }
140
141	type elab = { pp: prepath, valid: unit -> bool }	type elab = { pp: prepath,
142		valid: unit -> bool,
143		reanchor: (anchor -> string) -> prepath option }
144
145	type anchorval = unit -> elab	type anchorval = unit -> elab
146
#	Line 148	Line 150
150	is_set: anchor -> bool,	is_set: anchor -> bool,
151	reset: unit -> unit,	reset: unit -> unit,
152	bound: anchorval StringMap.map }	bound: anchorval StringMap.map }
153
154	datatype dir =	datatype dir =
155	CWD of { name: string, pp: prepath }	CWD of { name: string, pp: prepath }
156	| ANCHOR of { name: anchor, look: unit -> elab }	| ANCHOR of { name: anchor, look: unit -> elab }
#	Line 177	Line 180
180	fun compare (f1: file, f2: file) = Int.compare (#2 f1, #2 f2)	fun compare (f1: file, f2: file) = Int.compare (#2 f1, #2 f2)
181
182	val null_pp : prepath = { revarcs = [], vol = "", isAbs = false }	val null_pp : prepath = { revarcs = [], vol = "", isAbs = false }
183	val bogus_elab : elab = { pp = null_pp, valid = fn _ => false }	val bogus_elab : elab =
184		{ pp = null_pp, valid = fn _ => false, reanchor = fn _ => NONE }
185
186	fun string2pp n = let	fun string2pp n = let
187	val { arcs, vol, isAbs } = P.fromString n	val { arcs, vol, isAbs } = P.fromString n
#	Line 193	Line 197
197
198	fun absElab (arcs, vol) =	fun absElab (arcs, vol) =
199	{ pp = { revarcs = rev arcs, vol = vol, isAbs = true },	{ pp = { revarcs = rev arcs, vol = vol, isAbs = true },
200	valid = fn () => true }	valid = fn () => true, reanchor = fn _ => NONE }
201
202	fun unintern (f: file) = #1 f	fun unintern (f: file) = #1 f
203
#	Line 273	Line 277
277	{ revarcs = revarcs, vol = vol, isAbs = isAbs }	{ revarcs = revarcs, vol = vol, isAbs = isAbs }
278	| dirPP _ = impossible "dirPP"	| dirPP _ = impossible "dirPP"
279
280	fun dirElab { pp, valid } = { pp = dirPP pp, valid = valid }	fun dirElab { pp, valid, reanchor } =
281		{ pp = dirPP pp, valid = valid,
282		reanchor = Option.map dirPP o reanchor }
283
284	fun augPP arcs { revarcs, vol, isAbs } =	fun augPP arcs { revarcs, vol, isAbs } =
285	{ revarcs = List.revAppend (arcs, revarcs), vol = vol, isAbs = isAbs }	{ revarcs = List.revAppend (arcs, revarcs), vol = vol, isAbs = isAbs }
286
287	fun augElab arcs { pp, valid } = { pp = augPP arcs pp, valid = valid }	fun augElab arcs { pp, valid, reanchor } =
288		{ pp = augPP arcs pp, valid = valid,
289		reanchor = Option.map (augPP arcs) o reanchor }
290
291	fun elab_dir (CWD { name, pp }) =	fun elab_dir (CWD { name, pp }) =
292	let fun valid () = name = #name (!cwd_info)	let fun valid () = name = #name (!cwd_info)
293		fun reanchor (a: anchor -> string) = NONE
294	in	in
295	if valid () then { pp = null_pp, valid = valid }	if valid () then { pp = null_pp, valid = valid,
296	else { pp = pp, valid = fn () => true }	reanchor = reanchor }
297		else { pp = pp, valid = fn () => true, reanchor = reanchor }
298	end	end
299	| elab_dir (ANCHOR { name, look }) = look ()	| elab_dir (ANCHOR { name, look }) = look ()
300	| elab_dir (ROOT vol) = absElab ([], vol)	| elab_dir (ROOT vol) = absElab ([], vol)
301	| elab_dir (DIR p) = dirElab (elab_file p)	| elab_dir (DIR p) = dirElab (elab_file p)
302
303	and elab_file (PATH { context, arcs, elab, id }) =	and elab_file (PATH { context, arcs, elab, id }) =
304	let val e as { pp, valid } = !elab	let val e as { pp, valid, reanchor } = !elab
305	in	in
306	if valid () then e	if valid () then e
307	else let val e' = augElab arcs (elab_dir context)	else let val e' = augElab arcs (elab_dir context)
#	Line 390	Line 400
400	end	end
401	fun get_free a = let	fun get_free a = let
402	val (pp, validity) = fetch a	val (pp, validity) = fetch a
403		fun reanchor cvt = SOME (string2pp (cvt a))
404	in	in
405	{ pp = pp, valid = fn () => !validity }	{ pp = pp, valid = fn () => !validity, reanchor = reanchor }
406	end	end
407	fun set_free (a, ppo) = let	fun set_free (a, ppo) = let
408	val (_, validity) = fetch a	val (_, validity) = fetch a
#	Line 523	Line 534
534	fun extend { context, arcs, err } morearcs =	fun extend { context, arcs, err } morearcs =
535	{ context = context, arcs = arcs @ morearcs, err = err }	{ context = context, arcs = arcs @ morearcs, err = err }
536
537	fun osstring_reanchored anchor f = let	fun osstring_reanchored cvt f =
538	fun path (PATH { context, arcs, ... }) =	Option.map pp2name (#reanchor (elab_file (unintern f)) cvt)
	Option.map (augPP arcs) (ctxt context)
	and ctxt (CWD _) = NONE
	| ctxt (ROOT _) = NONE
	| ctxt (DIR p) = Option.map dirPP (path p)
	| ctxt (ANCHOR { name, ... }) = SOME (string2pp (anchor name))
	in
	Option.map pp2name (path (unintern f))
	end
539
540	fun osstring_prefile_relative (p as { arcs, context, ... }) =	fun osstring_prefile_relative (p as { arcs, context, ... }) =
541	case context of	case context of

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

Legend: Removed from v.758   changed lines   Added in v.759

---

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