CVS: sml-dist/src/compiler/FLINT/kernel ltyextern.sml, 1.19.24.13, 1.19.24.14 ltykindchk.sml, 1.1.2.2, 1.1.2.3 pplty.sml, 1.1.2.14, 1.1.2.15
David MacQueen <[email protected]> Thu, 24 Aug 2006 09:32:48 -0700
| Newsgroups | gmane.comp.lang.sml.smlnj.commits |
|---|---|
| Message-ID | <[email protected]> |
Update of /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv20703/src/compiler/FLINT/kernel
Modified Files:
Tag: primop-branch-2
ltyextern.sml ltykindchk.sml pplty.sml
Log Message:
updated kind check, ppLty
Index: ltyextern.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/ltyextern.sml,v
retrieving revision 1.19.24.13
retrieving revision 1.19.24.14
diff -C2 -d -r1.19.24.13 -r1.19.24.14
*** ltyextern.sml 23 Aug 2006 23:44:17 -0000 1.19.24.13
--- ltyextern.sml 24 Aug 2006 16:32:44 -0000 1.19.24.14
***************
*** 68,72 ****
val ltKindChk = LtyKindChk.ltKindCheckGen ()
! val (tcKindChk,teKindChk) = LtyKindChk.tcteKindCheckGen ()
val tkc_mono = LT.tkc_mono
--- 68,72 ----
val ltKindChk = LtyKindChk.ltKindCheckGen ()
! val (tcKindChk,tcKindVer,teKindChk) = LtyKindChk.tcteKindCheckGen ()
val tkc_mono = LT.tkc_mono
Index: ltykindchk.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/Attic/ltykindchk.sml,v
retrieving revision 1.1.2.2
retrieving revision 1.1.2.3
diff -C2 -d -r1.1.2.2 -r1.1.2.3
*** ltykindchk.sml 24 Aug 2006 14:56:24 -0000 1.1.2.2
--- ltykindchk.sml 24 Aug 2006 16:32:45 -0000 1.1.2.3
***************
*** 25,31 ****
val tcKindCheckGen : unit -> (Lty.tkindEnv -> Lty.tyc -> Lty.tkind)
val tcKindVerifyGen : unit -> (Lty.tkindEnv -> (Lty.tkind * Lty.tyc) -> unit)
val ltKindCheckGen : unit -> (Lty.tkindEnv -> Lty.lty -> Lty.tkind)
val tcteKindCheckGen : unit -> (Lty.tkindEnv -> Lty.tyc -> Lty.tkind) *
! (Lty.tycEnv * int * Lty.tkindEnv -> unit)
end (* signature LTYKINDCHK *)
--- 25,33 ----
val tcKindCheckGen : unit -> (Lty.tkindEnv -> Lty.tyc -> Lty.tkind)
val tcKindVerifyGen : unit -> (Lty.tkindEnv -> (Lty.tkind * Lty.tyc) -> unit)
+ val teKindCheckGen : unit -> (Lty.tkindEnv -> (Lty.tycEnv * int) -> unit)
val ltKindCheckGen : unit -> (Lty.tkindEnv -> Lty.lty -> Lty.tkind)
val tcteKindCheckGen : unit -> (Lty.tkindEnv -> Lty.tyc -> Lty.tkind) *
! (Lty.tkindEnv -> (Lty.tkind * Lty.tyc) -> unit) *
! (Lty.tkindEnv -> (Lty.tycEnv * int) -> unit)
end (* signature LTYKINDCHK *)
***************
*** 38,42 ****
open Lty
! fun bug s = ErrorMsg.impossible ("Lty:" ^ s)
(********************************************************************
--- 40,46 ----
open Lty
! fun bug s = ErrorMsg.impossible ("LtyKindChk:" ^ s)
!
! val with_pp = PP.with_default_pp
(********************************************************************
***************
*** 61,65 ****
(List.nth(ks, i)
handle Subscript => raise KindChk "Invalid TC_SEQ index")
! | _ => raise KindChk "Projecting out of non-tyc sequence")
(* tks_eqv: not used, and not exported -- was used in superceded version
--- 65,69 ----
(List.nth(ks, i)
handle Subscript => raise KindChk "Invalid TC_SEQ index")
! | _ => raise KindChk "Projecting out of sequence")
(* tks_eqv: not used, and not exported -- was used in superceded version
***************
*** 97,100 ****
--- 101,105 ----
end) *)
+ (*
(* strip any unused type variables out of a kenv, given a list of
* [encoded] free type variables. the result is a "parallel list" of
***************
*** 122,126 ****
handle Subscript =>
(print "### tkLookupFreeVars:3\n";
! PP.with_default_pp
(fn ppstrm =>
(PP.string ppstrm "tyc: ";
--- 127,131 ----
handle Subscript =>
(print "### tkLookupFreeVars:3\n";
! with_pp
(fn ppstrm =>
(PP.string ppstrm "tyc: ";
***************
*** 145,148 ****
--- 150,154 ----
* on the decoded pairs *)
end
+ *)
structure Memo :> sig
***************
*** 158,169 ****
end)
! type dict = (tkind * tkind) list TcDict.map ref
val newDict : unit -> dict = ref o (fn () => TcDict.empty)
fun recallOrCompute (dict, kenv, tyc, doit) =
! (* what are the valuations of tyc's free variables
! * in kenv? *)
! (* (might not be available for some tycs) *)
! case tkLookupFreeVars (kenv, tyc)
of SOME ks_fvs =>
let
--- 164,176 ----
end)
! (* type dict = (tkind * tkind) list TcDict.map ref *)
! type dict = tkind TcDict.map ref
val newDict : unit -> dict = ref o (fn () => TcDict.empty)
fun recallOrCompute (dict, kenv, tyc, doit) =
! (* only cashe kinds of closed tycs, to avoid possibility
! * of free tvs that are not bound in kenv *)
! case tc_vs tyc (* tkLookupFreeVars (kenv, tyc) *)
! (*
of SOME ks_fvs =>
let
***************
*** 190,208 ****
end
end
! | NONE =>
! (* freevars were not available. we'll have to
! * recompute and cannot cache the result.
! *)
! doit()
end (* Memo *)
(* return the kind of a given tyc in the given kind environment *)
! fun tcteKindCheckGen() = let
! val dict = Memo.newDict()
! fun tkTyc (kenv : tkindEnv) t = let
(* default recursive invocation *)
! val g = tkTyc kenv
(* how to compute the kind of a tyc *)
fun mkI tycI =
--- 197,222 ----
end
end
! *)
! of SOME [] => (* tyc is closed *)
! (case TcDict.find(!dict, tyc)
! of SOME tk => tk
! | NONE =>
! let val tk = doit()
! in dict := TcDict.insert(!dict, tyc, tk);
! tk
! end)
! | _ => (* not known to be closed. Have to compute,
! * and can't cashe. *)
! doit()
end (* Memo *)
(* return the kind of a given tyc in the given kind environment *)
! fun tcteKindCheckGen() =
! let val dict = Memo.newDict()
! fun tcKindChk (kenv : tkindEnv) t = let
(* default recursive invocation *)
! val g = tcKindChk kenv
(* how to compute the kind of a tyc *)
fun mkI tycI =
***************
*** 213,225 ****
(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"
| TC_PRIM pt =>
tkc_int (PrimTyc.pt_arity pt)
| TC_FN(ks, tc) =>
! tkc_fun(ks, tkTyc (tkInsert (kenv,ks)) tc)
| TC_APP (tc, tcs) =>
tkApp (g tc, map g tcs)
--- 227,239 ----
(with_pp (fn s =>
(PU.pps s "KindChk: unbound tv: ";
! PPLty.ppTyc 10 s (tc_injX tycI);
PP.newline s));
! raise KindChk "unbound tv"))
| TC_NVAR _ =>
! bug "TC_NVAR not supported yet in tcKindChk"
| TC_PRIM pt =>
tkc_int (PrimTyc.pt_arity pt)
| TC_FN(ks, tc) =>
! tkc_fun(ks, tcKindChk (tkInsert (kenv,ks)) tc)
| TC_APP (tc, tcs) =>
tkApp (g tc, map g tcs)
***************
*** 240,259 ****
| _ => tkApp(k, map g ts)
in case (tk_outX nk)
! of TK_FUN(a, b) =>
! let val arg =
! case a
of [x] => x
! | _ => tkc_seq a
(* "sequencize" the domain to make it comparable
! * to b *)
in
(* Kind check recursive tyc app ??*)
(* [KM ???] seems bogus if arg is a proper subkind,
* but probably ok if tkSubkind is really equivalence *)
! if tkSubkind(arg, b) then (* order? *)
! (if n = 1 then b else tkSel(arg, i))
else raise KindChk "Recursive app mismatch"
end
! | _ => raise KindChk "FIX with no generator"
end
| TC_ABS tc =>
--- 254,273 ----
| _ => tkApp(k, map g ts)
in case (tk_outX nk)
! of TK_FUN(argk, resk) =>
! let val argk' =
! case argk
of [x] => x
! | _ => tkc_seq argk
(* "sequencize" the domain to make it comparable
! * to resk *)
in
(* Kind check recursive tyc app ??*)
(* [KM ???] seems bogus if arg is a proper subkind,
* but probably ok if tkSubkind is really equivalence *)
! if tkSubkind(argk', resk) then (* order? *)
! (if n = 1 then resk else tkSel(resk, i))
else raise KindChk "Recursive app mismatch"
end
! | _ => raise KindChk "FIX with bad generator"
end
| TC_ABS tc =>
***************
*** 273,280 ****
(tkAssertIsMono (g tc);
tkc_mono)
! | TC_PARROW _ => bug "unexpected TC_PARROW in tkTyc"
! (* | TC_ENV _ => bug "unexpected TC_ENV in tkTyc" *)
| TC_ENV(body, 0, j, teEmpty) =>
! (tkTyc (List.drop(kenv,j)) body
handle Subscript =>
bug "[Env]: dropping too many frames")
--- 287,294 ----
(tkAssertIsMono (g tc);
tkc_mono)
! | TC_PARROW _ => bug "unexpected TC_PARROW in tcKindChk"
! (* | TC_ENV _ => bug "unexpected TC_ENV in tcKindChk" *)
| TC_ENV(body, 0, j, teEmpty) =>
! (tcKindChk (List.drop(kenv,j)) body
handle Subscript =>
bug "[Env]: dropping too many frames")
***************
*** 290,297 ****
val bodyKenv =
foldr addBindToKEnv kenv' (teToBinders env)
! in chkKindEnv(env,j,kenv);
! tkTyc bodyKenv body
end)
! (* | TC_IND _ => bug "unexpected TC_IND in tkTyc" *)
| TC_IND(newtyc, oldtycI) =>
let val newtycknd = g newtyc
--- 304,311 ----
val bodyKenv =
foldr addBindToKEnv kenv' (teToBinders env)
! in teKindChk kenv (env,j);
! tcKindChk bodyKenv body
end)
! (* | TC_IND _ => bug "unexpected TC_IND in tcKindChk" *)
| TC_IND(newtyc, oldtycI) =>
let val newtycknd = g newtyc
***************
*** 299,305 ****
if tk_eq(newtycknd, mkI oldtycI)
then newtycknd
! else bug "tkTyc[IND]: new tyc and old tycI kind mismatch"
end
! | TC_CONT _ => bug "unexpected TC_CONT in tkTyc"
fun mk () =
mkI (tc_outX t)
--- 313,319 ----
if tk_eq(newtycknd, mkI oldtycI)
then newtycknd
! else bug "tcKindChk[IND]: new and old kind mismatch"
end
! | TC_CONT _ => bug "unexpected TC_CONT in tcKindChk"
fun mk () =
mkI (tc_outX t)
***************
*** 307,312 ****
Memo.recallOrCompute (dict, kenv, t, mk)
handle tkUnbound => raise KindChk "tkUnbound"
! end
! and chkKindEnv(env : tycEnv,j,kenv : tkindEnv) : unit =
let
fun chkBinder(Lamb _) = ()
--- 321,327 ----
Memo.recallOrCompute (dict, kenv, t, mk)
handle tkUnbound => raise KindChk "tkUnbound"
! end (* function tcKindChk *)
!
! and teKindChk(kenv: tkindEnv) (env: tycEnv, j: int) : unit =
let
fun chkBinder(Lamb _) = ()
***************
*** 314,350 ****
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 tcteKindCheckGen *)
fun tcKindCheckGen() =
! case tcteKindCheckGen()
! of (tcKindChk, _) => tcKindChk
-
- (* assert that the kind of `tc' is a subkind of `k' in `kenv' *)
fun tcKindVerifyGen() =
! let val tkTyc = tcKindCheckGen()
! fun tkChk kenv (k, tc) =
! tkAssertSubkind (tkTyc kenv tc, k)
! in tkChk
! end (* function tkChkGen *)
!
(* ltKindCheckGen : unit -> tkindEnv -> lty -> tkind *)
fun ltKindCheckGen () =
! let val (tkChk, chkKindEnv) = tcteKindCheckGen()
fun ltyIChk (kenv : tkindEnv) (ltyI : ltyI) =
(case ltyI
of LT_TYC(tyc) =>
! (tkAssertIsMono (tkChk kenv tyc); tkc_mono)
| LT_STR(ltys) => tkc_seq(map (ltyChk' kenv) ltys)
| LT_FCT(paramLtys, rngLtys) =>
--- 329,365 ----
let
val kenv' = List.drop(kenv, j-j')
! val argks = map (fn t => tcKindChk kenv' t) args
in if tksSubkind(ks, argks)
then ()
! else bug "teKindChk: Beta binder kinds mismatch"
end
handle Subscript =>
! bug "tcKindChk[Env]: dropping too many frames"
in app chkBinder (teToBinders env)
! end (* function teKindChk *)
!
! (* assert that the kind of `tc' is a subkind of `k' in `kenv' *)
! fun tcKindVer kenv (k, tc) =
! tkAssertSubkind (tcKindChk kenv tc, k)
in
! (tcKindChk, tcKindVer, teKindChk)
end (* function tcteKindCheckGen *)
fun tcKindCheckGen() =
! #1(tcteKindCheckGen())
fun tcKindVerifyGen() =
! #2(tcteKindCheckGen())
!
! fun teKindCheckGen() =
! #3(tcteKindCheckGen())
!
(* ltKindCheckGen : unit -> tkindEnv -> lty -> tkind *)
fun ltKindCheckGen () =
! let val (tcKindChk, _, teKindChk) = tcteKindCheckGen()
fun ltyIChk (kenv : tkindEnv) (ltyI : ltyI) =
(case ltyI
of LT_TYC(tyc) =>
! (tkAssertIsMono (tcKindChk kenv tyc); tkc_mono)
| LT_STR(ltys) => tkc_seq(map (ltyChk' kenv) ltys)
| LT_FCT(paramLtys, rngLtys) =>
***************
*** 380,384 ****
val bodyKenv =
foldr addBindToKEnv kenv' (teToBinders env)
! in chkKindEnv(env,j,kenv);
ltyChk' bodyKenv body
end))
--- 395,399 ----
val bodyKenv =
foldr addBindToKEnv kenv' (teToBinders env)
! in teKindChk kenv (env,j);
ltyChk' bodyKenv body
end))
Index: pplty.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/Attic/pplty.sml,v
retrieving revision 1.1.2.14
retrieving revision 1.1.2.15
diff -C2 -d -r1.1.2.14 -r1.1.2.15
*** pplty.sml 24 Aug 2006 14:56:24 -0000 1.1.2.14
--- pplty.sml 24 Aug 2006 16:32:45 -0000 1.1.2.15
***************
*** 75,79 ****
fun ppKeFrame pd ppstrm ks =
! ppList ppstrm {sep=",", pp=ppTKind pd} ks)
fun ppKindEnv pd ppstrm kenv =
--- 75,79 ----
fun ppKeFrame pd ppstrm ks =
! ppList ppstrm {sep=",", pp=ppTKind pd} ks
fun ppKindEnv pd ppstrm kenv =
-------------------------------------------------------------------------
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