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

Parent Directory | Revision Log

---

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

---

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