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/reps/typeoper.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/FLINT/reps/typeoper.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 102 - (view) (download)

1 : monnier 69 (* Copyright 1998 YALE FLINT PROJECT *)
2 : monnier 16 (* typeoper.sml *)
3 :    
4 :     signature TYPEOPER =
5 :     sig
6 :     type kenv
7 : monnier 69 type tkind = LtyDef.tkind
8 :     type tyc = LtyDef.tyc
9 :     type lty = LtyDef.lty
10 :     type tvar = LtyDef.tvar
11 :     type lvar = LambdaVar.lvar
12 :     type lexp = FLINT.lexp
13 :     type value = FLINT.value
14 :    
15 : monnier 16 val initKE : kenv
16 : monnier 69 val tkAbs : kenv * (tvar * tkind) list * lvar ->
17 :     (kenv * (lexp * lexp -> lexp))
18 :     val tcLexp : kenv -> tyc -> lexp
19 :     val tsLexp : kenv * tyc list -> lexp
20 : monnier 16
21 : monnier 69 val utgc : tyc * kenv * tyc -> value -> lexp
22 :     val utgd : tyc * kenv * tyc -> value -> lexp
23 :     val tgdc : int * tyc * kenv * tyc -> value -> lexp
24 :     val tgdd : int * tyc * kenv * tyc -> value -> lexp
25 : monnier 16
26 : monnier 69 val mkwrp : tyc * kenv * bool * tyc -> lexp -> lexp
27 :     val mkuwp : tyc * kenv * bool * tyc -> lexp -> lexp
28 : monnier 16
29 : monnier 69 val arrSub : tyc * kenv * lty * lty -> value list -> lexp
30 :     val arrUpd : tyc * kenv * PrimOp.primop * lty * lty -> value list -> lexp
31 :     val arrNew : tyc * lvar * lvar * kenv -> value list -> lexp
32 : monnier 16
33 :     end (* signature TYPEOPER *)
34 :    
35 :     structure TypeOper : TYPEOPER =
36 :     struct
37 :    
38 :     local structure DI = DebIndex
39 :     structure LT = LtyExtern
40 :     structure LV = LambdaVar
41 :     structure PO = PrimOp
42 :     structure PT = PrimTyc
43 :     structure BT = BasicTypes
44 :     structure TP = Types
45 : monnier 69 open LtyKernel FLINT RuntimeType
46 : monnier 16 in
47 :    
48 : monnier 69 type tkind = tkind
49 :     type tyc = tyc
50 :     type lty = lty
51 :     type tvar = LtyDef.tvar
52 :     type lvar = LV.lvar
53 :     type lexp = lexp
54 :     type value = value
55 : monnier 16
56 :     fun bug s = ErrorMsg.impossible ("LtyPrim: " ^ s)
57 :     fun say (s : string) = Control.Print.say s
58 : monnier 69 fun mkv _ = LV.mkLvar()
59 : monnier 16 val ident = fn le => le
60 : monnier 69 val fkfun = FK_FUN{isrec=NONE,known=false,inline=true, fixed=LT.ffc_fixed}
61 : monnier 16
62 : monnier 69 fun mkarw(ts1, ts2) = LT.tcc_arrow(LT.ffc_fixed, ts1, ts2)
63 :    
64 :     val lt_arw = LT.ltc_tyc o LT.tcc_arrow
65 :     fun wty tc =
66 :     (NONE, PO.WRAP, lt_arw(LT.ffc_fixed, [tc], [LT.tcc_void]), [])
67 :     fun uwty tc =
68 :     (NONE, PO.UNWRAP, lt_arw(LT.ffc_fixed, [LT.tcc_void], [tc]), [])
69 :    
70 :     fun FU_WRAP(tc, vs, v, e) = PRIMOP(wty tc, vs, v, e)
71 :     fun FU_UNWRAP(tc, vs, v, e) = PRIMOP(uwty tc, vs, v, e)
72 :     val FU_rk_tuple = FlintUtil.rk_tuple
73 :    
74 :     fun WRAP(t, u) =
75 :     let val v = mkv()
76 :     in FU_WRAP(t, [u], v, RET[VAR v])
77 :     end
78 :    
79 :     fun UNWRAP(t, u) =
80 :     let val v = mkv()
81 :     in FU_UNWRAP(t, [u], v, RET[VAR v])
82 :     end
83 :    
84 :     (****************************************************************************
85 :     * UTILITY FUNCTIONS AND CONSTANTS *
86 :     ****************************************************************************)
87 :     fun split(RET [v]) = (v, ident)
88 : monnier 16 | split x = let val v = mkv()
89 : monnier 69 in (VAR v, fn z => LET([v], x, z))
90 : monnier 16 end
91 :    
92 :     fun SELECTg(i, e) =
93 :     let val (v, hdr) = split e
94 : monnier 69 val x = mkv()
95 :     in hdr(SELECT(v, i, x, RET [VAR x]))
96 : monnier 16 end
97 :    
98 : monnier 69 fun FNg(vts, e) =
99 :     let val f = mkv()
100 :     in FIX([(fkfun, f, vts, e)], RET[VAR f])
101 :     end
102 :    
103 :     fun SELECTv(i, u) =
104 :     let val x = mkv()
105 :     in SELECT(u, i, x, RET [VAR x])
106 :     end
107 :    
108 : monnier 16 fun APPg(e1, e2) =
109 :     let val (v1, h1) = split e1
110 :     val (v2, h2) = split e2
111 : monnier 69 in h1(h2(APP(v1, [v2])))
112 : monnier 16 end
113 :    
114 :     fun RECORDg es =
115 : monnier 69 let fun f ([], vs, hdr) =
116 :     let val x = mkv()
117 :     in hdr(RECORD(FU_rk_tuple, rev vs, x, RET[VAR x]))
118 :     end
119 : monnier 16 | f (e::r, vs, hdr) =
120 :     let val (v, h) = split e
121 :     in f(r, v::vs, hdr o h)
122 :     end
123 :     in f(es, [], ident)
124 :     end
125 :    
126 :     fun SRECORDg es =
127 : monnier 69 let fun f ([], vs, hdr) =
128 :     let val x = mkv()
129 :     in hdr(RECORD(RK_STRUCT, rev vs, x, RET[VAR x]))
130 :     end
131 : monnier 16 | f (e::r, vs, hdr) =
132 :     let val (v, h) = split e
133 :     in f(r, v::vs, hdr o h)
134 :     end
135 :     in f(es, [], ident)
136 :     end
137 :    
138 :     fun WRAPg (z, b, e) =
139 :     let val (v, h) = split e
140 : monnier 69 in h(WRAP(z, v))
141 : monnier 16 end
142 :    
143 :     fun UNWRAPg (z, b, e) =
144 :     let val (v, h) = split e
145 : monnier 69 in h(UNWRAP(z, v))
146 : monnier 16 end
147 :    
148 :     fun WRAPcast (z, b, e) =
149 :     let val (v, h) = split e
150 : monnier 69 val pt = LT.ltc_arrow(LT.ffc_fixed, [LT.ltc_tyc z], [LT.ltc_void])
151 :     val pv = (NONE,PO.CAST,pt,[])
152 :     val x = mkv()
153 :     in h(PRIMOP(pv, [v], x, RET[VAR x]))
154 : monnier 16 end
155 :    
156 :     fun UNWRAPcast (z, b, e) =
157 :     let val (v, h) = split e
158 : monnier 69 val pt = LT.ltc_arrow(LT.ffc_fixed, [LT.ltc_void], [LT.ltc_tyc z])
159 :     val pv = (NONE,PO.CAST,pt,[])
160 :     val x = mkv()
161 :     in h(PRIMOP(pv, [v], x, RET[VAR x]))
162 : monnier 16 end
163 :    
164 :     fun SWITCHg (e, s, ce, d) =
165 :     let val (v, h) = split e
166 :     in h(SWITCH(v, s, ce, d))
167 :     end
168 :    
169 : monnier 69 fun COND(u,e1,e2) = u(e1,e2)
170 : monnier 16
171 :    
172 :     (****************************************************************************
173 :     * KIND ENVIRONMENTS *
174 :     ****************************************************************************)
175 :     type kenv = (LV.lvar list * tkind list) list
176 :    
177 :     val initKE = []
178 :     fun addKE(kenv, vs, ks) = (vs,ks)::kenv
179 :     fun vlookKE(kenv, i, j) =
180 :     let val (vs,_) = (List.nth(kenv, i-1)
181 :     handle _ => bug "unexpected case1 in vlookKE")
182 :     in ((List.nth(vs, j) handle _ => bug "unexpected case2 in vlookKE"))
183 :     end
184 :    
185 :     fun klookKE(kenv, i, j) =
186 :     let val (_,ks) = (List.nth(kenv, i-1)
187 :     handle _ => bug "unexpected case1 in klookKE")
188 :     in ((List.nth(ks, j) handle _ => bug "unexpected case2 in klookKE"))
189 :     end
190 :    
191 :     (****************************************************************************
192 :     * MAIN FUNCTIONS *
193 :     ****************************************************************************)
194 :    
195 : monnier 69 (* val tkAbsGen : kenv * lvar list * tkind list * lvar * fkind
196 :     -> kenv * ((lexp *lexp) -> lexp) *)
197 :     fun tkAbsGen (kenv, vs, ks, f, fk) =
198 :     let val mkArgTy = case fk of FK_FUN _ => LT.ltc_tuple
199 :     | FK_FCT => LT.ltc_str
200 :     val argt = mkArgTy (map LT.tk_lty ks)
201 :    
202 :     val w = mkv()
203 : monnier 16 fun h([], i, base) = base
204 : monnier 69 | h(v::r, i, base) = h(r, i+1, SELECT(VAR w, i, v, base))
205 :    
206 :     fun hdr (e1, e2) = FIX([(fk, f, [(w, argt)], h(vs,0,e1))], e2)
207 : monnier 16 in (addKE(kenv, vs, ks), hdr)
208 :     end
209 :    
210 : monnier 69 (* val tkAbs: kenv * (tvar * tkind) list -> kenv * (lexp * lexp -> lexp) *)
211 :     fun tkAbs (kenv, tvks, f) =
212 :     let val (vs, ks) = ListPair.unzip tvks
213 :     in tkAbsGen(kenv, vs, ks, f, FK_FCT)
214 :     end
215 : monnier 16
216 : monnier 69 (* val tkTfn: kenv * tkind list -> kenv * (lexp -> lexp) *)
217 :     fun tkTfn (kenv, ks) =
218 :     let val vs = map (fn _ => mkv ()) ks
219 :     val f = mkv()
220 :     val (nkenv, hdr) = tkAbsGen(kenv, vs, ks, f, fkfun)
221 :     in (nkenv, fn e => hdr(e, RET[VAR f]))
222 :     end
223 : monnier 16
224 : monnier 69 val intty = LT.ltc_int
225 :     val boolty = (* LT.ltc_bool *) LT.ltc_void
226 :     val inteqty = LT.ltc_arrow(LT.ffc_fixed, [intty, intty], [boolty])
227 :     val intopty = LT.ltc_arrow(LT.ffc_fixed, [intty, intty], [intty])
228 :     val ieqprim = (NONE, PO.IEQL, inteqty, [])
229 :     val iaddprim = (NONE, PO.IADD, intopty, [])
230 :     fun ieqLexp (e1, e2) =
231 :     let val (v1, h1) = split e1
232 :     val (v2, h2) = split e2
233 :     in fn (te, fe) => h1(h2(BRANCH(ieqprim, [v1,v2], te, fe)))
234 :     end
235 :     fun iaddLexp (e1, e2) =
236 :     let val (v1, h1) = split e1
237 :     val (v2, h2) = split e2
238 :     val x = mkv ()
239 :     in h1(h2(PRIMOP(iaddprim, [v1,v2], x, RET[VAR x])))
240 :     end
241 : monnier 16
242 : monnier 69 val tolexp = fn tcode => RET[tovalue tcode]
243 :     val tcode_void : lexp = tolexp tcode_void
244 :     val tcode_record : lexp = tolexp tcode_record
245 :     val tcode_int32 : lexp = tolexp tcode_int32
246 :     val tcode_pair : lexp = tolexp tcode_pair
247 :     val tcode_fpair : lexp = tolexp tcode_fpair
248 :     val tcode_real : lexp = tolexp tcode_real
249 :     val tcode_realN : int -> lexp = fn i => tolexp (tcode_realN i)
250 :    
251 : monnier 16 datatype outcome
252 :     = YES
253 :     | NO
254 :     | MAYBE of lexp
255 :    
256 : monnier 69 (* tcLexp maps TC_VAR to proper lvars, TC_PRIM to proper constants *)
257 :     (* val tcLexp : kenv -> tyc -> lexp *)
258 :     fun tcLexp (kenv : kenv) (tc : tyc) =
259 :     let fun loop (x : tyc) =
260 : monnier 16 (case (tc_out x)
261 :     of (TC_FN(ks, tx)) =>
262 : monnier 69 let val (nenv, hdr) = tkTfn(kenv, ks)
263 :     in hdr(tcLexp nenv tx)
264 : monnier 16 end
265 :     | (TC_APP(tx, ts)) =>
266 :     (case tc_out tx
267 :     of (TC_APP _ | TC_PROJ _ | TC_VAR _) =>
268 :     APPg(loop tx, tcsLexp(kenv, ts))
269 :     | _ => tcode_void)
270 :     | (TC_SEQ ts) => tcsLexp(kenv, ts)
271 :     | (TC_PROJ(tx, i)) => SELECTg(i, loop tx)
272 :     | (TC_PRIM pt) =>
273 :     if (pt = PT.ptc_real) then tcode_real
274 :     else if (pt = PT.ptc_int32) then tcode_int32
275 :     else tcode_void
276 : monnier 69 | (TC_VAR(i, j)) => RET[(VAR(vlookKE(kenv, i, j)))]
277 : monnier 45 | (TC_TUPLE (_, [t1,t2])) =>
278 : monnier 16 (case (isFloat(kenv,t1), isFloat(kenv,t2))
279 :     of (YES, YES) => tcode_fpair
280 :     | ((NO, _) | (_, NO)) => tcode_pair
281 :     | ((MAYBE e, YES) | (YES, MAYBE e)) =>
282 : monnier 69 let val test = ieqLexp(e, tcode_real)
283 : monnier 16 in COND(test, tcode_fpair, tcode_pair)
284 :     end
285 :     | (MAYBE e1, MAYBE e2) =>
286 : monnier 69 let val e = iaddLexp(e1, e2)
287 :     val test = ieqLexp(e, tcode_realN 2)
288 : monnier 16 in COND(test, tcode_fpair, tcode_pair)
289 :     end)
290 : monnier 102 | (TC_TUPLE (_, [])) => tcode_void
291 : monnier 45 | (TC_TUPLE (_, ts)) => tcode_record
292 : monnier 16 | (TC_ARROW (_,tc1,tc2)) => tcode_void
293 :     | (TC_ABS tx) => loop tx
294 : monnier 69 | (TC_TOKEN(_,tx)) => loop tx
295 : monnier 16 | (TC_FIX((n,tx,ts), i)) =>
296 :     let val ntx =
297 :     (case ts
298 :     of [] => tx
299 :     | _ =>
300 :     (case tc_out tx
301 :     of TC_FN(_, x) => x
302 :     | _ => bug "unexpected FIX 333 in tcLexp-loop"))
303 :     val tk =
304 :     (case tc_out ntx
305 :     of TC_FN (ks, _) => List.nth(ks, i)
306 :     | _ => bug "unexpected FIX tycs in tcLexp-loop")
307 :     in case tk_out tk
308 : monnier 45 of TK_FUN(ks, _) =>
309 : monnier 69 (let val (_, hdr) = tkTfn(kenv, ks)
310 : monnier 45 in hdr(tcode_void)
311 :     end)
312 : monnier 16 | _ => tcode_void
313 :     end
314 :     | (TC_SUM _) => bug "unexpected TC_SUM tyc in tcLexp-loop"
315 :     | (TC_ENV _) => bug "unexpected TC_ENV tyc in tcLexp-loop"
316 :     | (TC_CONT _) => bug "unexpected TC_CONT tyc in tcLexp-loop"
317 :     | (TC_IND _) => bug "unexpected TC_IND tyc in tcLexp-loop"
318 :     | (TC_NVAR _) => bug "unexpected TC_NVAR tyc in tcLexp-loop"
319 :     | _ => bug "unexpected tyc in tcLexp-loop")
320 :     in loop tc
321 :     end (* function tcLexp *)
322 :    
323 :     and tcsLexp (kenv, ts) =
324 : monnier 69 let fun h tc = tcLexp kenv tc
325 : monnier 16 in RECORDg(map h ts)
326 :     end (* function tcsLexp *)
327 :    
328 :     and tsLexp (kenv, ts) =
329 : monnier 69 let fun h tc = tcLexp kenv tc
330 : monnier 16 in SRECORDg(map h ts)
331 :     end (* function tsLexp *)
332 :    
333 :     (** an improvement is to lift all of these code to the start of the
334 :     compilation unit *)
335 :     (*** THE FOLLOWING CODE IS ROUGH AND NEEDS TO BE POLISHED ! ***)
336 :     and isFloat (kenv, tc) =
337 :     let fun loop x =
338 :     (case (tc_out x)
339 :     of (TC_PRIM pt) =>
340 :     if (pt = PT.ptc_real) then YES else NO
341 : monnier 45 | (TC_TUPLE (_, ts)) => NO
342 : monnier 16 | (TC_ARROW (_,tc1,tc2)) => NO
343 : monnier 69 | (TC_TOKEN(_,tx)) => loop tx
344 : monnier 16 | (TC_FIX(_, i)) => NO
345 :     | (TC_APP(tx, _)) =>
346 :     (case tc_out tx
347 :     of (TC_APP _ | TC_PROJ _ | TC_VAR _) =>
348 : monnier 69 MAYBE(tcLexp kenv x)
349 : monnier 16 | _ => NO)
350 :     (* | (TC_ABS tx) => loop tx *)
351 :     | (TC_VAR(i,j)) =>
352 :     let val k = klookKE(kenv, i, j)
353 :     in case (tk_out k)
354 :     of TK_BOX => NO
355 : monnier 69 | _ => MAYBE(tcLexp kenv x)
356 : monnier 16 end
357 : monnier 69 | _ => MAYBE(tcLexp kenv x))
358 : monnier 16
359 :     in loop tc
360 :     end
361 :    
362 :     fun isPair (kenv, tc) =
363 :     let fun loop x =
364 :     (case (tc_out x)
365 :     of (TC_PRIM pt) => NO
366 : monnier 45 | (TC_TUPLE (_, [_,_])) => YES
367 : monnier 16 | (TC_TUPLE _) => NO
368 :     | (TC_ARROW _) => NO
369 : monnier 69 | (TC_TOKEN(_,tx)) => loop tx
370 : monnier 16 | (TC_FIX(_, i)) => NO
371 :     | (TC_APP(tx, _)) =>
372 :     (case tc_out tx
373 :     of (TC_APP _ | TC_PROJ _ | TC_VAR _ | TC_NVAR _) =>
374 : monnier 69 MAYBE(tcLexp kenv x)
375 : monnier 16 | _ => NO)
376 :     (* | (TC_ABS tx) => loop tx *)
377 : monnier 69 | _ => MAYBE(tcLexp kenv x))
378 : monnier 16
379 :     in loop tc
380 :     end
381 :    
382 :     (****************************************************************************
383 :     * TYPED INTERPRETATION OF UNTAGGED *
384 :     ****************************************************************************)
385 :     (** tc is of kind Omega; this function tests whether tc can be int31 ? *)
386 :     fun tcTag (kenv, tc) =
387 : monnier 69 let fun loop x = (* a lot of approximations in this function *)
388 : monnier 16 (case (tc_out x)
389 :     of (TC_PRIM pt) => if PT.unboxed pt then NO else YES
390 : monnier 69 (* if PT.ubxupd pt then YES else NO *)
391 : monnier 16 (* this is just an approximation *)
392 : monnier 102 | (TC_TUPLE (_, [])) => YES
393 : monnier 45 | (TC_TUPLE (_, ts)) => NO
394 : monnier 69 | (TC_ARROW (_,tc1,tc2)) => YES (* NO *)
395 : monnier 16 | (TC_ABS tx) => loop tx
396 : monnier 69 | (TC_TOKEN(_,tx)) => loop tx
397 : monnier 16 | (TC_FIX(_, i)) => YES
398 :     | (TC_APP(tx, _)) =>
399 :     (case tc_out tx
400 :     of (TC_APP _ | TC_PROJ _ | TC_VAR _) =>
401 : monnier 69 MAYBE (tcLexp kenv x)
402 : monnier 16 | _ => YES)
403 : monnier 69 | _ => (MAYBE (tcLexp kenv x)))
404 : monnier 16 in loop tc
405 :     end (* function tcTag *)
406 :    
407 : monnier 69 (* val utgc : tyc * kenv * tyc -> value -> lexp *)
408 :     fun utgc (tc, kenv, rt) =
409 : monnier 16 (case tcTag(kenv, tc)
410 : monnier 69 of YES => (fn u => let val v = mkv()
411 :     in RECORD(FU_rk_tuple, [u], v,
412 :     WRAP(LT.tcc_tuple[rt], VAR v))
413 :     end)
414 :     | NO => (fn u => WRAP(rt, u))
415 : monnier 16 | MAYBE ne =>
416 : monnier 69 (fn u => let val v = mkv()
417 :     val hh = ieqLexp(ne, tcode_void)
418 :     in COND(hh, RECORD(FU_rk_tuple, [u], v,
419 :     WRAP(LT.tcc_tuple[rt], VAR v)),
420 :     WRAP(rt, u))
421 :     end))
422 : monnier 16
423 : monnier 69 (* val utgd : tyc * kenv * tyc -> value -> lexp *)
424 :     fun utgd (tc, kenv, rt) =
425 : monnier 16 (case tcTag(kenv, tc)
426 : monnier 69 of YES => (fn u => let val v = mkv() and z = mkv()
427 :     in FU_UNWRAP(LT.tcc_tuple [rt], [u], v,
428 :     SELECT(VAR v, 0, z, RET[VAR z]))
429 :     end)
430 :     | NO => (fn u => UNWRAP(rt, u))
431 : monnier 16 | MAYBE ne =>
432 : monnier 69 (fn u => let val v = mkv() and z = mkv()
433 :     val hh = ieqLexp(ne, tcode_void)
434 :     in COND(hh, FU_UNWRAP(LT.tcc_tuple [rt], [u], v,
435 :     SELECT(VAR v, 0, z, RET[VAR z])),
436 :     UNWRAP(rt, u))
437 :     end))
438 : monnier 16
439 : monnier 69 (* val tgdc : int * tyc * kenv * tyc -> value -> lexp *)
440 :     fun tgdc (i, tc, kenv, rt) =
441 :     let val nt = LT.tcc_tuple [LT.tcc_int, rt]
442 :     in fn u => let val x = mkv()
443 :     in RECORD(FU_rk_tuple, [INT i, u], x, WRAP(nt, VAR x))
444 :     end
445 : monnier 16 end
446 :    
447 : monnier 69 (* val tgdd : int * tyc * kenv * tyc -> value -> lexp *)
448 :     fun tgdd (i, tc, kenv, rt) =
449 :     let val nt = LT.tcc_tuple [LT.tcc_int, rt]
450 :     in fn u => let val x = mkv() and v = mkv()
451 :     in FU_UNWRAP(nt, [u], x, SELECT(VAR x, 1, v, RET[VAR v]))
452 :     end
453 : monnier 16 end
454 :    
455 :     (****************************************************************************
456 :     * TYPED INTERPRETATION OF FP RECORD *
457 :     ****************************************************************************)
458 :     (** tc is a ground tyc of kind Omega, only record types and arrow types are
459 :     interesting for the time being. *)
460 :     (** all of these wrappers probably should be lifted to the top of the
461 :     program, otherwise we may run into space blow-up ! *)
462 :     (* val tcCoerce : kenv * tyc * bool * bool -> (lexp -> lexp) option *)
463 : monnier 69 fun tcCoerce (kenv, tc, nt, wflag, b) =
464 :     (case (tc_out tc, tc_out nt)
465 :     of (TC_TUPLE (_, ts), _) =>
466 : monnier 16 let fun h([], i, e, el, 0) = NONE
467 :     | h([], i, e, el, res) =
468 :     let val w = mkv()
469 :     val wx = VAR w
470 : monnier 69 fun g(i, NONE) = SELECTv(i, wx)
471 : monnier 16 | g(i, SOME _) =
472 :     if wflag then
473 : monnier 69 UNWRAPg(LT.tcc_real, b, SELECTv(i, wx))
474 :     else WRAPg(LT.tcc_real, b, SELECTv(i, wx))
475 : monnier 16
476 :     val ntc = LT.tcc_tuple(map (fn _ => LT.tcc_real) ts)
477 :    
478 :     val ne = RECORDg (map g (rev el))
479 : monnier 69 val test = ieqLexp(e, tcode_realN res)
480 : monnier 16
481 :     fun hdr0 xe =
482 :     if wflag then
483 : monnier 69 COND(test, LET([w], xe, WRAPcast(ntc, b, ne)),
484 :     WRAPcast(nt, b, xe))
485 :     else COND(test, LET([w], UNWRAPcast(ntc, b, xe), ne),
486 :     UNWRAPcast(nt, b, xe))
487 : monnier 16
488 : monnier 69 fun hdr (xe as (RET[(VAR _)])) = hdr0 xe
489 : monnier 16 | hdr xe = let val z = mkv()
490 : monnier 69 in LET([z], xe, hdr0 (RET[VAR z]))
491 : monnier 16 end
492 :     in SOME hdr
493 :     end
494 :     | h(a::r, i, e, el, res) =
495 :     (case isFloat(kenv, a)
496 :     of NO => NONE
497 :     | YES => h(r, i+1, e, (i,NONE)::el, res)
498 : monnier 69 | MAYBE z => h(r, i+1, iaddLexp(e, z),
499 : monnier 16 (i, SOME a)::el, res+1))
500 :    
501 : monnier 69 in h(ts, 0, RET[INT 0], [], 0)
502 : monnier 16 end
503 : monnier 69 | (TC_ARROW _, _) => (* (tc1, tc2) => *)
504 :     let val (tc1, _) = LT.tcd_parrow tc
505 :     val (_, tc2) = LT.tcd_parrow nt
506 : monnier 16 in (case isPair(kenv, tc1)
507 :     of (YES | NO) => NONE
508 :     | (MAYBE e) =>
509 :     let val w = mkv()
510 : monnier 69 val test1 = ieqLexp(RET[(VAR w)], tcode_pair)
511 :     val test2 = ieqLexp(RET[(VAR w)], tcode_fpair)
512 :     val m = mkv() and m2 = mkv()
513 :     val n = mkv() and n2 = mkv()
514 : monnier 16
515 :     val tc_real = LT.tcc_real
516 : monnier 69 val tc_breal = LT.tcc_void (* LT.tcc_wrap tc_real *)
517 :     val lt_breal = LT.ltc_tyc tc_breal
518 : monnier 16 val tc_void = LT.tcc_void
519 :     val lt_void = LT.ltc_void
520 :     val tc_pair = LT.tcc_tuple [tc_void, tc_void]
521 :     val tc_fpair = LT.tcc_tuple [tc_real, tc_real]
522 :     val tc_bfpair = LT.tcc_tuple [tc_breal, tc_breal]
523 :     val lt_pair = LT.ltc_tyc tc_pair
524 :     val lt_fpair = LT.ltc_tyc tc_fpair
525 :     val lt_bfpair = LT.ltc_tyc tc_bfpair
526 :     val ident = fn le => le
527 :    
528 : monnier 69 val (argt1, body1, hh1) =
529 : monnier 16 if wflag then (* wrapping *)
530 : monnier 69 ([(m,lt_void),(m2,lt_void)],
531 :     fn sv =>
532 :     let val xx = mkv() and yy = mkv()
533 :     in RECORD(FU_rk_tuple, [VAR m, VAR m2], xx,
534 :     FU_WRAP(tc_pair, [VAR xx], yy,
535 :     APP(sv, [VAR yy])))
536 :     end,
537 :     fn le =>
538 :     WRAPcast(mkarw([tc_void,tc_void],[tc2]),
539 :     true, le))
540 : monnier 16 else (* unwrapping *)
541 : monnier 69 let val x = mkv() and y = mkv() and z = mkv()
542 :     in ([(m, lt_void)],
543 :     fn sv =>
544 :     let val xx = mkv()
545 :     in LET([xx],
546 :     UNWRAPcast(
547 :     mkarw([tc_void, tc_void], [tc2]),
548 :     true, RET[sv]),
549 :     FU_UNWRAP(tc_pair, [VAR m], x,
550 :     SELECT(VAR x, 0, y,
551 :     SELECT(VAR x, 1, z,
552 :     APP(VAR xx, [VAR y, VAR z])))))
553 :     end,
554 :     ident)
555 : monnier 16 end
556 :    
557 : monnier 69 val (argt2, body2, hh2) =
558 :     if wflag then (* wrapping *)
559 :     ([(n,lt_breal),(n2,lt_breal)],
560 :     fn sv =>
561 :     let val xx = mkv() and yy = mkv()
562 :     in LET ([xx],
563 :     RECORDg [UNWRAP(tc_real, VAR n),
564 :     UNWRAP(tc_real, VAR n2)],
565 :     FU_WRAP(tc_fpair, [VAR xx], yy,
566 :     APP(sv, [VAR yy])))
567 :     end,
568 :     fn le => WRAPcast(mkarw([tc_breal,tc_breal],[tc2]),
569 :     true, le))
570 :     else (* unwrapping *)
571 :     let val x = mkv() and y = mkv() and z = mkv()
572 :     val q0 = mkv() and q1 = mkv()
573 :     in ([(n, lt_void)],
574 :     fn sv =>
575 :     let val xx = mkv()
576 :     in LET([xx],
577 :     UNWRAPcast(
578 :     mkarw([tc_breal, tc_breal], [tc2]),
579 :     true, RET[sv]),
580 :     FU_UNWRAP(tc_fpair, [VAR n], x,
581 :     SELECT(VAR x, 0, y,
582 :     FU_WRAP(tc_real, [VAR y], q0,
583 :     SELECT(VAR x, 1, z,
584 :     FU_WRAP(tc_real, [VAR z], q1,
585 :     APP(VAR xx, [VAR q0, VAR q1])))))))
586 :     end,
587 :     ident)
588 : monnier 16 end
589 :    
590 : monnier 69 val hh3 = if wflag then fn le => WRAPcast(nt, true, le)
591 :     else fn le => UNWRAPcast(nt, true, le)
592 : monnier 16
593 :     (*** NEEDS MORE WORK TO DO THE RIGHT COERCIONS ***)
594 :     fun hdr0(sv) =
595 : monnier 69 LET([w], e,
596 :     COND(test1, hh1(FNg(argt1, body1 sv)),
597 :     COND(test2, hh2(FNg(argt2, body2 sv)),
598 :     hh3(RET[sv]))))
599 : monnier 16
600 : monnier 69 fun hdr (xe as RET [sv]) = hdr0 sv
601 : monnier 16 | hdr xe = let val z = mkv()
602 : monnier 69 in LET([z], xe, hdr0(VAR z))
603 : monnier 16 end
604 :     in SOME hdr
605 :     end)
606 :     end
607 :     | _ => NONE)
608 :    
609 : monnier 69 (* val mkwrp : tyc * kenv * bool * tyc -> lexp -> lexp *)
610 :     fun mkwrp (tc, kenv, b, nt) =
611 :     (case tcCoerce(kenv, tc, nt, true, b)
612 :     of NONE => (fn le => WRAPg(nt, b, le))
613 : monnier 16 | SOME hdr => hdr)
614 :    
615 : monnier 69 (* val mkuwp : tyc * kenv * bool * tyc -> lexp -> lexp *)
616 :     fun mkuwp (tc, kenv, b, nt) =
617 :     (case tcCoerce(kenv, tc, nt, false, b)
618 :     of NONE => (fn le => UNWRAPg(nt, b, le))
619 : monnier 16 | SOME hdr => hdr)
620 :    
621 :     val realSub = PO.NUMSUBSCRIPT{kind=PO.FLOAT 64, checked=false, immutable=false}
622 :     val realUpd = PO.NUMUPDATE{kind=PO.FLOAT 64, checked=false}
623 :    
624 : monnier 69 fun rsubLexp (vs, t) =
625 :     let val x = mkv()
626 :     in PRIMOP((NONE, realSub, t, []), vs, x, RET[VAR x])
627 :     end
628 :    
629 :     fun rupdLexp (vs, t) =
630 :     let val x = mkv()
631 :     in PRIMOP((NONE, realUpd, t, []), vs, x, RET[VAR x])
632 :     end
633 :    
634 :     fun subLexp (vs, t) =
635 :     let val x = mkv()
636 :     in PRIMOP((NONE, PO.SUBSCRIPT, t, []), vs, x, RET[VAR x])
637 :     end
638 :    
639 :     fun updLexp (po, vs, t) =
640 :     let val x = mkv()
641 :     in PRIMOP((NONE, po, t, []), vs, x, RET[VAR x])
642 :     end
643 :    
644 :    
645 :     fun arrSub (tc, kenv, blt, rlt) =
646 :     let val nt = blt
647 :     val rnt = rlt
648 : monnier 16 in (case isFloat(kenv, tc)
649 : monnier 69 of NO => (fn vs => subLexp(vs, nt))
650 :     | YES => (fn vs => WRAPg(LT.tcc_real, true, rsubLexp(vs, rnt)))
651 : monnier 16 | MAYBE z =>
652 : monnier 69 (let val test = ieqLexp(z, tcode_real)
653 :     in (fn vs =>
654 :     COND(test, WRAPg(LT.tcc_real, true, rsubLexp(vs, rnt)),
655 :     subLexp(vs, nt)))
656 : monnier 16 end))
657 :     end
658 :    
659 : monnier 69 fun arrUpd(tc, kenv, po, blt, rlt) =
660 :     let val nt = blt
661 :     val rnt = rlt
662 : monnier 16 in (case isFloat(kenv,tc)
663 : monnier 69 of NO => (fn vs => updLexp(po, vs, nt))
664 :     | YES => (fn [x,y,z] =>
665 :     let val nz = mkv()
666 :     in LET([nz], UNWRAPg(LT.tcc_real, true, RET[z]),
667 :     rupdLexp([x,y,VAR nz], rnt))
668 :     end)
669 : monnier 16 | MAYBE z =>
670 : monnier 69 (let val test = ieqLexp(z, tcode_real)
671 :     in (fn (vs as [x,y,z]) =>
672 :     COND(test,
673 :     let val nz = mkv()
674 :     in LET([nz], UNWRAPg(LT.tcc_real, true, RET[z]),
675 :     rupdLexp([x,y,VAR nz], rnt))
676 :     end,
677 :     updLexp(po, vs, nt)))
678 : monnier 16 end))
679 :     end
680 :    
681 : monnier 69 fun arrNew(tc, pv, rv, kenv) =
682 : monnier 16 (case isFloat(kenv,tc)
683 : monnier 69 of NO => (fn vs =>
684 :     let val x= mkv()
685 :     in LET([x], APPg(RET[VAR pv], tsLexp(kenv, [tc])),
686 :     APP(VAR x, vs))
687 :     end)
688 :     | YES => (fn (vs as [x,y]) =>
689 :     let val z = mkv()
690 :     in LET([z], UNWRAPg(LT.tcc_real, true, RET[y]),
691 :     APP(VAR rv, [x, VAR z]))
692 :     end)
693 : monnier 16 | MAYBE z =>
694 : monnier 69 (let val test = ieqLexp(z, tcode_real)
695 :     in (fn (vs as [x,y]) =>
696 :     COND(test,
697 :     let val z = mkv()
698 :     in LET([z], UNWRAPg(LT.tcc_real, true, RET[y]),
699 :     APP(VAR rv, [x, VAR z]))
700 :     end,
701 :     let val z= mkv()
702 :     in LET([z], APPg(RET[VAR pv], tsLexp(kenv, [tc])),
703 :     APP(VAR z, vs))
704 :     end))
705 : monnier 16 end))
706 :    
707 :     end (* toplevel local *)
708 :     end (* structure TypeOper *)
709 :    
710 :    
711 : league 78
712 :     (*
713 :     * $Log: typeoper.sml,v $
714 :     * Revision 1.1.1.1 1998/04/08 18:39:44 george
715 :     * Version 110.5
716 :     *
717 :     *)

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