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

Parent Directory | Revision Log | Patch

	revision 269, Mon May 10 13:34:43 1999 UTC	revision 270, Tue May 11 07:45:42 1999 UTC
#	Line 7	Line 7
7	*)	*)
8	signature ABSPATH = sig	signature ABSPATH = sig
9
10		type context
11	type t	type t
12
13	val revalidateCwd : unit -> unit	val revalidateCwd : unit -> unit
14
15		val cwdContext: unit -> context
16		val configContext: (unit -> string) -> context
17		val relativeContext: t -> context
18
19	val name : t -> string	val name : t -> string
20	val compare : t * t -> order	val compare : t * t -> order
21
22	val native : { context: t, spec: string } -> t	val native : { context: context, spec: string } -> t
23	val standard : { context: t, spec: string } -> t	val standard : { context: context, spec: string } -> t
24
25	val joinDirFile : { dir: t, file: string } -> t	val joinDirFile : { dir: t, file: string } -> t
26	val splitDirFile : t -> { dir: t, file: string }	val splitDirFile : t -> { dir: t, file: string }
#	Line 39	Line 44
44	| compareId (PRESENT _, ABSENT _) = GREATER	| compareId (PRESENT _, ABSENT _) = GREATER
45	| compareId (ABSENT s, ABSENT s') = String.compare (s, s')	| compareId (ABSENT s, ABSENT s') = String.compare (s, s')
46
47	fun getId f = PRESENT (F.fileId f) handle _ => ABSENT f	fun getId f = (PRESENT (F.fileId f) handle _ => ABSENT f)
48
49	type elaboration = { stamp : unit ref,	type elaboration = { stamp : unit ref,
50	name : string,	name : string,
#	Line 54	Line 59
59	*)	*)
60
61	type cwdinfo = { stamp: unit ref, name: string, id: id }	type cwdinfo = { stamp: unit ref, name: string, id: id }
62	datatype t =
63		datatype context =
64	CUR of cwdinfo	CUR of cwdinfo
65	| CONFIG_ANCHOR of { fetch: unit -> string,	| CONFIG_ANCHOR of { fetch: unit -> string,
66	cache: elaboration option ref }	cache: elaboration option ref }
67	| SPEC of { context: t,	| RELATIVE of t
68
69		and  t =
70		PATH of { context: context,
71	spec: string,	spec: string,
72	cache: elaboration option ref }	cache: elaboration option ref }
73
#	Line 100	Line 109
109	else ()	else ()
110	end	end
111
112	(* elaborate a path -- uses internal caching, don't cache	fun cwdContext () =
113	* results externally! *)	CUR { stamp = cwdStamp (), name = cwdName (), id = cwdId () }
114	fun elab p = let
115		fun configContext fetch =
116		CONFIG_ANCHOR { fetch = fetch, cache = ref NONE }
117
118		fun relativeContext p = RELATIVE p
119
120	fun mkElab (cache, name) = let	fun mkElab (cache, name) = let
121	val e = { stamp = !elabStamp, name = name, id = ref NONE }	val e : elaboration =
122		{ stamp = !elabStamp, name = name, id = ref NONE }
123	in	in
124	cache := SOME e; e	cache := SOME e; e
125	end	end
126	fun resolve_anchor { fetch, cache } = mkElab (cache, fetch ())
127	fun resolve_spec { context, spec, cache } = let	fun validElab NONE = NONE
128		| validElab (SOME (e as { stamp, name, id })) =
129		if stamp = !elabStamp then SOME e else NONE
130
131		fun elabContext c =
132		case c of
133		CUR { stamp, name, id } =>
134		{ stamp = !elabStamp, id = ref (SOME id),
135		name = if stamp = cwdStamp () orelse
136		name = cwdName ()
137		then P.currentArc else name }
138		| CONFIG_ANCHOR { fetch, cache } =>
139		(case validElab (!cache) of
140		SOME e => e
141		| NONE => mkElab (cache, fetch ()))
142		| RELATIVE p => elab p
143
144		and elab (PATH { context, spec, cache }) =
145		(case validElab (!cache) of
146		SOME e => e
147		| NONE => let
148	val name =	val name =
149	if P.isAbsolute spec then spec	if P.isAbsolute spec then spec
150	else P.mkCanonical (P.concat (#name (elab context), spec))	else P.mkCanonical
151		(P.concat (#name (elabContext context),
152		spec))
153	in	in
154	mkElab (cache, name)	mkElab (cache, name)
155	end	end)
	in
	case p of
	CUR { stamp, name, id } =>
	{ stamp = !elabStamp, id = ref (SOME id),
	name = if stamp = cwdStamp ()
	orelse name = cwdName () then
	P.currentArc
	else name }
	| CONFIG_ANCHOR (a as { cache = ref NONE, ... }) =>
	resolve_anchor a
	| CONFIG_ANCHOR (a as { cache = ref (SOME (e as { stamp, ... })),
	... }) =>
	if stamp = !elabStamp then e else resolve_anchor a
	| SPEC (s as { cache = ref NONE, ... }) =>
	resolve_spec s
	| SPEC (s as { cache = ref (SOME (e as { stamp, ... })), ...}) =>
	if stamp = !elabStamp then e else resolve_spec s
	end
156
157	(* get the file id (calls elab, so don't cache externally!) *)	(* get the file id (calls elab, so don't cache externally!) *)
158	fun id p = let	fun id p = let
#	Line 155	Line 174
174	fun compare (p1, p2) = compareId (id p1, id p2)	fun compare (p1, p2) = compareId (id p1, id p2)
175
176	fun fresh (context, spec) =	fun fresh (context, spec) =
177	SPEC { context = context, spec = spec, cache = ref NONE }	PATH { context = context, spec = spec, cache = ref NONE }
178
179	(* make an abstract path from a native string *)	(* make an abstract path from a native string *)
180	fun native { spec, context } = fresh (context, spec)	fun native { spec, context } = fresh (context, spec)
#	Line 191	Line 210
210	end	end
211
212	(* . and .. are not permitted as file parameter *)	(* . and .. are not permitted as file parameter *)
213	fun joinDirFile { dir, file } =	fun joinDirFile { dir = PATH { context, spec, ... }, file } =
214	if file = P.currentArc orelse file = P.parentArc then	if file = P.currentArc orelse file = P.parentArc then
215	raise Fail "AbsPath.joinDirFile: . or .."	raise Fail "AbsPath.joinDirFile: . or .."
216	else case dir of	else fresh (context, P.joinDirFile { dir = spec, file = file })
	(CUR _ | CONFIG_ANCHOR _) => fresh (dir, file)
	| SPEC { context, spec, ... } =>
	fresh (context, P.joinDirFile { dir = spec, file = file })
217
218	(* splitDirFile never walks past a context.	(* splitDirFile never walks past a context.
219	* Moreover, it is an error to split something that ends in "..". *)	* Moreover, it is an error to split something that ends in "..". *)
220	fun splitDirFile (x as (CUR _ | CONFIG_ANCHOR _)) =	fun splitDirFile (PATH { context, spec, ... }) = let
	raise Fail "AbsPath.splitDirFile: CUR or CONFIG_ANCHOR"
	| splitDirFile (SPEC { context, spec, ... }) = let
221	fun loop "" =	fun loop "" =
222	raise Fail "AbsPath.splitDirFile: tried to split context"	raise Fail "AbsPath.splitDirFile: tried to split a context"
223	| loop spec = let	| loop spec = let
224	val { dir, file } = P.splitDirFile spec	val { dir, file } = P.splitDirFile spec
225	in	in
#	Line 215	Line 229
229	else (dir, file)	else (dir, file)
230	end	end
231	val (dir, file) = loop spec	val (dir, file) = loop spec
232	val dir = if dir = "" then context else fresh (context, dir)	val dir = if dir = "" then P.currentArc else dir
233	in	in
234	{ dir = dir, file = file }	{ dir = fresh (context, dir), file = file }
235	end	end
236
237	val dir = #dir o splitDirFile	val dir = #dir o splitDirFile

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

Legend: Removed from v.269   changed lines   Added in v.270

---

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