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/parse/parse.sml
ViewVC logotype

Annotation of /sml/trunk/src/cm/parse/parse.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 398 - (view) (download)

1 : blume 270 (*
2 :     * Parser for CM description files.
3 :     *
4 :     * (C) 1999 Lucent Technologies, Bell Laboratories
5 :     *
6 :     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7 :     *)
8 : blume 310 signature PARSE = sig
9 : blume 301 val parse :
10 : blume 355 GroupReg.groupreg option ->
11 : blume 310 GeneralParams.param -> bool option ->
12 : blume 354 SrcPath.t -> (CMSemant.group * GeneralParams.info) option
13 : blume 367 val reset : unit -> unit
14 : blume 268 end
15 :    
16 : blume 362 functor ParseFn (val pending : unit -> DependencyGraph.impexp SymbolMap.map
17 :     structure Stabilize: STABILIZE) :> PARSE = struct
18 : blume 268
19 :     val lookAhead = 30
20 :    
21 :     structure S = GenericVC.Source
22 :     structure EM = GenericVC.ErrorMsg
23 :     structure SM = GenericVC.SourceMap
24 : blume 348 structure GG = GroupGraph
25 : blume 268
26 :     structure CMLrVals = CMLrValsFun (structure Token = LrParser.Token)
27 :     structure CMLex = CMLexFun (structure Tokens = CMLrVals.Tokens)
28 :     structure CMParse =
29 :     JoinWithArg (structure ParserData = CMLrVals.ParserData
30 :     structure Lex = CMLex
31 :     structure LrParser = LrParser)
32 :    
33 : blume 367 (* the "stable group cache" *)
34 :     val sgc = ref (SrcPathMap.empty: CMSemant.group SrcPathMap.map)
35 :     fun reset () = sgc := SrcPathMap.empty
36 :    
37 : blume 355 fun parse gropt param stabflag group = let
38 : blume 270
39 : blume 311 val stabthis = isSome stabflag
40 :     val staball = stabflag = SOME true
41 : blume 310
42 : blume 355 val groupreg =
43 :     case gropt of
44 :     SOME r => r
45 :     | NONE => GroupReg.new ()
46 : blume 309 val errcons = EM.defaultConsumer ()
47 :     val ginfo = { param = param, groupreg = groupreg, errcons = errcons }
48 : blume 268
49 : blume 301 (* The "group cache" -- we store "group options"; having
50 :     * NONE registered for a group means that a previous attempt
51 :     * to parse it had failed. *)
52 : blume 354 val gc = ref (SrcPathMap.empty: CMSemant.group option SrcPathMap.map)
53 : blume 273
54 : blume 367 fun mparse (group, groupstack, pErrFlag, stabthis, curlib) =
55 :     case SrcPathMap.find (!sgc, group) of
56 :     SOME g => SOME g
57 :     | NONE =>
58 :     (case SrcPathMap.find (!gc, group) of
59 :     SOME gopt => gopt
60 :     | NONE => let
61 :     fun cache_nonstable gopt =
62 :     (gc := SrcPathMap.insert (!gc, group, gopt);
63 :     gopt)
64 :     fun cache_stable g =
65 :     (sgc := SrcPathMap.insert (!sgc, group, g);
66 :     SOME g)
67 :     fun isStable (GG.GROUP { kind, ... }) =
68 : blume 398 case kind of GG.STABLELIB => true | _ => false
69 : blume 367 val pres =
70 :     parse' (group, groupstack, pErrFlag,
71 :     stabthis, curlib)
72 :     in
73 :     case pres of
74 :     NONE => cache_nonstable NONE
75 :     | SOME g =>
76 :     if isStable g then cache_stable g
77 :     else cache_nonstable (SOME g)
78 :     end)
79 : blume 273
80 : blume 367 and parse' (group, groupstack, pErrFlag, stabthis, curlib) = let
81 : blume 286 (* checking for cycles among groups and printing them nicely *)
82 : blume 294 fun findCycle ([], _) = []
83 :     | findCycle ((h as (g, (s, p1, p2))) :: t, cyc) =
84 : blume 354 if SrcPath.compare (g, group) = EQUAL then rev (h :: cyc)
85 : blume 294 else findCycle (t, h :: cyc)
86 :     fun report ((g, (s, p1, p2)), hist) = let
87 :     fun pphist pps = let
88 :     fun loop (_, []) = ()
89 :     | loop (g0, (g, (s, p1, p2)) :: t) = let
90 :     val s = EM.matchErrorString s (p1, p2)
91 :     in
92 :     PrettyPrint.add_string pps s;
93 :     PrettyPrint.add_string pps ": importing ";
94 : blume 354 PrettyPrint.add_string pps (SrcPath.specOf g0);
95 : blume 294 PrettyPrint.add_newline pps;
96 :     loop (g, t)
97 :     end
98 : blume 273 in
99 : blume 294 PrettyPrint.add_newline pps;
100 :     loop (g, hist)
101 : blume 273 end
102 :     in
103 : blume 294 EM.error s (p1, p2) EM.COMPLAIN
104 :     ("group hierarchy forms a cycle with " ^
105 : blume 354 SrcPath.specOf group)
106 : blume 294 pphist
107 : blume 273 end
108 :    
109 : blume 310 fun getStable gpath = let
110 : blume 330 fun getStableSG p =
111 : blume 367 mparse (p, groupstack, pErrFlag, staball, SOME gpath)
112 : blume 310 in
113 : blume 398 Stabilize.loadStable ginfo { getGroup = getStableSG,
114 :     anyerrors = pErrFlag } gpath
115 : blume 310 end
116 :    
117 : blume 340 (* We stabilize libraries only because a stable library will
118 :     * encompass the contents of its sub-groups
119 :     * (but not sub-libraries!). *)
120 : blume 348 fun stabilize (g as GG.GROUP { kind = GG.NOLIB, ... }) = SOME g
121 : blume 340 | stabilize g =
122 : blume 311 Stabilize.stabilize ginfo { group = g, anyerrors = pErrFlag }
123 : blume 310
124 : blume 294 (* normal processing -- used when there is no cycle to report *)
125 :     fun normal_processing () = let
126 : blume 354 val context = SrcPath.sameDirContext group
127 : blume 294
128 : blume 345 fun work stream = let
129 :     val source =
130 : blume 354 S.newSource (SrcPath.osstring group,
131 :     1, stream, false, errcons)
132 : blume 345 val sourceMap = #sourceMap source
133 :     val _ = GroupReg.register groupreg (group, source)
134 : blume 297
135 : blume 345 (* We can hard-wire the source into this
136 :     * error function because the function is only for
137 :     * immediate use and doesn't get stored into persistent
138 :     * data structures. *)
139 :     fun error r m =
140 :     EM.error source r EM.COMPLAIN m EM.nullErrorBody
141 : blume 397 fun obsolete r =
142 :     if EnvConfig.getSet StdConfig.warn_obsolete NONE then
143 :     EM.error source r EM.WARN
144 :     "old-style operator (obsolete)" EM.nullErrorBody
145 :     else ()
146 : blume 294
147 : blume 345 (* recParse returns a group (not an option).
148 : blume 380 * This function is used to parse sub-groups.
149 : blume 345 * Errors are propagated by explicitly setting the
150 :     * "anyErrors" flag of the parent group. *)
151 : blume 367 fun recParse (p1, p2) curlib p = let
152 :     val gs' = (group, (source, p1, p2)) :: groupstack
153 : blume 345 val myErrorFlag = #anyErrors source
154 : blume 294 in
155 : blume 367 case mparse (p, gs', myErrorFlag, staball, curlib) of
156 : blume 345 NONE => (myErrorFlag := true;
157 :     CMSemant.emptyGroup group)
158 :     | SOME res => res
159 : blume 294 end
160 : blume 345 handle exn as IO.Io _ =>
161 :     (error (p1, p2) (General.exnMessage exn);
162 :     CMSemant.emptyGroup group)
163 :    
164 :     fun doMember (p, p1, p2, c) =
165 :     CMSemant.member (ginfo, recParse (p1, p2))
166 :     { sourcepath = p, class = c,
167 :     group = (group, (p1, p2)) }
168 :    
169 :     (* Build the argument for the lexer; the lexer's local
170 :     * state is encapsulated here to make sure the parser
171 :     * is re-entrant. *)
172 :     val lexarg = let
173 :     (* local state *)
174 :     val depth = ref 0
175 :     val curstring = ref []
176 :     val startpos = ref 0
177 :     val instring = ref false
178 :     (* handling comments *)
179 :     fun enterC () = depth := !depth + 1
180 :     fun leaveC () = let
181 :     val d = !depth - 1
182 :     in
183 :     depth := d;
184 :     d = 0
185 :     end
186 :     (* handling strings *)
187 :     fun newS pos =
188 :     (instring := true;
189 :     curstring := [];
190 :     startpos := pos)
191 :     fun addS c = curstring := c :: !curstring
192 :     fun addSC (s, offs) =
193 :     addS (chr (ord (String.sub (s, 2)) - offs))
194 :     fun addSN (s, pos) = let
195 :     val ns = substring (s, 1, 3)
196 :     val n = Int.fromString ns
197 :     in
198 :     addS (chr (valOf n))
199 :     handle _ =>
200 :     error (pos, pos + size s)
201 :     ("illegal decimal char spec: " ^ ns)
202 :     end
203 :     fun getS (pos, tok) =
204 :     (instring := false;
205 :     tok (implode (rev (!curstring)), !startpos, pos))
206 :     (* handling EOF *)
207 :     fun handleEof () = let
208 :     val pos = SM.lastChange sourceMap
209 :     in
210 :     if !depth > 0 then
211 :     error (pos, pos)
212 :     "unexpected end of input in comment"
213 :     else if !instring then
214 :     error (pos, pos)
215 :     "unexpected end of input in string"
216 :     else ();
217 :     pos
218 :     end
219 :     (* handling line breaks *)
220 :     fun newline pos = SM.newline sourceMap pos
221 :     (* handling #line directives *)
222 :     fun sync (p, t) = let
223 :     fun sep c = c = #"#" orelse Char.isSpace c
224 :     fun cvt s = getOpt (Int.fromString s, 0)
225 :     fun r (line, col, file) = SM.resynch sourceMap
226 :     (p, { fileName = file,
227 :     line = line, column = col })
228 :     in
229 :     case String.tokens sep t of
230 :     [_, line] =>
231 :     r (cvt line, NONE, NONE)
232 :     | [_, line, file] =>
233 :     r (cvt line, NONE, SOME file)
234 :     | [_, line, col, file] =>
235 :     r (cvt line, SOME (cvt col), SOME file)
236 :     | _ => error (p, p + size t)
237 :     "illegal #line directive"
238 :     end
239 : blume 294 in
240 : blume 345 { enterC = enterC,
241 :     leaveC = leaveC,
242 :     newS = newS,
243 :     addS = addS,
244 :     addSC = addSC,
245 :     addSN = addSN,
246 :     getS = getS,
247 :     handleEof = handleEof,
248 :     newline = newline,
249 : blume 397 obsolete = obsolete,
250 : blume 345 error = error,
251 :     sync = sync}
252 : blume 294 end
253 : blume 345
254 :     fun inputc k = TextIO.input stream
255 :    
256 :     val lexer = CMLex.makeLexer inputc lexarg
257 :     val tokenStream = LrParser.Stream.streamify lexer
258 :     val (parseResult, _) =
259 :     CMParse.parse (lookAhead, tokenStream,
260 :     fn (s,p1,p2) => error (p1, p2) s,
261 : blume 397 (group, context, obsolete, error,
262 : blume 367 doMember, curlib, ginfo))
263 : blume 294 in
264 : blume 345 if !(#anyErrors source) then NONE
265 :     else SOME parseResult
266 : blume 294 end
267 : blume 364 fun openIt () = TextIO.openIn (SrcPath.osstring group)
268 : blume 345 val pro =
269 : blume 364 SafeIO.perform { openIt = openIt,
270 : blume 345 closeIt = TextIO.closeIn,
271 :     work = work,
272 :     cleanup = fn () => () }
273 : blume 268 in
274 : blume 345 case pro of
275 :     NONE => NONE
276 :     | SOME pr =>
277 :     if stabthis then stabilize pr
278 :     else SOME pr
279 : blume 268 end
280 : blume 294 handle LrParser.ParseError => NONE
281 : blume 268 in
282 : blume 294 case findCycle (groupstack, []) of
283 :     h :: t => (report (h, t); NONE)
284 : blume 310 | [] =>
285 :     (case getStable group of
286 : blume 364 NONE =>
287 :     (Say.vsay ["[scanning ", SrcPath.descr group,
288 :     "]\n"];
289 :     normal_processing ())
290 :     | SOME g =>
291 :     (Say.vsay ["[library ", SrcPath.descr group,
292 :     " is stable]\n"];
293 :     SOME g))
294 : blume 268 end
295 :     in
296 : blume 367 case mparse (group, [], ref false, stabthis, NONE) of
297 : blume 303 NONE => NONE
298 : blume 387 | SOME g => let
299 :     val reach1 = Reachable.reachable g
300 :     val reach2 = Reachable.reachable' (pending ())
301 :     val reach = SrcPathSet.union (reach1, reach2)
302 :     in
303 :     SmlInfo.forgetAllBut reach;
304 :     SOME (g, ginfo)
305 :     end
306 : blume 274 end
307 : blume 268 end

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