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

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