Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/cm/smlfile/smlinfo.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 364 - (view) (download)

1 : blume 275 (*
2 : blume 282 * Bundling information pertaining to one SML source file.
3 :     * - only includes information that does not require running
4 :     * the machine-dependent part of the compiler
5 : blume 275 *
6 :     * (C) 1999 Lucent Technologies, Bell Laboratories
7 :     *
8 :     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
9 :     *)
10 : blume 270 signature SMLINFO = sig
11 :    
12 :     type info
13 : blume 305 type ord_key = info
14 : blume 270
15 : blume 295 type complainer = GenericVC.ErrorMsg.complainer
16 : blume 297 type ast = GenericVC.Ast.dec
17 :     type region = GenericVC.SourceMap.region
18 : blume 299 type source = GenericVC.Source.inputSource
19 : blume 274
20 : blume 279 val eq : info * info -> bool (* compares sourcepaths *)
21 :     val compare : info * info -> order (* compares sourcepaths *)
22 :    
23 : blume 299 val info : GeneralParams.info ->
24 : blume 354 { sourcepath: SrcPath.t,
25 :     group: SrcPath.t * region,
26 : blume 326 share: bool option,
27 :     split: bool }
28 : blume 270 -> info
29 :    
30 : blume 354 val sourcepath : info -> SrcPath.t
31 :     val skelname : info -> string
32 :     val binname : info -> string
33 : blume 299 val error : GeneralParams.info -> info -> complainer
34 : blume 277
35 : blume 299 val parsetree : GeneralParams.info -> info -> (ast * source) option
36 : blume 301 val exports : GeneralParams.info -> info -> SymbolSet.set option
37 :     val skeleton : GeneralParams.info -> info -> Skeleton.decl option
38 : blume 295 val share : info -> bool option
39 : blume 326 val split : info -> bool
40 : blume 301 val lastseen : info -> TStamp.t
41 : blume 279
42 : blume 301 (* forget a parse tree that we are done with *)
43 :     val forgetParsetree : info -> unit
44 :    
45 :     (* evict all but the reachable nodes in the cache *)
46 : blume 354 val forgetAllBut : SrcPathSet.set -> unit
47 : blume 301
48 : blume 280 (* different ways of describing an sml file using group and source *)
49 :     val spec : info -> string (* sspec *)
50 :     val fullSpec : info -> string (* gspec(sspec) *)
51 : blume 354 val descr : info -> string (* sname *)
52 :     val fullDescr : info -> string (* gname(sspec) *)
53 : blume 305
54 : blume 306 val errorLocation : GeneralParams.info -> info -> string
55 : blume 270 end
56 :    
57 :     structure SmlInfo :> SMLINFO = struct
58 :    
59 : blume 275 structure Source = GenericVC.Source
60 :     structure SF = GenericVC.SmlFile
61 :     structure EM = GenericVC.ErrorMsg
62 : blume 286 structure FNP = FilenamePolicy
63 : blume 275
64 :     type source = Source.inputSource
65 : blume 297 type ast = GenericVC.Ast.dec
66 :     type region = GenericVC.SourceMap.region
67 : blume 274
68 : blume 295 type complainer = EM.complainer
69 : blume 274
70 : blume 297 datatype persinfo =
71 : blume 354 PERS of { group: SrcPath.t * region,
72 : blume 297 lastseen: TStamp.t ref,
73 : blume 299 parsetree: (ast * source) option ref,
74 : blume 297 skeleton: Skeleton.decl option ref }
75 :    
76 : blume 275 datatype info =
77 : blume 354 INFO of { sourcepath: SrcPath.t,
78 : blume 361 mkSkelname: unit -> string,
79 :     mkBinname: unit -> string,
80 : blume 297 persinfo: persinfo,
81 : blume 326 share: bool option,
82 :     split: bool }
83 : blume 270
84 : blume 305 type ord_key = info
85 :    
86 : blume 277 fun sourcepath (INFO { sourcepath = sp, ... }) = sp
87 : blume 361 fun skelname (INFO { mkSkelname = msn, ... }) = msn ()
88 :     fun binname (INFO { mkBinname = mbn, ... }) = mbn ()
89 : blume 295 fun share (INFO { share = s, ... }) = s
90 : blume 326 fun split (INFO { split = s, ... }) = s
91 : blume 270
92 : blume 299 fun gerror (gp: GeneralParams.info) = GroupReg.error (#groupreg gp)
93 : blume 297
94 :     fun error gp (INFO { persinfo = PERS { group, ... }, ... }) =
95 :     gerror gp group
96 :    
97 : blume 279 fun compare (INFO { sourcepath = p, ... }, INFO { sourcepath = p', ... }) =
98 : blume 354 SrcPath.compare (p, p')
99 : blume 279 fun eq (i, i') = compare (i, i') = EQUAL
100 :    
101 : blume 301 fun lastseen (INFO { persinfo = PERS { lastseen, ... }, ... }) =
102 :     !lastseen
103 :    
104 : blume 354 val knownInfo = ref (SrcPathMap.empty: persinfo SrcPathMap.map)
105 : blume 277
106 : blume 301 fun forgetParsetree (INFO { persinfo = PERS { parsetree, ... }, ... }) =
107 :     parsetree := NONE
108 :    
109 :     fun forgetAllBut reachable = let
110 : blume 354 fun isReachable (p, m) = SrcPathSet.member (reachable, p)
111 : blume 301 in
112 : blume 354 knownInfo := SrcPathMap.filteri isReachable (!knownInfo)
113 : blume 301 end
114 :    
115 : blume 330 (* check timestamp and throw away any invalid cache *)
116 :     fun validate (sourcepath, PERS pir) = let
117 :     (* don't use "..." pattern to have the compiler catch later
118 :     * additions to the type! *)
119 :     val { group, lastseen, parsetree, skeleton } = pir
120 :     val ts = !lastseen
121 : blume 354 val nts = SrcPath.tstamp sourcepath
122 : blume 330 in
123 : blume 345 if TStamp.needsUpdate { source = nts, target = ts } then
124 : blume 330 (lastseen := nts;
125 :     parsetree := NONE;
126 :     skeleton := NONE)
127 :     else ()
128 :     end
129 :    
130 : blume 299 fun info (gp: GeneralParams.info) arg = let
131 : blume 326 val { sourcepath, group = gr as (group, region), share, split } = arg
132 : blume 310 val policy = #fnpolicy (#param gp)
133 : blume 361 fun mkSkelname () = FNP.mkSkelName policy sourcepath
134 :     fun mkBinname () = FNP.mkBinName policy sourcepath
135 : blume 297 val groupreg = #groupreg gp
136 :     fun newpersinfo () = let
137 : blume 354 val ts = SrcPath.tstamp sourcepath
138 : blume 330 val pi = PERS { group = gr, lastseen = ref ts,
139 : blume 297 parsetree = ref NONE, skeleton = ref NONE }
140 : blume 281 in
141 : blume 354 knownInfo := SrcPathMap.insert (!knownInfo, sourcepath, pi);
142 : blume 297 pi
143 : blume 281 end
144 : blume 297 fun persinfo () =
145 : blume 354 case SrcPathMap.find (!knownInfo, sourcepath) of
146 : blume 297 NONE => newpersinfo ()
147 :     | SOME (pi as PERS { group = gr' as (g, r), ... }) =>
148 : blume 354 if SrcPath.compare (group, g) <> EQUAL then let
149 :     val n = SrcPath.descr sourcepath
150 : blume 322 in
151 :     if GroupReg.registered groupreg g then
152 :     (gerror gp gr EM.COMPLAIN
153 :     (concat ["ML source file ", n,
154 :     " appears in more than one group"])
155 :     EM.nullErrorBody;
156 :     gerror gp gr' EM.COMPLAIN
157 :     (concat ["(previous occurence of ", n, ")"])
158 :     EM.nullErrorBody)
159 :     else
160 :     gerror gp gr EM.WARN
161 :     (concat ["ML source file ", n,
162 :     " has switched groups"])
163 :     EM.nullErrorBody;
164 :     newpersinfo ()
165 :     end
166 : blume 330 else (validate (sourcepath, pi); pi)
167 : blume 281 in
168 : blume 297 INFO { sourcepath = sourcepath,
169 : blume 361 mkSkelname = mkSkelname,
170 :     mkBinname = mkBinname,
171 : blume 297 persinfo = persinfo (),
172 : blume 326 share = share,
173 :     split = split }
174 : blume 281 end
175 : blume 277
176 : blume 275 (* the following functions are only concerned with getting the data,
177 :     * not with checking time stamps *)
178 : blume 297 fun getParseTree gp (i as INFO ir, quiet, noerrors) = let
179 :     val { sourcepath, persinfo = PERS { parsetree, ... }, ... } = ir
180 : blume 281 val err = if noerrors then (fn m => ())
181 : blume 297 else (fn m => error gp i EM.COMPLAIN m EM.nullErrorBody)
182 : blume 274 in
183 : blume 275 case !parsetree of
184 :     SOME pt => SOME pt
185 :     | NONE => let
186 : blume 345 fun work stream = let
187 :     val _ = if noerrors orelse quiet then ()
188 : blume 354 else Say.vsay ["[parsing ",
189 :     SrcPath.descr sourcepath, "]\n"]
190 : blume 345 val source =
191 : blume 354 Source.newSource (SrcPath.osstring sourcepath,
192 :     1, stream, false, #errcons gp)
193 : blume 275 in
194 : blume 345 (SF.parse source, source)
195 :     end
196 : blume 364 fun openIt () = TextIO.openIn (SrcPath.osstring sourcepath)
197 : blume 345 val pto =
198 :     SOME (SafeIO.perform { openIt = openIt,
199 :     closeIt = TextIO.closeIn,
200 :     work = work,
201 :     cleanup = fn () => () })
202 : blume 275 in
203 :     parsetree := pto;
204 :     pto
205 : blume 345 end handle exn as IO.Io _ => (err (General.exnMessage exn); NONE)
206 :     | SF.Compile msg => (err msg; NONE)
207 : blume 274 end
208 :    
209 : blume 297 fun getSkeleton gp (i as INFO ir, noerrors) = let
210 : blume 361 val { sourcepath, mkSkelname, persinfo = PERS pir, ... } = ir
211 : blume 297 val { skeleton, lastseen, ... } = pir
212 : blume 275 in
213 :     case !skeleton of
214 : blume 301 SOME sk => SOME sk
215 : blume 361 | NONE => let
216 :     val skelname = mkSkelname ()
217 :     in
218 :     case SkelIO.read (skelname, !lastseen) of
219 :     SOME sk => (skeleton := SOME sk; SOME sk)
220 :     | NONE =>
221 :     (case getParseTree gp (i, false, noerrors) of
222 :     SOME (tree, source) => let
223 :     fun err sv region s =
224 :     EM.error source region sv s
225 :     EM.nullErrorBody
226 :     val { skeleton = sk, complain } =
227 :     SkelCvt.convert { tree = tree,
228 :     err = err }
229 :     in
230 :     if noerrors then () else complain ();
231 : blume 310 if EM.anyErrors (EM.errors source) then
232 : blume 361 if noerrors then ()
233 :     else error gp i EM.COMPLAIN
234 : blume 310 "error(s) in ML source file"
235 :     EM.nullErrorBody
236 : blume 354 else (SkelIO.write (skelname, sk, !lastseen);
237 : blume 310 skeleton := SOME sk);
238 :     SOME sk
239 : blume 361 end
240 :     | NONE => NONE)
241 :     end
242 : blume 275 end
243 :    
244 : blume 330 fun skeleton0 noerrors gp i = getSkeleton gp (i, noerrors)
245 : blume 281
246 :     (* we only complain at the time of getting the exports *)
247 : blume 301 fun exports gp i = Option.map SkelExports.exports (skeleton0 false gp i)
248 : blume 281 val skeleton = skeleton0 true
249 : blume 275
250 : blume 330 fun parsetree gp i = getParseTree gp (i, true, true)
251 : blume 282
252 : blume 354 fun spec (INFO { sourcepath, ... }) = SrcPath.specOf sourcepath
253 : blume 297 fun fullSpec (INFO { sourcepath, persinfo = PERS { group, ... }, ... }) =
254 : blume 354 concat [SrcPath.specOf (#1 group), "(", SrcPath.specOf sourcepath, ")"]
255 :     fun descr (INFO { sourcepath, ... }) = SrcPath.descr sourcepath
256 :     fun fullDescr (INFO { sourcepath, persinfo = PERS { group, ... }, ... }) =
257 :     concat [SrcPath.descr (#1 group), "(", SrcPath.specOf sourcepath, ")"]
258 : blume 305
259 : blume 306 fun errorLocation (gp: GeneralParams.info) (INFO i) = let
260 :     val { persinfo = PERS { group = (group, reg), ... }, ... } = i
261 : blume 305 in
262 : blume 306 EM.matchErrorString (GroupReg.lookup (#groupreg gp) group) reg
263 : blume 305 end
264 : blume 270 end

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