CVS: sml-dist/src/compiler/FLINT/kernel ltyextern.sml, 1.19.24.2, 1.19.24.3

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

Modified Files:
      Tag: primop-branch-2
	ltyextern.sml 
Log Message:
ltyextern subkinding type functions and kind checking error reporting fixes

Index: ltyextern.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/ltyextern.sml,v
retrieving revision 1.19.24.2
retrieving revision 1.19.24.3
diff -C2 -d -r1.19.24.2 -r1.19.24.3
*** ltyextern.sml	11 Aug 2006 20:42:23 -0000	1.19.24.2
--- ltyextern.sml	17 Aug 2006 20:54:13 -0000	1.19.24.3
***************
*** 60,64 ****
   *                      KIND-CHECKING ROUTINES                      *
   ********************************************************************)
! exception TkTycChk
  exception LtyAppChk
  
--- 60,64 ----
   *                      KIND-CHECKING ROUTINES                      *
   ********************************************************************)
! exception TkTycChk of string
  exception LtyAppChk
  
***************
*** 81,85 ****
            tksSubkind (ks1, ks2)
        | (LT.TK_FUN (ks1, k1'), LT.TK_FUN (ks2, k2')) => 
!           tksSubkind (ks1, ks2) andalso (* contravariant *)
            tkSubkind (k1', k2')
        | _ => false
--- 81,85 ----
            tksSubkind (ks1, ks2)
        | (LT.TK_FUN (ks1, k1'), LT.TK_FUN (ks2, k2')) => 
!           tksSubkind (ks2, ks1) andalso (* contravariant *)
            tkSubkind (k1', k2')
        | _ => false
***************
*** 91,106 ****
  fun tkAssertSubkind (k1, k2) =
      if tkSubkind (k1, k2) then ()
!     else raise TkTycChk
  
  (* assert that a kind is monomorphic *)
  fun tkAssertIsMono k =
      if tkIsMono k then ()
!     else raise TkTycChk
  
  (* select the ith element from a kind sequence *)
  fun tkSel (tk, i) = 
    (case (tk_out tk)
!     of (LT.TK_SEQ ks) => (List.nth(ks, i) handle _ => raise TkTycChk)
!      | _ => raise TkTycChk)
  
  fun tks_eqv (ks1, ks2) = tk_eqv(tkc_seq ks1, tkc_seq ks2)
--- 91,106 ----
  fun tkAssertSubkind (k1, k2) =
      if tkSubkind (k1, k2) then ()
!     else raise TkTycChk "Subkind assertion failed!"
  
  (* assert that a kind is monomorphic *)
  fun tkAssertIsMono k =
      if tkIsMono k then ()
!     else raise TkTycChk "Mono assertion failed!"
  
  (* select the ith element from a kind sequence *)
  fun tkSel (tk, i) = 
    (case (tk_out tk)
!     of (LT.TK_SEQ ks) => (List.nth(ks, i) handle Subscript => raise TkTycChk "Invalid TC_SEQ index")
!      | _ => raise TkTycChk "Projecting out of non-tyc sequence")
  
  fun tks_eqv (ks1, ks2) = tk_eqv(tkc_seq ks1, tkc_seq ks2)
***************
*** 108,113 ****
  fun tkApp (tk, tks) = 
    (case (tk_out tk)
!     of LT.TK_FUN(a, b) => if tks_eqv(a, tks) then b else raise TkTycChk
!      | _ => raise TkTycChk)
  
  (* check the application of tycs of kinds `tks' to a type function of
--- 108,113 ----
  fun tkApp (tk, tks) = 
    (case (tk_out tk)
!     of LT.TK_FUN(a, b) => if tks_eqv(a, tks) then b else raise TkTycChk "Param/Arg Tyc Kind mismatch"
!      | _ => raise TkTycChk "Application of non-TK_FUN")
  
  (* check the application of tycs of kinds `tks' to a type function of
***************
*** 117,122 ****
    (case (tk_out tk)
      of LT.TK_FUN(a, b) =>
!        if tksSubkind(tks, a) then b else raise TkTycChk
!      | _ => raise TkTycChk)
  
  (* Kind-checking naturally requires traversing type graphs.  to avoid
--- 117,122 ----
    (case (tk_out tk)
      of LT.TK_FUN(a, b) =>
!        if tksSubkind(tks, a) then b else raise TkTycChk "Param/Arg Tyc Kind mismatch"
!      | _ => raise TkTycChk "Application of non-TK_FUN") 
  
  (* Kind-checking naturally requires traversing type graphs.  to avoid
***************
*** 214,218 ****
                   tkc_mono)
                | LT.TC_FIX ((n, tc, ts), i) =>
!                 let val k = g tc
                      val nk =
                          case ts of
--- 214,220 ----
                   tkc_mono)
                | LT.TC_FIX ((n, tc, ts), i) =>
!                 let (* Kind check generator tyc *)
! 		    val k = g tc
! 		    (* Kind check freetycs *)
                      val nk =
                          case ts of
***************
*** 227,235 ****
                                    | _ => tkc_seq a
                          in
                              if tkSubkind(arg, b) then (* order? *)
                                  (if n = 1 then b else tkSel(arg, i))
!                             else raise TkTycChk
                          end
!                       | _ => raise TkTycChk
                  end
                | LT.TC_ABS tc =>
--- 229,238 ----
                                    | _ => tkc_seq a
                          in
+ 			    (* Kind check recursive tyc app ??*)
                              if tkSubkind(arg, b) then (* order? *)
                                  (if n = 1 then b else tkSel(arg, i))
!                             else raise TkTycChk "Recursive app mismatch"
                          end
!                       | _ => raise TkTycChk "FIX with no generator"
                  end
                | LT.TC_ABS tc =>


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