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 313 - (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 310 GeneralParams.param -> bool option ->
11 :     AbsPath.t -> (CMSemant.group * GeneralParams.info) option
12 : blume 268 end
13 :    
14 : blume 310 functor ParseFn (structure Stabilize: STABILIZE) :> PARSE = struct
15 : blume 268
16 :     val lookAhead = 30
17 :    
18 :     structure S = GenericVC.Source
19 :     structure EM = GenericVC.ErrorMsg
20 :     structure SM = GenericVC.SourceMap
21 :    
22 :     structure CMLrVals = CMLrValsFun (structure Token = LrParser.Token)
23 :     structure CMLex = CMLexFun (structure Tokens = CMLrVals.Tokens)
24 :     structure CMParse =
25 :     JoinWithArg (structure ParserData = CMLrVals.ParserData
26 :     structure Lex = CMLex
27 :     structure LrParser = LrParser)
28 :    
29 : blume 310 fun parse param stabflag group = let
30 : blume 270
31 : blume 311 val stabthis = isSome stabflag
32 :     val staball = stabflag = SOME true
33 : blume 310
34 : blume 286 val groupreg = GroupReg.new ()
35 : blume 309 val errcons = EM.defaultConsumer ()
36 :     val ginfo = { param = param, groupreg = groupreg, errcons = errcons }
37 : blume 268
38 : blume 301 (* The "group cache" -- we store "group options"; having
39 :     * NONE registered for a group means that a previous attempt
40 :     * to parse it had failed. *)
41 :     val gc = ref (AbsPathMap.empty: CMSemant.group option AbsPathMap.map)
42 : blume 273
43 : blume 310 fun mparse (group, groupstack, pErrFlag, stabthis) =
44 : blume 294 case AbsPathMap.find (!gc, group) of
45 :     SOME g => g
46 :     | NONE => let
47 : blume 310 val g = parse' (group, groupstack, pErrFlag, stabthis)
48 : blume 294 in
49 :     gc := AbsPathMap.insert (!gc, group, g);
50 :     g
51 :     end
52 : blume 273
53 : blume 310 and parse' (group, groupstack, pErrFlag, stabthis) = let
54 : blume 286 (* checking for cycles among groups and printing them nicely *)
55 : blume 294 fun findCycle ([], _) = []
56 :     | findCycle ((h as (g, (s, p1, p2))) :: t, cyc) =
57 :     if AbsPath.compare (g, group) = EQUAL then rev (h :: cyc)
58 :     else findCycle (t, h :: cyc)
59 :     fun report ((g, (s, p1, p2)), hist) = let
60 :     fun pphist pps = let
61 :     fun loop (_, []) = ()
62 :     | loop (g0, (g, (s, p1, p2)) :: t) = let
63 :     val s = EM.matchErrorString s (p1, p2)
64 :     in
65 :     PrettyPrint.add_string pps s;
66 :     PrettyPrint.add_string pps ": importing ";
67 :     PrettyPrint.add_string pps (AbsPath.spec g0);
68 :     PrettyPrint.add_newline pps;
69 :     loop (g, t)
70 :     end
71 : blume 273 in
72 : blume 294 PrettyPrint.add_newline pps;
73 :     loop (g, hist)
74 : blume 273 end
75 :     in
76 : blume 294 EM.error s (p1, p2) EM.COMPLAIN
77 :     ("group hierarchy forms a cycle with " ^
78 :     AbsPath.spec group)
79 :     pphist
80 : blume 273 end
81 :    
82 : blume 310 fun getStable gpath = let
83 :     val loadStable =
84 :     Stabilize.loadStable (ginfo, getStable, pErrFlag)
85 :     in
86 :     case AbsPathMap.find (!gc, gpath) of
87 :     SOME (x as SOME _) => x
88 :     | SOME NONE => NONE
89 :     | NONE =>
90 :     (case loadStable gpath of
91 :     NONE => NONE
92 :     | x as SOME _ =>
93 : blume 311 (gc := AbsPathMap.insert (!gc, gpath, x);
94 :     x))
95 : blume 310 end
96 :    
97 :     fun stabilize g =
98 : blume 311 Stabilize.stabilize ginfo { group = g, anyerrors = pErrFlag }
99 : blume 310
100 : blume 294 (* normal processing -- used when there is no cycle to report *)
101 :     fun normal_processing () = let
102 :     val currentDir = AbsPath.dir group
103 :     val context = AbsPath.relativeContext (AbsPath.dir group)
104 :     val filename = AbsPath.name group
105 : blume 310 val _ = Say.vsay ["[scanning ", filename, "]\n"]
106 : blume 294 val stream = TextIO.openIn filename
107 :     val source = S.newSource (filename, 1, stream, false, errcons)
108 :     val sourceMap = #sourceMap source
109 :     val _ = GroupReg.register groupreg (group, source)
110 :    
111 : blume 297 (* We can hard-wire the source into this
112 :     * error function because the function is only for
113 :     * immediate use and doesn't get stored into persistent
114 :     * data structures. *)
115 :     fun error r m =
116 :     EM.error source r EM.COMPLAIN m EM.nullErrorBody
117 :    
118 : blume 294 (* recParse returns a group (not an option).
119 :     * This function is used to parse aliases and sub-groups.
120 :     * Errors are propagated by explicitly setting the
121 :     * "anyErrors" flag of the parent group. *)
122 :     fun recParse (p1, p2) p = let
123 :     val groupstack' = (group, (source, p1, p2)) :: groupstack
124 : blume 310 val myErrorFlag = #anyErrors source
125 : blume 286 in
126 : blume 310 case mparse (p, groupstack', myErrorFlag, staball) of
127 :     NONE => (myErrorFlag := true;
128 : blume 294 CMSemant.emptyGroup group)
129 :     | SOME res => res
130 : blume 286 end
131 : blume 294 handle exn as IO.Io _ =>
132 :     (error (p1, p2) (General.exnMessage exn);
133 :     CMSemant.emptyGroup group)
134 :    
135 : blume 297 fun doMember (p, p1, p2, c) =
136 : blume 299 CMSemant.member (ginfo, recParse (p1, p2))
137 : blume 297 { sourcepath = p, class = c,
138 :     group = (group, (p1, p2)) }
139 : blume 294
140 : blume 301 (* Build the argument for the lexer; the lexer's local
141 :     * state is encapsulated here to make sure the parser
142 :     * is re-entrant. *)
143 : blume 294 val lexarg = let
144 :     (* local state *)
145 :     val depth = ref 0
146 :     val curstring = ref []
147 :     val startpos = ref 0
148 :     val instring = ref false
149 :     (* handling comments *)
150 :     fun enterC () = depth := !depth + 1
151 :     fun leaveC () = let
152 :     val d = !depth - 1
153 :     in
154 :     depth := d;
155 :     d = 0
156 :     end
157 :     (* handling strings *)
158 :     fun newS pos =
159 :     (instring := true; curstring := []; startpos := pos)
160 :     fun addS c = curstring := c :: !curstring
161 :     fun addSC (s, offs) =
162 :     addS (chr (ord (String.sub (s, 2)) - offs))
163 :     fun addSN (s, pos) = let
164 :     val ns = substring (s, 1, 3)
165 :     val n = Int.fromString ns
166 :     in
167 :     addS (chr (valOf n))
168 :     handle _ =>
169 :     error (pos, pos + size s)
170 :     ("illegal decimal char spec: " ^ ns)
171 :     end
172 :     fun getS (pos, tok) =
173 :     (instring := false;
174 :     tok (implode (rev (!curstring)), !startpos, pos))
175 :     (* handling EOF *)
176 :     fun handleEof () = let
177 :     val pos = SM.lastChange sourceMap
178 :     in
179 :     if !depth > 0 then
180 :     error (pos, pos)
181 :     "unexpected end of input in comment"
182 :     else if !instring then
183 :     error (pos, pos)
184 :     "unexpected end of input in string"
185 :     else ();
186 :     pos
187 :     end
188 :     (* handling line breaks *)
189 :     fun newline pos = SM.newline sourceMap pos
190 : blume 313 (* handling #line directives *)
191 :     fun sync (p, t) = let
192 :     fun sep c = c = #"#" orelse Char.isSpace c
193 :     fun cvt s = getOpt (Int.fromString s, 0)
194 :     fun r (line, col, file) = SM.resynch sourceMap
195 :     (p, { fileName = file, line = line, column = col })
196 :     in
197 :     case String.tokens sep t of
198 :     [_, line] =>
199 :     r (cvt line, NONE, NONE)
200 :     | [_, line, file] =>
201 :     r (cvt line, NONE, SOME file)
202 :     | [_, line, col, file] =>
203 :     r (cvt line, SOME (cvt col), SOME file)
204 :     | _ => error (p, p + size t)
205 :     "illegal #line directive"
206 :     end
207 : blume 294 in
208 :     { enterC = enterC,
209 :     leaveC = leaveC,
210 :     newS = newS,
211 :     addS = addS,
212 :     addSC = addSC,
213 :     addSN = addSN,
214 :     getS = getS,
215 :     handleEof = handleEof,
216 :     newline = newline,
217 : blume 313 error = error,
218 :     sync = sync}
219 : blume 294 end
220 :    
221 :     fun inputc k = TextIO.input stream
222 :    
223 :     val lexer = CMLex.makeLexer inputc lexarg
224 :     val tokenStream = LrParser.Stream.streamify lexer
225 :     val (parseResult, _) =
226 :     CMParse.parse (lookAhead, tokenStream,
227 :     fn (s,p1,p2) => error (p1, p2) s,
228 : blume 297 (group, context, error, recParse,
229 : blume 299 doMember, ginfo))
230 : blume 268 in
231 : blume 294 TextIO.closeIn stream;
232 :     if !(#anyErrors source) then NONE
233 : blume 310 else if stabthis then stabilize parseResult
234 : blume 294 else SOME parseResult
235 : blume 268 end
236 : blume 294 handle LrParser.ParseError => NONE
237 : blume 268 in
238 : blume 294 case findCycle (groupstack, []) of
239 :     h :: t => (report (h, t); NONE)
240 : blume 310 | [] =>
241 :     (case getStable group of
242 :     NONE => normal_processing ()
243 :     | SOME g => SOME g)
244 : blume 268 end
245 :     in
246 : blume 310 case mparse (group, [], ref false, stabthis) of
247 : blume 303 NONE => NONE
248 :     | SOME g =>
249 :     if CheckSharing.check (g, ginfo) then
250 :     (SmlInfo.forgetAllBut (Reachable.reachable g);
251 :     SOME (g, ginfo))
252 :     else NONE
253 : blume 274 end
254 : blume 268 end

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