Annotation of /sml/trunk/src/cm/main/filename-policy.sml

Parent Directory | Revision Log

---

Revision 666 - (view) (download)

1 :	blume	297	(*
2 :			* A type representing different choices for file naming conventions.
3 :			*
4 :			* (C) 1999 Lucent Technologies, Bell Laboratories
5 :			*
6 :			* Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7 :			*)
8 :			signature FILENAMEPOLICY = sig
9 :
10 :			type policy
11 :	blume	329	type policyMaker = { arch: string, os: SMLofNJ.SysInfo.os_kind } -> policy
12 :	blume	297
13 :	blume	329	val colocate : policyMaker
14 :	blume	357	val separate : { bindir: string, bootdir: string } -> policyMaker
15 :	blume	297
16 :	blume	642	val colocate_generic : { arch: string, os: string } -> policy
17 :			val separate_generic : { bindir: string, bootdir: string } ->
18 :			{ arch: string, os: string } -> policy
19 :
20 :	blume	666	val mkBinName : policy -> SrcPath.file -> string
21 :			val mkSkelName : policy -> SrcPath.file -> string
22 :			val mkStableName : policy -> SrcPath.file * Version.t option -> string
23 :	blume	357
24 :			val kind2name : SMLofNJ.SysInfo.os_kind -> string
25 :	blume	297	end
26 :
27 :	blume	331	functor FilenamePolicyFn (val cmdir : string
28 :	blume	632	val versiondir: Version.t -> string
29 :	blume	331	val skeldir : string) :> FILENAMEPOLICY = struct
30 :	blume	297
31 :	blume	666	type policy = { bin: SrcPath.file -> string,
32 :			skel: SrcPath.file -> string,
33 :			stable: SrcPath.file * Version.t option -> string }
34 :	blume	297
35 :	blume	329	type policyMaker = { arch: string, os: SMLofNJ.SysInfo.os_kind } -> policy
36 :	blume	297
37 :	blume	322	fun kind2name SMLofNJ.SysInfo.BEOS = "beos"
38 :			| kind2name SMLofNJ.SysInfo.MACOS = "macos"
39 :			| kind2name SMLofNJ.SysInfo.OS2 = "os2"
40 :			| kind2name SMLofNJ.SysInfo.UNIX = "unix"
41 :			| kind2name SMLofNJ.SysInfo.WIN32 = "win32"
42 :
43 :	blume	632	fun mkPolicy (shiftbin, shiftstable, ignoreversion) { arch, os } = let
44 :			fun cmname dl s = let
45 :	blume	354	val { dir = d0, file = f } = OS.Path.splitDirFile s
46 :			val d1 = OS.Path.joinDirFile { dir = d0, file = cmdir }
47 :	blume	632	fun subDir (sd, d) = OS.Path.joinDirFile { dir = d, file = sd }
48 :			val d2 = foldl subDir d1 dl
49 :	blume	329	in
50 :	blume	354	OS.Path.joinDirFile { dir = d2, file = f }
51 :	blume	329	end
52 :	blume	642	val archos = concat [arch, "-", os]
53 :	blume	632	val stable0 = cmname [archos] o shiftstable
54 :			val stable =
55 :			if ignoreversion then stable0 o #1
56 :			else (fn (s, NONE) => stable0 s
57 :			| (s, SOME v) => let
58 :			val try =
59 :			cmname [versiondir v, archos] (shiftstable s)
60 :			val exists =
61 :			OS.FileSys.access (try, []) handle _ => false
62 :			in
63 :			if exists then try else stable0 s
64 :			end)
65 :	blume	322	in
66 :	blume	632	{ skel = cmname [skeldir] o SrcPath.osstring,
67 :			bin = cmname [archos] o shiftbin,
68 :			stable = stable }
69 :	blume	322	end
70 :
71 :	blume	642	fun ungeneric g { arch, os } = g { arch = arch, os = kind2name os }
72 :	blume	329
73 :	blume	642	val colocate_generic = mkPolicy (SrcPath.osstring, SrcPath.osstring, false)
74 :
75 :			fun separate_generic { bindir, bootdir } = let
76 :	blume	666	fun shiftname root p = let
77 :			fun anchor a = OS.Path.concat (root, a)
78 :			in
79 :			case SrcPath.osstring_reanchored anchor p of
80 :	blume	354	SOME s => s
81 :			| NONE => (Say.say ["Failure: ", SrcPath.descr p,
82 :	blume	352	" is not an anchored path!\n"];
83 :			raise Fail "bad path")
84 :	blume	666	end
85 :	blume	322	in
86 :	blume	632	mkPolicy (shiftname bindir, shiftname bootdir, true)
87 :	blume	322	end
88 :
89 :	blume	642	val colocate = ungeneric colocate_generic
90 :			val separate = ungeneric o separate_generic
91 :
92 :	blume	354	fun mkBinName (p: policy) s = #bin p s
93 :			fun mkSkelName (p: policy) s = #skel p s
94 :	blume	632	fun mkStableName (p: policy) (s, v) = #stable p (s, v)
95 :	blume	297	end
96 :	blume	331
97 :			structure FilenamePolicy =
98 :	blume	632	FilenamePolicyFn (val cmdir = "CM" val skeldir = "SKEL"
99 :			val versiondir = Version.toString)

---

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