CVS: sml-dist/src/compiler/FLINT/trans translate.sml, 1.33.4.9, 1.33.4.10

Update of /cvsroot/smlnj/sml-dist/src/compiler/FLINT/trans
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv17325/FLINT/trans

Modified Files:
      Tag: primop-branch-2
	translate.sml 
Log Message:
matchInstType: added TV_MARK case...prune VARty infinite loops problem

Index: translate.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/trans/translate.sml,v
retrieving revision 1.33.4.9
retrieving revision 1.33.4.10
diff -C2 -d -r1.33.4.9 -r1.33.4.10
*** translate.sml	13 Jul 2006 22:35:51 -0000	1.33.4.9
--- translate.sml	18 Jul 2006 01:10:33 -0000	1.33.4.10
***************
*** 859,866 ****
                 of (SOME p, SOME t) => (p,t)
                  | _ => bug "mkVE: unrecognized primop name"
            val intrinsicParams =
                (* compute intrinsic instantiation params of intrinsicType *)
                case ((TU.matchInstTypes(occty, intrinsicType)) : (TP.tyvar list * TP.tyvar list) option )
!                 of SOME(_, tvs) => map TU.pruneTyvar tvs
                   | NONE => (complain EM.COMPLAIN "matchInstTypes"
                                (fn ppstrm => 
--- 859,867 ----
                 of (SOME p, SOME t) => (p,t)
                  | _ => bug "mkVE: unrecognized primop name"
+ 	  val _ = print "mkVE: before matchInstTypes\n"
            val intrinsicParams =
                (* compute intrinsic instantiation params of intrinsicType *)
                case ((TU.matchInstTypes(occty, intrinsicType)) : (TP.tyvar list * TP.tyvar list) option )
!                 of SOME(_, tvs) => (print ("tvs length "^ (Int.toString (length tvs)) ^"\n"); map TU.pruneTyvar tvs)
                   | NONE => (complain EM.COMPLAIN "matchInstTypes"
                                (fn ppstrm => 
***************
*** 879,884 ****
  				     PP.newline ppstrm;
  				     PP.string ppstrm "instpoly intrinsicType: ";
! 				     PPType.ppType env ppstrm (#1 (TU.instantiatePoly intrinsicType))));
! 			    bug "primop intrinsic type doesn't match occurence type")
         in case (primop, intrinsicParams)
              of (PO.POLYEQL, [t]) => eqGen(intrinsicType, t, toTcLt d)
--- 880,888 ----
  				     PP.newline ppstrm;
  				     PP.string ppstrm "instpoly intrinsicType: ";
! 				     let val inst = (#1 (TU.instantiatePoly intrinsicType))	 
! 				     in PPType.ppType env ppstrm inst 
! 				     end));
! 			    bug "primop intrinsic type doesn't match occurrence type")
! 	  val _ = print "mkVE: after matchInstTypes\n"
         in case (primop, intrinsicParams)
              of (PO.POLYEQL, [t]) => eqGen(intrinsicType, t, toTcLt d)
***************
*** 1161,1171 ****
   ***************************************************************************)
  and mkDec (dec, d) = 
!   let fun g (VALdec vbs) = mkVBs(vbs, d)
!         | g (VALRECdec rvbs) = mkRVBs(rvbs, d)
          | g (ABSTYPEdec{body,...}) = g body
!         | g (EXCEPTIONdec ebs) = mkEBs(ebs, d)
!         | g (STRdec sbs) = mkStrbs(sbs, d)
!         | g (ABSdec sbs) = mkStrbs(sbs, d)
!         | g (FCTdec fbs) = mkFctbs(fbs, d)
          | g (LOCALdec(ld, vd)) = (g ld) o (g vd)
          | g (SEQdec ds) =  foldr (op o) ident (map g ds)
--- 1165,1175 ----
   ***************************************************************************)
  and mkDec (dec, d) = 
!   let fun g (VALdec vbs) = (print "VALdec"; mkVBs(vbs, d))
!         | g (VALRECdec rvbs) = (print "VALRECdec"; mkRVBs(rvbs, d))
          | g (ABSTYPEdec{body,...}) = g body
!         | g (EXCEPTIONdec ebs) = (print "EXCEPTIONdec"; mkEBs(ebs, d))
!         | g (STRdec sbs) = (print "STRdec"; mkStrbs(sbs, d))
!         | g (ABSdec sbs) = (print "ABSdec"; mkStrbs(sbs, d))
!         | g (FCTdec fbs) = (print "FCTdec"; mkFctbs(fbs, d))
          | g (LOCALdec(ld, vd)) = (g ld) o (g vd)
          | g (SEQdec ds) =  foldr (op o) ident (map g ds)
***************
*** 1196,1200 ****
  
        and g (VARexp (ref v, ts)) = 
!             mkVE(v, map TP.VARty ts, d)
  
          | g (CONexp (dc, ts)) = (let val _ = print "mkExp CONexp: "
--- 1200,1204 ----
  
        and g (VARexp (ref v, ts)) = 
!             (print "mkExp VARexp\n"; mkVE(v, map TP.VARty ts, d))
  
          | g (CONexp (dc, ts)) = (let val _ = print "mkExp CONexp: "
***************
*** 1207,1210 ****
--- 1211,1215 ----
  					     in c end)
          | g (INTexp (s, t)) =
+ 	  (print "mkExp INTexp\n";
               ((if TU.equalType (t, BT.intTy) then INT (LN.int s)
                 else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)
***************
*** 1215,1221 ****
  		   end
                 else bug "translate INTexp")
!               handle Overflow => (repErr "int constant too large"; INT 0))
  
          | g (WORDexp(s, t)) =
               ((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)
                 else if TU.equalType (t, BT.word8Ty) then WORD (LN.word8 s)
--- 1220,1227 ----
  		   end
                 else bug "translate INTexp")
!               handle Overflow => (repErr "int constant too large"; INT 0)))
  
          | g (WORDexp(s, t)) =
+ 	  (print "WORDexp\n";
               ((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)
                 else if TU.equalType (t, BT.word8Ty) then WORD (LN.word8 s)
***************
*** 1226,1230 ****
  		   end
                 else (ppType t; bug "translate WORDexp"))
!                handle Overflow => (repErr "word constant too large"; INT 0))
  
          | g (REALexp s) = REAL s
--- 1232,1236 ----
  		   end
                 else (ppType t; bug "translate WORDexp"))
!                handle Overflow => (repErr "word constant too large"; INT 0)))
  
          | g (REALexp s) = REAL s


-------------------------------------------------------------------------
Take Surveys. Earn Cash. Influence the Future of IT
Join SourceForge.net's Techsay panel and you'll get the chance to share your
opinions on IT & business topics through brief surveys -- and earn cash
http://www.techsay.com/default.php?page=join.php&p=sourceforge&CID=DEVDEV