Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/trunk/src/compiler/FLINT/reps/typeoper.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 68, Fri Apr 3 00:06:42 1998 UTC revision 69, Fri Apr 3 00:06:55 1998 UTC
# Line 1  Line 1 
1  (* Copyright 1996 by Bell Laboratories *)  (* Copyright 1998 YALE FLINT PROJECT *)
2  (* typeoper.sml *)  (* typeoper.sml *)
3    
4  signature TYPEOPER =  signature TYPEOPER =
5  sig  sig
6    type kenv    type kenv
7    val initKE : kenv    type tkind = LtyDef.tkind
8      type tyc   = LtyDef.tyc
9    val tkLexp : kenv * LtyKernel.tkind list ->    type lty   = LtyDef.lty
10                                (kenv * (Lambda.lexp -> Lambda.lexp))    type tvar  = LtyDef.tvar
11      type lvar  = LambdaVar.lvar
12    val tcLexp  : kenv * LtyKernel.tyc -> Lambda.lexp    type lexp  = FLINT.lexp
13    val tsLexp : kenv * LtyKernel.tyc list -> Lambda.lexp    type value = FLINT.value
14    
15    val utgc : kenv * LtyKernel.tyc -> Lambda.lexp -> Lambda.lexp    val initKE : kenv
16    val utgd : kenv * LtyKernel.tyc -> Lambda.lexp -> Lambda.lexp    val tkAbs  : kenv * (tvar * tkind) list * lvar ->
17    val tgdc : kenv * int * LtyKernel.tyc -> Lambda.lexp -> Lambda.lexp                    (kenv * (lexp * lexp -> lexp))
18    val tgdd : kenv * int * LtyKernel.tyc -> Lambda.lexp -> Lambda.lexp    val tcLexp : kenv -> tyc -> lexp
19      val tsLexp : kenv * tyc list -> lexp
20    val mkwrp : kenv * bool * LtyKernel.tyc -> Lambda.lexp -> Lambda.lexp  
21    val mkuwp : kenv * bool * LtyKernel.tyc -> Lambda.lexp -> Lambda.lexp    val utgc   : tyc * kenv * tyc -> value -> lexp
22      val utgd   : tyc * kenv * tyc -> value -> lexp
23    val arrSub : kenv * LtyKernel.lty * LtyKernel.tyc    val tgdc   : int * tyc * kenv * tyc -> value -> lexp
24                   -> Lambda.value -> Lambda.lexp    val tgdd   : int * tyc * kenv * tyc -> value -> lexp
25    val arrUpd : kenv * LtyKernel.lty * LtyKernel.tyc  
26                   -> Lambda.value -> Lambda.lexp    val mkwrp  : tyc * kenv * bool * tyc -> lexp -> lexp
27    val arrNew : kenv * LtyKernel.lty * LtyKernel.tyc * LambdaVar.lvar    val mkuwp  : tyc * kenv * bool * tyc -> lexp -> lexp
28                   * LambdaVar.lvar -> Lambda.value -> Lambda.lexp  
29      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    
33  end (* signature TYPEOPER *)  end (* signature TYPEOPER *)
34    
# Line 39  Line 42 
42        structure PT = PrimTyc        structure PT = PrimTyc
43        structure BT = BasicTypes        structure BT = BasicTypes
44        structure TP = Types        structure TP = Types
45        open LtyKernel Lambda        open LtyKernel FLINT RuntimeType
46  in  in
47    
48  (****************************************************************************  type tkind = tkind
49   *                  UTILITY FUNCTIONS AND CONSTANTS                         *  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    
56  fun bug s = ErrorMsg.impossible ("LtyPrim: " ^ s)  fun bug s = ErrorMsg.impossible ("LtyPrim: " ^ s)
57  fun say (s : string) = Control.Print.say s  fun say (s : string) = Control.Print.say s
58    fun mkv _ = LV.mkLvar()
 val mkv = LV.mkLvar  
59  val ident = fn le => le  val ident = fn le => le
60    val fkfun = FK_FUN{isrec=NONE,known=false,inline=true, fixed=LT.ffc_fixed}
61    
62  fun split(SVAL v) = (v, ident)  fun mkarw(ts1, ts2) = LT.tcc_arrow(LT.ffc_fixed, ts1, ts2)
63    | split x = let val v = mkv()  
64                 in (VAR v, fn z => LET(v, x, z))  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                end
78    
79  fun ltAppSt (lt, ts) =  fun UNWRAP(t, u) =
80    (case LT.lt_inst(lt, ts)    let val v = mkv()
81      of [b] => b     in FU_UNWRAP(t, [u], v, RET[VAR v])
82       | _ => bug "unexpected case in ltAppSt")    end
83    
84    (****************************************************************************
85     *                  UTILITY FUNCTIONS AND CONSTANTS                         *
86     ****************************************************************************)
87    fun split(RET [v]) = (v, ident)
88      | split x = let val v = mkv()
89                   in (VAR v, fn z => LET([v], x, z))
90                  end
91    
92  fun SELECTg(i, e) =  fun SELECTg(i, e) =
93    let val (v, hdr) = split e    let val (v, hdr) = split e
94     in hdr(SELECT(i, v))        val x = mkv()
95       in hdr(SELECT(v, i, x, RET [VAR x]))
96      end
97    
98    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    end
107    
108  fun APPg(e1, e2) =  fun APPg(e1, e2) =
109    let val (v1, h1) = split e1    let val (v1, h1) = split e1
110        val (v2, h2) = split e2        val (v2, h2) = split e2
111     in h1(h2(APP(v1, v2)))     in h1(h2(APP(v1, [v2])))
112    end    end
113    
114  fun RECORDg es =  fun RECORDg es =
115    let fun f ([], vs, hdr) = hdr(RECORD (rev vs))    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          | f (e::r, vs, hdr) =          | f (e::r, vs, hdr) =
120                let val (v, h) = split e                let val (v, h) = split e
121                 in f(r, v::vs, hdr o h)                 in f(r, v::vs, hdr o h)
# Line 83  Line 124 
124    end    end
125    
126  fun SRECORDg es =  fun SRECORDg es =
127    let fun f ([], vs, hdr) = hdr(SRECORD (rev vs))    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          | f (e::r, vs, hdr) =          | f (e::r, vs, hdr) =
132                let val (v, h) = split e                let val (v, h) = split e
133                 in f(r, v::vs, hdr o h)                 in f(r, v::vs, hdr o h)
# Line 93  Line 137 
137    
138  fun WRAPg (z, b, e) =  fun WRAPg (z, b, e) =
139    let val (v, h) = split e    let val (v, h) = split e
140     in h(WRAP(z, b, v))     in h(WRAP(z, v))
141    end    end
142    
143  fun UNWRAPg (z, b, e) =  fun UNWRAPg (z, b, e) =
144    let val (v, h) = split e    let val (v, h) = split e
145     in h(UNWRAP(z, b, v))     in h(UNWRAP(z, v))
146    end    end
147    
148  fun WRAPcast (z, b, e) =  fun WRAPcast (z, b, e) =
149    let val (v, h) = split e    let val (v, h) = split e
150        val pt = LT.ltc_arw(LT.ltc_tyc z, LT.ltc_tyc(LT.tcc_box z))        val pt = LT.ltc_arrow(LT.ffc_fixed, [LT.ltc_tyc z], [LT.ltc_void])
151        val pv = PRIM(PO.CAST,pt,[])        val pv = (NONE,PO.CAST,pt,[])
152     in h(APP(pv, v))        val x = mkv()
153       in h(PRIMOP(pv, [v], x, RET[VAR x]))
154    end    end
155    
156  fun UNWRAPcast (z, b, e) =  fun UNWRAPcast (z, b, e) =
157    let val (v, h) = split e    let val (v, h) = split e
158        val pt = LT.ltc_arw(LT.ltc_tyc(LT.tcc_box z), LT.ltc_tyc z)        val pt = LT.ltc_arrow(LT.ffc_fixed, [LT.ltc_void], [LT.ltc_tyc z])
159        val pv = PRIM(PO.CAST,pt,[])        val pv = (NONE,PO.CAST,pt,[])
160     in h(APP(pv, v))        val x = mkv()
161       in h(PRIMOP(pv, [v], x, RET[VAR x]))
162    end    end
163    
164  fun SWITCHg (e, s, ce, d) =  fun SWITCHg (e, s, ce, d) =
# Line 120  Line 166 
166     in h(SWITCH(v, s, ce, d))     in h(SWITCH(v, s, ce, d))
167    end    end
168    
169  fun fromto(i,j) = if i < j then (i::fromto(i+1,j)) else []  fun COND(u,e1,e2) = u(e1,e2)
   
 fun option(NONE) = false  
   | option(SOME _) = true  
   
 fun exists(p, a::r) = if p a then true else exists(p, r)  
   | exists(p, []) = false  
   
 fun opList l = exists(option, l)  
170    
 fun force (NONE, le) = le  
   | force (SOME f, le) = f le  
   
 val boolsign = BT.boolsign  
 val (trueDcon', falseDcon') =  
   let val lt = LT.ltc_parrow(LT.ltc_unit, LT.ltc_bool)  
       fun h (TP.DATACON{name,rep,typ,...}) = (name, rep, lt)  
    in (h BT.trueDcon, h BT.falseDcon)  
   end  
   
 fun COND(a,b,c) =  
   SWITCHg(a, boolsign, [(DATAcon(trueDcon'),b),  
                        (DATAcon(falseDcon'),c)], NONE)  
171    
172  (****************************************************************************  (****************************************************************************
173   *                           KIND ENVIRONMENTS                              *   *                           KIND ENVIRONMENTS                              *
# Line 167  Line 192 
192   *                            MAIN FUNCTIONS                                *   *                            MAIN FUNCTIONS                                *
193   ****************************************************************************)   ****************************************************************************)
194    
195  val tkLty = LT.tk_lty  (* 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 tkLexp: kenv * tkind list -> kenv * (lexp -> lexp) *)        val w = mkv()
 fun tkLexpG (kenv, ks, record) =  
   let val w = mkv()  
       val vs = map (fn _ => mkv ()) ks  
       val argt = record(map tkLty ks)  
203        fun h([], i, base) = base        fun h([], i, base) = base
204          | h(v::r, i, base) = h(r, i+1, LET(v, SELECT(i, VAR w), base))          | h(v::r, i, base) = h(r, i+1, SELECT(VAR w, i, v, base))
205        fun hdr le = FN(w, argt, h(vs, 0, le))  
206          fun hdr (e1, e2) = FIX([(fk, f, [(w, argt)], h(vs,0,e1))], e2)
207     in (addKE(kenv, vs, ks), hdr)     in (addKE(kenv, vs, ks), hdr)
208    end    end
209    
210  fun tkLexp (kenv, ks) = tkLexpG(kenv, ks, LT.ltc_str)  (* 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    
216    (* 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    
224    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    
242  (** mapping TC_VAR to proper lvars; TC_PRIM to proper constants *)  val tolexp = fn tcode => RET[tovalue tcode]
243  (** the actual type calculations should be lifted up till the innermost TFN *)  val tcode_void   : lexp = tolexp tcode_void
244  (* val tcLexp : kenv * tyc -> lexp *)  val tcode_record : lexp = tolexp tcode_record
245    val tcode_int32  : lexp = tolexp tcode_int32
246  val tcode_void = SVAL(INT 0)  val tcode_pair   : lexp = tolexp tcode_pair
247  val tcode_record = SVAL(INT 1)  val tcode_fpair  : lexp = tolexp tcode_fpair
248  val tcode_int32 = SVAL(INT 2)  val tcode_real   : lexp = tolexp tcode_real
249  val tcode_pair = SVAL(INT 3)  val tcode_realN  : int -> lexp = fn i => tolexp (tcode_realN i)
 val tcode_fpair = SVAL(INT 4)  
 val tcode_real = SVAL(INT 5)  
 fun tcode_realN n = SVAL(INT(n * 5))  
250    
251  datatype outcome  datatype outcome
252    = YES    = YES
253    | NO    | NO
254    | MAYBE of lexp    | MAYBE of lexp
255    
256  val intty = LT.ltc_int  (* tcLexp maps TC_VAR to proper lvars, TC_PRIM to proper constants *)
257  val boolty = LT.ltc_bool  (* val tcLexp : kenv -> tyc -> lexp *)
258  val inteqty = LT.ltc_arw(LT.ltc_tuple [intty, intty], boolty)  fun tcLexp (kenv : kenv) (tc : tyc) =
259  val intopty = LT.ltc_arw(LT.ltc_tuple [intty, intty], intty)    let fun loop (x : tyc) =
 val ieq = SVAL(PRIM(PO.IEQL, inteqty, []))  
 val iadd = SVAL(PRIM(PO.IADD, intopty, []))  
   
 fun tcLexp (kenv, tc) =  
   let fun loop x =  
260          (case (tc_out x)          (case (tc_out x)
261            of (TC_FN(ks, tx)) =>            of (TC_FN(ks, tx)) =>
262                  let val (nenv, hdr) = tkLexpG(kenv, ks, LT.ltc_tuple)                  let val (nenv, hdr) = tkTfn(kenv, ks)
263                   in hdr(tcLexp(nenv, tx))                   in hdr(tcLexp nenv tx)
264                  end                  end
265             | (TC_APP(tx, ts)) =>             | (TC_APP(tx, ts)) =>
266                  (case tc_out tx                  (case tc_out tx
# Line 224  Line 273 
273                  if (pt = PT.ptc_real) then tcode_real                  if (pt = PT.ptc_real) then tcode_real
274                  else if (pt = PT.ptc_int32) then tcode_int32                  else if (pt = PT.ptc_int32) then tcode_int32
275                       else tcode_void                       else tcode_void
276             | (TC_VAR(i, j)) => SVAL(VAR(vlookKE(kenv, i, j)))             | (TC_VAR(i, j)) => RET[(VAR(vlookKE(kenv, i, j)))]
277             | (TC_TUPLE (_, [t1,t2])) =>             | (TC_TUPLE (_, [t1,t2])) =>
278                  (case (isFloat(kenv,t1), isFloat(kenv,t2))                  (case (isFloat(kenv,t1), isFloat(kenv,t2))
279                    of (YES, YES) => tcode_fpair                    of (YES, YES) => tcode_fpair
280                     | ((NO, _) | (_, NO)) => tcode_pair                     | ((NO, _) | (_, NO)) => tcode_pair
281                     | ((MAYBE e, YES) | (YES, MAYBE e)) =>                     | ((MAYBE e, YES) | (YES, MAYBE e)) =>
282                          let val test = APPg(ieq, RECORDg[e, tcode_real])                          let val test = ieqLexp(e, tcode_real)
283                           in COND(test, tcode_fpair, tcode_pair)                           in COND(test, tcode_fpair, tcode_pair)
284                          end                          end
285                     | (MAYBE e1, MAYBE e2) =>                     | (MAYBE e1, MAYBE e2) =>
286                          let val e = APPg(iadd, RECORDg [e1, e2])                          let val e = iaddLexp(e1, e2)
287                              val test = APPg(ieq, RECORDg [e, tcode_realN 2])                              val test = ieqLexp(e, tcode_realN 2)
288                           in COND(test, tcode_fpair, tcode_pair)                           in COND(test, tcode_fpair, tcode_pair)
289                          end)                          end)
290             | (TC_TUPLE (_, ts)) => tcode_record             | (TC_TUPLE (_, ts)) => tcode_record
291             | (TC_ARROW (_,tc1,tc2)) => tcode_void             | (TC_ARROW (_,tc1,tc2)) => tcode_void
292             | (TC_ABS tx) => loop tx             | (TC_ABS tx) => loop tx
293             | (TC_BOX tx) => loop tx             | (TC_TOKEN(_,tx)) => loop tx
294             | (TC_FIX((n,tx,ts), i)) =>             | (TC_FIX((n,tx,ts), i)) =>
295                  let val ntx =                  let val ntx =
296                        (case ts                        (case ts
# Line 256  Line 305 
305                          | _ => bug "unexpected FIX tycs in tcLexp-loop")                          | _ => bug "unexpected FIX tycs in tcLexp-loop")
306                   in case tk_out tk                   in case tk_out tk
307                       of TK_FUN(ks, _) =>                       of TK_FUN(ks, _) =>
308                            (let val (_, hdr) =                            (let val (_, hdr) = tkTfn(kenv, ks)
                                         tkLexpG(kenv, ks, LT.ltc_tuple)  
309                              in hdr(tcode_void)                              in hdr(tcode_void)
310                             end)                             end)
311                        | _ => tcode_void                        | _ => tcode_void
312                  end                  end
            | (TC_TOKEN _) => bug "TC_TOKEN tyc currently not supported"  
313             | (TC_SUM _) => bug "unexpected TC_SUM tyc in tcLexp-loop"             | (TC_SUM _) => bug "unexpected TC_SUM tyc in tcLexp-loop"
314             | (TC_ENV _) => bug "unexpected TC_ENV tyc in tcLexp-loop"             | (TC_ENV _) => bug "unexpected TC_ENV tyc in tcLexp-loop"
315             | (TC_CONT _) => bug "unexpected TC_CONT tyc in tcLexp-loop"             | (TC_CONT _) => bug "unexpected TC_CONT tyc in tcLexp-loop"
# Line 273  Line 320 
320    end (* function tcLexp *)    end (* function tcLexp *)
321    
322  and tcsLexp (kenv, ts) =  and tcsLexp (kenv, ts) =
323    let fun h tc = tcLexp(kenv, tc)    let fun h tc = tcLexp kenv tc
324     in RECORDg(map h ts)     in RECORDg(map h ts)
325    end (* function tcsLexp *)    end (* function tcsLexp *)
326    
327  and tsLexp (kenv, ts) =  and tsLexp (kenv, ts) =
328    let fun h tc = tcLexp(kenv, tc)    let fun h tc = tcLexp kenv tc
329     in SRECORDg(map h ts)     in SRECORDg(map h ts)
330    end (* function tsLexp *)    end (* function tsLexp *)
331    
   
332  (** an improvement is to lift all of these code to the start of the  (** an improvement is to lift all of these code to the start of the
333      compilation unit *)      compilation unit *)
334  (*** THE FOLLOWING CODE IS ROUGH AND NEEDS TO BE POLISHED ! ***)  (*** THE FOLLOWING CODE IS ROUGH AND NEEDS TO BE POLISHED ! ***)
# Line 293  Line 339 
339                  if (pt = PT.ptc_real) then YES else NO                  if (pt = PT.ptc_real) then YES else NO
340             | (TC_TUPLE (_, ts)) => NO             | (TC_TUPLE (_, ts)) => NO
341             | (TC_ARROW (_,tc1,tc2)) => NO             | (TC_ARROW (_,tc1,tc2)) => NO
342             | (TC_BOX tx) => NO     (* this requires further thoughts ! *)             | (TC_TOKEN(_,tx)) => loop tx
343             | (TC_FIX(_, i)) => NO             | (TC_FIX(_, i)) => NO
344             | (TC_APP(tx, _)) =>             | (TC_APP(tx, _)) =>
345                  (case tc_out tx                  (case tc_out tx
346                    of (TC_APP _ | TC_PROJ _ | TC_VAR _) =>                    of (TC_APP _ | TC_PROJ _ | TC_VAR _) =>
347                         MAYBE(tcLexp(kenv, x))                         MAYBE(tcLexp kenv x)
348                     | _ => NO)                     | _ => NO)
349            (* | (TC_ABS tx) => loop tx  *)            (* | (TC_ABS tx) => loop tx  *)
350             | (TC_VAR(i,j)) =>             | (TC_VAR(i,j)) =>
351                  let val k = klookKE(kenv, i, j)                  let val k = klookKE(kenv, i, j)
352                   in case (tk_out k)                   in case (tk_out k)
353                       of TK_BOX => NO                       of TK_BOX => NO
354                        | _ => MAYBE(tcLexp(kenv, x))                        | _ => MAYBE(tcLexp kenv x)
355                  end                  end
356             | _ => MAYBE(tcLexp(kenv, x)))             | _ => MAYBE(tcLexp kenv x))
357    
358     in loop tc     in loop tc
359    end    end
# Line 319  Line 365 
365             | (TC_TUPLE (_, [_,_])) => YES             | (TC_TUPLE (_, [_,_])) => YES
366             | (TC_TUPLE _) => NO             | (TC_TUPLE _) => NO
367             | (TC_ARROW _) => NO             | (TC_ARROW _) => NO
368             | (TC_BOX tx) => NO     (* this requires further thoughts !!! *)             | (TC_TOKEN(_,tx)) => loop tx
369             | (TC_FIX(_, i)) => NO             | (TC_FIX(_, i)) => NO
370             | (TC_APP(tx, _)) =>             | (TC_APP(tx, _)) =>
371                  (case tc_out tx                  (case tc_out tx
372                    of (TC_APP _ | TC_PROJ _ | TC_VAR _ | TC_NVAR _) =>                    of (TC_APP _ | TC_PROJ _ | TC_VAR _ | TC_NVAR _) =>
373                         MAYBE(tcLexp(kenv, x))                         MAYBE(tcLexp kenv x)
374                     | _ => NO)                     | _ => NO)
375         (*    | (TC_ABS tx) =>  loop tx  *)         (*    | (TC_ABS tx) =>  loop tx  *)
376             | _ => MAYBE(tcLexp(kenv, x)))             | _ => MAYBE(tcLexp kenv x))
377    
378     in loop tc     in loop tc
379    end    end
# Line 337  Line 383 
383   ****************************************************************************)   ****************************************************************************)
384  (** tc is of kind Omega; this function tests whether tc can be int31 ? *)  (** tc is of kind Omega; this function tests whether tc can be int31 ? *)
385  fun tcTag (kenv, tc) =  fun tcTag (kenv, tc) =
386    let fun loop x =    let fun loop x =     (* a lot of approximations in this function *)
387          (case (tc_out x)          (case (tc_out x)
388            of (TC_PRIM pt) => if PT.unboxed pt then NO else YES            of (TC_PRIM pt) => if PT.unboxed pt then NO else YES
389                    (* if PT.ubxupd pt then YES else NO *)
390                      (* this is just an approximation *)                      (* this is just an approximation *)
391             | (TC_TUPLE (_, ts)) => NO             | (TC_TUPLE (_, ts)) => NO
392             | (TC_ARROW (_,tc1,tc2)) => YES             | (TC_ARROW (_,tc1,tc2)) => YES (* NO *)
393             | (TC_ABS tx) => loop tx             | (TC_ABS tx) => loop tx
394             | (TC_BOX tx) => loop tx             | (TC_TOKEN(_,tx)) => loop tx
395             | (TC_FIX(_, i)) => YES             | (TC_FIX(_, i)) => YES
396             | (TC_APP(tx, _)) =>             | (TC_APP(tx, _)) =>
397                  (case tc_out tx                  (case tc_out tx
398                    of (TC_APP _ | TC_PROJ _ | TC_VAR _) =>                    of (TC_APP _ | TC_PROJ _ | TC_VAR _) =>
399                         (let val e1 = tcLexp(kenv, x)                         MAYBE (tcLexp kenv x)
                          in MAYBE(APPg(ieq, RECORDg[e1, tcode_void]))  
                         end)  
400                     | _ => YES)                     | _ => YES)
401             | _ => (let val e1 = tcLexp(kenv, x)             | _ => (MAYBE (tcLexp kenv x)))
                     in MAYBE(APPg(ieq, RECORDg[e1, tcode_void]))  
                    end))  
402     in loop tc     in loop tc
403    end (* function tcTag *)    end (* function tcTag *)
404    
405  (* val utgc : kenv * tyc -> lexp -> lexp *)  (* val utgc : tyc * kenv * tyc -> value -> lexp *)
406  fun utgc (kenv, tc) =  fun utgc (tc, kenv, rt) =
407    (case tcTag(kenv, tc)    (case tcTag(kenv, tc)
408      of YES => (fn le => WRAPg(LT.tcc_tuple [tc], true, RECORDg[le]))      of YES => (fn u => let val v = mkv()
409       | NO => (fn le => le)                          in RECORD(FU_rk_tuple, [u], v,
410       | MAYBE ne =>                               WRAP(LT.tcc_tuple[rt], VAR v))
         let fun h(x as (SVAL(VAR v))) =  
                   COND(ne, WRAPg(LT.tcc_tuple [tc], true, RECORDg [x]),  
                            x)  
               | h x =  
                   let val w = mkv()  
                    in LET(w, x,  
                        COND(ne, WRAPg(LT.tcc_tuple [tc], true, RECORD [VAR w]),  
                                 SVAL(VAR w)))  
                   end  
          in h  
411          end)          end)
412         | NO => (fn u => WRAP(rt, u))
413         | MAYBE ne =>
414             (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    
421  (* val utgd : kenv * tyc -> lexp -> lexp *)  (* val utgd : tyc * kenv * tyc -> value -> lexp *)
422  fun utgd (kenv, tc) =  fun utgd (tc, kenv, rt) =
423    (case tcTag(kenv, tc)    (case tcTag(kenv, tc)
424      of YES =>      of YES => (fn u => let val v = mkv() and z = mkv()
425          (fn le => SELECTg(0, UNWRAPg(LT.tcc_tuple [tc], true, le)))                          in FU_UNWRAP(LT.tcc_tuple [rt], [u], v,
426       | NO => (fn le => le)                                 SELECT(VAR v, 0, z, RET[VAR z]))
      | MAYBE ne =>  
         let fun h(x as (SVAL(VAR v))) =  
                   COND(ne, SELECTg(0, UNWRAPg(LT.tcc_tuple [tc], true, x)), x)  
               | h x =  
                   let val w = mkv()  
                    in LET(w, x,  
                        COND(ne, SELECTg(0, UNWRAP(LT.tcc_tuple [tc],true,VAR w)),  
                                 SVAL(VAR w)))  
                   end  
          in h  
427          end)          end)
428         | NO => (fn u => UNWRAP(rt, u))
429         | MAYBE ne =>
430              (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    
437  (* val tgdc : kenv * int * tyc -> lexp -> lexp *)  (* val tgdc : int * tyc * kenv * tyc -> value -> lexp *)
438  fun tgdc (kenv, i, tc) =  fun tgdc (i, tc, kenv, rt) =
439    let val nt = LT.tcc_tuple [LT.tcc_int, tc]    let val nt = LT.tcc_tuple [LT.tcc_int, rt]
440     in (fn le => WRAPg(nt, true, RECORDg [SVAL(INT i), le]))     in fn u => let val x = mkv()
441                   in RECORD(FU_rk_tuple, [INT i, u], x, WRAP(nt, VAR x))
442    end    end
   
 (* val tgdd : kenv * int * tyc -> lexp -> lexp *)  
 fun tgdd (kenv, i, tc) =  
   let val nt = LT.tcc_tuple [LT.tcc_int, tc]  
    in (fn le => SELECTg(1, UNWRAPg(nt, true, le)))  
443    end    end
444    
445    (* 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      end
452    
453  (****************************************************************************  (****************************************************************************
454   *                      TYPED INTERPRETATION OF FP RECORD                   *   *                      TYPED INTERPRETATION OF FP RECORD                   *
# Line 416  Line 458 
458  (** all of these wrappers probably should be lifted to the top of the  (** all of these wrappers probably should be lifted to the top of the
459      program, otherwise we may run into space blow-up ! *)      program, otherwise we may run into space blow-up ! *)
460  (* val tcCoerce : kenv * tyc * bool * bool -> (lexp -> lexp) option *)  (* val tcCoerce : kenv * tyc * bool * bool -> (lexp -> lexp) option *)
461  fun tcCoerce (kenv, tc, wflag, b) =  fun tcCoerce (kenv, tc, nt, wflag, b) =
462    (case tc_out tc    (case (tc_out tc, tc_out nt)
463      of TC_TUPLE (_, ts) =>      of (TC_TUPLE (_, ts), _) =>
464           let fun h([], i, e, el, 0) = NONE           let fun h([], i, e, el, 0) = NONE
465                 | h([], i, e, el, res) =                 | h([], i, e, el, res) =
466                     let val w = mkv()                     let val w = mkv()
467                         val wx = VAR w                         val wx = VAR w
468                         fun g(i, NONE) =  SELECT(i, wx)                         fun g(i, NONE) =  SELECTv(i, wx)
469                           | g(i, SOME _) =                           | g(i, SOME _) =
470                               if wflag then                               if wflag then
471                                 UNWRAPg(LT.tcc_real, b, SELECT(i, wx))                                 UNWRAPg(LT.tcc_real, b, SELECTv(i, wx))
472                               else WRAPg(LT.tcc_real, b, SELECT(i, wx))                               else WRAPg(LT.tcc_real, b, SELECTv(i, wx))
473    
474                         val ntc = LT.tcc_tuple(map (fn _ => LT.tcc_real) ts)                         val ntc = LT.tcc_tuple(map (fn _ => LT.tcc_real) ts)
475    
476                         val ne = RECORDg (map g (rev el))                         val ne = RECORDg (map g (rev el))
477                         val test = APPg(ieq, RECORDg[e, tcode_realN res])                         val test = ieqLexp(e, tcode_realN res)
478    
479                         fun hdr0 xe =                         fun hdr0 xe =
480                           if wflag then                           if wflag then
481                             COND(test, LET(w, xe, WRAPcast(ntc, b, ne)),                             COND(test, LET([w], xe, WRAPcast(ntc, b, ne)),
482                                        WRAPcast(tc, b, xe))                                        WRAPcast(nt, b, xe))
483                           else COND(test, LET(w, UNWRAPcast(ntc, b, xe), ne),                           else COND(test, LET([w], UNWRAPcast(ntc, b, xe), ne),
484                                           UNWRAPcast(tc, b, xe))                                           UNWRAPcast(nt, b, xe))
485    
486                         fun hdr (xe as (SVAL(VAR _))) = hdr0 xe                         fun hdr (xe as (RET[(VAR _)])) = hdr0 xe
487                           | hdr xe = let val z = mkv()                           | hdr xe = let val z = mkv()
488                                       in LET(z, xe, hdr0 (SVAL(VAR z)))                                       in LET([z], xe, hdr0 (RET[VAR z]))
489                                      end                                      end
490                      in SOME hdr                      in SOME hdr
491                     end                     end
# Line 451  Line 493 
493                     (case isFloat(kenv, a)                     (case isFloat(kenv, a)
494                       of NO => NONE                       of NO => NONE
495                        | YES => h(r, i+1, e, (i,NONE)::el, res)                        | YES => h(r, i+1, e, (i,NONE)::el, res)
496                        | MAYBE z => h(r, i+1, APPg(iadd, RECORDg [e, z]),                        | MAYBE z => h(r, i+1, iaddLexp(e, z),
497                                       (i, SOME a)::el, res+1))                                       (i, SOME a)::el, res+1))
498    
499            in h(ts, 0, SVAL(INT 0), [], 0)            in h(ts, 0, RET[INT 0], [], 0)
500           end           end
501       | TC_ARROW _ => (* (tc1, tc2) => *)       | (TC_ARROW _, _) => (* (tc1, tc2) => *)
502          let val (tc1, tc2) = LT.tcd_parrow tc          let val (tc1, _) = LT.tcd_parrow tc
503                val (_, tc2) = LT.tcd_parrow nt
504           in (case isPair(kenv, tc1)           in (case isPair(kenv, tc1)
505                of (YES | NO) => NONE                of (YES | NO) => NONE
506                 | (MAYBE e) =>                 | (MAYBE e) =>
507                   let val w = mkv()                   let val w = mkv()
508                       val test1 = APPg(ieq, RECORDg[SVAL(VAR w), tcode_pair])                       val test1 = ieqLexp(RET[(VAR w)], tcode_pair)
509                       val test2 = APPg(ieq, RECORDg[SVAL(VAR w), tcode_fpair])                       val test2 = ieqLexp(RET[(VAR w)], tcode_fpair)
510                       val m = mkv()                       val m = mkv() and m2 = mkv()
511                       val n = mkv()                       val n = mkv() and n2 = mkv()
512    
513                       val tc_real = LT.tcc_real                       val tc_real = LT.tcc_real
514                       val tc_breal = LT.tcc_box tc_real                       val tc_breal = LT.tcc_void (* LT.tcc_wrap tc_real *)
515                         val lt_breal = LT.ltc_tyc tc_breal
516                       val tc_void = LT.tcc_void                       val tc_void = LT.tcc_void
517                       val lt_void = LT.ltc_void                       val lt_void = LT.ltc_void
518                       val tc_pair = LT.tcc_tuple [tc_void, tc_void]                       val tc_pair = LT.tcc_tuple [tc_void, tc_void]
# Line 479  Line 523 
523                       val lt_bfpair = LT.ltc_tyc tc_bfpair                       val lt_bfpair = LT.ltc_tyc tc_bfpair
524                       val ident = fn le => le                       val ident = fn le => le
525    
526                       val (argt1, body1, hh1, ih1) =                       val (argt1, body1, hh1) =
527                         if wflag then (* wrapping *)                         if wflag then (* wrapping *)
528                           (lt_pair, WRAP(tc_pair, true, VAR m),                           ([(m,lt_void),(m2,lt_void)],
529                            fn le => WRAPcast(LT.tcc_parrow(tc_pair,tc2), true, le),                            fn sv =>
530                            ident)                              let val xx = mkv() and yy = mkv()
531                         else (* unwrapping *)                               in RECORD(FU_rk_tuple, [VAR m, VAR m2], xx,
532                           let val q = mkv()                                    FU_WRAP(tc_pair, [VAR xx], yy,
533                            in (lt_void, UNWRAP(tc_pair, true, VAR m),ident,                                      APP(sv, [VAR yy])))
534                                fn le => UNWRAPcast(LT.tcc_parrow(tc_pair, tc2),                              end,
535                              fn le =>
536                                WRAPcast(mkarw([tc_void,tc_void],[tc2]),
537                                                 true, le))                                                 true, le))
538                           else (* unwrapping *)
539                             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                           end                           end
554    
555                       val (argt2, body2, hh2, ih2) =                       val (argt2, body2, hh2) =
556                         if wflag then                         if wflag then  (* wrapping *)
557                           (lt_bfpair, WRAPg(tc_fpair, true,                           ([(n,lt_breal),(n2,lt_breal)],
558                             RECORDg [UNWRAPg(tc_real, true, SELECT(0, VAR n)),                            fn sv =>
559                                      UNWRAPg(tc_real, true, SELECT(1, VAR n))]),                              let val xx = mkv() and yy = mkv()
560                            fn le => WRAPcast(LT.tcc_parrow(tc_bfpair,tc2), true, le),                               in LET ([xx],
561                            ident)                                     RECORDg [UNWRAP(tc_real, VAR n),
562                         else                                              UNWRAP(tc_real, VAR n2)],
563                           let val q = mkv()                                  FU_WRAP(tc_fpair, [VAR xx], yy,
564                            in (lt_void, LET(q, UNWRAP(tc_fpair, true, VAR n),                                     APP(sv, [VAR yy])))
565                              RECORDg [WRAPg(tc_real, true, SELECT(0, VAR q)),                              end,
566                                       WRAPg(tc_real, true, SELECT(1, VAR q))]),                            fn le => WRAPcast(mkarw([tc_breal,tc_breal],[tc2]),
                             ident,  
                             fn le => UNWRAPcast(LT.tcc_parrow(tc_bfpair, tc2),  
567                                               true, le))                                               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                           end                           end
587    
588                       val hh3 = if wflag then fn le => WRAPcast(tc, true, le)                       val hh3 = if wflag then fn le => WRAPcast(nt, true, le)
589                                 else fn le => UNWRAPcast(tc, true, le)                                 else fn le => UNWRAPcast(nt, true, le)
590    
591                       (*** NEEDS MORE WORK TO DO THE RIGHT COERCIONS ***)                       (*** NEEDS MORE WORK TO DO THE RIGHT COERCIONS ***)
592                       fun hdr0(sv) =                       fun hdr0(sv) =
593                         LET(w, e,                         LET([w], e,
594                           COND(test1, hh1(FN(m, argt1,                           COND(test1, hh1(FNg(argt1, body1 sv)),
595                                         APPg(ih1(SVAL sv), body1))),                             COND(test2, hh2(FNg(argt2, body2 sv)),
596                             COND(test2, hh2(FN(n, argt2,                                  hh3(RET[sv]))))
                                        APPg(ih2(SVAL sv), body2))),  
                                 hh3(SVAL sv))))  
597    
598                       fun hdr (xe as SVAL sv) = hdr0 sv                       fun hdr (xe as RET [sv]) = hdr0 sv
599                         | hdr xe = let val z = mkv()                         | hdr xe = let val z = mkv()
600                                     in LET(z, xe, hdr0(VAR z))                                     in LET([z], xe, hdr0(VAR z))
601                                    end                                    end
602                    in SOME hdr                    in SOME hdr
603                   end)                   end)
604          end          end
605       | _ => NONE)       | _ => NONE)
606    
607  (* val mkwrp : kenv * bool * tyc -> lexp -> lexp *)  (* val mkwrp : tyc * kenv * bool * tyc -> lexp -> lexp *)
608  fun mkwrp (kenv, b, tc) =  fun mkwrp (tc, kenv, b, nt) =
609    (case tcCoerce(kenv, tc, true, b)    (case tcCoerce(kenv, tc, nt, true, b)
610      of NONE => (fn le => WRAPg(tc, b, le))      of NONE => (fn le => WRAPg(nt, b, le))
611       | SOME hdr => hdr)       | SOME hdr => hdr)
612    
613  (* val mkuwp : kenv * bool * tyc -> lexp -> lexp *)  (* val mkuwp  : tyc * kenv * bool * tyc -> lexp -> lexp *)
614  fun mkuwp (kenv, b, tc) =  fun mkuwp (tc, kenv, b, nt) =
615    (case tcCoerce(kenv, tc, false, b)    (case tcCoerce(kenv, tc, nt, false, b)
616      of NONE => (fn le => UNWRAPg(tc, b, le))      of NONE => (fn le => UNWRAPg(nt, b, le))
617       | SOME hdr => hdr)       | SOME hdr => hdr)
618    
619  val realSub = PO.NUMSUBSCRIPT{kind=PO.FLOAT 64, checked=false, immutable=false}  val realSub = PO.NUMSUBSCRIPT{kind=PO.FLOAT 64, checked=false, immutable=false}
620  val realUpd = PO.NUMUPDATE{kind=PO.FLOAT 64, checked=false}  val realUpd = PO.NUMUPDATE{kind=PO.FLOAT 64, checked=false}
621    
622  fun arrSub(kenv, lt, tc) =  fun rsubLexp (vs, t) =
623    let val nt = LT.lt_pinst_st(lt, [tc])    let val x = mkv()
624        val rnt = LT.lt_pinst_st(lt, [LT.tcc_real])     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     in (case isFloat(kenv, tc)     in (case isFloat(kenv, tc)
647          of NO => (fn sv => APP(PRIM(PO.SUBSCRIPT, nt, []), sv))          of NO => (fn vs => subLexp(vs, nt))
648           | YES => (fn sv => WRAPg(LT.tcc_real, true,           | YES => (fn vs => WRAPg(LT.tcc_real, true, rsubLexp(vs, rnt)))
                                   APP(PRIM(realSub, rnt, []), sv)))  
649           | MAYBE z =>           | MAYBE z =>
650               (let val test = APPg(ieq, RECORDg[z, tcode_real])               (let val test = ieqLexp(z, tcode_real)
651                 in (fn sv =>                 in (fn vs =>
652                       COND(test, WRAPg(LT.tcc_real, true,                       COND(test, WRAPg(LT.tcc_real, true, rsubLexp(vs, rnt)),
653                                    APP(PRIM(realSub, rnt, []), sv)),                            subLexp(vs, nt)))
                           APP(PRIM(PO.SUBSCRIPT, nt, []), sv)))  
654                end))                end))
655    end    end
656    
657  fun arrUpd(kenv, lt, tc) =  fun arrUpd(tc, kenv, po, blt, rlt) =
658    let val nt = LT.lt_pinst_st(lt, [tc])    let val nt = blt
659        val rnt = LT.lt_pinst_st(lt, [LT.tcc_real])        val rnt = rlt
660     in (case isFloat(kenv,tc)     in (case isFloat(kenv,tc)
661          of NO => (fn sv => APP(PRIM(PO.UPDATE, nt, []), sv))          of NO => (fn vs => updLexp(po, vs, nt))
662           | YES => (fn sv => APPg(SVAL(PRIM(realUpd, rnt, [])),           | YES => (fn [x,y,z] =>
663                                RECORDg[SELECT(0, sv),                       let val nz = mkv()
664                                        SELECT(1, sv),                        in LET([nz], UNWRAPg(LT.tcc_real, true, RET[z]),
665                                   UNWRAPg(LT.tcc_real, true,                               rupdLexp([x,y,VAR nz], rnt))
666                                           SELECT(2, sv))]))                       end)
667           | MAYBE z =>           | MAYBE z =>
668               (let val test = APPg(ieq, RECORDg[z, tcode_real])               (let val test = ieqLexp(z, tcode_real)
669                 in (fn sv =>                 in (fn (vs as [x,y,z]) =>
670                       COND(test, APPg(SVAL(PRIM(realUpd, rnt, [])),                       COND(test,
671                                RECORDg[SELECT(0, sv),                            let val nz = mkv()
672                                        SELECT(1, sv),                             in LET([nz], UNWRAPg(LT.tcc_real, true, RET[z]),
673                                   UNWRAPg(LT.tcc_real, true,                                    rupdLexp([x,y,VAR nz], rnt))
674                                           SELECT(2, sv))]),                            end,
675                            APP(PRIM(PO.UPDATE, nt, []), sv)))                            updLexp(po, vs, nt)))
676                end))                end))
677    end    end
678    
679  fun arrNew(kenv, lt, tc, pv, rv) =  fun arrNew(tc, pv, rv, kenv) =
680    (case isFloat(kenv,tc)    (case isFloat(kenv,tc)
681      of NO => (fn sv => APPg(APPg(SVAL(VAR pv), tsLexp(kenv, [tc])), SVAL sv))      of NO => (fn vs =>
682       | YES => (fn sv => APPg(SVAL(VAR rv),                  let val x= mkv()
683                     RECORDg [SELECT(0, sv),                   in LET([x], APPg(RET[VAR pv], tsLexp(kenv, [tc])),
684                              UNWRAPg(LT.tcc_real, true, SELECT(1, sv))]))                          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       | MAYBE z =>       | MAYBE z =>
692           (let val test = APPg(ieq, RECORDg[z, tcode_real])           (let val test = ieqLexp(z, tcode_real)
693             in (fn sv =>             in (fn (vs as [x,y]) =>
694                   COND(test, APPg(SVAL(VAR rv),                   COND(test,
695                     RECORDg [SELECT(0, sv),                        let val z = mkv()
696                              UNWRAPg(LT.tcc_real, true, SELECT(1, sv))]),                         in LET([z], UNWRAPg(LT.tcc_real, true, RET[y]),
697                      APPg(APPg(SVAL(VAR pv), tsLexp(kenv, [tc])), SVAL sv)))                                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            end))            end))
704    
705  end (* toplevel local *)  end (* toplevel local *)
706  end (* structure TypeOper *)  end (* structure TypeOper *)
707    
708    
 (*  
  * $Log: ltyprim.sml,v $  
  * Revision 1.5  1998/01/07 15:18:16  dbm  
  *   Fixing bug 1323. Wrapping and unwrapping primitives were usually ignored  
  *   in the cpstrans phase before we perform the cps optimization. Unfortunately,  
  *   they could lead to ill-typed CPS programs. To resolve this, I turn those  
  *   sensitive wrap and unwrap primitives into "casts"; I leave the casts in the  
  *   code; the cps generic phase will generate a move for each cast. In the  
  *   long term, we have to think thoroughly about the meanings of these wrapping  
  *   primitives and how they interface with compile-time optimizations.  
  *  
  * Revision 1.4  1997/05/05 20:00:13  george  
  *   Change the term language into the quasi-A-normal form. Added a new round  
  *   of lambda contraction before and after type specialization and  
  *   representation analysis. Type specialization including minimum type  
  *   derivation is now turned on all the time. Real array is now implemented  
  *   as realArray. A more sophisticated partial boxing scheme is added and  
  *   used as the default.  
  *  
  * Revision 1.3  1997/04/18  15:49:02  george  
  *   Cosmetic changes on some constructor names. Changed the shape for  
  *   FIX type to potentially support shared dtsig. -- zsh  
  *  
  * Revision 1.2  1997/02/26  21:53:57  george  
  *    Fixing the incorrect wrapper bug, BUG 1158, reported by Ken Cline  
  *    (zcline.sml). This also fixes the core dump bug, BUG 1153,  
  *    reported by Nikolaj.  
  *  
  *)  

Legend:
Removed from v.68  
changed lines
  Added in v.69

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