CVS: sml-dist/src/compiler/FLINT/kernel lty.sig, 1.1.2.1, 1.1.2.2 lty.sml, 1.1.2.1, 1.1.2.2 ltykernel.sml, 1.18.12.15, 1.18.12.16 pplty.sml, 1.1.2.9, 1.1.2.10
David MacQueen <[email protected]> Tue, 15 Aug 2006 16:01:34 -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-serv2854/kernel
Modified Files:
Tag: primop-branch-2
lty.sig lty.sml ltykernel.sml pplty.sml
Log Message:
partially done rewrite of tycEnv machinery - not yet correct
Index: lty.sig
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/Attic/lty.sig,v
retrieving revision 1.1.2.1
retrieving revision 1.1.2.2
diff -C2 -d -r1.1.2.1 -r1.1.2.2
*** lty.sig 14 Aug 2006 23:47:47 -0000 1.1.2.1
--- lty.sig 15 Aug 2006 23:01:31 -0000 1.1.2.2
***************
*** 114,122 ****
(** utility functions on tycEnv *)
! exception tcUnbound
! val initTycEnv : tycEnv
! val tcLookup : int * tycEnv -> tycEnvElem
! val tcInsert : tycEnv * tycEnvElem -> tycEnv
! val tcSplit : tycEnv -> (tycEnvElem * tycEnv) option
(** utility functions on tkindEnv *)
--- 114,134 ----
(** utility functions on tycEnv *)
! (* values returned by lookupTycEnv *)
! datatype tycEnvElem
! = B of tkind list * tyc list
! | L of tkind list * int
!
! (* components of a tycEnv *)
! datatype tycEnvComp
! = TEempty
! | TEbind of tkind list * tyc list
! | TElam of tkind list * int * tycEnv
!
! exception UnboundTycEnv
! val emptyTycEnv : tycEnv
! val lookupTycEnv : tycEnv * int -> tycEnvElem
! val bindTycEnv : tkind list * tyc list -> tycEnv
! val lamTycEnv : tkind list * int * tycEnv -> tycEnv
! val splitTycEnv : tycEnv -> tycEnvComp
(** utility functions on tkindEnv *)
Index: lty.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/Attic/lty.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
*** lty.sml 14 Aug 2006 23:47:47 -0000 1.1.2.1
--- lty.sml 15 Aug 2006 23:01:32 -0000 1.1.2.2
***************
*** 241,245 ****
val N = 2048 (* 1024 *)
! val NN = itow (N*N)
val P = 0w509 (* was 0w1019, a prime < 1024 so that N*N*P < maxint *)
--- 241,245 ----
val N = 2048 (* 1024 *)
! val NNdec = itow (N*N) - 0w1
val P = 0w509 (* was 0w1019, a prime < 1024 so that N*N*P < maxint *)
***************
*** 255,259 ****
fun combine [x] = itow x
| combine (a::rest) =
! andb(itow a +(combine rest)*P, NN - 0w1)
| combine _ = bug "unexpected case in combine"
--- 255,259 ----
fun combine [x] = itow x
| combine (a::rest) =
! andb(itow a +(combine rest)*P, NNdec)
| combine _ = bug "unexpected case in combine"
***************
*** 269,273 ****
(case Weak.strong w
of SOME (r as ref(h',t',_)) =>
! if (h=h') andalso (eq {new=t, old=t'})
then (Array.update(table, i, revcat(l,z)); r)
else g(w::l, rest)
--- 269,273 ----
(case Weak.strong w
of SOME (r as ref(h',t',_)) =>
! IF (h=h') andalso (eq {new=t, old=t'})
then (Array.update(table, i, revcat(l,z)); r)
else g(w::l, rest)
***************
*** 478,535 ****
***************************************************************************)
! type tycEnvElem = tyc list option * int
!
(** utility functions for manipulating the tycEnv **)
- local
- val tcenv_nil : tycEnv = tc_injX(TC_PRIM(PT.ptc_void))
- fun tcenv_cons (t: tyc, b: tycEnv): tycEnv =
- tc_injX(TC_ARROW(FF_FIXED, [t],[b]))
! (* tc_encode : tycEnvElem -> tyc *)
! fun tc_encode(NONE, i) =
! tc_injX(TC_PROJ(tcenv_nil,i))
! | tc_encode(SOME ts, i) =
! tc_injX(TC_PROJ(tc_injX(TC_SEQ(ts)), i))
! (* tc_decode : tyc -> tycEnvElem *)
! fun tc_decode (x: tyc) : tycEnvElem =
! (case tc_outX x
! of TC_PROJ(y, i) =>
! (case tc_outX y
! of TC_SEQ ts => (SOME ts, i)
! | TC_PRIM _ => (NONE, i)
! | _ => bug "unexpected tycEnv1 in tc_decode")
! | _ => bug "unexpected tycEnv2 in tc_decode")
! in
! (* tcUnbound -- raised when first element of a deBruijn index is
* out of bounds *)
! exception tcUnbound
! val initTycEnv : tycEnv = tcenv_nil
! fun tcLookup(i, tenv : tycEnv) : tyc list option * int =
if i > 1 then
(case tc_outX tenv
! of TC_ARROW(_,_,[x]) => tcLookup(i-1, x) (* cons *)
! | TC_PRIM _ => raise tcUnbound (* nil *)
! | _ => bug "unexpected tycEnv in tcLookup")
else if i = 1 then
(case tc_outX tenv
! of TC_ARROW(_,[x],_) => tc_decode x (* cons *)
! | TC_PRIM _ => raise tcUnbound (* nil *)
! | _ => bug "unexpected tycEnv in tcLookup")
! else bug "index 0 in tcLookup"
! fun tcInsert(tenv : tycEnv, elem: tycEnvElem): tycEnv =
! tcenv_cons(tc_encode elem, tenv)
! fun tcSplit(tenv : tycEnv) : (tycEnvElem * tycEnv) option =
(case tc_outX tenv
! of TC_ARROW(_,[x],[y]) => SOME (tc_decode x, y)
! | _ => NONE)
!
! end (* local -- utility functions for tycEnv *)
(***************************************************************************
--- 478,532 ----
***************************************************************************)
! (* virtual tycEnv datatype
! * datatype tycEnv
! * = Empty
! * | B of tkind list * tyc list
! * | L of tkind list * int * tycEnv
! *)
!
(** utility functions for manipulating the tycEnv **)
! val emptyTycEnv : tycEnv = tc_injX(TC_SUM[])
! fun bindTycEnv (ks: tkind list, tycs : tyc list): tycEnv =
! tc_injX(TC_FN(ks,TC_SEQ tycs))
+ fun lamTycEnv (ks: tkind list, j: int, tenv: tycEnv) : tycEnv =
+ tc_injX(TC_PROJ(TC_FN(ks,tenv),j))
! (* TycEnvUnbound -- raised when first element of a deBruijn index is
* out of bounds *)
! exception UnboundTycEnv
! datatype tycEnvElem
! = B of tkind list * tyc list
! | L of tkind list * int
! (* 1-based index lookup *)
! fun lookupTycEnv(tenv : tycEnv, i) : tycEnvElem =
if i > 1 then
(case tc_outX tenv
! of TC_PROJ(TC_FN(_,tenv),_) => lookupTycEnv(tenv,i-1) (* L *)
! | TC_SUM _ | TC_PROJ _ => raise UnboundTycEnv (* Empty or B *)
! | _ => bug "unexpected tycEnv in tycEnvLookup")
else if i = 1 then
(case tc_outX tenv
! of TC_FN(ks,TC_SEQ(tycs)) => B(ks,tycs) (* Bind *)
! | TC_PROJ(TC_FN(ks,_,),j) => L(ks,j) (* Lam *)
! | TC_SUM _ => raise UnboundTycEnv (* Empty *)
! | _ => bug "unexpected tycEnv in tycEnvLookup")
! else bug "index 0 in tycEnvLookup"
! datatype tycEnvComp
! = TEempty
! | TEbind of tkind list * tyc list
! | TElam of tkind list * int * tycEnv
! fun splitTycEnv(tenv : tycEnv) : tycEnvComp =
(case tc_outX tenv
! of TC_FN(ks,TC_SEQ(tycs)) => TEbind(ks,tycs) (* B *)
! | TC_PROJ(TC_FN(ks,tenv,),j) => TElam(ks,j,tenv) (* L *)
! | TC_SUM _ => TEempty)
!
(***************************************************************************
Index: ltykernel.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/ltykernel.sml,v
retrieving revision 1.18.12.15
retrieving revision 1.18.12.16
diff -C2 -d -r1.18.12.15 -r1.18.12.16
*** ltykernel.sml 11 Aug 2006 20:42:23 -0000 1.18.12.15
--- ltykernel.sml 15 Aug 2006 23:01:32 -0000 1.18.12.16
***************
*** 249,254 ****
| _ => x)
! and h (x, 0, 0, _) = g x
! | h (x, ol, nl, tenv) =
let fun prop z = tcc_env(z, ol, nl, tenv)
handle Fail _ =>
--- 249,255 ----
| _ => x)
! (* [KM ???] claim: h will not return a TC_IND nor a TC_ENV *)
! and h (x, 0, 0, _) = g x (* [KM ???] redundant call to g here? *)
! | h (x, ol, nl, tenv) =
let fun prop z = tcc_env(z, ol, nl, tenv)
handle Fail _ =>
***************
*** 258,267 ****
raise Fail ("tc_lzrd prop"))
in (case tc_outX x
! of TC_VAR (i,j) =>
! if (i <= ol) then (* i is bound in tenv *)
! (case tcLookup(i, tenv)
! of (NONE, n) => tcc_var(nl - n, j) (* rule r5 *)
| (SOME ts, n) =>
! let val y = List.nth(ts, j)
handle Subscript =>
(with_pp(fn s =>
--- 259,268 ----
raise Fail ("tc_lzrd prop"))
in (case tc_outX x
! of TC_VAR (n,k) =>
! if (n <= ol) then (* i is bound in tenv *)
! (case lookupTycEnv(tenv, i)
! of (NONE, nl') => tcc_var(nl - nl', k) (* rule r5 *)
| (SOME ts, n) =>
! let val y = List.nth(ts, k)
handle Subscript =>
(with_pp(fn s =>
***************
*** 271,275 ****
pps "***Debugging***"; newline();
pps "tc_lzrd arg: "; PPLty.ppTyc (!dp) s t; newline();
! pps "i = "; ppi i; pps ", j = "; ppi j; newline();
pps "length(ts) = : "; ppi (length ts); newline();
pps "ts elements: "; break{nsp=2,offset=2};
--- 272,276 ----
pps "***Debugging***"; newline();
pps "tc_lzrd arg: "; PPLty.ppTyc (!dp) s t; newline();
! pps "n = "; ppi n; pps ", k = "; ppi k; newline();
pps "length(ts) = : "; ppi (length ts); newline();
pps "ts elements: "; break{nsp=2,offset=2};
***************
*** 281,287 ****
end);
raise tcUnbound2)
! in h(y, 0, nl - n, initTycEnv) (* rule r6 *)
end)
! else tcc_var(i-ol+nl, j) (* rule r4 *)
| TC_NVAR _ => x
| TC_PRIM _ => x (* rule r7 *)
--- 282,288 ----
end);
raise tcUnbound2)
! in h(y, 0, nl - nl', emptyTycEnv) (* rule r6 *)
end)
! else tcc_var(n-ol+nl, k) (* rule r4 *)
| TC_NVAR _ => x
| TC_PRIM _ => x (* rule r7 *)
***************
*** 399,403 ****
(case tc_outX b
of TC_ENV(b', ol', nl', te') =>
! (case tcSplit te'
of SOME((NONE, n), te) =>
if (n = nl'-1) andalso (ol' > 0)
--- 400,404 ----
(case tc_outX b
of TC_ENV(b', ol', nl', te') =>
! (case splitTycEnv te'
of SOME((NONE, n), te) =>
if (n = nl'-1) andalso (ol' > 0)
Index: pplty.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/Attic/pplty.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
*** pplty.sml 11 Aug 2006 20:42:23 -0000 1.1.2.9
--- pplty.sml 15 Aug 2006 23:01:32 -0000 1.1.2.10
***************
*** 12,16 ****
local
- structure LK = Lty
structure PT = PrimTyc
structure PP = PrettyPrintNew
--- 12,15 ----
***************
*** 153,158 ****
(openHOVBox 1;
pps "FIX(";
! (case (Lty.tc_outX datatypeFamily) of
! Lty.TC_FN(params, rectyc) => (* generator function *)
let fun ppMus 0 = ()
| ppMus i = (pps "mu";
--- 152,157 ----
(openHOVBox 1;
pps "FIX(";
! (case (Lty.tc_outX datatypeFamily)
! of Lty.TC_FN(params, rectyc) => (* generator function *)
let fun ppMus 0 = ()
| ppMus i = (pps "mu";
-------------------------------------------------------------------------
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