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/branches/rt-transition/cm/parse/parse.sml
ViewVC logotype

Annotation of /sml/branches/rt-transition/cm/parse/parse.sml

Parent Directory Parent Directory | Revision Log Revision Log


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

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