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/branches/primop-branch-2/src/compiler/FLINT/trans/translate.sml
ViewVC logotype

Diff of /sml/branches/primop-branch-2/src/compiler/FLINT/trans/translate.sml

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

revision 2061, Fri Sep 22 19:07:06 2006 UTC revision 2062, Mon Sep 25 03:26:52 2006 UTC
# Line 613  Line 613 
613    
614          system/smlnj/init/core-intinf.sml:51:    val finToInf  : int32 * bool -> intinf          system/smlnj/init/core-intinf.sml:51:    val finToInf  : int32 * bool -> intinf
615   *)   *)
616    fun inlToInfPrec (opname, coerceFnName, primop, primoplt) =
617       let
618            val (orig_arg_lt, res_lt) =
619                    case LT.ltd_arrow primoplt of
620                    (_, [a], [r]) => (a, r)
621                    | _ => bug ("unexpected type of " ^ opname)
622            val extra_arg_lt =
623                    if coerceFnName = "finToInf" then
624                            LT.ltc_arrow(LT.ffc_var(true,false), [LT.ltc_int32 ,LT.ltc_bool], [res_lt])
625                    else
626                            LT.ltc_parrow(LT.ltc_int32, res_lt)
627            val new_arg_lt = LT.ltc_tuple [orig_arg_lt, extra_arg_lt]
628            val new_lt = LT.ltc_parrow (new_arg_lt, res_lt )
629            val x = mkv ()
630        in
631           FN (x, orig_arg_lt,
632              APP (PRIM (primop, new_lt, []),
633                   RECORD [VAR x, coreAcc coerceFnName]))
634        end
635    
636    fun inlFromInfPrec (opname, coerceFnName, primop, primoplt) =
637        let
638            val (orig_arg_lt, res_lt) =
639                    case LT.ltd_arrow primoplt of
640                    (_, [a], [r]) => (a, r)
641                    | _ => bug ("unexpected type of " ^ opname)
642            val extra_arg_lt =
643                    LT.ltc_parrow (orig_arg_lt, LT.ltc_int32)
644            val new_arg_lt = LT.ltc_tuple [orig_arg_lt, extra_arg_lt]
645            val new_lt = LT.ltc_parrow (new_arg_lt, res_lt )
646            val x = mkv ()
647        in
648           FN (x, orig_arg_lt,
649              APP (PRIM (primop, new_lt, []),
650                   RECORD [VAR x, coreAcc coerceFnName]))
651        end
652    
653    
654  fun inl_infPrec (what, corename, p, lt, is_from_inf) = let  fun inl_infPrec (what, corename, p, lt, is_from_inf) = let
655      val (orig_arg_lt, res_lt) =      val (orig_arg_lt, res_lt) =
656          case LT.ltd_arrow lt of          case LT.ltd_arrow lt of
# Line 620  Line 658 
658            | _ => bug ("unexpected type of " ^ what)            | _ => bug ("unexpected type of " ^ what)
659      val extra_arg_lt =      val extra_arg_lt =
660          LT.ltc_parrow (if is_from_inf then (orig_arg_lt, LT.ltc_int32)          LT.ltc_parrow (if is_from_inf then (orig_arg_lt, LT.ltc_int32)
661                         else (LT.ltc_int32, orig_arg_lt))                         else (LT.ltc_int32, res_lt (* orig_arg_lt *) ))
662      val new_arg_lt = LT.ltc_tuple [orig_arg_lt, extra_arg_lt]      val new_arg_lt = LT.ltc_tuple [orig_arg_lt, extra_arg_lt]
663      val new_lt = LT.ltc_parrow (new_arg_lt, res_lt )      val new_lt = LT.ltc_parrow (new_arg_lt, res_lt )
664      val x = mkv ()      val x = mkv ()
665      (** Begin DEBUG edits *)      (** Begin DEBUG edits *)
666      val y = mkv ()      val y = mkv ()
667      (** val coreOcc = (if corename = "finToInf" then      val coreOcc = (if corename = "finToInf" then
668                          FN(y, LT.ltc_int32 (** Where should this type come from *),                          FN(y, LT.ltc_int32 (** Where should this type come from *),
669                             APP(coreAcc corename, RECORD [VAR y,                             APP(coreAcc corename, RECORD [VAR y,
670                                  falseLexp                                  falseLexp
671                                  (** Apply to CoreBasicType falseDcon ...  *) ]))                                  (** Apply to CoreBasicType falseDcon ...  *) ]))
672                     else coreAcc corename) *)                     else coreAcc corename)
673      (** End DEBUG edits *)      (** End DEBUG edits *)
674      val e =      val e =
675      FN (x, orig_arg_lt,      FN (x, orig_arg_lt,
# Line 832  Line 870 
870           * does the actual conversion to or from IntInf. *)           * does the actual conversion to or from IntInf. *)
871    
872          | g (p as PO.TEST_INF prec) =          | g (p as PO.TEST_INF prec) =
873              inl_infPrec ("TEST_INF", "testInf", p, lt, true)              inlFromInfPrec ("TEST_INF", "testInf", p, lt)
874          | g (p as PO.TRUNC_INF prec) =          | g (p as PO.TRUNC_INF prec) =
875              inl_infPrec ("TRUNC_INF", "truncInf", p, lt, true)              inlFromInfPrec ("TRUNC_INF", "truncInf", p, lt)
876          | g (p as PO.EXTEND_INF prec) =          | g (p as PO.EXTEND_INF prec) =
877              inl_infPrec ("EXTEND_INF", "finToInf", p, lt, false)              (* inl_infPrec ("EXTEND_INF", "finToInf", p, lt, false) *)
878                inlToInfPrec("EXTEND_INF", "finToInf", p, lt)
879          | g (p as PO.COPY_INF prec) =          | g (p as PO.COPY_INF prec) =
880              inl_infPrec ("COPY", "finToInf", p, lt, false)              inlToInfPrec ("COPY", "copyInf", p, lt)
881          (* default handling for all other primops *)          (* default handling for all other primops *)
882          | g p = PRIM(p, lt, ts)          | g p = PRIM(p, lt, ts)
883    

Legend:
Removed from v.2061  
changed lines
  Added in v.2062

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