Annotation of /sml/trunk/src/cm/smlfile/smlinfo.sml

Parent Directory | Revision Log

---

Revision 280 - (view) (download)

1 :	blume	275	(*
2 :			* Bundling all information pertaining to one SML source file.
3 :			*
4 :			* (C) 1999 Lucent Technologies, Bell Laboratories
5 :			*
6 :			* Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7 :			*)
8 :	blume	270	signature SMLINFO = sig
9 :
10 :			type info
11 :
12 :	blume	274	type policy = Policy.policy
13 :
14 :	blume	270	type fileoffset = AbsPath.t * int
15 :
16 :	blume	277	val resync : unit -> unit
17 :
18 :	blume	279	val eq : info * info -> bool (* compares sourcepaths *)
19 :			val compare : info * info -> order (* compares sourcepaths *)
20 :
21 :	blume	276	val info : policy ->
22 :	blume	274	{ sourcepath: AbsPath.t,
23 :			group: AbsPath.t,
24 :	blume	277	error: string -> (PrettyPrint.ppstream -> unit) -> unit,
25 :	blume	274	history: string list,
26 :	blume	277	share: bool option }
27 :	blume	270	-> info
28 :
29 :	blume	277	val sourcepath : info -> AbsPath.t
30 :			val error : info -> string -> (PrettyPrint.ppstream -> unit) -> unit
31 :
32 :	blume	270	val exports : info -> SymbolSet.set
33 :	blume	279	val skeleton : info -> Skeleton.decl
34 :
35 :	blume	280	(* different ways of describing an sml file using group and source *)
36 :			val spec : info -> string (* sspec *)
37 :			val fullSpec : info -> string (* gspec(sspec) *)
38 :			val name : info -> string (* sname *)
39 :			val fullName : info -> string (* gname(sspec) *)
40 :	blume	270	end
41 :
42 :			structure SmlInfo :> SMLINFO = struct
43 :
44 :	blume	275	structure Source = GenericVC.Source
45 :			structure Print = GenericVC.Control.Print
46 :			structure SF = GenericVC.SmlFile
47 :			structure EM = GenericVC.ErrorMsg
48 :
49 :			type source = Source.inputSource
50 :	blume	274	type parsetree = GenericVC.Ast.dec
51 :
52 :			type policy = Policy.policy
53 :
54 :	blume	275	datatype info =
55 :			INFO of {
56 :			sourcepath: AbsPath.t,
57 :			group: AbsPath.t,
58 :	blume	277	error: string -> (PrettyPrint.ppstream -> unit) -> unit,
59 :	blume	275	lastseen: TStamp.t ref,
60 :			parsetree: { tree: parsetree, source: source } option ref,
61 :			skelpath: AbsPath.t,
62 :			skeleton: Skeleton.decl option ref
63 :			(* to be extended *)
64 :			}
65 :	blume	270
66 :			type fileoffset = AbsPath.t * int
67 :			type stableinfo = { skeleton: Skeleton.decl, binary: fileoffset }
68 :
69 :	blume	277	fun sourcepath (INFO { sourcepath = sp, ... }) = sp
70 :			fun error (INFO { error = e, ... }) = e
71 :	blume	270
72 :	blume	279	fun compare (INFO { sourcepath = p, ... }, INFO { sourcepath = p', ... }) =
73 :			AbsPath.compare (p, p')
74 :			fun eq (i, i') = compare (i, i') = EQUAL
75 :
76 :	blume	277	(* If files change their file ids, then CM will be seriously
77 :			* disturbed because the ordering relation will change.
78 :			* We'll asume that this won't happen in general. However, we provide
79 :			* a "resync" function that -- at the very least -- should be run
80 :			* at startup time. *)
81 :			val knownInfo : info AbsPathMap.map ref = ref AbsPathMap.empty
82 :
83 :			fun resync () = let
84 :			val l = AbsPathMap.listItemsi (!knownInfo)
85 :			in
86 :			AbsPath.newEra (); (* force recalculation of file ids *)
87 :			knownInfo := foldl AbsPathMap.insert' AbsPathMap.empty l
88 :			end
89 :
90 :			fun info policy { sourcepath, group, error, history, share } =
91 :			case AbsPathMap.find (!knownInfo, sourcepath) of
92 :			SOME (i as INFO { group = g, error = e, ... }) =>
93 :			(if AbsPath.compare (group, g) <> EQUAL then
94 :			let val n = AbsPath.name sourcepath
95 :			in
96 :			error (concat ["ML source file ", n,
97 :			" appears in more than one group"])
98 :			EM.nullErrorBody;
99 :			e (concat ["(previous occurence of ", n, ")"])
100 :			EM.nullErrorBody
101 :			end
102 :			else ();
103 :			i)
104 :			| NONE => let
105 :			val i = INFO {
106 :			sourcepath = sourcepath,
107 :			group = group,
108 :			error = error,
109 :			lastseen = ref TStamp.NOTSTAMP,
110 :			parsetree = ref NONE,
111 :			skelpath = Policy.mkSkelPath policy sourcepath,
112 :			skeleton = ref NONE
113 :			}
114 :			in
115 :			knownInfo := AbsPathMap.insert (!knownInfo, sourcepath, i);
116 :			i
117 :			end
118 :
119 :	blume	275	(* check timestamp and throw away any invalid cache *)
120 :			fun validate (INFO ir) = let
121 :			(* don't use "..." pattern to have the compiler catch later
122 :			* additions to the type! *)
123 :			val { sourcepath, group, error, lastseen,
124 :			parsetree, skelpath, skeleton } = ir
125 :			val ts = !lastseen
126 :			val nts = AbsPath.tstamp sourcepath
127 :	blume	274	in
128 :	blume	275	if TStamp.earlier (ts, nts) then
129 :			(lastseen := nts;
130 :			parsetree := NONE;
131 :			skeleton := NONE)
132 :			else ()
133 :	blume	274	end
134 :
135 :	blume	275	(* the following functions are only concerned with getting the data,
136 :			* not with checking time stamps *)
137 :			fun getParseTree (INFO ir, quiet) = let
138 :			val { sourcepath, parsetree, error, ... } = ir
139 :	blume	276	val name = AbsPath.name sourcepath
140 :	blume	274	in
141 :	blume	275	case !parsetree of
142 :			SOME pt => SOME pt
143 :			| NONE => let
144 :			val stream = AbsPath.openTextIn sourcepath
145 :			val _ = if quiet then ()
146 :			else Say.vsay (concat ["[parsing ", name, "]\n"])
147 :			val source =
148 :			Source.newSource (name, 1, stream, false,
149 :			{ linewidth = !Print.linewidth,
150 :			flush = Print.flush,
151 :			consumer = Print.say })
152 :			val pto = let
153 :			val tree = SF.parse source
154 :			in
155 :			SOME { tree = tree, source = source }
156 :			end handle SF.Compile msg => (TextIO.closeIn stream;
157 :	blume	277	error msg EM.nullErrorBody;
158 :	blume	275	NONE)
159 :	blume	276	| exn => (TextIO.closeIn stream; raise exn)
160 :	blume	275	in
161 :			TextIO.closeIn stream;
162 :			parsetree := pto;
163 :			pto
164 :	blume	277	end handle exn as IO.Io _ => (error (General.exnMessage exn)
165 :			EM.nullErrorBody;
166 :	blume	276	NONE)
167 :	blume	274	end
168 :
169 :	blume	275	fun getSkeleton (INFO ir) = let
170 :			val { skelpath, skeleton, lastseen, error, ... } = ir
171 :			in
172 :			case !skeleton of
173 :			SOME sk => SOME sk
174 :			| NONE =>
175 :			(case SkelIO.read (skelpath, !lastseen) of
176 :			SOME sk => (skeleton := SOME sk; SOME sk)
177 :			| NONE =>
178 :			(case getParseTree (INFO ir, false) of
179 :			SOME { tree, source } => let
180 :			fun err sv region s =
181 :			EM.error source region sv s
182 :			EM.nullErrorBody
183 :			val sk =
184 :			SkelCvt.convert { tree = tree,
185 :			err = err }
186 :			in
187 :			if EM.anyErrors (EM.errors source) then
188 :			(error "error(s) in ML source file";
189 :			NONE)
190 :			else (SkelIO.write (skelpath, sk);
191 :			skeleton := SOME sk;
192 :			SOME sk)
193 :			end
194 :			| NONE => NONE))
195 :			end
196 :
197 :			(* first check the time stamp, then do your stuff... *)
198 :			fun exports i =
199 :			(validate i;
200 :			case getSkeleton i of
201 :			NONE => SymbolSet.empty
202 :			| SOME sk => SkelExports.exports sk)
203 :
204 :	blume	279	fun skeleton i =
205 :			(validate i;
206 :			case getSkeleton i of
207 :			NONE => Skeleton.SeqDecl []
208 :			| SOME sk => sk)
209 :
210 :	blume	280	fun spec (INFO { sourcepath, ... }) = AbsPath.spec sourcepath
211 :			fun fullSpec (INFO { group, sourcepath, ... }) =
212 :			concat [AbsPath.spec group, "(", AbsPath.spec sourcepath, ")"]
213 :			fun name (INFO { sourcepath, ... }) = AbsPath.name sourcepath
214 :			fun fullName (INFO { group, sourcepath, ... }) =
215 :			concat [AbsPath.name group, "(", AbsPath.spec sourcepath, ")"]
216 :	blume	270	end

---

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