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

Parent Directory | Revision Log | Patch

	revision 313, Thu Jun 3 09:26:34 1999 UTC	revision 493, Mon Nov 29 07:13:22 1999 UTC
#	Line 7	Line 7
7	*)	*)
8	signature PARSE = sig	signature PARSE = sig
9	val parse :	val parse :
10		GroupReg.groupreg option ->
11	GeneralParams.param -> bool option ->	GeneralParams.param -> bool option ->
12	AbsPath.t -> (CMSemant.group * GeneralParams.info) option	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	functor ParseFn (structure Stabilize: STABILIZE) :> PARSE = 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 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 26	Line 32
32	structure Lex = CMLex	structure Lex = CMLex
33	structure LrParser = LrParser)	structure LrParser = LrParser)
34
35	fun parse param stabflag group = let	(* the "stable group cache" *)
36		val sgc = ref (SrcPathMap.empty: CMSemant.group SrcPathMap.map)
37		fun reset () = sgc := SrcPathMap.empty
38
39		fun listLibs () = map #1 (SrcPathMap.listItemsi (!sgc))
40
41		fun dismissLib l =
42		(sgc := #1 (SrcPathMap.remove (!sgc, l)))
43		handle LibBase.NotFound => ()
44
45		fun parse gropt param stabflag group = let
46
47	val stabthis = isSome stabflag	val stabthis = isSome stabflag
48	val staball = stabflag = SOME true	val staball = stabflag = SOME true
49
50	val groupreg = GroupReg.new ()	val groupreg =
51		case gropt of
52		SOME r => r
53		| NONE => GroupReg.new ()
54	val errcons = EM.defaultConsumer ()	val errcons = EM.defaultConsumer ()
55	val ginfo = { param = param, groupreg = groupreg, errcons = errcons }	val ginfo = { param = param, groupreg = groupreg, errcons = errcons }
56
57	(* The "group cache" -- we store "group options";  having	(* The "group cache" -- we store "group options";  having
58	* NONE registered for a group means that a previous attempt	* NONE registered for a group means that a previous attempt
59	* to parse it had failed. *)	* to parse it had failed. *)
60	val gc = ref (AbsPathMap.empty: CMSemant.group option AbsPathMap.map)	val gc = ref (SrcPathMap.empty: CMSemant.group option SrcPathMap.map)
61
62	fun mparse (group, groupstack, pErrFlag, stabthis) =	fun hasCycle (group, groupstack) = let
	case AbsPathMap.find (!gc, group) of
	SOME g => g
	| NONE => let
	val g = parse' (group, groupstack, pErrFlag, stabthis)
	in
	gc := AbsPathMap.insert (!gc, group, g);
	g
	end
	and parse' (group, groupstack, pErrFlag, stabthis) = let
63	(* checking for cycles among groups and printing them nicely *)	(* checking for cycles among groups and printing them nicely *)
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 62	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 " ^	("group hierarchy forms a cycle with " ^
86	AbsPath.spec group)	SrcPath.specOf group)
87	pphist	pphist
88	end	end
89		in
90		case findCycle (groupstack, []) of
91		h :: t => (report (h, t); true)
92		| [] => false
93		end
94
95	fun getStable gpath = let	fun mparse (group, groupstack, pErrFlag, stabthis, curlib) = let
96	val loadStable =	fun getStable stablestack gpath = let
97	Stabilize.loadStable (ginfo, getStable, pErrFlag)	(* This is a separate "findCycle" routine that detects
98	in	* cycles among stable libraries.  These cycles should
99	case AbsPathMap.find (!gc, gpath) of	* never occur unless someone purposefully renames
100	SOME (x as SOME _) => x	* stable library files in a bad way. *)
101	| SOME NONE => NONE	fun findCycle ([], _) = NONE
102	| NONE =>	| findCycle (h :: t, cyc) =
103	(case loadStable gpath of	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	NONE => NONE
130	| x as SOME _ =>	| SOME g =>
131	(gc := AbsPathMap.insert (!gc, gpath, x);	(sgc := SrcPathMap.insert (!sgc, gpath, g);
132	x))	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	end
145		in
146	fun stabilize g =	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 }	Stabilize.stabilize ginfo { group = g, anyerrors = pErrFlag }
169
170	(* normal processing -- used when there is no cycle to report *)	(* normal processing -- used when there is no cycle to report *)
171	fun normal_processing () = let	fun normal_processing () = let
172	val currentDir = AbsPath.dir group	val _ = Say.vsay ["[scanning ", SrcPath.descr group, "]\n"]
173	val context = AbsPath.relativeContext (AbsPath.dir group)
174	val filename = AbsPath.name group	val context = SrcPath.sameDirContext group
175	val _ = Say.vsay ["[scanning ", filename, "]\n"]
176	val stream = TextIO.openIn filename	fun work stream = let
177	val source = S.newSource (filename, 1, stream, false, errcons)	val source =
178		S.newSource (SrcPath.osstring group,
179		1, stream, false, errcons)
180	val sourceMap = #sourceMap source	val sourceMap = #sourceMap source
181	val _ = GroupReg.register groupreg (group, source)	val _ = GroupReg.register groupreg (group, source)
182
#	Line 114	Line 186
186	* data structures. *)	* data structures. *)
187	fun error r m =	fun error r m =
188	EM.error source r EM.COMPLAIN m EM.nullErrorBody	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).	(* recParse returns a group (not an option).
196	* This function is used to parse aliases and sub-groups.	* This function is used to parse sub-groups.
197	* Errors are propagated by explicitly setting the	* Errors are propagated by explicitly setting the
198	* "anyErrors" flag of the parent group. *)	* "anyErrors" flag of the parent group. *)
199	fun recParse (p1, p2) p = let	fun recParse (p1, p2) curlib p = let
200	val groupstack' = (group, (source, p1, p2)) :: groupstack	val gs' = (group, (source, p1, p2)) :: groupstack
201	val myErrorFlag = #anyErrors source	val myErrorFlag = #anyErrors source
202	in	in
203	case mparse (p, groupstack', myErrorFlag, staball) of	case mparse (p, gs', myErrorFlag, staball, curlib) of
204	NONE => (myErrorFlag := true;	NONE => (myErrorFlag := true;
205	CMSemant.emptyGroup group)	CMSemant.emptyGroup group)
206	| SOME res => res	| SOME res => res
#	Line 132	Line 209
209	(error (p1, p2) (General.exnMessage exn);	(error (p1, p2) (General.exnMessage exn);
210	CMSemant.emptyGroup group)	CMSemant.emptyGroup group)
211
212	fun doMember (p, p1, p2, c) =	fun doMember ({ name, mkpath }, p1, p2, c) =
213	CMSemant.member (ginfo, recParse (p1, p2))	CMSemant.member (ginfo, recParse (p1, p2))
214	{ sourcepath = p, class = c,	{ name = name, mkpath = mkpath,
215	group = (group, (p1, p2)) }	class = c, group = (group, (p1, p2)),
216		context = context }
217
218	(* Build the argument for the lexer; the lexer's local	(* Build the argument for the lexer; the lexer's local
219	* state is encapsulated here to make sure the parser	* state is encapsulated here to make sure the parser
#	Line 156	Line 234
234	end	end
235	(* handling strings *)	(* handling strings *)
236	fun newS pos =	fun newS pos =
237	(instring := true; curstring := []; startpos := pos)	(instring := true;
238		curstring := [];
239		startpos := pos)
240	fun addS c = curstring := c :: !curstring	fun addS c = curstring := c :: !curstring
241	fun addSC (s, offs) =	fun addSC (s, offs) =
242	addS (chr (ord (String.sub (s, 2)) - offs))	addS (chr (ord (String.sub (s, 2)) - offs))
#	Line 192	Line 272
272	fun sep c = c = #"#" orelse Char.isSpace c	fun sep c = c = #"#" orelse Char.isSpace c
273	fun cvt s = getOpt (Int.fromString s, 0)	fun cvt s = getOpt (Int.fromString s, 0)
274	fun r (line, col, file) = SM.resynch sourceMap	fun r (line, col, file) = SM.resynch sourceMap
275	(p, { fileName = file, line = line, column = col })	(p, { fileName = file,
276		line = line, column = col })
277	in	in
278	case String.tokens sep t of	case String.tokens sep t of
279	[_, line] =>	[_, line] =>
#	Line 214	Line 295
295	getS = getS,	getS = getS,
296	handleEof = handleEof,	handleEof = handleEof,
297	newline = newline,	newline = newline,
298		obsolete = obsolete,
299	error = error,	error = error,
300	sync = sync}	sync = sync}
301	end	end
#	Line 225	Line 307
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	(group, context, error, recParse,	(group, context, obsolete, error,
311	doMember, ginfo))	doMember, curlib, ginfo))
312	in	in
	TextIO.closeIn stream;
313	if !(#anyErrors source) then NONE	if !(#anyErrors source) then NONE
	else if stabthis then stabilize parseResult
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	in
332	case findCycle (groupstack, []) of	if hasCycle (group, groupstack) then NONE
333	h :: t => (report (h, t); NONE)	else normal_processing ()
	| [] =>
	(case getStable group of
	NONE => normal_processing ()
	| SOME g => SOME g)
334	end	end
335	in	in
336	case mparse (group, [], ref false, stabthis) of	SmlInfo.newGeneration ();
337		case mparse (group, [], ref false, stabthis, NONE) of
338	NONE => NONE	NONE => NONE
339	| SOME g =>	| SOME g => SOME (g, ginfo)
	if CheckSharing.check (g, ginfo) then
	(SmlInfo.forgetAllBut (Reachable.reachable g);
	SOME (g, ginfo))
	else NONE
340	end	end
341	end	end

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

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

---

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