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

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