CVS: sml-dist/src/compiler/ElabData/types typesutil.sml, 1.3.2.15, 1.3.2.16
George Kuan <[email protected]> Wed, 26 Jul 2006 08:22:48 -0700
| Newsgroups | gmane.comp.lang.sml.smlnj.commits |
|---|---|
| Message-ID | <[email protected]> |
Update of /cvsroot/smlnj/sml-dist/src/compiler/ElabData/types
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv1834/src/compiler/ElabData/types
Modified Files:
Tag: primop-branch-2
typesutil.sml
Log Message:
typesutil, moduleutils, and translate...debugging output now checks debugging flag...more debugging for flintnm/ltykernel
Index: typesutil.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/ElabData/types/typesutil.sml,v
retrieving revision 1.3.2.15
retrieving revision 1.3.2.16
diff -C2 -d -r1.3.2.15 -r1.3.2.16
*** typesutil.sml 18 Jul 2006 02:39:07 -0000 1.3.2.15
--- typesutil.sml 26 Jul 2006 15:21:40 -0000 1.3.2.16
***************
*** 27,30 ****
--- 27,31 ----
val say = Control_Print.say
val debugging = ref false
+ fun debugmsg msg = if !debugging then say ("TypesUtil: " ^ msg ^ "\n") else ()
fun bug msg = EM.impossible("TypesUtil: "^msg)
***************
*** 157,173 ****
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
| prune ty = ty
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
| pruneTyvar _ = bug "pruneTyvar: not an instantiated tyvar"
--- 158,170 ----
fun prune(VARty(tv as ref(INSTANTIATED ty))) : ty =
! let val pruned = prune ty
! in tv := INSTANTIATED pruned; pruned
end
| prune ty = ty
fun pruneTyvar(tv as ref(INSTANTIATED ty)) : ty =
! let val pruned = prune ty
! in tv := INSTANTIATED pruned; pruned
! end
| pruneTyvar _ = bug "pruneTyvar: not an instantiated tyvar"
***************
*** 560,573 ****
fun matchInstTypes(specTy,actualTy) =
! let fun match'(WILDCARDty, _) = raise WILDCARDmatch (* possible? how? *)
| match'(_, WILDCARDty) = raise WILDCARDmatch (* possible? how? *)
| match'(ty1, ty2 as VARty(tv as ref(OPEN{kind=META,eq,...}))) =
if eq andalso not(checkEqTyInst(ty1))
! then (print "VARty META\n"; raise CompareTypes)
else if equalType(ty1, ty2)
! then (* (print "matching Equal Tyvars\n") *) ()
else tv := INSTANTIATED ty1
| 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
--- 557,571 ----
fun matchInstTypes(specTy,actualTy) =
! let fun debugmsg' msg = debugmsg ("matchInstTypes: " ^ msg)
! fun match'(WILDCARDty, _) = raise WILDCARDmatch (* possible? how? *)
| match'(_, WILDCARDty) = raise WILDCARDmatch (* possible? how? *)
| match'(ty1, ty2 as VARty(tv as ref(OPEN{kind=META,eq,...}))) =
if eq andalso not(checkEqTyInst(ty1))
! then (debugmsg' "VARty META\n"; raise CompareTypes)
else if equalType(ty1, ty2)
! then ()
else tv := INSTANTIATED ty1
| match'(ty1, VARty(tv as ref(INSTANTIATED ty2))) =
! if equalType(ty1,ty2) then () else (debugmsg' "INSTANTIATED"; raise CompareTypes)
(* GK: Does this make sense? matchInstTypes should not apply
as is if all the metavariables have been translated
***************
*** 578,613 ****
if eqTycon(tycon1,tycon2)
then ListPair.app match (args1,args2)
! else (print "CONty\n"; raise CompareTypes)
! | match'(_, UNDEFty) = (print "UNDEFty\n"; raise CompareTypes)
! | match'(_, IBOUND _) = (print "IBOUND\n"; raise CompareTypes)
! | 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"
! | (ref (UBOUND _)) => print "ubound\n"
! | (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
--- 576,592 ----
if eqTycon(tycon1,tycon2)
then ListPair.app match (args1,args2)
! else (debugmsg' "CONty"; raise CompareTypes)
! | match'(_, UNDEFty) = (debugmsg' "UNDEFty"; raise CompareTypes)
! | match'(_, IBOUND _) = (debugmsg' "IBOUND"; raise CompareTypes)
! | match'(_, POLYty _) = (debugmsg' "POLYty"; raise CompareTypes)
! | match'(_, CONty _) = (debugmsg' "unmatched CONty"; raise CompareTypes)
! | match'(t1, VARty vk) = (debugmsg' "VARty other";
! raise CompareTypes)
and match(ty1,ty2) = match'(headReduceType ty1, headReduceType ty2)
val (actinst, actParamTvs) = instantiatePoly actualTy
val (specinst, specGenericTvs) = instantiatePoly specTy
! val _ = debugmsg' "Instantiated both\n"
in match(specinst, actinst);
! debugmsg' "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