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 295 - (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 268 signature CMPARSE = sig
9 : blume 286 val parse : Primitive.configuration -> AbsPath.t -> CMSemant.group option
10 : blume 268 end
11 :    
12 :     structure CMParse :> CMPARSE = struct
13 :    
14 :     val lookAhead = 30
15 :    
16 :     structure S = GenericVC.Source
17 :     structure EM = GenericVC.ErrorMsg
18 :     structure SM = GenericVC.SourceMap
19 :     structure P = GenericVC.Control.Print
20 :    
21 :     structure CMLrVals = CMLrValsFun (structure Token = LrParser.Token)
22 :     structure CMLex = CMLexFun (structure Tokens = CMLrVals.Tokens)
23 :     structure CMParse =
24 :     JoinWithArg (structure ParserData = CMLrVals.ParserData
25 :     structure Lex = CMLex
26 :     structure LrParser = LrParser)
27 :    
28 : blume 281 (* The error function must look for the source using the GroupReg
29 :     * group register because the source must not be hard-wired into it
30 :     * (via closure creation). The reason for this is that the error
31 :     * function will get cached in SmlInfo.info but the source will change
32 :     * when one re-runs the analysis. *)
33 :    
34 : blume 286 fun parse primconf group = let
35 : blume 270
36 : blume 286 val groupreg = GroupReg.new ()
37 :     val fnpolicy = FilenamePolicy.default
38 :     val params = { groupreg = groupreg,
39 :     fnpolicy = fnpolicy,
40 : blume 295 primconf = primconf,
41 :     keep_going = false }
42 : blume 268
43 : blume 294 val gc = ref AbsPathMap.empty (* the "group cache" *)
44 : blume 273
45 : blume 294 fun mparse (group, groupstack) =
46 :     case AbsPathMap.find (!gc, group) of
47 :     SOME g => g
48 :     | NONE => let
49 :     val g = parse' (group, groupstack)
50 :     in
51 :     gc := AbsPathMap.insert (!gc, group, g);
52 :     g
53 :     end
54 : blume 273
55 : blume 294 and parse' (group, groupstack) = let
56 : blume 286 (* checking for cycles among groups and printing them nicely *)
57 : blume 294 fun findCycle ([], _) = []
58 :     | findCycle ((h as (g, (s, p1, p2))) :: t, cyc) =
59 :     if AbsPath.compare (g, group) = EQUAL then rev (h :: cyc)
60 :     else findCycle (t, h :: cyc)
61 :     fun report ((g, (s, p1, p2)), hist) = let
62 :     fun pphist pps = let
63 :     fun loop (_, []) = ()
64 :     | loop (g0, (g, (s, p1, p2)) :: t) = let
65 :     val s = EM.matchErrorString s (p1, p2)
66 :     in
67 :     PrettyPrint.add_string pps s;
68 :     PrettyPrint.add_string pps ": importing ";
69 :     PrettyPrint.add_string pps (AbsPath.spec g0);
70 :     PrettyPrint.add_newline pps;
71 :     loop (g, t)
72 :     end
73 : blume 273 in
74 : blume 294 PrettyPrint.add_newline pps;
75 :     loop (g, hist)
76 : blume 273 end
77 :     in
78 : blume 294 EM.error s (p1, p2) EM.COMPLAIN
79 :     ("group hierarchy forms a cycle with " ^
80 :     AbsPath.spec group)
81 :     pphist
82 : blume 273 end
83 :    
84 : blume 294 (* normal processing -- used when there is no cycle to report *)
85 :     fun normal_processing () = let
86 :     val currentDir = AbsPath.dir group
87 :     val context = AbsPath.relativeContext (AbsPath.dir group)
88 :     val filename = AbsPath.name group
89 :     val _ = Say.vsay (concat ["[scanning ", filename, "]\n"])
90 :     val stream = TextIO.openIn filename
91 :     val errcons = { linewidth = !P.linewidth,
92 :     flush = P.flush,
93 :     consumer = P.say }
94 :     val source = S.newSource (filename, 1, stream, false, errcons)
95 :     val sourceMap = #sourceMap source
96 :     val _ = GroupReg.register groupreg (group, source)
97 :     fun error' region sev m b = let
98 :     val src = GroupReg.lookup groupreg group
99 : blume 286 in
100 : blume 294 EM.error src region sev m b
101 : blume 286 end
102 : blume 294 fun error region m =
103 :     error' region EM.COMPLAIN m EM.nullErrorBody
104 :    
105 :     (* recParse returns a group (not an option).
106 :     * This function is used to parse aliases and sub-groups.
107 :     * Errors are propagated by explicitly setting the
108 :     * "anyErrors" flag of the parent group. *)
109 :     fun recParse (p1, p2) p = let
110 :     val groupstack' = (group, (source, p1, p2)) :: groupstack
111 : blume 286 in
112 : blume 294 case mparse (p, groupstack') of
113 :     NONE => (#anyErrors source := true;
114 :     CMSemant.emptyGroup group)
115 :     | SOME res => res
116 : blume 286 end
117 : blume 294 handle exn as IO.Io _ =>
118 :     (error (p1, p2) (General.exnMessage exn);
119 :     CMSemant.emptyGroup group)
120 :    
121 :     fun doMember (p, p1, p2, c, e) =
122 :     CMSemant.member (params, recParse (p1, p2))
123 :     { sourcepath = p, group = group,
124 :     class = c, error = e }
125 :    
126 :     val lexarg = let
127 :     (* local state *)
128 :     val depth = ref 0
129 :     val curstring = ref []
130 :     val startpos = ref 0
131 :     val instring = ref false
132 :     (* handling comments *)
133 :     fun enterC () = depth := !depth + 1
134 :     fun leaveC () = let
135 :     val d = !depth - 1
136 :     in
137 :     depth := d;
138 :     d = 0
139 :     end
140 :     (* handling strings *)
141 :     fun newS pos =
142 :     (instring := true; curstring := []; startpos := pos)
143 :     fun addS c = curstring := c :: !curstring
144 :     fun addSC (s, offs) =
145 :     addS (chr (ord (String.sub (s, 2)) - offs))
146 :     fun addSN (s, pos) = let
147 :     val ns = substring (s, 1, 3)
148 :     val n = Int.fromString ns
149 :     in
150 :     addS (chr (valOf n))
151 :     handle _ =>
152 :     error (pos, pos + size s)
153 :     ("illegal decimal char spec: " ^ ns)
154 :     end
155 :     fun getS (pos, tok) =
156 :     (instring := false;
157 :     tok (implode (rev (!curstring)), !startpos, pos))
158 :     (* handling EOF *)
159 :     fun handleEof () = let
160 :     val pos = SM.lastChange sourceMap
161 :     in
162 :     if !depth > 0 then
163 :     error (pos, pos)
164 :     "unexpected end of input in comment"
165 :     else if !instring then
166 :     error (pos, pos)
167 :     "unexpected end of input in string"
168 :     else ();
169 :     pos
170 :     end
171 :     (* handling line breaks *)
172 :     fun newline pos = SM.newline sourceMap pos
173 :     in
174 :     { enterC = enterC,
175 :     leaveC = leaveC,
176 :     newS = newS,
177 :     addS = addS,
178 :     addSC = addSC,
179 :     addSN = addSN,
180 :     getS = getS,
181 :     handleEof = handleEof,
182 :     newline = newline,
183 :     error = error }
184 :     end
185 :    
186 :     fun inputc k = TextIO.input stream
187 :    
188 :     val lexer = CMLex.makeLexer inputc lexarg
189 :     val tokenStream = LrParser.Stream.streamify lexer
190 :     val (parseResult, _) =
191 :     CMParse.parse (lookAhead, tokenStream,
192 :     fn (s,p1,p2) => error (p1, p2) s,
193 :     (group, context, error', error, recParse,
194 :     doMember))
195 : blume 268 in
196 : blume 294 TextIO.closeIn stream;
197 :     if !(#anyErrors source) then NONE
198 :     else SOME parseResult
199 : blume 268 end
200 : blume 294 handle LrParser.ParseError => NONE
201 : blume 268 in
202 : blume 294 case findCycle (groupstack, []) of
203 :     h :: t => (report (h, t); NONE)
204 :     | [] => normal_processing ()
205 : blume 268 end
206 : blume 294
207 : blume 268 in
208 : blume 294 mparse (group, [])
209 : blume 274 end
210 : blume 268 end

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