CVS: sml-dist/src/compiler/ElabData/types typesutil.sml, 1.3.2.13, 1.3.2.14

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

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

Index: typesutil.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/ElabData/types/typesutil.sml,v
retrieving revision 1.3.2.13
retrieving revision 1.3.2.14
diff -C2 -d -r1.3.2.13 -r1.3.2.14
*** typesutil.sml	13 Jul 2006 22:35:51 -0000	1.3.2.13
--- typesutil.sml	18 Jul 2006 01:10:33 -0000	1.3.2.14
***************
*** 157,161 ****
  
  fun prune(VARty(tv as ref(INSTANTIATED ty))) : ty =
!       let val pruned = prune ty
         in tv := INSTANTIATED pruned; pruned
        end
--- 157,163 ----
  
  fun prune(VARty(tv as ref(INSTANTIATED ty))) : ty =
!       let val _ = print "prune VARty\n"
! 	  val pruned = prune ty
! 	  val _ = print "pruned VARty\n"
         in tv := INSTANTIATED pruned; pruned
        end
***************
*** 163,167 ****
      
  fun pruneTyvar(tv as ref(INSTANTIATED ty)) : ty =
!       let val pruned = prune ty
         in tv := INSTANTIATED pruned; pruned
        end
--- 165,171 ----
      
  fun pruneTyvar(tv as ref(INSTANTIATED ty)) : ty =
!       let val _ = print "pruneTyvar\n"
! 	  val pruned = prune ty
! 	  val _ = print "pruned\n"
         in tv := INSTANTIATED pruned; pruned
        end
***************
*** 553,560 ****
   * the parameters of instantiation of the primop.
   *)
  
  fun matchInstTypes(specTy,actualTy) =
!     let	fun match'(WILDCARDty, _) = () (* possible? how? *)
! 	  | match'(_, WILDCARDty) = () (* possible? how? *)
  	  | match'(ty1, VARty(tv as ref(OPEN{kind=META,eq,...}))) =
                if eq andalso not(checkEqTyInst(ty1))
--- 557,565 ----
   * the parameters of instantiation of the primop.
   *)
+ exception WILDCARDmatch
  
  fun matchInstTypes(specTy,actualTy) =
!     let	fun match'(WILDCARDty, _) = raise WILDCARDmatch (* possible? how? *)
! 	  | match'(_, WILDCARDty) = raise WILDCARDmatch (* possible? how? *)
  	  | match'(ty1, VARty(tv as ref(OPEN{kind=META,eq,...}))) =
                if eq andalso not(checkEqTyInst(ty1))
***************
*** 563,566 ****
--- 568,576 ----
  	  | match'(ty1, VARty(tv as ref(INSTANTIATED ty2))) =
                if equalType(ty1,ty2) then () else (print "INSTANTIATED\n"; raise CompareTypes)
+ 	  (* GK: Does this make sense? matchInstTypes should not apply
+ 		 as is if all the metavariables have been translated 
+ 	         into TV_MARKs *)
+ 	  | match'(VARty(ref (TV_MARK m)), VARty(ref (TV_MARK m'))) = 
+ 	      if m = m' then () else raise CompareTypes 
  	  | match'(CONty(tycon1, args1), CONty(tycon2, args2)) =
  	      if eqTycon(tycon1,tycon2)
***************
*** 571,575 ****
  	  | match'(_, POLYty _) = (print "POLYty\n"; raise CompareTypes)
  	  | match'(_, CONty _) = (print "unmatched CONty\n"; raise CompareTypes)
! 	  | match'(_, VARty vk) = (print "VARty other\n"; 
  				  (case vk of 
  				       (ref (OPEN _)) => print "open\n"
--- 581,585 ----
  	  | match'(_, POLYty _) = (print "POLYty\n"; raise CompareTypes)
  	  | match'(_, CONty _) = (print "unmatched CONty\n"; raise CompareTypes)
! 	  | match'(t1, VARty vk) = (print "VARty other\n"; 
  				  (case vk of 
  				       (ref (OPEN _)) => print "open\n"
***************
*** 577,586 ****
  				     | (ref (LITERAL _)) => print "literal\n"
  				     | (ref (SCHEME _)) => print "scheme\n"
! 				     | (ref (TV_MARK _)) => print "mark\n");
  				  raise CompareTypes)
          and match(ty1,ty2) = match'(headReduceType ty1, headReduceType ty2)
          val (actinst, actParamTvs) = instantiatePoly actualTy
          val (specinst, specGenericTvs) = instantiatePoly specTy
      in match(specinst, actinst);
         SOME(specGenericTvs, actParamTvs)
      end handle CompareTypes => NONE
--- 587,611 ----
  				     | (ref (LITERAL _)) => print "literal\n"
  				     | (ref (SCHEME _)) => print "scheme\n"
! 				     | (ref (TV_MARK m)) => (print ("mark" ^ (Int.toString m) ^"\n");
! 							     (case t1 
! 							       of (VARty(ref (TV_MARK m'))) =>
! 								  print ("mark'" ^ (Int.toString m') ^ "\n")
! 								| (VARty(ref (OPEN _))) => 
! 								  print ("OPEN\n")
! 								| (VARty(ref (UBOUND _))) =>
! 								  print ("UBOUND\n")
! 								| (VARty(ref (LITERAL _))) =>
! 								  print ("LITERAL\n")
! 								| (VARty(ref (SCHEME _))) =>
! 								  print "SCHEME\n"
! 								| (POLYty _) => print "POLYty\n"))
! 				     | (ref (INSTANTIATED _)) => print "inst'ed\n");
  				  raise CompareTypes)
          and match(ty1,ty2) = match'(headReduceType ty1, headReduceType ty2)
          val (actinst, actParamTvs) = instantiatePoly actualTy
          val (specinst, specGenericTvs) = instantiatePoly specTy
+ 	val _ = print "Instantiated both\n"
      in match(specinst, actinst);
+        print "matched\n";
         SOME(specGenericTvs, actParamTvs)
      end handle CompareTypes => NONE


-------------------------------------------------------------------------
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