CVS: sml-dist/src/compiler/ElabData/types typesutil.sig, 1.2.20.2, 1.2.20.3 typesutil.sml, 1.3.2.6, 1.3.2.7

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

Modified Files:
      Tag: primop-branch-2
	typesutil.sig typesutil.sml 
Log Message:
fixup matchTypes in sigmatch, VALvar in many files

Index: typesutil.sig
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/ElabData/types/typesutil.sig,v
retrieving revision 1.2.20.2
retrieving revision 1.2.20.3
diff -C2 -d -r1.2.20.2 -r1.2.20.3
*** typesutil.sig	20 Jun 2006 01:28:00 -0000	1.2.20.2
--- typesutil.sig	7 Jul 2006 21:06:09 -0000	1.2.20.3
***************
*** 65,68 ****
--- 65,73 ----
    val compareTypes : Types.ty * Types.ty -> bool 
  
+   val matchInstTypes : Types.ty * Types.ty -> 
+                          (Types.tyvar list * Types.tyvar list) option
+    (* matchInstTypes probably supercedes compareTypes, and if so,
+     * compareTypes should be deleted *)
+ 
    val tyvarType : Types.ty -> Types.tyvar
  
***************
*** 75,81 ****
    val gtLabel : Symbol.symbol * Symbol.symbol -> bool
  (**
!   val isValue : Absyn.exp -> bool *)
    (* checks whether an expression is nonexpansive; used to determine
     * when type generalization is permitted under the value rule *)
    val isVarTy : Types.ty -> bool
   
--- 80,88 ----
    val gtLabel : Symbol.symbol * Symbol.symbol -> bool
  (**
!   val isValue : Absyn.exp -> bool
    (* checks whether an expression is nonexpansive; used to determine
     * when type generalization is permitted under the value rule *)
+   dbm: where has this moved to? typecheck.sml?
+ **)
    val isVarTy : Types.ty -> bool
   

Index: typesutil.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/ElabData/types/typesutil.sml,v
retrieving revision 1.3.2.6
retrieving revision 1.3.2.7
diff -C2 -d -r1.3.2.6 -r1.3.2.7
*** typesutil.sml	6 Jul 2006 15:00:39 -0000	1.3.2.6
--- typesutil.sml	7 Jul 2006 21:06:09 -0000	1.3.2.7
***************
*** 77,81 ****
   *)
  
! fun mkMETAtyBounded depth : ty = VARty(mkTyvar (mkMETA depth))
  
  fun mkMETAty() = mkMETAtyBounded infinity
--- 77,81 ----
   *)
  
! fun mkMETAtyBounded (depth: int) : ty = VARty(mkTyvar (mkMETA depth))
  
  fun mkMETAty() = mkMETAtyBounded infinity
***************
*** 333,350 ****
  
  fun dconType (tyc,domain) =
!     let val arity = tyconArity tyc
!     in
! 	case arity of
! 	    0 => (case domain of
! 		      NONE => CONty(tyc,[])
! 		    | SOME dom => dom --> CONty(tyc,[]))
! 	  | _ =>
! 	    POLYty{sign=mkPolySign arity,
! 		   tyfun=TYFUN{arity=arity,
! 			       body = case domain of
! 					  NONE => CONty(tyc,boundargs(arity))
! 					| SOME dom =>
! 					  dom --> CONty(tyc,boundargs(arity))}}
!     end
  
  (* matching a scheme against a target type -- used declaring overloadings *)
--- 333,347 ----
  
  fun dconType (tyc,domain) =
!     (case tyconArity tyc
!       of 0 => (case domain
!                  of NONE => CONty(tyc,[])
!                   | SOME dom => dom --> CONty(tyc,[]))
!        | arity =>
!          POLYty{sign=mkPolySign arity,
!                 tyfun=TYFUN{arity=arity,
!                             body = case domain
!                                      of NONE => CONty(tyc,boundargs(arity))
!                                       | SOME dom =>
!                                         dom --> CONty(tyc,boundargs(arity))}})
  
  (* matching a scheme against a target type -- used declaring overloadings *)
***************
*** 456,459 ****
--- 453,475 ----
      end
      handle CHECKEQ => false
+ 
+ fun checkEqTyInst(ty) =
+     let fun eqty(VARty(ref(INSTANTIATED ty))) = eqty ty
+           | eqty(VARty(ref(OPEN{eq,...}))) = if eq then () else raise CHECKEQ
+ 	  | eqty(CONty(DEFtyc{tyfun,...}, args)) =
+ 	      eqty(applyTyfun(tyfun,args))
+ 	  | eqty(CONty(GENtyc { eq, ... }, args)) =
+ 	     (case !eq
+ 		of OBJ => ()
+ 		 | YES => app eqty args
+ 		 | (NO | ABS | IND) => raise CHECKEQ
+ 		 | p => bug ("checkEqTyInst: "^eqpropToString p))
+ 	  | eqty(CONty(RECORDtyc _, args)) = app eqty args
+ 	  | eqty(IBOUND n) = bug "checkEqTyInst: IBOUND in instantiated polytype"
+ 	  | eqty _ = () (* what other cases? dbm *)
+      in eqty ty;
+ 	true
+     end
+     handle CHECKEQ => false
  end
  
***************
*** 473,478 ****
  		      in if eq andalso not(checkEqTySig(ty1,specsign))
  			 then raise CompareTypes
! 			 else ();
! 			 update(env,i,ty1)
  		     end handle Subscript => ())
  		 | ty => if equalType(ty1,ty)
--- 489,493 ----
  		      in if eq andalso not(checkEqTySig(ty1,specsign))
  			 then raise CompareTypes
! 			 else update(env,i,ty1)
  		     end handle Subscript => ())
  		 | ty => if equalType(ty1,ty)
***************
*** 497,503 ****
  		      (compType(body,sign,body',sign',arity); true)
  		  | WILDCARDty => true
! 		  | _ => false)
  	   | WILDCARDty => true
! 	   | _ =>
  	      (case actual
  		 of POLYty{sign,tyfun=TYFUN{arity,body}} =>
--- 512,518 ----
  		      (compType(body,sign,body',sign',arity); true)
  		  | WILDCARDty => true
! 		  | _ => false) (* if spec is poly, then actual must be poly *)
  	   | WILDCARDty => true
! 	   | _ => (* spec is a monotype *)
  	      (case actual
  		 of POLYty{sign,tyfun=TYFUN{arity,body}} =>
***************
*** 526,530 ****
--- 541,551 ----
  
     matchTypes is used in SigMatch for matching structures (matchStr1) only
+ 
+    dbm:This doesn't work. After instantiating spec and actual, have to do
+      a one-way match of spec (specinst) against (more general) actual (actinst),
+      and this match should instantiate the tyvars in actParamTvs to capture
+      the parameters that instantiate actual to produce specinst.
   *)
+ (*
  fun matchTypes (specTy, actualTy) =
      (* If specTy is an instance of actualTy, 
***************
*** 542,545 ****
--- 563,600 ----
  	end
      else ([], [])
+ *)
+ (* matchInstTypes: ty * ty -> (tyvar list * tyvar list) option
+  * The first argument is a spec type (e.g. from a signature spec),
+  * while the second is a potentially more general actual type. The
+  * two types are instantiated (if they are polymorphic), and a one-way
+  * match is performed on their generic instantiations. 
+  * [Note that the match cannot succeed if spec is polymorphic while
+  * actualTy is monomorphic.]
+  * This function is also used more generally to obtain instantiation
+  * parameters for a polytype (actualTy) to obtain one of its instantiations
+  * (specTy). This usage occurs in translate.sml where we match an occurrence
+  * type of a primop variable with the intrinsic type of the primop to obtain
+  * 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))
+ 	      then raise CompareTypes
+ 	      else tv := INSTANTIATED ty1
+ 	  | match'(ty1, VARty(tv as ref(INSTANTIATED ty2)) =
+               if equalType(ty1,ty2) then () else raise CompareTypes
+ 	  | match'(CONty(tycon1, args1), CONty(tycon2, args2)) =
+ 	      if eqTycon(tycon1,tycon2)
+ 	      then ListPair.app match (args1,args2)
+ 	      else raise CompareTypes
+ 	  | match' _ = 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
  
  (* given a single-type-variable type, extract out the tyvar *)
***************
*** 557,561 ****
   * see if a bound tyvar has occurred in some datatypes, e.g. 'a list. 
   * this is useful for representation analysis. This function probably
!  * will soon be obsolete. 
   *)
  fun getRecTyvarMap (n,ty) =
--- 612,616 ----
   * see if a bound tyvar has occurred in some datatypes, e.g. 'a list. 
   * this is useful for representation analysis. This function probably
!  * will soon be obsolete (dbm: Why?). 
   *)
  fun getRecTyvarMap (n,ty) =
***************
*** 623,627 ****
      let fun isrefdcon(DATACON{rep=A.REF,...}) = true
            | isrefdcon _ = false
!         fun iscast (VALvar { info, ... }) = InlInfo.isPrimCast info
            | iscast _ = false
  
--- 678,682 ----
      let fun isrefdcon(DATACON{rep=A.REF,...}) = true
            | isrefdcon _ = false
!         fun iscast (VALvar {prim, ...}) = PrimOpId.isPrimCast prim
            | iscast _ = false
  
***************
*** 931,934 ****
--- 986,992 ----
           | NONE => tyc)
  
+ (* dummyTyGen produces a generator of dummy types with names X0, X1, etc.
+  * These are used to to instantiate type metavariables in top-level val
+  * decls that are not generalized because of the value restriction. *)
  fun dummyTyGen () : unit -> Types.ty =
      let val count = ref 0


Using Tomcat but need to do more? Need to support web services, security?
Get stuff done quickly with pre-integrated technology to make your job easier
Download IBM WebSphere Application Server v.1.0.1 based on Apache Geronimo
http://sel.as-us.falkag.net/sel?cmd=lnk&kid=120709&bid=263057&dat=121642