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

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