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

Parent Directory | Revision Log | Patch

	revision 361, Wed Jun 30 06:44:04 1999 UTC	revision 493, Mon Nov 29 07:13:22 1999 UTC
#	Line 10	Line 10
10	GroupReg.groupreg option ->	GroupReg.groupreg option ->
11	GeneralParams.param -> bool option ->	GeneralParams.param -> bool option ->
12	SrcPath.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
#	Line 28	Line 32
32	structure Lex = CMLex	structure Lex = CMLex
33	structure LrParser = LrParser)	structure LrParser = LrParser)
34
35	fun parse gropt 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	val _ = SrcPath.revalidateCwd ()	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
#	Line 47	Line 59
59	* to parse it had failed. *)	* to parse it had failed. *)
60	val gc = ref (SrcPathMap.empty: CMSemant.group option SrcPathMap.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 SrcPathMap.find (!gc, group) of
	SOME g => g
	| NONE => let
	val g = parse' (group, groupstack, pErrFlag, stabthis)
	in
	gc := SrcPathMap.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) =
#	Line 69	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 (SrcPath.specOf 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
#	Line 85	Line 86
86	SrcPath.specOf 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	(* To make a cycle involving existing stable groups,	fun getStable stablestack gpath = let
97	* one must use aliases.  The cycle will be detected	(* This is a separate "findCycle" routine that detects
98	* amoung those aliases... (?? - hopefully) *)	* cycles among stable libraries.  These cycles should
99	fun getStableSG p =	* never occur unless someone purposefully renames
100	mparse (p, groupstack, pErrFlag, staball)	* 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	in
156	Stabilize.loadStable (ginfo, getStableSG, pErrFlag) gpath	gc := SrcPathMap.insert (!gc, group, pres);
157		pres
158		end)
159	end	end
160
161		and parse' (group, groupstack, pErrFlag, stabthis, curlib) = let
162
163	(* We stabilize libraries only because a stable library will	(* We stabilize libraries only because a stable library will
164	* encompass the contents of its sub-groups	* encompass the contents of its sub-groups
165	* (but not sub-libraries!). *)	* (but not sub-libraries!). *)
#	Line 105	Line 169
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
	val context = SrcPath.sameDirContext group
172	val _ = Say.vsay ["[scanning ", SrcPath.descr group, "]\n"]	val _ = Say.vsay ["[scanning ", SrcPath.descr group, "]\n"]
173
174		val context = SrcPath.sameDirContext group
175
176	fun work stream = let	fun work stream = let
177	val source =	val source =
178	S.newSource (SrcPath.osstring group,	S.newSource (SrcPath.osstring group,
#	Line 121	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' =	val gs' = (group, (source, p1, p2)) :: groupstack
	(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 140	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 225	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 236	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
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 =	val pro =
318	SafeIO.perform { openIt =	SafeIO.perform { openIt = openIt,
	fn () => SrcPath.openTextIn group,
319	closeIt = TextIO.closeIn,	closeIt = TextIO.closeIn,
320	work = work,	work = work,
321	cleanup = fn () => () }	cleanup = fn _ => () }
322	in	in
323	case pro of	case pro of
324	NONE => NONE	NONE => NONE
325	| SOME pr =>	| SOME pr =>
326		(SmlInfo.cleanGroup group;
327	if stabthis then stabilize pr	if stabthis then stabilize pr
328	else SOME pr	else SOME pr)
329	end	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.361   changed lines   Added in v.493

---

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