Diff of /sml/trunk/src/cm/compile/generic.sml

Parent Directory | Revision Log | Patch

	revision 313, Thu Jun 3 09:26:34 1999 UTC	revision 314, Fri Jun 4 06:41:45 1999 UTC
#	Line 1	Line 1
1	(*	(*
2	* The "generic" compilation traversal functor.	* The "generic" compilation traversal functor.
3		*  (In fact, it is probably possible to use this for things other
4		*   than compilation as well.)
5	*	*
6	* (C) 1999 Lucent Technologies, Bell Laboratories	* (C) 1999 Lucent Technologies, Bell Laboratories
7	*	*
#	Line 8	Line 10
10	local	local
11	structure GP = GeneralParams	structure GP = GeneralParams
12	structure DG = DependencyGraph	structure DG = DependencyGraph
13		structure GG = GroupGraph
14	in	in
15	functor CompileGenericFn (structure CT: COMPILATION_TYPE) :> sig	functor CompileGenericFn (structure CT: COMPILATION_TYPE) :> sig
16
17	type envdelta = CT.envdelta	type envdelta = CT.envdelta
18	type benv = CT.benv	type result = CT.result
	type env = CT.env
19
20	val bnode : GP.info -> DG.bnode -> envdelta option	val bnode : GP.info -> DG.bnode -> envdelta option
21	val farbnode : GP.info -> DG.farbnode -> benv option	val group : GP.info -> GG.group -> result option
	val snode : GP.info -> DG.snode -> envdelta option
	val sbnode : GP.info -> DG.sbnode -> envdelta option
	val farsbnode : GP.info -> DG.farsbnode -> env option
22
23	end = struct	end = struct
24
25	type envdelta = CT.envdelta	type envdelta = CT.envdelta
26	type env = CT.env	type env = CT.env
27	type benv = CT.benv	type benv = CT.benv
28		type result = CT.result
29
30		(* This is to prevent re-execution of dosml if the first one failed *)
31		local
32		val failures = ref SmlInfoSet.empty
33		in
34		fun dosml (i, e, gp) =
35		if SmlInfoSet.member (!failures, i) then NONE
36		else case CT.dosml (i, e, gp) of
37		SOME r => SOME r
38		| NONE => (failures := SmlInfoSet.add (!failures, i); NONE)
39		fun clearFailures () = failures := SmlInfoSet.empty
40		end
41
42		(* To implement "keep_going" we have two different ways to "fold"
43		* a "layer" function over a list.  The _k version is to be used
44		* if keep_going is true, otherwise the _s version applies.
45		* Note that there is a bit of typing mystery in the way I use
46		* these functions later: I had to be more verbose than I wanted
47		* to because of the "value restriction rule" in SML'97. *)
48	fun foldlayer_k layer f = let	fun foldlayer_k layer f = let
49	fun loop r [] = r	fun loop r [] = r
50	| loop NONE (h :: t) = (ignore (f h); loop NONE t)	| loop NONE (h :: t) = (ignore (f h); loop NONE t)
#	Line 99	Line 117
117	in	in
118	case e of	case e of
119	NONE => NONE	NONE => NONE
120	| SOME e => CT.dosml (smlinfo, e, gp)	| SOME e => dosml (smlinfo, e, gp)
121	end	end
122
123	and sbnode gp (DG.SB_BNODE b) = bnode gp b	and sbnode gp (DG.SB_BNODE b) = bnode gp b
#	Line 110	Line 128
128	(NONE, _) => NONE	(NONE, _) => NONE
129	| (SOME d, NONE) => SOME (CT.nofilter d)	| (SOME d, NONE) => SOME (CT.nofilter d)
130	| (SOME d, SOME s) => SOME (CT.filter (d, s))	| (SOME d, SOME s) => SOME (CT.filter (d, s))
131
132		fun impexp gp (n, _) = Option.map CT.env2result (farsbnode gp n)
133
134		fun group gp (GG.GROUP { exports, ... }) = let
135		val fl =
136		if #keep_going (#param gp) then foldlayer_k else foldlayer_s
137		in
138		(fl CT.rlayer (impexp gp)
139		(SOME CT.empty)
140		(SymbolMap.listItems exports))
141		before clearFailures ()
142		end
143	end	end
144	end	end

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

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

---

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