CVS: sml-dist/src/compiler/FLINT/kernel ltykindchk.sml, 1.1.2.1, 1.1.2.2 pplty.sml, 1.1.2.13, 1.1.2.14

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

Modified Files:
      Tag: primop-branch-2
	ltykindchk.sml pplty.sml 
Log Message:
added printer for kind environments

Index: ltykindchk.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/Attic/ltykindchk.sml,v
retrieving revision 1.1.2.1
retrieving revision 1.1.2.2
diff -C2 -d -r1.1.2.1 -r1.1.2.2
*** ltykindchk.sml	24 Aug 2006 12:20:15 -0000	1.1.2.1
--- ltykindchk.sml	24 Aug 2006 14:56:24 -0000	1.1.2.2
***************
*** 8,28 ****
    exception KindChk of string
  
-   (* assert that k1 is a subkind of k2 *)
    val tkAssertSubkind : Lty.tkind * Lty.tkind -> unit
  
-   (* assert that a kind is monomorphic *)
    val tkAssertIsMono : Lty.tkind -> unit
  
-   (* select the ith element (0 based) from a kind sequence *)
    val tkSel : Lty.tkind * int -> Lty.tkind
  
!   val tks_eqv : Lty.tkind list * Lty.tkind list -> bool
! 
!   (* tkApp: tkind * tkind list
!    * tkApp(tk,tks): check the validity of an application of a
     * type function of kind `tk' to a list of arguments of kinds `tks'.
     * Returns the result kind if valid, raises KindChk otherwise.
     *)
-   val tkApp : Lty.tkind * Lty.tkind list -> Lty.tkind
  
    val tcKindCheckGen :   unit -> (Lty.tkindEnv -> Lty.tyc -> Lty.tkind)
--- 8,25 ----
    exception KindChk of string
  
    val tkAssertSubkind : Lty.tkind * Lty.tkind -> unit
+   (* tkAssertSubkind(k1,k2): assert that k1 is a subkind of k2 *)
  
    val tkAssertIsMono : Lty.tkind -> unit
+   (* assert that a kind is monomorphic *)
  
    val tkSel : Lty.tkind * int -> Lty.tkind
+   (* select the ith element (0 based) from a kind sequence *)
  
!   val tkApp : Lty.tkind * Lty.tkind list -> Lty.tkind
!   (* tkApp(tk,tks): check the validity of an application of a
     * type function of kind `tk' to a list of arguments of kinds `tks'.
     * Returns the result kind if valid, raises KindChk otherwise.
     *)
  
    val tcKindCheckGen :   unit -> (Lty.tkindEnv -> Lty.tyc -> Lty.tkind)
***************
*** 66,70 ****
--- 63,70 ----
       | _ => raise KindChk "Projecting out of non-tyc sequence")
  
+ (* tks_eqv: not used, and not exported -- was used in superceded version 
+  * of tkApp that used it instead of tksSubkind
  fun tks_eqv (ks1, ks2) = tk_eq(tkc_seq ks1, tkc_seq ks2)
+  *)
  
  (* tkApp: tkind * tkind list
***************
*** 207,213 ****
          (* how to compute the kind of a tyc *)
  	fun mkI tycI =
!             case tycI of
!                 TC_VAR (i, j) =>
!                 tkLookup (kenv, i, j)
                | TC_NVAR _ => 
                  bug "TC_NVAR not supported yet in tkTyc"
--- 207,219 ----
          (* how to compute the kind of a tyc *)
  	fun mkI tycI =
!             case tycI
!              of TC_VAR (i, j) =>
!                 (tkLookup (kenv, i, j)
!                  handle tkUnbound =>
!                   (with_pp (fn s =>
!                      (PU.pps s "KindChk: unbound tv: ";
!                       PPL.ppTycI 10 s tycI;
!                       PP.newline s));
!                    raise KindChk "unbound tv")
                | TC_NVAR _ => 
                  bug "TC_NVAR not supported yet in tkTyc"
***************
*** 233,239 ****
                            of [] => k 
                             | _ => tkApp(k, map g ts)
!                 in
!                     case (tk_outX nk) of
!                         TK_FUN(a, b) => 
                          let val arg =
                                  case a
--- 239,244 ----
                            of [] => k 
                             | _ => tkApp(k, map g ts)
!                  in case (tk_outX nk)
!                      of TK_FUN(a, b) => 
                          let val arg =
                                  case a

Index: pplty.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/Attic/pplty.sml,v
retrieving revision 1.1.2.13
retrieving revision 1.1.2.14
diff -C2 -d -r1.1.2.13 -r1.1.2.14
*** pplty.sml	23 Aug 2006 23:44:17 -0000	1.1.2.13
--- pplty.sml	24 Aug 2006 14:56:24 -0000	1.1.2.14
***************
*** 74,77 ****
--- 74,90 ----
          | SOME(elem, rest) => elem::tycEnvFlatten(rest))
  
+ fun ppKeFrame pd ppstrm ks =
+     ppList ppstrm {sep=",", pp=ppTKind pd} ks)
+ 
+ fun ppKindEnv pd ppstrm kenv =
+     if pd < 1 then pps ppstrm "<tkenv>" else
+     let val {openHOVBox, openHVBox, closeBox, pps, ppi, ...} = en_pp ppstrm
+      in pps "[";
+         openHOVBox 1;
+         ppList ppstrm {sep=",",pp=ppKeFrame (pd-1)} kenv;
+         closeBox ();
+         pps "]"
+     end
+ 
  fun ppTEBinder pd ppstrm (binder: Lty.teBinder) =
      if pd < 1 then pps ppstrm "<teBinder>" else
***************
*** 91,95 ****
  	in if pd < 2 then () 
  	   else (pps " : ";
! 		 ppList ppstrm {sep="*", pp=ppTKind (pd-1)} ks)
  	end;
         closeBox()
--- 104,108 ----
  	in if pd < 2 then () 
  	   else (pps " : ";
!                  ppKeFrame (pd-1) ppstrm ks)
  	end;
         closeBox()
***************
*** 286,289 ****
--- 299,303 ----
      end (* ppTyc *)
  
+ 
  fun ppTycEnv pd ppstrm (tycEnv : Lty.tycEnv) =
      if pd < 1 then pps ppstrm "<tycEnv>" else


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