Annotation of /sml/branches/FLINT/src/compiler/Semant/statenv/cmstatenv.sml

Parent Directory | Revision Log

---

Revision 167 - (view) (download)

1 :	monnier	89	(* COPYRIGHT (c) 1996 Bell Laboratories *)
2 :			(* cmstatenv.sml *)
3 :
4 :			structure CMStaticEnv : CMSTATICENV = struct
5 :
6 :			local
7 :			structure M = Modules
8 :			structure ED = EntPath.EvDict
9 :			structure I = ModuleId
10 :			structure V = VarCon
11 :			structure T = Types
12 :			structure B = Bindings
13 :			structure SE = StaticEnv
14 :			in
15 :
16 :			val debugging = ref false (* to keep signature happy *)
17 :
18 :			(* -------------- *)
19 :
20 :			structure Key = struct
21 :			type ord_key = I.modId
22 :			val cmpKey = I.cmp
23 :			end
24 :
25 :			structure D = BinaryDict (Key)
26 :
27 :			type modmap = { strD : M.Structure D.dict,
28 :			sigD : M.Signature D.dict,
29 :			fctD : M.Functor D.dict,
30 :			tycD : T.tycon D.dict,
31 :			eenvD : M.entityEnv D.dict }
32 :
33 :			type modmaps = modmap list
34 :
35 :			type staticEnv = SE.staticEnv * modmaps
36 :
37 :			val emptyModmap : modmap =
38 :			{ strD = D.mkDict (),
39 :			sigD = D.mkDict (),
40 :			fctD = D.mkDict (),
41 :			tycD = D.mkDict (),
42 :			eenvD = D.mkDict () }
43 :
44 :			fun unCM (se, _) = se
45 :
46 :			val empty = (StaticEnv.empty, [])
47 :
48 :			(* don't worry about space leak -- it is not permanent *)
49 :			fun atop ((se1, mm1), (se2, mm2)) = (SE.atop (se1, se2), mm1 @ mm2)
50 :
51 :			fun adjCM (scsel, se) = let
52 :			fun layerAll [] = []
53 :			| layerAll [(_, mm)] = mm
54 :			| layerAll ((_, mm) :: r) = mm @ layerAll r
55 :			in
56 :			(se, layerAll scsel)
57 :			end
58 :
59 :			fun mkLook sel (se: staticEnv) mid = let
60 :			fun look [] = NONE
61 :			| look (mm :: mms) =
62 :			case D.peek (sel mm, mid) of
63 :			NONE => look mms
64 :			| SOME x => SOME x
65 :			in
66 :			look (#2 se)
67 :			end
68 :
69 :			val lookSTR = mkLook #strD
70 :			val lookSIG = mkLook #sigD
71 :			val lookFCT = mkLook #fctD
72 :			val lookTYC = mkLook #tycD
73 :			val lookEENV = mkLook #eenvD
74 :			val lookFSIG = fn _ => fn _ => NONE
75 :
76 :			exception Id
77 :
78 :			fun strId (M.STR { rlzn = { stamp = rlznst, ... },
79 :			sign = M.SIG { stamp = sigst, ...}, ... }) =
80 :			I.STRid { rlzn = rlznst, sign = sigst }
81 :			| strId _ = raise Id
82 :
83 :			fun fsigId(M.FSIG{paramsig=M.SIG{stamp=sp,...},
84 :			bodysig=M.SIG{stamp=sb,...},...}) =
85 :			I.FSIGid{paramsig=sp,bodysig=sb}
86 :			| fsigId _ = raise Id
87 :
88 :			fun fctId(M.FCT{rlzn={stamp,...},sign,...}) =
89 :			I.FCTid{rlzn=stamp,sign=fsigId sign}
90 :			| fctId _ = raise Id
91 :
92 :			fun addSTR (i, b) { strD, sigD, fctD, tycD, eenvD } =
93 :			{ strD = D.insert (strD, i, b),
94 :			sigD = sigD, fctD = fctD, tycD = tycD, eenvD = eenvD }
95 :			fun addSIG (i, b) { strD, sigD, fctD, tycD, eenvD } =
96 :			{ strD = strD,
97 :			sigD = D.insert (sigD, i, b),
98 :			fctD = fctD, tycD = tycD, eenvD = eenvD }
99 :			fun addFCT (i, b) { strD, sigD, fctD, tycD, eenvD } =
100 :			{ strD = strD, sigD = sigD,
101 :			fctD = D.insert (fctD, i, b),
102 :			tycD = tycD, eenvD = eenvD }
103 :			fun addTYC (i, b) { strD, sigD, fctD, tycD, eenvD } =
104 :			{ strD = strD, sigD = sigD, fctD = fctD,
105 :			tycD = D.insert (tycD, i, b),
106 :			eenvD = eenvD }
107 :			fun addEENV (i, b) { strD, sigD, fctD, tycD, eenvD } =
108 :			{ strD = strD, sigD = sigD, fctD = fctD, tycD = tycD,
109 :			eenvD = D.insert (eenvD, i, b) }
110 :
111 :			fun enter (sel, add) (i, b, go_inside) (table: modmap) =
112 :			case D.peek (sel table, i) of
113 :			SOME _ => table
114 :			| NONE => go_inside (add (i, b) table)
115 :
116 :			val enterSTR = enter (#strD, addSTR)
117 :			val enterSIG = enter (#sigD, addSIG)
118 :			val enterFCT = enter (#fctD, addFCT)
119 :			val enterTYC = enter (#tycD, addTYC)
120 :			val enterEENV = enter (#eenvD, addEENV)
121 :
122 :			fun nothing table = table
123 :			fun list x = foldr (op o) nothing x
124 :
125 :			fun getbindings env = SE.fold (fn ((s, b), l) => b :: l) nil env
126 :
127 :			fun binding (B.VALbind v) = var v
128 :			| binding (B.CONbind v) = datacon v
129 :			| binding (B.TYCbind v) = tycon v
130 :			| binding (B.SIGbind v) = Signature v
131 :			| binding (B.STRbind v) = Structure v
132 :			| binding (B.FSGbind v) = fctSig v
133 :			| binding (B.FCTbind v) = Functor v
134 :			| binding (B.FIXbind v) = nothing
135 :
136 :			and var (V.VALvar { typ = ref t, ...}) = ty t
137 :			| var (V.OVLDvar { options = ref p, scheme = s, ...}) =
138 :			(list (map var_option p) o tyfun s)
139 :			| var (V.ERRORvar) = nothing
140 :
141 :			and var_option {indicator, variant} = ty indicator o var variant
142 :
143 :			and tyfun (T.TYFUN { body, ...}) = ty body
144 :
145 :			and ty (T.VARty (ref (T.INSTANTIATED t))) = ty t
146 :			| ty (T.CONty (tyc, tyl)) = (tycon tyc o list (map ty tyl))
147 :			| ty (T.POLYty { tyfun = t, ...}) = tyfun t
148 :			| ty _ = nothing
149 :
150 :			and tycon (t as T.GENtyc { stamp, ... }) =
151 :			enterTYC (I.TYCid stamp, t, nothing)
152 :			| tycon (T.DEFtyc { tyfun = t, ... }) = tyfun t
153 :			| tycon _ = nothing
154 :
155 :			and datacon (T.DATACON {typ, ... }) = ty typ
156 :
157 :			and spec (M.TYCspec { spec = t, ... }) = tycon t
158 :			| spec (M.STRspec { sign = s, ... }) = Signature s
159 :			| spec (M.FCTspec { sign = s, ... }) = fctSig s
160 :			| spec (M.VALspec { spec = t, ... }) = ty t
161 :			| spec (M.CONspec { spec = d, ... }) = datacon d
162 :
163 :			and Signature (s as M.SIG { stamp, elements = e, ... }) =
164 :			enterSIG (I.SIGid stamp, s, fn x => list (map (spec o #2) e) x)
165 :			| Signature M.ERRORsig = nothing
166 :
167 :			and Structure (s as M.STR { sign = g, rlzn = r, ... }) =
168 :			enterSTR (strId s, s, fn x => (Signature g o strEntity r) x)
169 :			| Structure (M.STRSIG { sign = s, ... }) = Signature s
170 :			| Structure (M.ERRORstr) = nothing
171 :
172 :			and tycExp (M.CONSTtyc t) = tycon t
173 :			| tycExp _ = nothing
174 :
175 :			and strExp (M.VARstr _) = nothing
176 :			| strExp (M.CONSTstr strent) = strEntity strent
177 :			| strExp (M.STRUCTURE { entDec = d, ... }) = entityDec d
178 :			| strExp (M.APPLY (f, s)) = fctExp f o strExp s
179 :			| strExp (M.LETstr (d, e)) = entityDec d o strExp e
180 :			| strExp (M.ABSstr (s, e)) = Signature s o strExp e
181 :			| strExp (M.CONSTRAINstr { raw, coercion, ... }) =
182 :			strExp raw o strExp coercion
183 :			| strExp (M.FORMstr fs) = fctSig fs
184 :
185 :			and fctExp (M.VARfct _) = nothing
186 :			| fctExp (M.CONSTfct f) = fctEntity f
187 :			| fctExp (M.LAMBDA { body, ... }) = strExp body
188 :			| fctExp (M.LAMBDA_TP { body, sign, ... }) =
189 :			strExp body o fctSig sign
190 :			| fctExp (M.LETfct (d, f)) = entityDec d o fctExp f
191 :
192 :			and entityDec (M.TYCdec (v, t)) = tycExp t
193 :			| entityDec (M.STRdec (v, s, _)) = strExp s
194 :			| entityDec (M.FCTdec(v,f)) = fctExp f
195 :			| entityDec (M.SEQdec ds) = list (map entityDec ds)
196 :			| entityDec (M.LOCALdec (din, dout)) = entityDec din o entityDec dout
197 :			| entityDec (M.ERRORdec) = nothing
198 :			| entityDec (M.EMPTYdec) = nothing
199 :
200 :			and strEntity { entities = e, ...} = entityEnv e
201 :
202 :			and fctEntity { closure = M.CLOSURE { body = b, env = e, ... }, ... } =
203 :			strExp b o entityEnv e
204 :
205 :			and tycEntity t = tycon t
206 :
207 :			and entityEnv (e as M.MARKeenv(s, rest)) =
208 :			enterEENV (I.EENVid s, e, fn x => entityEnv rest x)
209 :			| entityEnv (M.BINDeenv (d, rest)) =
210 :			(list (map (entity o #2) (ED.members d))) o entityEnv rest
211 :			| entityEnv M.NILeenv = nothing
212 :			| entityEnv M.ERReenv = nothing
213 :
214 :			and entity(M.TYCent t) = tycEntity t
215 :			| entity(M.STRent s) = strEntity s
216 :			| entity(M.FCTent f) = fctEntity f
217 :			| entity _ = nothing
218 :
219 :			and fctSig (M.FSIG { paramsig = p, bodysig = b, ... }) =
220 :			Signature p o Signature b
221 :			| fctSig M.ERRORfsig = nothing
222 :
223 :			and Functor (f as M.FCT { sign = s, rlzn = r, ...}) =
224 :			enterFCT (fctId f, f, fn x => (fctSig s o fctEntity r) x)
225 :			| Functor M.ERRORfct = nothing
226 :
227 :			and env e = list (map binding (getbindings e))
228 :
229 :			fun CM env0 = (env0, [env env0 emptyModmap])
230 :
231 :			val CM = Stats.doPhase (Stats.makePhase "Compiler 038 cmstatenv") CM
232 :
233 :			fun consolidate (e, _) = CM (SE.consolidate e)
234 :			end (* local *)
235 :			end (* structure CMStaticEnv *)
236 :
237 :
238 :			(*
239 :	monnier	167	* $Log: cmstatenv.sml,v $
240 :			* Revision 1.1.1.1 1998/04/08 18:39:36 george
241 :			* Version 110.5
242 :			*
243 :	monnier	89	*)

---

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