CVS: sml-dist/src/compiler/FLINT/kernel lty.sig, 1.1.2.5, 1.1.2.6 lty.sml, 1.1.2.9, 1.1.2.10 ltyextern.sml, 1.19.24.7, 1.19.24.8

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

Modified Files:
      Tag: primop-branch-2
	lty.sig lty.sml ltyextern.sml 
Log Message:
lty kind checker

Index: lty.sig
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/Attic/lty.sig,v
retrieving revision 1.1.2.5
retrieving revision 1.1.2.6
diff -C2 -d -r1.1.2.5 -r1.1.2.6
*** lty.sig	18 Aug 2006 17:28:28 -0000	1.1.2.5
--- lty.sig	18 Aug 2006 20:55:00 -0000	1.1.2.6
***************
*** 188,191 ****
--- 188,193 ----
  (* Kind checker *)
  exception LtyAppChk
+ 
+ val tkTycGen : unit -> (tkindEnv -> tyc -> tkind)
  val tkChkGen : unit -> (tkindEnv -> (tkind * tyc) -> unit)
  

Index: lty.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/Attic/lty.sml,v
retrieving revision 1.1.2.9
retrieving revision 1.1.2.10
diff -C2 -d -r1.1.2.9 -r1.1.2.10
*** lty.sml	18 Aug 2006 17:28:28 -0000	1.1.2.9
--- lty.sml	18 Aug 2006 20:55:00 -0000	1.1.2.10
***************
*** 779,783 ****
  
  (* return the kind of a given tyc in the given kind environment *)
! fun tkTycGen() = let
      val dict = Memo.newDict()
  
--- 779,783 ----
  
  (* return the kind of a given tyc in the given kind environment *)
! fun tkTycGen'() = let
      val dict = Memo.newDict()
  
***************
*** 785,803 ****
          (* default recursive invocation *)    
          val g = tkTyc kenv
- 	fun chkKindEnv(env : tycEnv,j,kenv : tkindEnv) : unit =
- 	    let 
- 		fun chkBinder(Lamb _) = ()
- 		  | chkBinder(Beta(j',args,ks)) = 
- 		    let 
- 			val kenv' = List.drop(kenv, j-j')
- 			val argks = map (fn t => tkTyc kenv' t) args
- 		    in if tksSubkind(ks, argks)
- 		       then ()
- 		       else bug "chkKindEnv: Beta binder kinds mismatch"
- 		    end
- 		    handle Subscript => 
- 			   bug "tkTyc[Env]: dropping too many frames"
- 	    in app chkBinder (teToBinders env)
- 	    end
          (* how to compute the kind of a tyc *)
          fun mk() =
--- 785,788 ----
***************
*** 884,891 ****
          Memo.recallOrCompute (dict, kenv, t, mk)
      end
  in
!     tkTyc
! end (* function tkTycGen *)
  
  (* assert that the kind of `tc' is a subkind of `k' in `kenv' *)
  fun tkChkGen() =
--- 869,896 ----
          Memo.recallOrCompute (dict, kenv, t, mk)
      end
+     and chkKindEnv(env : tycEnv,j,kenv : tkindEnv) : unit =
+ 	let 
+ 	    fun chkBinder(Lamb _) = ()
+ 	      | chkBinder(Beta(j',args,ks)) = 
+ 		let 
+ 		    val kenv' = List.drop(kenv, j-j')
+ 		    val argks = map (fn t => tkTyc kenv' t) args
+ 		in if tksSubkind(ks, argks)
+ 		   then ()
+ 		   else bug "chkKindEnv: Beta binder kinds mismatch"
+ 		end
+ 		handle Subscript => 
+ 		       bug "tkTyc[Env]: dropping too many frames"
+ 	in app chkBinder (teToBinders env)
+ 	end (* function chkKindEnv *)
  in
!     (tkTyc, chkKindEnv)
! end (* function tkTycGen' *)
  
+ fun tkTycGen() = 
+     case tkTycGen'() 
+      of (tkTyc, _) => tkTyc
+       
+  
  (* assert that the kind of `tc' is a subkind of `k' in `kenv' *)
  fun tkChkGen() =
***************
*** 894,899 ****
              tkAssertSubkind (tkTyc kenv tc, k)
      in tkChk
!     end
! end (* local *)
  
  end (* structure Lty *)
--- 899,946 ----
              tkAssertSubkind (tkTyc kenv tc, k)
      in tkChk
!     end (* function tkChkGen *)
  
+ 
+ fun ltyChk (lty : lty) =
+     let val (tkChk, chkKindEnv) = tkTycGen'()
+ 	fun ltyChk' (kenv : tkindEnv) (lty : lty) =
+ 	    (case lt_outX lty 
+ 	      of LT_TYC(tyc) => 
+ 		   (tkAssertIsMono (tkChk kenv tyc); tkc_mono)
+ 	       | LT_STR(ltys) => tkc_seq(map (ltyChk' kenv) ltys)
+ 	       | LT_FCT(paramLtys, rngLtys) => 
+ 		   let val paramks = map (ltyChk' kenv) paramLtys
+ 		       val tenv' = paramks :: kenv
+ 		   in 
+ 		       tkc_fun(paramks,
+ 			      tkc_seq(map (ltyChk' tenv') rngLtys))
+ 		   end
+ 		    (* TODO might need a little more here *)
+ 	       | LT_POLY(ks, ltys) => 
+ 		   tkc_seq(map (ltyChk' (ks::kenv)) ltys)
+ 		   (* ??? *)
+ 	       | LT_CONT(ltys) => 
+ 		   tkc_seq(map (ltyChk' kenv) ltys)
+ 	       | LT_IND(thunk, sigltyI) =>
+ 		   (ltyChk' kenv) thunk
+ 		   (* TODO Need to check against sigltyI kind also? *)
+ 	       | LT_ENV(body, i, j, env) =>
+ 		   (* Should be the same as checking TC_ENV *)
+ 		   (let val kenv' = 
+ 			    List.drop(kenv, j)
+ 			    handle Subscript => 
+ 				   bug "[Env]: dropping too many frames"
+ 			fun bindToKinds(Lamb(_,ks)) = ks
+ 			  | bindToKinds(Beta(_,_,ks)) = ks
+ 			fun addBindToKEnv(b,ke) = 
+ 			    bindToKinds b :: ke
+ 			val bodyKenv = 
+ 			    foldr addBindToKEnv kenv' (teToBinders env)
+ 		    in chkKindEnv(env,j,kenv);
+ 		       ltyChk' bodyKenv body
+ 		    end))
+     in ltyChk' [] lty
+     end (* function ltyChk *)	   
+ end (* local *)
+ 		   
  end (* structure Lty *)

Index: ltyextern.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/ltyextern.sml,v
retrieving revision 1.19.24.7
retrieving revision 1.19.24.8
diff -C2 -d -r1.19.24.7 -r1.19.24.8
*** ltyextern.sml	18 Aug 2006 17:28:28 -0000	1.19.24.7
--- ltyextern.sml	18 Aug 2006 20:55:00 -0000	1.19.24.8
***************
*** 311,314 ****
--- 311,317 ----
      end
  *)
+ 
+ val tkTycGen : unit -> (tkindEnv -> tyc -> tkind) = LT.tkTycGen
+ val tkChkGen : unit -> (tkindEnv -> (tkind * tyc) -> unit) = LT.tkChkGen
      
  (* lty application with kind-checking (exported) *)


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