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

Parent Directory | Revision Log | Patch

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

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

Legend: Removed from v.282   changed lines   Added in v.493

---

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