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/trunk/src/compiler/FLINT/trans/tempexpn.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/FLINT/trans/tempexpn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 419 - (view) (download)

1 : monnier 245 (* COPYRIGHT (c) 1995 AT&T Bell Laboratories *)
2 :     (* tempexpn.sml *)
3 :    
4 :     structure TemplateExpansion =
5 :     struct
6 :    
7 :     local open Types VarCon Access Absyn ErrorMsg MCCommon BasicTypes
8 :    
9 :     in
10 :    
11 :     exception Lookup
12 :    
13 :     fun lookup (a as VALvar{access=LVAR a',...},
14 :     (VALvar{access=LVAR b,...},c)::d) =
15 :     if a' = b then c else lookup(a, d)
16 :     | lookup (VALvar _, (VALvar _, _)::_) =
17 :     ErrorMsg.impossible "833 in tempexpn"
18 :     | lookup _ = raise Lookup
19 :    
20 :     val mkLvar = LambdaVar.mkLvar
21 :    
22 :     exception CANT_MATCH
23 :    
24 :     fun foo x = impossible "no templates yet"
25 :     (*
26 :     (case lookup (x, !constructor_env)
27 :     of {rep = TEMPLrep (NOpat, _, _),...} => raise CANT_MATCH
28 :     | {rep = TEMPLrep x,...} => x
29 :     | _ => raise Internal 1)
30 :     handle Lookup => raise (Internal 2)
31 :     *)
32 :    
33 :     fun foo' x = impossible "no symbolic constants yet"
34 :     (*
35 :     (case lookup (x, !constructor_env)
36 :     of {rep = CONSTrep (NOpat, _),...} => raise CANT_MATCH
37 :     | {rep = CONSTrep x,...} => x
38 :     | _ => raise Internal 3)
39 :     handle Lookup => raise (Internal 4)
40 :     *)
41 :    
42 :     fun andPatterns(WILDpat, pat) = pat
43 :     | andPatterns(pat, WILDpat) = pat
44 :     | andPatterns(CONSTRAINTpat(pat, _), pat') = andPatterns(pat, pat')
45 :     | andPatterns(pat, CONSTRAINTpat(pat', _))= andPatterns(pat, pat')
46 :     | andPatterns(VARpat v, pat) = LAYEREDpat(VARpat v, pat)
47 :     | andPatterns(pat, VARpat v) = LAYEREDpat(VARpat v, pat)
48 :     | andPatterns(CONpat(k,t), CONpat(k',t')) =
49 :     if conEq (k, k') then CONpat(k,t)
50 :     else if abstract k then LAYEREDpat(CONpat(k,t), CONpat(k',t'))
51 :     else if abstract k' then LAYEREDpat(CONpat(k',t'), CONpat(k,t))
52 :     else raise CANT_MATCH
53 :     | andPatterns(CONpat(k,t), APPpat(k',t',pat)) =
54 :     if abstract k then LAYEREDpat(CONpat(k,t), APPpat(k',t',pat))
55 :     else if abstract k' then LAYEREDpat(APPpat(k',t',pat), CONpat(k,t))
56 :     else raise CANT_MATCH
57 :     | andPatterns(APPpat(k',t',pat), CONpat(k,t)) =
58 :     if abstract k then LAYEREDpat(CONpat(k,t), APPpat(k',t',pat))
59 :     else if abstract k' then LAYEREDpat(APPpat(k',t',pat), CONpat(k,t))
60 :     else raise CANT_MATCH
61 :     | andPatterns(APPpat(k,t,pat), APPpat(k',t',pat')) =
62 :     if conEq (k, k') then APPpat(k,t,andPatterns(pat,pat'))
63 :     else if abstract k then
64 :     LAYEREDpat(APPpat(k,t,pat),APPpat(k',t',pat'))
65 :     else if abstract k' then
66 :     LAYEREDpat(APPpat(k',t',pat'), APPpat(k,t,pat))
67 :     else raise CANT_MATCH
68 :     | andPatterns(CONpat(k,t), pat) =
69 :     if abstract k then LAYEREDpat(CONpat(k,t), pat)
70 :     else impossible "Non abstract CONpat & non constructor pat in andPat"
71 :     | andPatterns(pat, CONpat(k,t)) =
72 :     if abstract k then LAYEREDpat(CONpat(k,t), pat)
73 :     else impossible "non constructor pat & Non abstract CONpat in andPat"
74 :     | andPatterns(APPpat(k,t,pat), pat') =
75 :     if abstract k then LAYEREDpat(APPpat(k,t,pat), pat')
76 :     else impossible "Non abstract APPpat & non constructor pat in andPat"
77 :     | andPatterns(pat, APPpat(k,t,pat')) =
78 :     if abstract k then LAYEREDpat(APPpat(k,t,pat'), pat)
79 :     else impossible "non constructor pat & Non abstract APPpat in andPat"
80 :     | andPatterns(LAYEREDpat(CONSTRAINTpat(pat1, _), pat2), pat) =
81 :     andPatterns(LAYEREDpat(pat1, pat2), pat)
82 :     | andPatterns(pat, LAYEREDpat(CONSTRAINTpat(pat1, _), pat2)) =
83 :     andPatterns(pat, LAYEREDpat(pat1, pat2))
84 :     | andPatterns(LAYEREDpat(pat1, pat2), pat) =
85 :     LAYEREDpat(pat1, andPatterns(pat2, pat))
86 :     | andPatterns(pat, LAYEREDpat(pat1, pat2)) =
87 :     LAYEREDpat(pat1, andPatterns(pat2, pat))
88 :     | andPatterns(INTpat (p as (s,t)), INTpat (s',t')) =
89 :     ((if TypesUtil.equalType(t,intTy) then
90 :     if (LiteralToNum.int s) = (LiteralToNum.int s')
91 :     then INTpat p
92 :     else raise CANT_MATCH
93 :     else if TypesUtil.equalType(t,int32Ty) then
94 :     if (LiteralToNum.int32 s) = (LiteralToNum.int32 s')
95 :     then INTpat p
96 :     else raise CANT_MATCH
97 :     else ErrorMsg.impossible "andPatterns/INTpat in tempexpn")
98 :     handle Overflow =>
99 :     ErrorMsg.impossible "overflow during int or word patter comparisons")
100 :     | andPatterns(WORDpat (p as (w,t)), WORDpat (w',t')) =
101 :     ((if TypesUtil.equalType(t,wordTy) then
102 :     if (LiteralToNum.word w) = (LiteralToNum.word w')
103 :     then WORDpat p
104 :     else raise CANT_MATCH
105 :     else if TypesUtil.equalType(t,word8Ty) then
106 :     if (LiteralToNum.word8 w) = (LiteralToNum.word8 w')
107 :     then WORDpat p
108 :     else raise CANT_MATCH
109 :     else if TypesUtil.equalType(t,word32Ty) then
110 :     if (LiteralToNum.word32 w) = (LiteralToNum.word32 w')
111 :     then WORDpat p
112 :     else raise CANT_MATCH
113 :     else ErrorMsg.impossible "andPatterns/WORDpat in tempexpn")
114 :     handle Overflow =>
115 :     ErrorMsg.impossible "overflow during int or word patter comparisons")
116 :     | andPatterns(REALpat r, REALpat r') =
117 :     if r = r' then REALpat r else raise CANT_MATCH
118 :     | andPatterns(STRINGpat s, STRINGpat s') =
119 :     if s = s' then STRINGpat s else raise CANT_MATCH
120 :     | andPatterns(CHARpat s, CHARpat s') =
121 :     if s = s' then CHARpat s else raise CANT_MATCH
122 :     | andPatterns(pat1 as RECORDpat{fields=p,...},
123 :     pat2 as RECORDpat{fields=q,...}) =
124 :     mkRECORDpat pat1 (multiAnd(map #2 p, map #2 q))
125 :    
126 :     (******************* how to and two types ? **************************)
127 :     | andPatterns(VECTORpat(p,t), VECTORpat(p',t')) =
128 :     if (length p) = (length p') then VECTORpat(multiAnd(p,p'),t)
129 :     else raise CANT_MATCH
130 :     | andPatterns (p1, p2) =
131 :     impossible "bas andPattern call"
132 :    
133 :     and multiAnd (nil, nil) = nil
134 :     | multiAnd (pat::rest, pat'::rest') =
135 :     (andPatterns(pat,pat'))::(multiAnd(rest, rest'))
136 :     | multiAnd _ = impossible "bad multiAnd call"
137 :    
138 :     fun instantiatePatexp (VARpat v, env) = lookup(v, env)
139 :     | instantiatePatexp (LAYEREDpat(pat1, pat2),env) =
140 :     andPatterns(instantiatePatexp(pat1,env),instantiatePatexp(pat2,env))
141 :     | instantiatePatexp (CONSTRAINTpat(pat, _), env) =
142 :     instantiatePatexp(pat, env)
143 :     | instantiatePatexp (APPpat(k,t,pat), env) =
144 :     APPpat(k,t,instantiatePatexp(pat, env))
145 :     | instantiatePatexp (pat as RECORDpat{fields,...}, env) =
146 :     mkRECORDpat pat (multiInstantiatePatexp(map #2 fields, env))
147 :     | instantiatePatexp (VECTORpat(pats,t), env) =
148 :     VECTORpat (multiInstantiatePatexp(pats, env), t)
149 :     | instantiatePatexp (pat, env) = pat
150 :     and multiInstantiatePatexp(nil, env) = nil
151 :     | multiInstantiatePatexp(pat::rest, env) =
152 :     (instantiatePatexp(pat, env))::(multiInstantiatePatexp(rest, env))
153 :    
154 :     fun instance (VARpat (VALvar {path, typ, info, ...})) =
155 :     VARsimp (VALvar{access=LVAR (mkLvar()), path=path, typ=typ, info=info})
156 :     | instance (VARpat _) = impossible "bad variabel in match"
157 :     | instance (RECORDpat{fields,...}) =
158 :     RECORDsimp(map (fn(lab,pat)=>(lab,instance pat)) fields)
159 :     | instance (CONSTRAINTpat(pat, _)) = instance pat
160 :     | instance pat = impossible "bad instance call"
161 :    
162 :     fun simpToPat (VARsimp v) = VARpat v
163 :     | simpToPat (RECORDsimp labsimps) =
164 :     RECORDpat {fields=map(fn(lab,simp)=>(lab,simpToPat simp)) labsimps,
165 :     flex=false, typ = ref UNDEFty}
166 :    
167 :     fun trivpatTrivEnv (VARpat v, VARsimp x) = [(v, VARpat x)]
168 :     | trivpatTrivEnv (CONSTRAINTpat(tpat, _), simp) =
169 :     trivpatTrivEnv (tpat, simp)
170 :     | trivpatTrivEnv (RECORDpat{fields,...}, RECORDsimp labsimps) =
171 :     multiTrivpatTrivEnv (map #2 fields, map #2 labsimps)
172 :     | trivpatTrivEnv _ = impossible "trivpatTrivEnv"
173 :     and multiTrivpatTrivEnv (nil, nil) = nil
174 :     | multiTrivpatTrivEnv (tpat::trest, simp::srest)=
175 :     (trivpatTrivEnv(tpat, simp))@(multiTrivpatTrivEnv(trest, srest))
176 :     | multiTrivpatTrivEnv _ = impossible "multiTrivpatTrivEnv"
177 :    
178 :     fun wildEnv (VARpat v) = [(v, WILDpat)]
179 :     | wildEnv (CONSTRAINTpat(tpat, _)) = wildEnv tpat
180 :     | wildEnv (RECORDpat{fields,...}) = List.concat (map (wildEnv o #2) fields)
181 :     | wildEnv _ = impossible "wildEnv called on non-trivpat"
182 :    
183 :     fun matchTrivpat (VARpat v, pat)= ([(v, pat)], nil, nil)
184 :     | matchTrivpat (CONSTRAINTpat(tpat, _), pat) = matchTrivpat(tpat, pat)
185 :     | matchTrivpat (tpat, CONSTRAINTpat(pat, _)) = matchTrivpat(tpat, pat)
186 :     | matchTrivpat (RECORDpat{fields=tps,...},RECORDpat{fields=ps,...}) =
187 :     multiMatchTrivpat(map #2 tps, map #2 ps)
188 :     | matchTrivpat (tpat, WILDpat) =
189 :     (wildEnv tpat, nil, nil)
190 :     | matchTrivpat (tpat, VARpat v) =
191 :     let val a = instance tpat
192 :     val b = trivpatTrivEnv (tpat, a)
193 :     in (b, [(v, a)], nil)
194 :     end
195 :     | matchTrivpat (tpat, CONpat(k,t)) =
196 :     let val a = instance tpat
197 :     val b = trivpatTrivEnv (tpat, a)
198 :     in (b, nil, [(a, CONpat(k,t))])
199 :     end
200 :     | matchTrivpat (tpat, APPpat(k,t,pat)) =
201 :     let val a = instance tpat
202 :     val b = trivpatTrivEnv (tpat, a)
203 :     in (b, nil, [(a, APPpat(k,t,pat))])
204 :     end
205 :     | matchTrivpat (tpat, LAYEREDpat(CONpat(k,t), pat)) =
206 :     let val a = instance tpat
207 :     val (pat', varEnv, constr) =
208 :     matchTrivpat(tpat, andPatterns(simpToPat a, pat))
209 :     in (pat', varEnv, (a, CONpat(k,t))::constr)
210 :     end
211 :     | matchTrivpat (tpat, LAYEREDpat(APPpat(k,t,spat), pat)) =
212 :     let val a = instance tpat
213 :     val (pat', varEnv, constr) =
214 :     matchTrivpat(tpat, andPatterns(simpToPat a, pat))
215 :     in (pat', varEnv, (a, APPpat(k,t,spat))::constr)
216 :     end
217 :     | matchTrivpat (tpat, LAYEREDpat(VARpat v, pat)) =
218 :     let val a = instance tpat
219 :     val (pat', varEnv, constr) =
220 :     matchTrivpat(tpat, andPatterns(simpToPat a, pat))
221 :     in (pat', (v,a)::varEnv, constr)
222 :     end
223 :     | matchTrivpat (tpat, LAYEREDpat(CONSTRAINTpat(pat1, _), pat2)) =
224 :     matchTrivpat (tpat, LAYEREDpat(pat1, pat2))
225 :     | matchTrivpat (tpat, pat) = impossible "bad matchTrivpat call"
226 :     and multiMatchTrivpat (nil, nil) = (nil, nil, nil)
227 :     | multiMatchTrivpat (tpat::trest, pat::prest) =
228 :     let val (patenv, varenv, constr) = multiMatchTrivpat(trest, prest)
229 :     val (patenv', varenv', constr') = matchTrivpat(tpat, pat)
230 :     in (patenv@patenv', varenv@varenv', constr@constr')
231 :     end
232 :     | multiMatchTrivpat _ = impossible "bad multiMatchTrivpat call"
233 :    
234 :     fun newVars (RECORDsimp labsimps, env) =
235 :     multiNewVars(map #2 labsimps, env)
236 :     | newVars (VARsimp (v as VALvar {path, typ, info, ...}), env) =
237 :     ((lookup(v, env); env)
238 :     handle Lookup =>
239 :     ((v,VALvar{path=path, typ=typ,access=LVAR (mkLvar()),
240 :     info=info})::env))
241 :     | newVars (VARsimp _, _) = impossible "bad instance call to newVars"
242 :     and multiNewVars(nil, env) = env
243 :     | multiNewVars(simp::rest, env) = multiNewVars(rest, newVars(simp, env))
244 :    
245 :     fun instantiateLocalVars (nil, env) = env
246 :     | instantiateLocalVars ((path,pat)::rest, env) =
247 :     instantiateLocalVars(rest, newVars(path, env))
248 :    
249 :     fun instSimpexp(VARsimp v, env) = VARsimp (lookup(v, env))
250 :     | instSimpexp(RECORDsimp labsimps, env) =
251 :     RECORDsimp (multiInstSimpexp (labsimps, env))
252 :     and multiInstSimpexp(nil, env) = nil
253 :     | multiInstSimpexp((lab,simpexp)::rest, env) =
254 :     (lab, instSimpexp(simpexp, env))::(multiInstSimpexp(rest, env))
255 :    
256 :     fun instantiateConstrs(nil, locEnv, env) = nil
257 :     | instantiateConstrs((simpexp, pat)::rest, locEnv, env) =
258 :     (instSimpexp(simpexp, locEnv), instantiatePatexp(pat, env))
259 :     :: (instantiateConstrs(rest, locEnv, env))
260 :    
261 :     fun liftenv nil = nil
262 :     | liftenv ((v,x)::rest) = (v, VARpat x)::(liftenv rest)
263 :    
264 :     fun templExpand(k, pat) =
265 :     let
266 :     val (patexp, trivpat, constrs) = foo k
267 :     val (env, varnames, newconstrs) = matchTrivpat(trivpat, pat)
268 :     val env' = instantiateLocalVars (constrs, nil)
269 :     val newEnv = env@(liftenv env')
270 :     in
271 :     (instantiatePatexp(patexp, newEnv),
272 :     newconstrs@(instantiateConstrs(constrs, env', newEnv)),
273 :     varnames)
274 :     end
275 :    
276 :     fun constExpand k =
277 :     let
278 :     val (patexp, constrs) = foo' k
279 :     val newEnv = instantiateLocalVars (constrs, nil)
280 :     val lNewEnv = liftenv newEnv
281 :     in
282 :     (instantiatePatexp(patexp, lNewEnv),
283 :     instantiateConstrs(constrs, newEnv, lNewEnv),
284 :     nil)
285 :     end
286 :    
287 :     fun multiTemplateExpand nil = (nil, nil, nil)
288 :     | multiTemplateExpand (pat::rest) =
289 :     let
290 :     val (pats', constr1, varenv1) = multiTemplateExpand rest
291 :     val (pat', constr2, varenv2) = templateExpandPattern pat
292 :     in
293 :     (pat'::pats', constr1@constr2, varenv1@varenv2)
294 :     end
295 :    
296 :     and templateExpandPattern (APPpat(k,t,pat)) =
297 :     let
298 :     val (pat', patConstraints, patVarenv) = templateExpandPattern pat
299 :     in
300 :     if template k then
301 :     let
302 :     val (newPat, kConstraints, kVarenv) = templExpand(k, pat')
303 :     in
304 :     (newPat, patConstraints@kConstraints, patVarenv@kVarenv)
305 :     end
306 :     else
307 :     (APPpat(k,t,pat'), patConstraints, patVarenv)
308 :     end
309 :     | templateExpandPattern (CONpat(k,t)) =
310 :     if template k then
311 :     let
312 :     val (newPat, constraints, varenv) = constExpand k
313 :     in
314 :     (newPat, constraints, varenv)
315 :     end
316 :     else
317 :     (CONpat(k,t), nil, nil)
318 :     | templateExpandPattern (pat as RECORDpat{fields,...}) =
319 :     let
320 :     val (pats', constr, varenv) = multiTemplateExpand (map #2 fields)
321 :     in
322 :     (mkRECORDpat pat pats', constr, varenv)
323 :     end
324 :     | templateExpandPattern (VECTORpat(pats,t)) =
325 :     let
326 :     val (pats', constr, varenv) = multiTemplateExpand pats
327 :     in
328 :     (VECTORpat(pats,t), constr, varenv)
329 :     end
330 :     | templateExpandPattern (LAYEREDpat(pat1, pat2)) =
331 :     let
332 :     val (pat1', constr1, varenv1) = templateExpandPattern pat1
333 :     val (pat2', constr2, varenv2) = templateExpandPattern pat2
334 :     in
335 :     (LAYEREDpat(pat1', pat2'), constr1@constr2, varenv1@varenv2)
336 :     end
337 :     | templateExpandPattern (CONSTRAINTpat(pat, _)) =
338 :     templateExpandPattern pat
339 :     | templateExpandPattern pat = (pat, nil, nil)
340 :    
341 :     fun fullyExpandBinding varenv (VARsimp v) =
342 :     (fullyExpandBinding varenv (lookup(v, varenv))
343 :     handle Lookup => VARsimp v)
344 :     | fullyExpandBinding varenv (RECORDsimp labsimps) =
345 :     RECORDsimp
346 :     (map (fn(lab,simp)=>(lab,fullyExpandBinding varenv simp)) labsimps)
347 :    
348 :     fun fullyExpandBindingTrivpat varenv (VARpat v) =
349 :     (fullyExpandBindingTrivpat varenv (simpToPat(lookup(v, varenv)))
350 :     handle Lookup => VARpat v)
351 :     | fullyExpandBindingTrivpat varenv (pat as RECORDpat{fields,...})=
352 :     mkRECORDpat pat (map (fullyExpandBindingTrivpat varenv o #2) fields)
353 :     | fullyExpandBindingTrivpat varenv (CONSTRAINTpat(pat, _)) =
354 :     fullyExpandBindingTrivpat varenv pat
355 :     | fullyExpandBindingTrivpat _ _ =
356 :     impossible "fullyExpandBindingTrivpat miscalled"
357 :    
358 :     end (* toplevel local *)
359 :     end (* structure TemplateExpansion *)
360 :    
361 :    

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