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 735 - (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 666 val parse : { load_plugin: SrcPath.dir -> string -> bool,
10 : blume 537 gr: GroupReg.groupreg,
11 :     param: GeneralParams.param,
12 :     stabflag: bool option,
13 : blume 666 group: SrcPath.file,
14 : blume 537 init_group: CMSemant.group,
15 :     paranoid: bool }
16 :     -> (CMSemant.group * GeneralParams.info) option
17 : blume 367 val reset : unit -> unit
18 : blume 666 val listLibs : unit -> SrcPath.file list
19 : blume 505 val dropPickles : unit -> unit
20 : blume 666 val dismissLib : SrcPath.file -> unit
21 : blume 268 end
22 :    
23 : blume 362 functor ParseFn (val pending : unit -> DependencyGraph.impexp SymbolMap.map
24 : blume 537 val evictStale : unit -> unit
25 : blume 588 structure StabModmap : STAB_MODMAP
26 :     structure Stabilize : STABILIZE) :> PARSE = struct
27 : blume 268
28 : blume 569 structure VerifyStable = VerStabFn (structure Stabilize = Stabilize)
29 :    
30 : blume 268 val lookAhead = 30
31 :    
32 :     structure S = GenericVC.Source
33 :     structure EM = GenericVC.ErrorMsg
34 :     structure SM = GenericVC.SourceMap
35 : blume 348 structure GG = GroupGraph
36 : blume 569 structure DG = DependencyGraph
37 : blume 268
38 :     structure CMLrVals = CMLrValsFun (structure Token = LrParser.Token)
39 :     structure CMLex = CMLexFun (structure Tokens = CMLrVals.Tokens)
40 :     structure CMParse =
41 :     JoinWithArg (structure ParserData = CMLrVals.ParserData
42 :     structure Lex = CMLex
43 :     structure LrParser = LrParser)
44 :    
45 : blume 367 (* the "stable group cache" *)
46 :     val sgc = ref (SrcPathMap.empty: CMSemant.group SrcPathMap.map)
47 :     fun reset () = sgc := SrcPathMap.empty
48 :    
49 : blume 569 fun majorGC () = SMLofNJ.Internals.GC.doGC 7
50 :    
51 : blume 537 fun cachedStable (p, ig as GG.GROUP { grouppath, ... }) =
52 :     if SrcPath.compare (p, grouppath) = EQUAL then SOME ig
53 :     else SrcPathMap.find (!sgc, p)
54 : blume 587 | cachedStable (_, GG.ERRORGROUP) = NONE
55 : blume 514
56 : blume 573 (* When an entry A vanishes from the stable cache (this only happens in
57 :     * paranoid mode), then all the other ones that refer to A must
58 :     * vasish, too. They might still be valid themselves, but if they
59 :     * had been unpickled before A became invalid they will point to
60 :     * invalid data. By removing them from the cache we force them to
61 :     * be re-read and re-unpickled. This restores sanity. *)
62 : blume 587 fun delCachedStable (p, GG.GROUP { grouppath = igp, ... }) =
63 :     let val changed = ref true
64 :     fun canStay GG.ERRORGROUP = true (* doesn't matter *)
65 :     | canStay (GG.GROUP { sublibs, ... }) = let
66 : blume 666 fun goodSublib (p, gth, _) =
67 : blume 652 case gth () of
68 :     GG.GROUP { kind = GG.LIB { kind = GG.STABLE _,
69 :     ... }, ... } =>
70 :     SrcPath.compare (p, igp) = EQUAL orelse
71 :     SrcPathMap.inDomain (!sgc, p)
72 :     | _ => true
73 : blume 632 val cs = List.all goodSublib sublibs
74 : blume 587 in
75 :     if cs then () else changed := true;
76 :     cs
77 :     end
78 : blume 573 in
79 : blume 587 (sgc := #1 (SrcPathMap.remove (!sgc, p)))
80 :     handle LibBase.NotFound => ();
81 :     while !changed do
82 :     (changed := false; sgc := SrcPathMap.filter canStay (!sgc))
83 : blume 573 end
84 : blume 587 | delCachedStable (_, GG.ERRORGROUP) = ()
85 : blume 573
86 : blume 479 fun listLibs () = map #1 (SrcPathMap.listItemsi (!sgc))
87 : blume 404
88 : blume 505 fun dropPickles () = let
89 : blume 632 fun drop (GG.GROUP { kind = GG.LIB { kind = GG.STABLE dropper,
90 :     ... }, ... }) = dropper ()
91 : blume 505 | drop _ = ()
92 :     in
93 : blume 507 SrcPathMap.app drop (!sgc)
94 : blume 505 end
95 :    
96 : blume 404 fun dismissLib l =
97 : blume 588 (StabModmap.reset ();
98 :     sgc := #1 (SrcPathMap.remove (!sgc, l)))
99 : blume 404 handle LibBase.NotFound => ()
100 :    
101 : blume 537 fun parse args = let
102 : blume 569 val { load_plugin, gr, param, stabflag, group,
103 :     init_group, paranoid } = args
104 : blume 270
105 : blume 587 val { grouppath = init_gname, ... } =
106 :     case init_group of
107 :     GG.GROUP x => x
108 :     | GG.ERRORGROUP =>
109 :     EM.impossible "parse.sml: parse: bad init group"
110 : blume 537
111 : blume 311 val stabthis = isSome stabflag
112 :     val staball = stabflag = SOME true
113 : blume 310
114 : blume 537 val groupreg = gr
115 : blume 309 val errcons = EM.defaultConsumer ()
116 : blume 692 val youngest = ref TStamp.ancient
117 :     val ginfo0 = { param = param, groupreg = groupreg,
118 :     errcons = errcons, youngest = youngest }
119 : blume 587 val keep_going = #keep_going param
120 : blume 268
121 : blume 301 (* The "group cache" -- we store "group options"; having
122 :     * NONE registered for a group means that a previous attempt
123 : blume 537 * to parse it had failed.
124 :     * This registry is primed with the "init" group because it is
125 :     * "special" and cannot be parsed directly. *)
126 :     val gc = ref (SrcPathMap.singleton (init_gname, SOME init_group))
127 : blume 273
128 : blume 569 val em = ref StableMap.empty
129 :    
130 : blume 587 fun update_em (GG.GROUP ns_g, GG.GROUP s_g) =
131 :     let val s_e = #exports s_g
132 : blume 652 fun add (sy, (snth, _, _)) =
133 :     case snth () of
134 :     (_ , DG.SB_SNODE (DG.SNODE sn)) =>
135 :     (case SymbolMap.find (s_e, sy) of
136 :     NONE => ()
137 :     | SOME (bnth, _, _) =>
138 :     (case bnth () of
139 :     (_, DG.SB_BNODE (DG.BNODE bn, _)) =>
140 :     em := StableMap.insert (!em, #bininfo bn,
141 :     #smlinfo sn)
142 :     | _ => ()))
143 :     | _ => ()
144 : blume 587 in
145 :     SymbolMap.appi add (#exports ns_g)
146 :     end
147 :     | update_em _ = ()
148 : blume 569
149 :     fun registerNewStable (p, g) =
150 :     (sgc := SrcPathMap.insert (!sgc, p, g);
151 :     SrcPathSet.app (SmlInfo.cleanGroup true) (Reachable.groupsOf g);
152 :     evictStale ();
153 :     (gc := #1 (SrcPathMap.remove (!gc, p));
154 :     (* ... and for good measure, do a major GC... *)
155 :     majorGC ())
156 :     handle LibBase.NotFound => ())
157 :    
158 : blume 435 fun hasCycle (group, groupstack) = let
159 : blume 286 (* checking for cycles among groups and printing them nicely *)
160 : blume 294 fun findCycle ([], _) = []
161 :     | findCycle ((h as (g, (s, p1, p2))) :: t, cyc) =
162 : blume 354 if SrcPath.compare (g, group) = EQUAL then rev (h :: cyc)
163 : blume 294 else findCycle (t, h :: cyc)
164 :     fun report ((g, (s, p1, p2)), hist) = let
165 :     fun pphist pps = let
166 :     fun loop (_, []) = ()
167 :     | loop (g0, (g, (s, p1, p2)) :: t) = let
168 :     val s = EM.matchErrorString s (p1, p2)
169 :     in
170 : blume 435 PrettyPrint.add_newline pps;
171 : blume 294 PrettyPrint.add_string pps s;
172 :     PrettyPrint.add_string pps ": importing ";
173 : blume 666 PrettyPrint.add_string pps (SrcPath.descr g0);
174 : blume 294 loop (g, t)
175 :     end
176 : blume 273 in
177 : blume 294 loop (g, hist)
178 : blume 273 end
179 :     in
180 : blume 294 EM.error s (p1, p2) EM.COMPLAIN
181 :     ("group hierarchy forms a cycle with " ^
182 : blume 666 SrcPath.descr group)
183 : blume 294 pphist
184 : blume 273 end
185 : blume 435 in
186 :     case findCycle (groupstack, []) of
187 :     h :: t => (report (h, t); true)
188 :     | [] => false
189 :     end
190 : blume 273
191 : blume 666 fun mparse args = let
192 :     val (group, vers, groupstack, pErrFlag, stabthis, curlib,
193 :     ginfo, rb) = args
194 :     fun getStable stablestack (ginfo, gpath, vers, rb) = let
195 : blume 435 (* This is a separate "findCycle" routine that detects
196 :     * cycles among stable libraries. These cycles should
197 :     * never occur unless someone purposefully renames
198 :     * stable library files in a bad way. *)
199 :     fun findCycle ([], _) = NONE
200 :     | findCycle (h :: t, cyc) =
201 :     if SrcPath.compare (h, gpath) = EQUAL then SOME (h :: cyc)
202 :     else findCycle (t, h :: cyc)
203 :     fun report cyc = let
204 :     fun pphist pps = let
205 :     fun loop [] = ()
206 :     | loop (h :: t) =
207 :     (PrettyPrint.add_newline pps;
208 :     PrettyPrint.add_string pps (SrcPath.descr h);
209 :     loop t)
210 :     in
211 :     loop (rev cyc)
212 :     end
213 :     in
214 :     EM.errorNoFile (errcons, pErrFlag) SM.nullRegion
215 :     EM.COMPLAIN
216 :     ("stable libraries form a cycle with " ^
217 :     SrcPath.descr gpath)
218 :     pphist
219 :     end
220 :     fun load () = let
221 : blume 666 val go = Stabilize.loadStable
222 : blume 435 { getGroup = getStable (gpath :: stablestack),
223 :     anyerrors = pErrFlag }
224 : blume 666 (ginfo, gpath, vers, rb)
225 : blume 435 in
226 :     case go of
227 :     NONE => NONE
228 :     | SOME g =>
229 : blume 514 (registerNewStable (gpath, g);
230 : blume 435 Say.vsay ["[library ", SrcPath.descr gpath,
231 :     " is stable]\n"];
232 :     SOME g)
233 :     end
234 : blume 310 in
235 : blume 435 case findCycle (stablestack, []) of
236 : blume 537 NONE => (case cachedStable (gpath, init_group) of
237 : blume 435 SOME g => SOME g
238 :     | NONE => load ())
239 :     | SOME cyc => (report cyc; NONE)
240 : blume 310 end
241 : blume 537
242 :     fun stabilize NONE = NONE
243 :     | stabilize (SOME g) =
244 :     (case g of
245 : blume 587 GG.ERRORGROUP => NONE
246 :     | GG.GROUP { kind = GG.LIB _, ... } => let
247 : blume 537 val go = Stabilize.stabilize ginfo
248 :     { group = g, anyerrors = pErrFlag }
249 :     in
250 :     case go of
251 :     NONE => NONE
252 : blume 569 | SOME g' =>
253 :     (registerNewStable (group, g'); SOME g')
254 : blume 537 end
255 :     | _ => SOME g)
256 : blume 435 in
257 : blume 537 case SrcPathMap.find (!gc, group) of
258 :     SOME gopt => gopt
259 :     | NONE => let
260 : blume 666 fun try_s () = getStable [] (ginfo, group, vers, rb)
261 :     fun try_n () =
262 :     parse' (group, groupstack, pErrFlag, curlib, ginfo, rb)
263 : blume 537 fun reg gopt =
264 :     (gc := SrcPathMap.insert (!gc, group, gopt); gopt)
265 :     fun proc_n gopt =
266 :     reg (if stabthis then stabilize gopt
267 :     else (SmlInfo.cleanGroup false group; gopt))
268 :     in
269 :     if paranoid then
270 :     case try_n () of
271 :     NONE => reg NONE
272 : blume 569 | SOME g => let
273 :     val gopt' =
274 :     if VerifyStable.verify ginfo (!em) g then
275 :     reg (case try_s () of
276 :     NONE => SOME g
277 :     | SOME g' => SOME g')
278 : blume 573 else (delCachedStable (group, init_group);
279 :     proc_n (SOME g))
280 : blume 569 in
281 :     case gopt' of
282 :     NONE => NONE
283 :     | SOME g' => (update_em (g, g'); SOME g')
284 :     end
285 : blume 537 else case try_s () of
286 :     SOME g => reg (SOME g)
287 :     | NONE => proc_n (try_n ())
288 :     end
289 : blume 435 end
290 : blume 310
291 : blume 537 (* Parse' is used when we are sure that we don't want to load
292 :     * a stable library. *)
293 : blume 666 and parse' (group, groupstack, pErrFlag, curlib, ginfo, rb) = let
294 : blume 435
295 : blume 666 val ginfo = GeneralParams.bind ginfo rb
296 :    
297 : blume 294 (* normal processing -- used when there is no cycle to report *)
298 :     fun normal_processing () = let
299 : blume 435 val _ = Say.vsay ["[scanning ", SrcPath.descr group, "]\n"]
300 :    
301 : blume 666 val context = SrcPath.dir group
302 : blume 735 val local_registry = CMSemant.newToolRegistry ()
303 : blume 294
304 : blume 345 fun work stream = let
305 :     val source =
306 : blume 354 S.newSource (SrcPath.osstring group,
307 :     1, stream, false, errcons)
308 : blume 345 val sourceMap = #sourceMap source
309 :     val _ = GroupReg.register groupreg (group, source)
310 : blume 297
311 : blume 345 (* We can hard-wire the source into this
312 :     * error function because the function is only for
313 :     * immediate use and doesn't get stored into persistent
314 :     * data structures. *)
315 :     fun error r m =
316 :     EM.error source r EM.COMPLAIN m EM.nullErrorBody
317 : blume 397 fun obsolete r =
318 : blume 433 if #get StdConfig.warn_obsolete () then
319 : blume 397 EM.error source r EM.WARN
320 :     "old-style operator (obsolete)" EM.nullErrorBody
321 :     else ()
322 : blume 294
323 : blume 345 (* recParse returns a group (not an option).
324 : blume 380 * This function is used to parse sub-groups.
325 : blume 345 * Errors are propagated by explicitly setting the
326 :     * "anyErrors" flag of the parent group. *)
327 : blume 666 fun recParse (p1, p2) curlib (p, v, rb) = let
328 : blume 367 val gs' = (group, (source, p1, p2)) :: groupstack
329 : blume 587 (* my error flag *)
330 :     val mef = #anyErrors source
331 : blume 294 in
332 : blume 587 (* unless we are in keep-going mode we do no further
333 :     * recursive traversals once there was an error on
334 :     * this group. *)
335 :     if !mef andalso not keep_going then GG.ERRORGROUP
336 : blume 666 else case mparse (p, v, gs', mef, staball,
337 :     curlib, ginfo, rb) of
338 : blume 587 NONE => (mef := true; GG.ERRORGROUP)
339 :     | SOME res => res
340 : blume 294 end
341 : blume 345 handle exn as IO.Io _ =>
342 :     (error (p1, p2) (General.exnMessage exn);
343 : blume 587 GG.ERRORGROUP)
344 : blume 345
345 : blume 587 fun doMember ({ name, mkpath }, p1, p2, c, oto) =
346 : blume 632 CMSemant.member { gp = ginfo,
347 :     rparse = recParse (p1, p2),
348 :     load_plugin = load_plugin }
349 :     { name = name, mkpath = mkpath,
350 :     class = c, tooloptions = oto,
351 :     group = (group, (p1, p2)),
352 : blume 735 local_registry = local_registry,
353 : blume 632 context = context }
354 : blume 345
355 :     (* Build the argument for the lexer; the lexer's local
356 :     * state is encapsulated here to make sure the parser
357 :     * is re-entrant. *)
358 :     val lexarg = let
359 :     (* local state *)
360 :     val depth = ref 0
361 :     val curstring = ref []
362 :     val startpos = ref 0
363 :     val instring = ref false
364 :     (* handling comments *)
365 :     fun enterC () = depth := !depth + 1
366 :     fun leaveC () = let
367 :     val d = !depth - 1
368 :     in
369 :     depth := d;
370 :     d = 0
371 :     end
372 :     (* handling strings *)
373 :     fun newS pos =
374 :     (instring := true;
375 :     curstring := [];
376 :     startpos := pos)
377 :     fun addS c = curstring := c :: !curstring
378 :     fun addSC (s, offs) =
379 :     addS (chr (ord (String.sub (s, 2)) - offs))
380 :     fun addSN (s, pos) = let
381 :     val ns = substring (s, 1, 3)
382 :     val n = Int.fromString ns
383 :     in
384 :     addS (chr (valOf n))
385 :     handle _ =>
386 :     error (pos, pos + size s)
387 :     ("illegal decimal char spec: " ^ ns)
388 :     end
389 :     fun getS (pos, tok) =
390 :     (instring := false;
391 :     tok (implode (rev (!curstring)), !startpos, pos))
392 :     (* handling EOF *)
393 :     fun handleEof () = let
394 :     val pos = SM.lastChange sourceMap
395 :     in
396 :     if !depth > 0 then
397 :     error (pos, pos)
398 :     "unexpected end of input in comment"
399 :     else if !instring then
400 :     error (pos, pos)
401 :     "unexpected end of input in string"
402 :     else ();
403 :     pos
404 :     end
405 :     (* handling line breaks *)
406 :     fun newline pos = SM.newline sourceMap pos
407 :     (* handling #line directives *)
408 :     fun sync (p, t) = let
409 :     fun sep c = c = #"#" orelse Char.isSpace c
410 :     fun cvt s = getOpt (Int.fromString s, 0)
411 :     fun r (line, col, file) = SM.resynch sourceMap
412 :     (p, { fileName = file,
413 :     line = line, column = col })
414 :     in
415 :     case String.tokens sep t of
416 :     [_, line] =>
417 :     r (cvt line, NONE, NONE)
418 :     | [_, line, file] =>
419 :     r (cvt line, NONE, SOME file)
420 :     | [_, line, col, file] =>
421 :     r (cvt line, SOME (cvt col), SOME file)
422 :     | _ => error (p, p + size t)
423 :     "illegal #line directive"
424 :     end
425 : blume 294 in
426 : blume 345 { enterC = enterC,
427 :     leaveC = leaveC,
428 :     newS = newS,
429 :     addS = addS,
430 :     addSC = addSC,
431 :     addSN = addSN,
432 :     getS = getS,
433 :     handleEof = handleEof,
434 :     newline = newline,
435 : blume 397 obsolete = obsolete,
436 : blume 345 error = error,
437 :     sync = sync}
438 : blume 294 end
439 : blume 345
440 :     fun inputc k = TextIO.input stream
441 :    
442 : blume 595 val tokenStream = CMParse.makeLexer inputc lexarg
443 : blume 345 val (parseResult, _) =
444 :     CMParse.parse (lookAhead, tokenStream,
445 :     fn (s,p1,p2) => error (p1, p2) s,
446 : blume 397 (group, context, obsolete, error,
447 : blume 537 doMember, curlib, ginfo, init_group))
448 : blume 294 in
449 : blume 345 if !(#anyErrors source) then NONE
450 :     else SOME parseResult
451 : blume 294 end
452 : blume 364 fun openIt () = TextIO.openIn (SrcPath.osstring group)
453 : blume 268 in
454 : blume 537 SafeIO.perform { openIt = openIt,
455 :     closeIt = TextIO.closeIn,
456 :     work = work,
457 :     cleanup = fn _ => () }
458 : blume 268 end
459 : blume 294 handle LrParser.ParseError => NONE
460 : blume 268 in
461 : blume 435 if hasCycle (group, groupstack) then NONE
462 :     else normal_processing ()
463 : blume 268 end
464 :     in
465 : blume 487 SmlInfo.newGeneration ();
466 : blume 666 case mparse (group, NONE, [], ref false, stabthis, NONE, ginfo0, []) of
467 : blume 303 NONE => NONE
468 : blume 666 | SOME g => SOME (g, ginfo0)
469 : blume 274 end
470 : blume 268 end

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