Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/branches/FLINT/src/compiler/Semant/statenv/cmstatenv.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log 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