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 70 - (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 45 | (TC_TUPLE (_, ts)) => tcode_record
291 : monnier 16 | (TC_ARROW (_,tc1,tc2)) => tcode_void
292 :     | (TC_ABS tx) => loop tx
293 : monnier 69 | (TC_TOKEN(_,tx)) => loop tx
294 : monnier 16 | (TC_FIX((n,tx,ts), i)) =>
295 :     let val ntx =
296 :     (case ts
297 :     of [] => tx
298 :     | _ =>
299 :     (case tc_out tx
300 :     of TC_FN(_, x) => x
301 :     | _ => bug "unexpected FIX 333 in tcLexp-loop"))
302 :     val tk =
303 :     (case tc_out ntx
304 :     of TC_FN (ks, _) => List.nth(ks, i)
305 :     | _ => bug "unexpected FIX tycs in tcLexp-loop")
306 :     in case tk_out tk
307 : monnier 45 of TK_FUN(ks, _) =>
308 : monnier 69 (let val (_, hdr) = tkTfn(kenv, ks)
309 : monnier 45 in hdr(tcode_void)
310 :     end)
311 : monnier 16 | _ => tcode_void
312 :     end
313 :     | (TC_SUM _) => bug "unexpected TC_SUM tyc in tcLexp-loop"
314 :     | (TC_ENV _) => bug "unexpected TC_ENV tyc in tcLexp-loop"
315 :     | (TC_CONT _) => bug "unexpected TC_CONT tyc in tcLexp-loop"
316 :     | (TC_IND _) => bug "unexpected TC_IND tyc in tcLexp-loop"
317 :     | (TC_NVAR _) => bug "unexpected TC_NVAR tyc in tcLexp-loop"
318 :     | _ => bug "unexpected tyc in tcLexp-loop")
319 :     in loop tc
320 :     end (* function tcLexp *)
321 :    
322 :     and tcsLexp (kenv, ts) =
323 : monnier 69 let fun h tc = tcLexp kenv tc
324 : monnier 16 in RECORDg(map h ts)
325 :     end (* function tcsLexp *)
326 :    
327 :     and tsLexp (kenv, ts) =
328 : monnier 69 let fun h tc = tcLexp kenv tc
329 : monnier 16 in SRECORDg(map h ts)
330 :     end (* function tsLexp *)
331 :    
332 :     (** an improvement is to lift all of these code to the start of the
333 :     compilation unit *)
334 :     (*** THE FOLLOWING CODE IS ROUGH AND NEEDS TO BE POLISHED ! ***)
335 :     and isFloat (kenv, tc) =
336 :     let fun loop x =
337 :     (case (tc_out x)
338 :     of (TC_PRIM pt) =>
339 :     if (pt = PT.ptc_real) then YES else NO
340 : monnier 45 | (TC_TUPLE (_, ts)) => NO
341 : monnier 16 | (TC_ARROW (_,tc1,tc2)) => NO
342 : monnier 69 | (TC_TOKEN(_,tx)) => loop tx
343 : monnier 16 | (TC_FIX(_, i)) => NO
344 :     | (TC_APP(tx, _)) =>
345 :     (case tc_out tx
346 :     of (TC_APP _ | TC_PROJ _ | TC_VAR _) =>
347 : monnier 69 MAYBE(tcLexp kenv x)
348 : monnier 16 | _ => NO)
349 :     (* | (TC_ABS tx) => loop tx *)
350 :     | (TC_VAR(i,j)) =>
351 :     let val k = klookKE(kenv, i, j)
352 :     in case (tk_out k)
353 :     of TK_BOX => NO
354 : monnier 69 | _ => MAYBE(tcLexp kenv x)
355 : monnier 16 end
356 : monnier 69 | _ => MAYBE(tcLexp kenv x))
357 : monnier 16
358 :     in loop tc
359 :     end
360 :    
361 :     fun isPair (kenv, tc) =
362 :     let fun loop x =
363 :     (case (tc_out x)
364 :     of (TC_PRIM pt) => NO
365 : monnier 45 | (TC_TUPLE (_, [_,_])) => YES
366 : monnier 16 | (TC_TUPLE _) => NO
367 :     | (TC_ARROW _) => NO
368 : monnier 69 | (TC_TOKEN(_,tx)) => loop tx
369 : monnier 16 | (TC_FIX(_, i)) => NO
370 :     | (TC_APP(tx, _)) =>
371 :     (case tc_out tx
372 :     of (TC_APP _ | TC_PROJ _ | TC_VAR _ | TC_NVAR _) =>
373 : monnier 69 MAYBE(tcLexp kenv x)
374 : monnier 16 | _ => NO)
375 :     (* | (TC_ABS tx) => loop tx *)
376 : monnier 69 | _ => MAYBE(tcLexp kenv x))
377 : monnier 16
378 :     in loop tc
379 :     end
380 :    
381 :     (****************************************************************************
382 :     * TYPED INTERPRETATION OF UNTAGGED *
383 :     ****************************************************************************)
384 :     (** tc is of kind Omega; this function tests whether tc can be int31 ? *)
385 :     fun tcTag (kenv, tc) =
386 : monnier 69 let fun loop x = (* a lot of approximations in this function *)
387 : monnier 16 (case (tc_out x)
388 :     of (TC_PRIM pt) => if PT.unboxed pt then NO else YES
389 : monnier 69 (* if PT.ubxupd pt then YES else NO *)
390 : monnier 16 (* this is just an approximation *)
391 : monnier 45 | (TC_TUPLE (_, ts)) => NO
392 : monnier 69 | (TC_ARROW (_,tc1,tc2)) => YES (* NO *)
393 : monnier 16 | (TC_ABS tx) => loop tx
394 : monnier 69 | (TC_TOKEN(_,tx)) => loop tx
395 : monnier 16 | (TC_FIX(_, i)) => YES
396 :     | (TC_APP(tx, _)) =>
397 :     (case tc_out tx
398 :     of (TC_APP _ | TC_PROJ _ | TC_VAR _) =>
399 : monnier 69 MAYBE (tcLexp kenv x)
400 : monnier 16 | _ => YES)
401 : monnier 69 | _ => (MAYBE (tcLexp kenv x)))
402 : monnier 16 in loop tc
403 :     end (* function tcTag *)
404 :    
405 : monnier 69 (* val utgc : tyc * kenv * tyc -> value -> lexp *)
406 :     fun utgc (tc, kenv, rt) =
407 : monnier 16 (case tcTag(kenv, tc)
408 : monnier 69 of YES => (fn u => let val v = mkv()
409 :     in RECORD(FU_rk_tuple, [u], v,
410 :     WRAP(LT.tcc_tuple[rt], VAR v))
411 :     end)
412 :     | NO => (fn u => WRAP(rt, u))
413 : monnier 16 | MAYBE ne =>
414 : monnier 69 (fn u => let val v = mkv()
415 :     val hh = ieqLexp(ne, tcode_void)
416 :     in COND(hh, RECORD(FU_rk_tuple, [u], v,
417 :     WRAP(LT.tcc_tuple[rt], VAR v)),
418 :     WRAP(rt, u))
419 :     end))
420 : monnier 16
421 : monnier 69 (* val utgd : tyc * kenv * tyc -> value -> lexp *)
422 :     fun utgd (tc, kenv, rt) =
423 : monnier 16 (case tcTag(kenv, tc)
424 : monnier 69 of YES => (fn u => let val v = mkv() and z = mkv()
425 :     in FU_UNWRAP(LT.tcc_tuple [rt], [u], v,
426 :     SELECT(VAR v, 0, z, RET[VAR z]))
427 :     end)
428 :     | NO => (fn u => UNWRAP(rt, u))
429 : monnier 16 | MAYBE ne =>
430 : monnier 69 (fn u => let val v = mkv() and z = mkv()
431 :     val hh = ieqLexp(ne, tcode_void)
432 :     in COND(hh, FU_UNWRAP(LT.tcc_tuple [rt], [u], v,
433 :     SELECT(VAR v, 0, z, RET[VAR z])),
434 :     UNWRAP(rt, u))
435 :     end))
436 : monnier 16
437 : monnier 69 (* val tgdc : int * tyc * kenv * tyc -> value -> lexp *)
438 :     fun tgdc (i, tc, kenv, rt) =
439 :     let val nt = LT.tcc_tuple [LT.tcc_int, rt]
440 :     in fn u => let val x = mkv()
441 :     in RECORD(FU_rk_tuple, [INT i, u], x, WRAP(nt, VAR x))
442 :     end
443 : monnier 16 end
444 :    
445 : monnier 69 (* val tgdd : int * tyc * kenv * tyc -> value -> lexp *)
446 :     fun tgdd (i, tc, kenv, rt) =
447 :     let val nt = LT.tcc_tuple [LT.tcc_int, rt]
448 :     in fn u => let val x = mkv() and v = mkv()
449 :     in FU_UNWRAP(nt, [u], x, SELECT(VAR x, 1, v, RET[VAR v]))
450 :     end
451 : monnier 16 end
452 :    
453 :     (****************************************************************************
454 :     * TYPED INTERPRETATION OF FP RECORD *
455 :     ****************************************************************************)
456 :     (** tc is a ground tyc of kind Omega, only record types and arrow types are
457 :     interesting for the time being. *)
458 :     (** all of these wrappers probably should be lifted to the top of the
459 :     program, otherwise we may run into space blow-up ! *)
460 :     (* val tcCoerce : kenv * tyc * bool * bool -> (lexp -> lexp) option *)
461 : monnier 69 fun tcCoerce (kenv, tc, nt, wflag, b) =
462 :     (case (tc_out tc, tc_out nt)
463 :     of (TC_TUPLE (_, ts), _) =>
464 : monnier 16 let fun h([], i, e, el, 0) = NONE
465 :     | h([], i, e, el, res) =
466 :     let val w = mkv()
467 :     val wx = VAR w
468 : monnier 69 fun g(i, NONE) = SELECTv(i, wx)
469 : monnier 16 | g(i, SOME _) =
470 :     if wflag then
471 : monnier 69 UNWRAPg(LT.tcc_real, b, SELECTv(i, wx))
472 :     else WRAPg(LT.tcc_real, b, SELECTv(i, wx))
473 : monnier 16
474 :     val ntc = LT.tcc_tuple(map (fn _ => LT.tcc_real) ts)
475 :    
476 :     val ne = RECORDg (map g (rev el))
477 : monnier 69 val test = ieqLexp(e, tcode_realN res)
478 : monnier 16
479 :     fun hdr0 xe =
480 :     if wflag then
481 : monnier 69 COND(test, LET([w], xe, WRAPcast(ntc, b, ne)),
482 :     WRAPcast(nt, b, xe))
483 :     else COND(test, LET([w], UNWRAPcast(ntc, b, xe), ne),
484 :     UNWRAPcast(nt, b, xe))
485 : monnier 16
486 : monnier 69 fun hdr (xe as (RET[(VAR _)])) = hdr0 xe
487 : monnier 16 | hdr xe = let val z = mkv()
488 : monnier 69 in LET([z], xe, hdr0 (RET[VAR z]))
489 : monnier 16 end
490 :     in SOME hdr
491 :     end
492 :     | h(a::r, i, e, el, res) =
493 :     (case isFloat(kenv, a)
494 :     of NO => NONE
495 :     | YES => h(r, i+1, e, (i,NONE)::el, res)
496 : monnier 69 | MAYBE z => h(r, i+1, iaddLexp(e, z),
497 : monnier 16 (i, SOME a)::el, res+1))
498 :    
499 : monnier 69 in h(ts, 0, RET[INT 0], [], 0)
500 : monnier 16 end
501 : monnier 69 | (TC_ARROW _, _) => (* (tc1, tc2) => *)
502 :     let val (tc1, _) = LT.tcd_parrow tc
503 :     val (_, tc2) = LT.tcd_parrow nt
504 : monnier 16 in (case isPair(kenv, tc1)
505 :     of (YES | NO) => NONE
506 :     | (MAYBE e) =>
507 :     let val w = mkv()
508 : monnier 69 val test1 = ieqLexp(RET[(VAR w)], tcode_pair)
509 :     val test2 = ieqLexp(RET[(VAR w)], tcode_fpair)
510 :     val m = mkv() and m2 = mkv()
511 :     val n = mkv() and n2 = mkv()
512 : monnier 16
513 :     val tc_real = LT.tcc_real
514 : monnier 69 val tc_breal = LT.tcc_void (* LT.tcc_wrap tc_real *)
515 :     val lt_breal = LT.ltc_tyc tc_breal
516 : monnier 16 val tc_void = LT.tcc_void
517 :     val lt_void = LT.ltc_void
518 :     val tc_pair = LT.tcc_tuple [tc_void, tc_void]
519 :     val tc_fpair = LT.tcc_tuple [tc_real, tc_real]
520 :     val tc_bfpair = LT.tcc_tuple [tc_breal, tc_breal]
521 :     val lt_pair = LT.ltc_tyc tc_pair
522 :     val lt_fpair = LT.ltc_tyc tc_fpair
523 :     val lt_bfpair = LT.ltc_tyc tc_bfpair
524 :     val ident = fn le => le
525 :    
526 : monnier 69 val (argt1, body1, hh1) =
527 : monnier 16 if wflag then (* wrapping *)
528 : monnier 69 ([(m,lt_void),(m2,lt_void)],
529 :     fn sv =>
530 :     let val xx = mkv() and yy = mkv()
531 :     in RECORD(FU_rk_tuple, [VAR m, VAR m2], xx,
532 :     FU_WRAP(tc_pair, [VAR xx], yy,
533 :     APP(sv, [VAR yy])))
534 :     end,
535 :     fn le =>
536 :     WRAPcast(mkarw([tc_void,tc_void],[tc2]),
537 :     true, le))
538 : monnier 16 else (* unwrapping *)
539 : monnier 69 let val x = mkv() and y = mkv() and z = mkv()
540 :     in ([(m, lt_void)],
541 :     fn sv =>
542 :     let val xx = mkv()
543 :     in LET([xx],
544 :     UNWRAPcast(
545 :     mkarw([tc_void, tc_void], [tc2]),
546 :     true, RET[sv]),
547 :     FU_UNWRAP(tc_pair, [VAR m], x,
548 :     SELECT(VAR x, 0, y,
549 :     SELECT(VAR x, 1, z,
550 :     APP(VAR xx, [VAR y, VAR z])))))
551 :     end,
552 :     ident)
553 : monnier 16 end
554 :    
555 : monnier 69 val (argt2, body2, hh2) =
556 :     if wflag then (* wrapping *)
557 :     ([(n,lt_breal),(n2,lt_breal)],
558 :     fn sv =>
559 :     let val xx = mkv() and yy = mkv()
560 :     in LET ([xx],
561 :     RECORDg [UNWRAP(tc_real, VAR n),
562 :     UNWRAP(tc_real, VAR n2)],
563 :     FU_WRAP(tc_fpair, [VAR xx], yy,
564 :     APP(sv, [VAR yy])))
565 :     end,
566 :     fn le => WRAPcast(mkarw([tc_breal,tc_breal],[tc2]),
567 :     true, le))
568 :     else (* unwrapping *)
569 :     let val x = mkv() and y = mkv() and z = mkv()
570 :     val q0 = mkv() and q1 = mkv()
571 :     in ([(n, lt_void)],
572 :     fn sv =>
573 :     let val xx = mkv()
574 :     in LET([xx],
575 :     UNWRAPcast(
576 :     mkarw([tc_breal, tc_breal], [tc2]),
577 :     true, RET[sv]),
578 :     FU_UNWRAP(tc_fpair, [VAR n], x,
579 :     SELECT(VAR x, 0, y,
580 :     FU_WRAP(tc_real, [VAR y], q0,
581 :     SELECT(VAR x, 1, z,
582 :     FU_WRAP(tc_real, [VAR z], q1,
583 :     APP(VAR xx, [VAR q0, VAR q1])))))))
584 :     end,
585 :     ident)
586 : monnier 16 end
587 :    
588 : monnier 69 val hh3 = if wflag then fn le => WRAPcast(nt, true, le)
589 :     else fn le => UNWRAPcast(nt, true, le)
590 : monnier 16
591 :     (*** NEEDS MORE WORK TO DO THE RIGHT COERCIONS ***)
592 :     fun hdr0(sv) =
593 : monnier 69 LET([w], e,
594 :     COND(test1, hh1(FNg(argt1, body1 sv)),
595 :     COND(test2, hh2(FNg(argt2, body2 sv)),
596 :     hh3(RET[sv]))))
597 : monnier 16
598 : monnier 69 fun hdr (xe as RET [sv]) = hdr0 sv
599 : monnier 16 | hdr xe = let val z = mkv()
600 : monnier 69 in LET([z], xe, hdr0(VAR z))
601 : monnier 16 end
602 :     in SOME hdr
603 :     end)
604 :     end
605 :     | _ => NONE)
606 :    
607 : monnier 69 (* val mkwrp : tyc * kenv * bool * tyc -> lexp -> lexp *)
608 :     fun mkwrp (tc, kenv, b, nt) =
609 :     (case tcCoerce(kenv, tc, nt, true, b)
610 :     of NONE => (fn le => WRAPg(nt, b, le))
611 : monnier 16 | SOME hdr => hdr)
612 :    
613 : monnier 69 (* val mkuwp : tyc * kenv * bool * tyc -> lexp -> lexp *)
614 :     fun mkuwp (tc, kenv, b, nt) =
615 :     (case tcCoerce(kenv, tc, nt, false, b)
616 :     of NONE => (fn le => UNWRAPg(nt, b, le))
617 : monnier 16 | SOME hdr => hdr)
618 :    
619 :     val realSub = PO.NUMSUBSCRIPT{kind=PO.FLOAT 64, checked=false, immutable=false}
620 :     val realUpd = PO.NUMUPDATE{kind=PO.FLOAT 64, checked=false}
621 :    
622 : monnier 69 fun rsubLexp (vs, t) =
623 :     let val x = mkv()
624 :     in PRIMOP((NONE, realSub, t, []), vs, x, RET[VAR x])
625 :     end
626 :    
627 :     fun rupdLexp (vs, t) =
628 :     let val x = mkv()
629 :     in PRIMOP((NONE, realUpd, t, []), vs, x, RET[VAR x])
630 :     end
631 :    
632 :     fun subLexp (vs, t) =
633 :     let val x = mkv()
634 :     in PRIMOP((NONE, PO.SUBSCRIPT, t, []), vs, x, RET[VAR x])
635 :     end
636 :    
637 :     fun updLexp (po, vs, t) =
638 :     let val x = mkv()
639 :     in PRIMOP((NONE, po, t, []), vs, x, RET[VAR x])
640 :     end
641 :    
642 :    
643 :     fun arrSub (tc, kenv, blt, rlt) =
644 :     let val nt = blt
645 :     val rnt = rlt
646 : monnier 16 in (case isFloat(kenv, tc)
647 : monnier 69 of NO => (fn vs => subLexp(vs, nt))
648 :     | YES => (fn vs => WRAPg(LT.tcc_real, true, rsubLexp(vs, rnt)))
649 : monnier 16 | MAYBE z =>
650 : monnier 69 (let val test = ieqLexp(z, tcode_real)
651 :     in (fn vs =>
652 :     COND(test, WRAPg(LT.tcc_real, true, rsubLexp(vs, rnt)),
653 :     subLexp(vs, nt)))
654 : monnier 16 end))
655 :     end
656 :    
657 : monnier 69 fun arrUpd(tc, kenv, po, blt, rlt) =
658 :     let val nt = blt
659 :     val rnt = rlt
660 : monnier 16 in (case isFloat(kenv,tc)
661 : monnier 69 of NO => (fn vs => updLexp(po, vs, nt))
662 :     | YES => (fn [x,y,z] =>
663 :     let val nz = mkv()
664 :     in LET([nz], UNWRAPg(LT.tcc_real, true, RET[z]),
665 :     rupdLexp([x,y,VAR nz], rnt))
666 :     end)
667 : monnier 16 | MAYBE z =>
668 : monnier 69 (let val test = ieqLexp(z, tcode_real)
669 :     in (fn (vs as [x,y,z]) =>
670 :     COND(test,
671 :     let val nz = mkv()
672 :     in LET([nz], UNWRAPg(LT.tcc_real, true, RET[z]),
673 :     rupdLexp([x,y,VAR nz], rnt))
674 :     end,
675 :     updLexp(po, vs, nt)))
676 : monnier 16 end))
677 :     end
678 :    
679 : monnier 69 fun arrNew(tc, pv, rv, kenv) =
680 : monnier 16 (case isFloat(kenv,tc)
681 : monnier 69 of NO => (fn vs =>
682 :     let val x= mkv()
683 :     in LET([x], APPg(RET[VAR pv], tsLexp(kenv, [tc])),
684 :     APP(VAR x, vs))
685 :     end)
686 :     | YES => (fn (vs as [x,y]) =>
687 :     let val z = mkv()
688 :     in LET([z], UNWRAPg(LT.tcc_real, true, RET[y]),
689 :     APP(VAR rv, [x, VAR z]))
690 :     end)
691 : monnier 16 | MAYBE z =>
692 : monnier 69 (let val test = ieqLexp(z, tcode_real)
693 :     in (fn (vs as [x,y]) =>
694 :     COND(test,
695 :     let val z = mkv()
696 :     in LET([z], UNWRAPg(LT.tcc_real, true, RET[y]),
697 :     APP(VAR rv, [x, VAR z]))
698 :     end,
699 :     let val z= mkv()
700 :     in LET([z], APPg(RET[VAR pv], tsLexp(kenv, [tc])),
701 :     APP(VAR z, vs))
702 :     end))
703 : monnier 16 end))
704 :    
705 :     end (* toplevel local *)
706 :     end (* structure TypeOper *)
707 :    
708 :    

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