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 44, Sun Mar 22 20:10:57 1998 UTC revision 45, Sun Mar 22 20:11:09 1998 UTC
# Line 34  Line 34 
34    
35  local structure DI = DebIndex  local structure DI = DebIndex
36        structure LT = LtyExtern        structure LT = LtyExtern
       structure LU = LtyUtil  
37        structure LV = LambdaVar        structure LV = LambdaVar
38        structure PO = PrimOp        structure PO = PrimOp
39        structure PT = PrimTyc        structure PT = PrimTyc
# Line 168  Line 167 
167   *                            MAIN FUNCTIONS                                *   *                            MAIN FUNCTIONS                                *
168   ****************************************************************************)   ****************************************************************************)
169    
170  val tkLty = LU.tkLty  val tkLty = LT.tk_lty
171    
172  (* val tkLexp: kenv * tkind list -> kenv * (lexp -> lexp) *)  (* val tkLexp: kenv * tkind list -> kenv * (lexp -> lexp) *)
173  fun tkLexpG (kenv, ks, record) =  fun tkLexpG (kenv, ks, record) =
# Line 226  Line 225 
225                  else if (pt = PT.ptc_int32) then tcode_int32                  else if (pt = PT.ptc_int32) then tcode_int32
226                       else tcode_void                       else tcode_void
227             | (TC_VAR(i, j)) => SVAL(VAR(vlookKE(kenv, i, j)))             | (TC_VAR(i, j)) => SVAL(VAR(vlookKE(kenv, i, j)))
228             | (TC_TUPLE [t1,t2]) =>             | (TC_TUPLE (_, [t1,t2])) =>
229                  (case (isFloat(kenv,t1), isFloat(kenv,t2))                  (case (isFloat(kenv,t1), isFloat(kenv,t2))
230                    of (YES, YES) => tcode_fpair                    of (YES, YES) => tcode_fpair
231                     | ((NO, _) | (_, NO)) => tcode_pair                     | ((NO, _) | (_, NO)) => tcode_pair
# Line 239  Line 238 
238                              val test = APPg(ieq, RECORDg [e, tcode_realN 2])                              val test = APPg(ieq, RECORDg [e, tcode_realN 2])
239                           in COND(test, tcode_fpair, tcode_pair)                           in COND(test, tcode_fpair, tcode_pair)
240                          end)                          end)
241             | (TC_TUPLE ts) => tcode_record             | (TC_TUPLE (_, ts)) => tcode_record
242             | (TC_ARROW (_,tc1,tc2)) => tcode_void             | (TC_ARROW (_,tc1,tc2)) => tcode_void
243             | (TC_ABS tx) => loop tx             | (TC_ABS tx) => loop tx
244             | (TC_BOX tx) => loop tx             | (TC_BOX tx) => loop tx
# Line 256  Line 255 
255                         of TC_FN (ks, _) => List.nth(ks, i)                         of TC_FN (ks, _) => List.nth(ks, i)
256                          | _ => bug "unexpected FIX tycs in tcLexp-loop")                          | _ => bug "unexpected FIX tycs in tcLexp-loop")
257                   in case tk_out tk                   in case tk_out tk
258                       of TK_FUN(k1, _) =>                       of TK_FUN(ks, _) =>
                           (case tk_out k1  
                             of TK_SEQ ks =>  
259                                   (let val (_, hdr) =                                   (let val (_, hdr) =
260                                          tkLexpG(kenv, ks, LT.ltc_tuple)                                          tkLexpG(kenv, ks, LT.ltc_tuple)
261                                     in hdr(tcode_void)                                     in hdr(tcode_void)
262                                    end)                                    end)
                              | _ => bug "unexpected FIX tyc2 in tcLexp-loop")  
263                        | _ => tcode_void                        | _ => tcode_void
264                  end                  end
265               | (TC_TOKEN _) => bug "TC_TOKEN tyc currently not supported"
266             | (TC_SUM _) => bug "unexpected TC_SUM tyc in tcLexp-loop"             | (TC_SUM _) => bug "unexpected TC_SUM tyc in tcLexp-loop"
267             | (TC_ENV _) => bug "unexpected TC_ENV tyc in tcLexp-loop"             | (TC_ENV _) => bug "unexpected TC_ENV tyc in tcLexp-loop"
268             | (TC_CONT _) => bug "unexpected TC_CONT tyc in tcLexp-loop"             | (TC_CONT _) => bug "unexpected TC_CONT tyc in tcLexp-loop"
# Line 294  Line 291 
291          (case (tc_out x)          (case (tc_out x)
292            of (TC_PRIM pt) =>            of (TC_PRIM pt) =>
293                  if (pt = PT.ptc_real) then YES else NO                  if (pt = PT.ptc_real) then YES else NO
294             | (TC_TUPLE ts) => NO             | (TC_TUPLE (_, ts)) => NO
295             | (TC_ARROW (_,tc1,tc2)) => NO             | (TC_ARROW (_,tc1,tc2)) => NO
296             | (TC_BOX tx) => NO     (* this requires further thoughts ! *)             | (TC_BOX tx) => NO     (* this requires further thoughts ! *)
297             | (TC_FIX(_, i)) => NO             | (TC_FIX(_, i)) => NO
# Line 319  Line 316 
316    let fun loop x =    let fun loop x =
317          (case (tc_out x)          (case (tc_out x)
318            of (TC_PRIM pt) => NO            of (TC_PRIM pt) => NO
319             | (TC_TUPLE [_,_]) => YES             | (TC_TUPLE (_, [_,_])) => YES
320             | (TC_TUPLE _) => NO             | (TC_TUPLE _) => NO
321             | (TC_ARROW _) => NO             | (TC_ARROW _) => NO
322             | (TC_BOX tx) => NO     (* this requires further thoughts !!! *)             | (TC_BOX tx) => NO     (* this requires further thoughts !!! *)
# Line 344  Line 341 
341          (case (tc_out x)          (case (tc_out x)
342            of (TC_PRIM pt) => if PT.unboxed pt then NO else YES            of (TC_PRIM pt) => if PT.unboxed pt then NO else YES
343                      (* this is just an approximation *)                      (* this is just an approximation *)
344             | (TC_TUPLE ts) => NO             | (TC_TUPLE (_, ts)) => NO
345             | (TC_ARROW (_,tc1,tc2)) => YES             | (TC_ARROW (_,tc1,tc2)) => YES
346             | (TC_ABS tx) => loop tx             | (TC_ABS tx) => loop tx
347             | (TC_BOX tx) => loop tx             | (TC_BOX tx) => loop tx
# Line 421  Line 418 
418  (* val tcCoerce : kenv * tyc * bool * bool -> (lexp -> lexp) option *)  (* val tcCoerce : kenv * tyc * bool * bool -> (lexp -> lexp) option *)
419  fun tcCoerce (kenv, tc, wflag, b) =  fun tcCoerce (kenv, tc, wflag, b) =
420    (case tc_out tc    (case tc_out tc
421      of TC_TUPLE ts =>      of TC_TUPLE (_, ts) =>
422           let fun h([], i, e, el, 0) = NONE           let fun h([], i, e, el, 0) = NONE
423                 | h([], i, e, el, res) =                 | h([], i, e, el, res) =
424                     let val w = mkv()                     let val w = mkv()
# Line 460  Line 457 
457            in h(ts, 0, SVAL(INT 0), [], 0)            in h(ts, 0, SVAL(INT 0), [], 0)
458           end           end
459       | TC_ARROW _ => (* (tc1, tc2) => *)       | TC_ARROW _ => (* (tc1, tc2) => *)
460          let val (tc1, tc2) = LU.tcd_arw tc          let val (tc1, tc2) = LT.tcd_parrow tc
461           in (case isPair(kenv, tc1)           in (case isPair(kenv, tc1)
462                of (YES | NO) => NONE                of (YES | NO) => NONE
463                 | (MAYBE e) =>                 | (MAYBE e) =>
# Line 485  Line 482 
482                       val (argt1, body1, hh1, ih1) =                       val (argt1, body1, hh1, ih1) =
483                         if wflag then (* wrapping *)                         if wflag then (* wrapping *)
484                           (lt_pair, WRAP(tc_pair, true, VAR m),                           (lt_pair, WRAP(tc_pair, true, VAR m),
485                            fn le => WRAPcast(LU.tcc_arw(tc_pair,tc2), true, le),                            fn le => WRAPcast(LT.tcc_parrow(tc_pair,tc2), true, le),
486                            ident)                            ident)
487                         else (* unwrapping *)                         else (* unwrapping *)
488                           let val q = mkv()                           let val q = mkv()
489                            in (lt_void, UNWRAP(tc_pair, true, VAR m),ident,                            in (lt_void, UNWRAP(tc_pair, true, VAR m),ident,
490                                fn le => UNWRAPcast(LU.tcc_arw(tc_pair, tc2),                                fn le => UNWRAPcast(LT.tcc_parrow(tc_pair, tc2),
491                                                 true, le))                                                 true, le))
492                           end                           end
493    
# Line 499  Line 496 
496                           (lt_bfpair, WRAPg(tc_fpair, true,                           (lt_bfpair, WRAPg(tc_fpair, true,
497                             RECORDg [UNWRAPg(tc_real, true, SELECT(0, VAR n)),                             RECORDg [UNWRAPg(tc_real, true, SELECT(0, VAR n)),
498                                      UNWRAPg(tc_real, true, SELECT(1, VAR n))]),                                      UNWRAPg(tc_real, true, SELECT(1, VAR n))]),
499                            fn le => WRAPcast(LU.tcc_arw(tc_bfpair,tc2), true, le),                            fn le => WRAPcast(LT.tcc_parrow(tc_bfpair,tc2), true, le),
500                            ident)                            ident)
501                         else                         else
502                           let val q = mkv()                           let val q = mkv()
# Line 507  Line 504 
504                              RECORDg [WRAPg(tc_real, true, SELECT(0, VAR q)),                              RECORDg [WRAPg(tc_real, true, SELECT(0, VAR q)),
505                                       WRAPg(tc_real, true, SELECT(1, VAR q))]),                                       WRAPg(tc_real, true, SELECT(1, VAR q))]),
506                              ident,                              ident,
507                              fn le => UNWRAPcast(LU.tcc_arw(tc_bfpair, tc2),                              fn le => UNWRAPcast(LT.tcc_parrow(tc_bfpair, tc2),
508                                               true, le))                                               true, le))
509                           end                           end
510    
# Line 548  Line 545 
545  val realUpd = PO.NUMUPDATE{kind=PO.FLOAT 64, checked=false}  val realUpd = PO.NUMUPDATE{kind=PO.FLOAT 64, checked=false}
546    
547  fun arrSub(kenv, lt, tc) =  fun arrSub(kenv, lt, tc) =
548    let val nt = ltAppSt(lt, [tc])    let val nt = LT.lt_pinst_st(lt, [tc])
549        val rnt = ltAppSt(lt, [LT.tcc_real])        val rnt = LT.lt_pinst_st(lt, [LT.tcc_real])
550     in (case isFloat(kenv, tc)     in (case isFloat(kenv, tc)
551          of NO => (fn sv => APP(PRIM(PO.SUBSCRIPT, nt, []), sv))          of NO => (fn sv => APP(PRIM(PO.SUBSCRIPT, nt, []), sv))
552           | YES => (fn sv => WRAPg(LT.tcc_real, true,           | YES => (fn sv => WRAPg(LT.tcc_real, true,
# Line 564  Line 561 
561    end    end
562    
563  fun arrUpd(kenv, lt, tc) =  fun arrUpd(kenv, lt, tc) =
564    let val nt = ltAppSt(lt, [tc])    let val nt = LT.lt_pinst_st(lt, [tc])
565        val rnt = ltAppSt(lt, [LT.tcc_real])        val rnt = LT.lt_pinst_st(lt, [LT.tcc_real])
566     in (case isFloat(kenv,tc)     in (case isFloat(kenv,tc)
567          of NO => (fn sv => APP(PRIM(PO.UPDATE, nt, []), sv))          of NO => (fn sv => APP(PRIM(PO.UPDATE, nt, []), sv))
568           | YES => (fn sv => APPg(SVAL(PRIM(realUpd, rnt, [])),           | YES => (fn sv => APPg(SVAL(PRIM(realUpd, rnt, [])),

Legend:
Removed from v.44  
changed lines
  Added in v.45

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