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

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