Annotation of /sml/branches/SMLNJ/src/compiler/FLINT/trans/tempexpn.sml

Parent Directory | Revision Log

---

Revision 16 - (view) (download)
Original Path: sml/trunk/src/compiler/FLINT/trans/tempexpn.sml

1 :	monnier	16	(* 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 :
362 :			(*
363 :			* $Log: tempexpn.sml,v $
364 :			* Revision 1.2 1997/01/28 23:20:50 jhr
365 :			* Integer and word literals are now represented by IntInf.int (instead of
366 :			* as strings).
367 :			*
368 :			* Revision 1.1.1.1 1997/01/14 01:38:47 george
369 :			* Version 109.24
370 :			*
371 :			*)

---

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