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

Parent Directory | Revision Log

---

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

---

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