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 251 - (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 197 val initKE : kenv
16 :    
17 : monnier 69 val tkAbs : kenv * (tvar * tkind) list * lvar ->
18 :     (kenv * (lexp * lexp -> lexp))
19 :     val tcLexp : kenv -> tyc -> lexp
20 : monnier 220 val tsLexp : kenv * tyc list -> lexp
21 : monnier 16
22 : monnier 69 val utgc : tyc * kenv * tyc -> value -> lexp
23 :     val utgd : tyc * kenv * tyc -> value -> lexp
24 :     val tgdc : int * tyc * kenv * tyc -> value -> lexp
25 :     val tgdd : int * tyc * kenv * tyc -> value -> lexp
26 : monnier 16
27 : monnier 69 val mkwrp : tyc * kenv * bool * tyc -> lexp -> lexp
28 :     val mkuwp : tyc * kenv * bool * tyc -> lexp -> lexp
29 : monnier 16
30 : monnier 69 val arrSub : tyc * kenv * lty * lty -> value list -> lexp
31 :     val arrUpd : tyc * kenv * PrimOp.primop * lty * lty -> value list -> lexp
32 :     val arrNew : tyc * lvar * lvar * kenv -> value list -> lexp
33 : monnier 16
34 :     end (* signature TYPEOPER *)
35 :    
36 : monnier 197 signature Outcome =
37 :     sig
38 :     datatype outcome = YES
39 :     | NO
40 :     | MAYBE of FLINT.lexp
41 :     end
42 :    
43 :     structure OT:Outcome = RuntimeType
44 :    
45 : monnier 16 structure TypeOper : TYPEOPER =
46 :     struct
47 :    
48 :     local structure DI = DebIndex
49 :     structure LT = LtyExtern
50 :     structure LV = LambdaVar
51 :     structure PO = PrimOp
52 :     structure PT = PrimTyc
53 :     structure BT = BasicTypes
54 :     structure TP = Types
55 : monnier 197 structure RT = RuntimeType
56 :     open LtyKernel FLINT OT
57 : monnier 16 in
58 :    
59 : monnier 69 type tkind = tkind
60 :     type tyc = tyc
61 :     type lty = lty
62 :     type tvar = LtyDef.tvar
63 :     type lvar = LV.lvar
64 :     type lexp = lexp
65 :     type value = value
66 : monnier 197 type kenv = RT.kenv
67 : monnier 16
68 : monnier 197 fun bug s = ErrorMsg.impossible ("TypeOper: " ^ s)
69 : monnier 16 fun say (s : string) = Control.Print.say s
70 : monnier 69 fun mkv _ = LV.mkLvar()
71 : monnier 16 val ident = fn le => le
72 : monnier 184 val fkfun = {isrec=NONE, known=false, inline=IH_ALWAYS, cconv=CC_FUN LT.ffc_fixed}
73 : monnier 16
74 : monnier 69 fun mkarw(ts1, ts2) = LT.tcc_arrow(LT.ffc_fixed, ts1, ts2)
75 :    
76 :     val lt_arw = LT.ltc_tyc o LT.tcc_arrow
77 : monnier 197
78 : monnier 69 fun wty tc =
79 :     (NONE, PO.WRAP, lt_arw(LT.ffc_fixed, [tc], [LT.tcc_void]), [])
80 :     fun uwty tc =
81 :     (NONE, PO.UNWRAP, lt_arw(LT.ffc_fixed, [LT.tcc_void], [tc]), [])
82 :    
83 :     fun FU_WRAP(tc, vs, v, e) = PRIMOP(wty tc, vs, v, e)
84 :     fun FU_UNWRAP(tc, vs, v, e) = PRIMOP(uwty tc, vs, v, e)
85 :     val FU_rk_tuple = FlintUtil.rk_tuple
86 :    
87 :     fun WRAP(t, u) =
88 :     let val v = mkv()
89 :     in FU_WRAP(t, [u], v, RET[VAR v])
90 :     end
91 :    
92 :     fun UNWRAP(t, u) =
93 :     let val v = mkv()
94 :     in FU_UNWRAP(t, [u], v, RET[VAR v])
95 :     end
96 :    
97 :     (****************************************************************************
98 :     * UTILITY FUNCTIONS AND CONSTANTS *
99 :     ****************************************************************************)
100 : monnier 197
101 : monnier 69 fun split(RET [v]) = (v, ident)
102 : monnier 16 | split x = let val v = mkv()
103 : monnier 69 in (VAR v, fn z => LET([v], x, z))
104 : monnier 16 end
105 :    
106 :     fun SELECTg(i, e) =
107 :     let val (v, hdr) = split e
108 : monnier 69 val x = mkv()
109 :     in hdr(SELECT(v, i, x, RET [VAR x]))
110 : monnier 16 end
111 :    
112 : monnier 69 fun FNg(vts, e) =
113 :     let val f = mkv()
114 :     in FIX([(fkfun, f, vts, e)], RET[VAR f])
115 :     end
116 :    
117 :     fun SELECTv(i, u) =
118 :     let val x = mkv()
119 :     in SELECT(u, i, x, RET [VAR x])
120 :     end
121 :    
122 : monnier 220 fun APPg(e1, e2) =
123 : monnier 16 let val (v1, h1) = split e1
124 : monnier 220 val (v2, h2) = split e2
125 :     in h1(h2(APP(v1, [v2])))
126 : monnier 16 end
127 :    
128 :     fun RECORDg es =
129 : monnier 69 let fun f ([], vs, hdr) =
130 :     let val x = mkv()
131 :     in hdr(RECORD(FU_rk_tuple, rev vs, x, RET[VAR x]))
132 :     end
133 : monnier 16 | f (e::r, vs, hdr) =
134 :     let val (v, h) = split e
135 :     in f(r, v::vs, hdr o h)
136 :     end
137 :     in f(es, [], ident)
138 :     end
139 :    
140 :     fun SRECORDg es =
141 : monnier 69 let fun f ([], vs, hdr) =
142 :     let val x = mkv()
143 :     in hdr(RECORD(RK_STRUCT, rev vs, x, RET[VAR x]))
144 :     end
145 : monnier 16 | f (e::r, vs, hdr) =
146 :     let val (v, h) = split e
147 :     in f(r, v::vs, hdr o h)
148 :     end
149 :     in f(es, [], ident)
150 :     end
151 :    
152 :     fun WRAPg (z, b, e) =
153 :     let val (v, h) = split e
154 : monnier 69 in h(WRAP(z, v))
155 : monnier 16 end
156 :    
157 :     fun UNWRAPg (z, b, e) =
158 :     let val (v, h) = split e
159 : monnier 69 in h(UNWRAP(z, v))
160 : monnier 16 end
161 :    
162 :     fun WRAPcast (z, b, e) =
163 :     let val (v, h) = split e
164 : monnier 69 val pt = LT.ltc_arrow(LT.ffc_fixed, [LT.ltc_tyc z], [LT.ltc_void])
165 :     val pv = (NONE,PO.CAST,pt,[])
166 :     val x = mkv()
167 :     in h(PRIMOP(pv, [v], x, RET[VAR x]))
168 : monnier 16 end
169 :    
170 :     fun UNWRAPcast (z, b, e) =
171 :     let val (v, h) = split e
172 : monnier 69 val pt = LT.ltc_arrow(LT.ffc_fixed, [LT.ltc_void], [LT.ltc_tyc z])
173 :     val pv = (NONE,PO.CAST,pt,[])
174 :     val x = mkv()
175 :     in h(PRIMOP(pv, [v], x, RET[VAR x]))
176 : monnier 16 end
177 :    
178 :     fun SWITCHg (e, s, ce, d) =
179 :     let val (v, h) = split e
180 :     in h(SWITCH(v, s, ce, d))
181 :     end
182 :    
183 : monnier 69 fun COND(u,e1,e2) = u(e1,e2)
184 : monnier 16
185 :    
186 :     (****************************************************************************
187 :     * KIND ENVIRONMENTS *
188 :     ****************************************************************************)
189 :    
190 : monnier 197 fun addKE(kenv, vs, ks) = RT.addKE
191 : monnier 16
192 :    
193 :     (****************************************************************************
194 :     * MAIN FUNCTIONS *
195 :     ****************************************************************************)
196 :    
197 : monnier 69 (* val tkAbsGen : kenv * lvar list * tkind list * lvar * fkind
198 :     -> kenv * ((lexp *lexp) -> lexp) *)
199 : monnier 197 val tkAbsGen = RT.tkAbsGen
200 : monnier 69
201 : monnier 16
202 : monnier 69 (* val tkAbs: kenv * (tvar * tkind) list -> kenv * (lexp * lexp -> lexp) *)
203 : monnier 197 val tkAbs = RT.tkAbs
204 : monnier 16
205 : monnier 69 (* val tkTfn: kenv * tkind list -> kenv * (lexp -> lexp) *)
206 : monnier 197 val tkTfn = RT.tkTfn
207 : monnier 16
208 : monnier 197 val ieqLexp = RT.ieqLexp
209 : monnier 16
210 : monnier 197 val iaddLexp = RT.iaddLexp
211 : monnier 69
212 : monnier 16
213 : monnier 197 val tovalue = RT.tovalue
214 :     val tcode_void = RT.tcode_void
215 :     val tcode_record = RT.tcode_record
216 :     val tcode_int32 = RT.tcode_int32
217 :     val tcode_pair = RT.tcode_pair
218 :     val tcode_fpair = RT.tcode_fpair
219 :     val tcode_real = RT.tcode_real
220 :     val tcode_realN = RT.tcode_realN
221 :    
222 :    
223 : monnier 69 (* tcLexp maps TC_VAR to proper lvars, TC_PRIM to proper constants *)
224 :     (* val tcLexp : kenv -> tyc -> lexp *)
225 : monnier 16
226 : monnier 197 val initKE = RT.initKE
227 : monnier 16
228 : monnier 197 val tcLexp = RT.rtLexp
229 :     val tsLexp = RT.tsLexp
230 : monnier 16
231 : monnier 197 val isFloat = RT.isFloat
232 : monnier 16
233 : monnier 197 val isPair = RT.isPair
234 : monnier 16
235 :    
236 :     (****************************************************************************
237 :     * TYPED INTERPRETATION OF UNTAGGED *
238 :     ****************************************************************************)
239 : monnier 197
240 : monnier 16 (** tc is of kind Omega; this function tests whether tc can be int31 ? *)
241 :     fun tcTag (kenv, tc) =
242 : monnier 69 let fun loop x = (* a lot of approximations in this function *)
243 : monnier 16 (case (tc_out x)
244 :     of (TC_PRIM pt) => if PT.unboxed pt then NO else YES
245 : monnier 69 (* if PT.ubxupd pt then YES else NO *)
246 : monnier 16 (* this is just an approximation *)
247 : monnier 102 | (TC_TUPLE (_, [])) => YES
248 : monnier 45 | (TC_TUPLE (_, ts)) => NO
249 : monnier 69 | (TC_ARROW (_,tc1,tc2)) => YES (* NO *)
250 : monnier 16 | (TC_ABS tx) => loop tx
251 : monnier 69 | (TC_TOKEN(_,tx)) => loop tx
252 : monnier 16 | (TC_FIX(_, i)) => YES
253 :     | (TC_APP(tx, _)) =>
254 :     (case tc_out tx
255 :     of (TC_APP _ | TC_PROJ _ | TC_VAR _) =>
256 : monnier 69 MAYBE (tcLexp kenv x)
257 : monnier 16 | _ => YES)
258 : monnier 69 | _ => (MAYBE (tcLexp kenv x)))
259 : monnier 16 in loop tc
260 :     end (* function tcTag *)
261 :    
262 : monnier 69 (* val utgc : tyc * kenv * tyc -> value -> lexp *)
263 :     fun utgc (tc, kenv, rt) =
264 : monnier 16 (case tcTag(kenv, tc)
265 : monnier 69 of YES => (fn u => let val v = mkv()
266 :     in RECORD(FU_rk_tuple, [u], v,
267 :     WRAP(LT.tcc_tuple[rt], VAR v))
268 :     end)
269 :     | NO => (fn u => WRAP(rt, u))
270 : monnier 16 | MAYBE ne =>
271 : monnier 69 (fn u => let val v = mkv()
272 :     val hh = ieqLexp(ne, tcode_void)
273 :     in COND(hh, RECORD(FU_rk_tuple, [u], v,
274 :     WRAP(LT.tcc_tuple[rt], VAR v)),
275 :     WRAP(rt, u))
276 :     end))
277 : monnier 16
278 : monnier 69 (* val utgd : tyc * kenv * tyc -> value -> lexp *)
279 :     fun utgd (tc, kenv, rt) =
280 : monnier 16 (case tcTag(kenv, tc)
281 : monnier 69 of YES => (fn u => let val v = mkv() and z = mkv()
282 :     in FU_UNWRAP(LT.tcc_tuple [rt], [u], v,
283 :     SELECT(VAR v, 0, z, RET[VAR z]))
284 :     end)
285 :     | NO => (fn u => UNWRAP(rt, u))
286 : monnier 16 | MAYBE ne =>
287 : monnier 69 (fn u => let val v = mkv() and z = mkv()
288 :     val hh = ieqLexp(ne, tcode_void)
289 :     in COND(hh, FU_UNWRAP(LT.tcc_tuple [rt], [u], v,
290 :     SELECT(VAR v, 0, z, RET[VAR z])),
291 :     UNWRAP(rt, u))
292 :     end))
293 : monnier 16
294 : monnier 69 (* val tgdc : int * tyc * kenv * tyc -> value -> lexp *)
295 :     fun tgdc (i, tc, kenv, rt) =
296 :     let val nt = LT.tcc_tuple [LT.tcc_int, rt]
297 :     in fn u => let val x = mkv()
298 :     in RECORD(FU_rk_tuple, [INT i, u], x, WRAP(nt, VAR x))
299 :     end
300 : monnier 16 end
301 :    
302 : monnier 69 (* val tgdd : int * tyc * kenv * tyc -> value -> lexp *)
303 :     fun tgdd (i, tc, kenv, rt) =
304 :     let val nt = LT.tcc_tuple [LT.tcc_int, rt]
305 :     in fn u => let val x = mkv() and v = mkv()
306 :     in FU_UNWRAP(nt, [u], x, SELECT(VAR x, 1, v, RET[VAR v]))
307 :     end
308 : monnier 16 end
309 :    
310 :     (****************************************************************************
311 :     * TYPED INTERPRETATION OF FP RECORD *
312 :     ****************************************************************************)
313 :     (** tc is a ground tyc of kind Omega, only record types and arrow types are
314 :     interesting for the time being. *)
315 :     (** all of these wrappers probably should be lifted to the top of the
316 :     program, otherwise we may run into space blow-up ! *)
317 :     (* val tcCoerce : kenv * tyc * bool * bool -> (lexp -> lexp) option *)
318 : monnier 69 fun tcCoerce (kenv, tc, nt, wflag, b) =
319 :     (case (tc_out tc, tc_out nt)
320 :     of (TC_TUPLE (_, ts), _) =>
321 : monnier 16 let fun h([], i, e, el, 0) = NONE
322 :     | h([], i, e, el, res) =
323 :     let val w = mkv()
324 :     val wx = VAR w
325 : monnier 69 fun g(i, NONE) = SELECTv(i, wx)
326 : monnier 16 | g(i, SOME _) =
327 :     if wflag then
328 : monnier 69 UNWRAPg(LT.tcc_real, b, SELECTv(i, wx))
329 :     else WRAPg(LT.tcc_real, b, SELECTv(i, wx))
330 : monnier 16
331 :     val ntc = LT.tcc_tuple(map (fn _ => LT.tcc_real) ts)
332 :    
333 :     val ne = RECORDg (map g (rev el))
334 : monnier 69 val test = ieqLexp(e, tcode_realN res)
335 : monnier 16
336 :     fun hdr0 xe =
337 :     if wflag then
338 : monnier 69 COND(test, LET([w], xe, WRAPcast(ntc, b, ne)),
339 :     WRAPcast(nt, b, xe))
340 :     else COND(test, LET([w], UNWRAPcast(ntc, b, xe), ne),
341 :     UNWRAPcast(nt, b, xe))
342 : monnier 16
343 : monnier 69 fun hdr (xe as (RET[(VAR _)])) = hdr0 xe
344 : monnier 16 | hdr xe = let val z = mkv()
345 : monnier 69 in LET([z], xe, hdr0 (RET[VAR z]))
346 : monnier 16 end
347 :     in SOME hdr
348 :     end
349 :     | h(a::r, i, e, el, res) =
350 :     (case isFloat(kenv, a)
351 :     of NO => NONE
352 :     | YES => h(r, i+1, e, (i,NONE)::el, res)
353 : monnier 69 | MAYBE z => h(r, i+1, iaddLexp(e, z),
354 : monnier 16 (i, SOME a)::el, res+1))
355 :    
356 : monnier 69 in h(ts, 0, RET[INT 0], [], 0)
357 : monnier 16 end
358 : monnier 69 | (TC_ARROW _, _) => (* (tc1, tc2) => *)
359 :     let val (tc1, _) = LT.tcd_parrow tc
360 :     val (_, tc2) = LT.tcd_parrow nt
361 : monnier 16 in (case isPair(kenv, tc1)
362 :     of (YES | NO) => NONE
363 :     | (MAYBE e) =>
364 :     let val w = mkv()
365 : monnier 69 val test1 = ieqLexp(RET[(VAR w)], tcode_pair)
366 :     val test2 = ieqLexp(RET[(VAR w)], tcode_fpair)
367 :     val m = mkv() and m2 = mkv()
368 :     val n = mkv() and n2 = mkv()
369 : monnier 16
370 :     val tc_real = LT.tcc_real
371 : monnier 69 val tc_breal = LT.tcc_void (* LT.tcc_wrap tc_real *)
372 :     val lt_breal = LT.ltc_tyc tc_breal
373 : monnier 16 val tc_void = LT.tcc_void
374 :     val lt_void = LT.ltc_void
375 :     val tc_pair = LT.tcc_tuple [tc_void, tc_void]
376 :     val tc_fpair = LT.tcc_tuple [tc_real, tc_real]
377 :     val tc_bfpair = LT.tcc_tuple [tc_breal, tc_breal]
378 :     val lt_pair = LT.ltc_tyc tc_pair
379 :     val lt_fpair = LT.ltc_tyc tc_fpair
380 :     val lt_bfpair = LT.ltc_tyc tc_bfpair
381 :     val ident = fn le => le
382 :    
383 : monnier 69 val (argt1, body1, hh1) =
384 : monnier 16 if wflag then (* wrapping *)
385 : monnier 69 ([(m,lt_void),(m2,lt_void)],
386 :     fn sv =>
387 :     let val xx = mkv() and yy = mkv()
388 :     in RECORD(FU_rk_tuple, [VAR m, VAR m2], xx,
389 :     FU_WRAP(tc_pair, [VAR xx], yy,
390 :     APP(sv, [VAR yy])))
391 :     end,
392 :     fn le =>
393 :     WRAPcast(mkarw([tc_void,tc_void],[tc2]),
394 :     true, le))
395 : monnier 16 else (* unwrapping *)
396 : monnier 69 let val x = mkv() and y = mkv() and z = mkv()
397 :     in ([(m, lt_void)],
398 :     fn sv =>
399 :     let val xx = mkv()
400 :     in LET([xx],
401 :     UNWRAPcast(
402 :     mkarw([tc_void, tc_void], [tc2]),
403 :     true, RET[sv]),
404 :     FU_UNWRAP(tc_pair, [VAR m], x,
405 :     SELECT(VAR x, 0, y,
406 :     SELECT(VAR x, 1, z,
407 :     APP(VAR xx, [VAR y, VAR z])))))
408 :     end,
409 :     ident)
410 : monnier 16 end
411 :    
412 : monnier 69 val (argt2, body2, hh2) =
413 :     if wflag then (* wrapping *)
414 :     ([(n,lt_breal),(n2,lt_breal)],
415 :     fn sv =>
416 :     let val xx = mkv() and yy = mkv()
417 :     in LET ([xx],
418 :     RECORDg [UNWRAP(tc_real, VAR n),
419 :     UNWRAP(tc_real, VAR n2)],
420 :     FU_WRAP(tc_fpair, [VAR xx], yy,
421 :     APP(sv, [VAR yy])))
422 :     end,
423 :     fn le => WRAPcast(mkarw([tc_breal,tc_breal],[tc2]),
424 :     true, le))
425 :     else (* unwrapping *)
426 :     let val x = mkv() and y = mkv() and z = mkv()
427 :     val q0 = mkv() and q1 = mkv()
428 :     in ([(n, lt_void)],
429 :     fn sv =>
430 :     let val xx = mkv()
431 :     in LET([xx],
432 :     UNWRAPcast(
433 :     mkarw([tc_breal, tc_breal], [tc2]),
434 :     true, RET[sv]),
435 :     FU_UNWRAP(tc_fpair, [VAR n], x,
436 :     SELECT(VAR x, 0, y,
437 :     FU_WRAP(tc_real, [VAR y], q0,
438 :     SELECT(VAR x, 1, z,
439 :     FU_WRAP(tc_real, [VAR z], q1,
440 :     APP(VAR xx, [VAR q0, VAR q1])))))))
441 :     end,
442 :     ident)
443 : monnier 16 end
444 :    
445 : monnier 69 val hh3 = if wflag then fn le => WRAPcast(nt, true, le)
446 :     else fn le => UNWRAPcast(nt, true, le)
447 : monnier 16
448 :     (*** NEEDS MORE WORK TO DO THE RIGHT COERCIONS ***)
449 :     fun hdr0(sv) =
450 : monnier 69 LET([w], e,
451 :     COND(test1, hh1(FNg(argt1, body1 sv)),
452 :     COND(test2, hh2(FNg(argt2, body2 sv)),
453 :     hh3(RET[sv]))))
454 : monnier 16
455 : monnier 69 fun hdr (xe as RET [sv]) = hdr0 sv
456 : monnier 16 | hdr xe = let val z = mkv()
457 : monnier 69 in LET([z], xe, hdr0(VAR z))
458 : monnier 16 end
459 :     in SOME hdr
460 :     end)
461 :     end
462 :     | _ => NONE)
463 :    
464 : monnier 69 (* val mkwrp : tyc * kenv * bool * tyc -> lexp -> lexp *)
465 :     fun mkwrp (tc, kenv, b, nt) =
466 :     (case tcCoerce(kenv, tc, nt, true, b)
467 :     of NONE => (fn le => WRAPg(nt, b, le))
468 : monnier 16 | SOME hdr => hdr)
469 :    
470 : monnier 69 (* val mkuwp : tyc * kenv * bool * tyc -> lexp -> lexp *)
471 :     fun mkuwp (tc, kenv, b, nt) =
472 :     (case tcCoerce(kenv, tc, nt, false, b)
473 :     of NONE => (fn le => UNWRAPg(nt, b, le))
474 : monnier 16 | SOME hdr => hdr)
475 :    
476 :     val realSub = PO.NUMSUBSCRIPT{kind=PO.FLOAT 64, checked=false, immutable=false}
477 :     val realUpd = PO.NUMUPDATE{kind=PO.FLOAT 64, checked=false}
478 :    
479 : monnier 69 fun rsubLexp (vs, t) =
480 :     let val x = mkv()
481 :     in PRIMOP((NONE, realSub, t, []), vs, x, RET[VAR x])
482 :     end
483 :    
484 :     fun rupdLexp (vs, t) =
485 :     let val x = mkv()
486 :     in PRIMOP((NONE, realUpd, t, []), vs, x, RET[VAR x])
487 :     end
488 :    
489 :     fun subLexp (vs, t) =
490 :     let val x = mkv()
491 :     in PRIMOP((NONE, PO.SUBSCRIPT, t, []), vs, x, RET[VAR x])
492 :     end
493 :    
494 :     fun updLexp (po, vs, t) =
495 :     let val x = mkv()
496 :     in PRIMOP((NONE, po, t, []), vs, x, RET[VAR x])
497 :     end
498 :    
499 :    
500 :     fun arrSub (tc, kenv, blt, rlt) =
501 :     let val nt = blt
502 :     val rnt = rlt
503 : monnier 16 in (case isFloat(kenv, tc)
504 : monnier 69 of NO => (fn vs => subLexp(vs, nt))
505 :     | YES => (fn vs => WRAPg(LT.tcc_real, true, rsubLexp(vs, rnt)))
506 : monnier 16 | MAYBE z =>
507 : monnier 69 (let val test = ieqLexp(z, tcode_real)
508 :     in (fn vs =>
509 :     COND(test, WRAPg(LT.tcc_real, true, rsubLexp(vs, rnt)),
510 :     subLexp(vs, nt)))
511 : monnier 16 end))
512 :     end
513 :    
514 : monnier 69 fun arrUpd(tc, kenv, po, blt, rlt) =
515 :     let val nt = blt
516 :     val rnt = rlt
517 : monnier 16 in (case isFloat(kenv,tc)
518 : monnier 69 of NO => (fn vs => updLexp(po, vs, nt))
519 :     | YES => (fn [x,y,z] =>
520 :     let val nz = mkv()
521 :     in LET([nz], UNWRAPg(LT.tcc_real, true, RET[z]),
522 :     rupdLexp([x,y,VAR nz], rnt))
523 :     end)
524 : monnier 16 | MAYBE z =>
525 : monnier 69 (let val test = ieqLexp(z, tcode_real)
526 :     in (fn (vs as [x,y,z]) =>
527 :     COND(test,
528 :     let val nz = mkv()
529 :     in LET([nz], UNWRAPg(LT.tcc_real, true, RET[z]),
530 :     rupdLexp([x,y,VAR nz], rnt))
531 :     end,
532 :     updLexp(po, vs, nt)))
533 : monnier 16 end))
534 :     end
535 :    
536 : monnier 69 fun arrNew(tc, pv, rv, kenv) =
537 : monnier 16 (case isFloat(kenv,tc)
538 : monnier 69 of NO => (fn vs =>
539 :     let val x= mkv()
540 :     in LET([x], APPg(RET[VAR pv], tsLexp(kenv, [tc])),
541 :     APP(VAR x, vs))
542 :     end)
543 :     | YES => (fn (vs as [x,y]) =>
544 :     let val z = mkv()
545 :     in LET([z], UNWRAPg(LT.tcc_real, true, RET[y]),
546 :     APP(VAR rv, [x, VAR z]))
547 :     end)
548 : monnier 16 | MAYBE z =>
549 : monnier 69 (let val test = ieqLexp(z, tcode_real)
550 :     in (fn (vs as [x,y]) =>
551 :     COND(test,
552 :     let val z = mkv()
553 :     in LET([z], UNWRAPg(LT.tcc_real, true, RET[y]),
554 :     APP(VAR rv, [x, VAR z]))
555 :     end,
556 :     let val z= mkv()
557 :     in LET([z], APPg(RET[VAR pv], tsLexp(kenv, [tc])),
558 :     APP(VAR z, vs))
559 :     end))
560 : monnier 16 end))
561 :    
562 :     end (* toplevel local *)
563 :     end (* structure TypeOper *)
564 :    

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