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 283 - (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 :     val parse : AbsPath.t -> CMSemant.group option
10 :     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 273 fun parse' (group, groupstack) = let
35 : blume 270
36 :     val currentDir = AbsPath.dir group
37 :     val context = AbsPath.relativeContext (AbsPath.dir group)
38 :     val filename = AbsPath.name group
39 : blume 275 val _ = Say.vsay (concat ["[scanning ", filename, "]\n"])
40 : blume 268 val stream = TextIO.openIn filename
41 :     val errcons =
42 :     { linewidth = !P.linewidth, flush = P.flush, consumer = P.say }
43 :     val source = S.newSource (filename, 1, stream, false, errcons)
44 :     val sourceMap = #sourceMap source
45 : blume 281 val _ = GroupReg.register (group, source)
46 :     fun error' region m b = let
47 :     val src = GroupReg.lookup group
48 :     in
49 :     EM.error src region EM.COMPLAIN m b
50 :     end
51 : blume 277 fun error region m = error' region m EM.nullErrorBody
52 : blume 268
53 : blume 273 (* recParse returns a group (not an option)
54 :     * and re-raises LrParser.ParseError.
55 :     * This exception will be handled by the surrounding
56 :     * call to parse.
57 :     * This function is used to parse aliases and sub-groups. *)
58 :     fun recParse (p1, p2) p =
59 : blume 282 (case parse' (p, (group, (source, p1, p2)) :: groupstack) of
60 : blume 283 NONE => (#anyErrors source := true; CMSemant.emptyGroup group)
61 : blume 282 | SOME res => res)
62 :     handle exn as IO.Io _ => (error (p1, p2) (General.exnMessage exn);
63 : blume 283 CMSemant.emptyGroup group)
64 : blume 273
65 : blume 275 fun doMember (p, p1, p2, c, e) =
66 : blume 277 CMSemant.member (recParse (p1, p2))
67 :     { sourcepath = p,
68 :     group = group,
69 :     class = c,
70 :     error = e }
71 : blume 273
72 :     (* checking for cycles among groups and printing them nicely *)
73 :     val _ = let
74 :     fun findCycle ([], _) = []
75 :     | findCycle ((h as (g, (s, p1, p2))) :: t, cyc) =
76 :     if AbsPath.compare (g, group) = EQUAL then rev (h :: cyc)
77 :     else findCycle (t, h :: cyc)
78 :     fun report ((g, (s, p1, p2)), hist) = let
79 :     fun pphist pps = let
80 :     fun loop (_, []) = ()
81 :     | loop (g0, (g, (s, p1, p2)) :: t) = let
82 :     val s = EM.matchErrorString s (p1, p2)
83 :     in
84 :     PrettyPrint.add_string pps s;
85 : blume 282 PrettyPrint.add_string pps ": importing ";
86 : blume 273 PrettyPrint.add_string pps (AbsPath.spec g0);
87 :     PrettyPrint.add_newline pps;
88 :     loop (g, t)
89 :     end
90 :     in
91 :     PrettyPrint.add_newline pps;
92 : blume 274 loop (g, hist)
93 : blume 273 end
94 :     in
95 :     EM.error s (p1, p2) EM.COMPLAIN
96 :     ("group hierarchy forms a cycle with " ^ AbsPath.spec group)
97 : blume 274 pphist;
98 :     raise LrParser.ParseError
99 : blume 273 end
100 :     in
101 :     case findCycle (groupstack, []) of
102 :     [] => ()
103 :     | h :: t => report (h, t)
104 :     end
105 :    
106 : blume 268 val lexarg = let
107 :     (* local state *)
108 :     val depth = ref 0
109 :     val curstring = ref []
110 :     val startpos = ref 0
111 :     val instring = ref NONE
112 :     (* handling comments *)
113 :     fun enterC () = depth := !depth + 1
114 :     fun leaveC () = let val d = !depth - 1 in depth := d; d = 0 end
115 :     (* handling strings *)
116 :     fun newS (pos, kind) =
117 :     (instring := SOME kind;
118 :     curstring := [];
119 :     startpos := pos)
120 :     fun addS c = curstring := c :: !curstring
121 :     fun addSC (s, offs) = addS (chr (ord (String.sub (s, 2)) - offs))
122 :     fun addSN (s, pos) = let
123 :     val ns = substring (s, 1, 3)
124 :     val n = Int.fromString ns
125 :     in
126 :     addS (chr (valOf n))
127 :     handle _ =>
128 :     error (pos, pos + size s)
129 :     ("illegal decimal char spec: " ^ ns)
130 :     end
131 :     fun getS (pos, tok) =
132 :     (instring := NONE;
133 :     tok (implode (rev (!curstring)), !startpos, pos))
134 :     (* handling EOF *)
135 :     fun handleEof () = let
136 :     val pos = SM.lastChange sourceMap
137 :     in
138 :     if !depth > 0 then
139 :     error (pos, pos) "unexpected end of input in comment"
140 :     else if isSome (!instring) then
141 :     error (pos, pos)
142 :     ("unexpected end of input in " ^ valOf (!instring))
143 :     else ();
144 :     pos
145 :     end
146 :     (* handling line breaks *)
147 :     fun newline pos = SM.newline sourceMap pos
148 :     in
149 :     { enterC = enterC,
150 :     leaveC = leaveC,
151 :     newS = newS,
152 :     addS = addS,
153 :     addSC = addSC,
154 :     addSN = addSN,
155 :     getS = getS,
156 :     handleEof = handleEof,
157 :     newline = newline,
158 :     error = error }
159 :     end
160 :    
161 :     fun inputc k =
162 :     TextIO.input stream
163 :    
164 :     val lexer = CMLex.makeLexer inputc lexarg
165 :     val tokenStream = LrParser.Stream.streamify lexer
166 :     val (parseResult, _) =
167 :     CMParse.parse (lookAhead, tokenStream,
168 :     fn (s,p1,p2) => error (p1, p2) s,
169 : blume 283 (group, context, error', error, recParse, doMember))
170 : blume 268 in
171 :     TextIO.closeIn stream;
172 : blume 273 if !(#anyErrors source) then NONE
173 :     else SOME parseResult
174 : blume 274 end
175 :     handle LrParser.ParseError => NONE
176 : blume 273
177 : blume 281 fun parse group = (GroupReg.clear (); parse' (group, []))
178 : blume 268 end

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