Annotation of /sml/trunk/src/cm/parse/parse.sml

Parent Directory | Revision Log

---

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

---

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