CVS: sml-dist/src/compiler/FLINT/kernel lty.sml, 1.1.2.14, 1.1.2.15 ltykernel.sml, 1.18.12.19, 1.18.12.20
David MacQueen <[email protected]> Mon, 21 Aug 2006 16:07:09 -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-serv19573/src/compiler/FLINT/kernel
Modified Files:
Tag: primop-branch-2
lty.sml ltykernel.sml
Log Message:
debugging plambda type checking
Index: lty.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/Attic/lty.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
*** lty.sml 21 Aug 2006 20:38:36 -0000 1.1.2.14
--- lty.sml 21 Aug 2006 23:07:05 -0000 1.1.2.15
***************
*** 476,480 ****
| AX_NO => bug "unexpected case in lt_nvars"
! end (* local -- hask consing *)
(***************************************************************************
--- 476,480 ----
| AX_NO => bug "unexpected case in lt_nvars"
! end (* local -- hash consing *)
(***************************************************************************
***************
*** 996,1000 ****
end (* function tkChkGen *)
!
fun ltyChkGen () =
let val (tkChk, chkKindEnv) = tkTycGen'()
--- 996,1000 ----
end (* function tkChkGen *)
! (* ltyChkGen : unit -> tkindEnv -> lty -> tkind *)
fun ltyChkGen () =
let val (tkChk, chkKindEnv) = tkTycGen'()
Index: ltykernel.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/ltykernel.sml,v
retrieving revision 1.18.12.19
retrieving revision 1.18.12.20
diff -C2 -d -r1.18.12.19 -r1.18.12.20
*** ltykernel.sml 21 Aug 2006 20:38:36 -0000 1.18.12.19
--- ltykernel.sml 21 Aug 2006 23:07:07 -0000 1.18.12.20
***************
*** 62,65 ****
--- 62,71 ----
in neweff orelse (withEff(r, ol, nl, tenv))
end
+
+ fun tenvLength (tenv: tycEnv) : int =
+ case teDest tenv
+ of NONE => 0
+ | SOME(_,tenv') => 1 + tenvLength tenv'
+
in
***************
*** 67,92 ****
(let fun checkTCVAR tyc = (* GK -- debugging *)
case (tc_outX tyc)
! of TC_VAR(i,j) =>
! (case teLookup(tenv,i)
of SOME(Beta(_,ts,ks)) =>
! if j >= length ts
! then (print "tcc_env TC_VAR ";
! print (Int.toString j);
print ", ts length = ";
print (Int.toString (length ts));
print "\n";
! raise Fail "Bad TC_ENV TC_VAR")
else ()
| SOME(Lamb(_,ks)) =>
! if j >= length ks
! then (print "tcc_env TC_VAR ";
! print (Int.toString j);
print ", ks length = ";
print (Int.toString (length ks));
print "\n";
! raise Fail "Bad TC_ENV TC_VAR")
else ()
! | NONE => (print "tcc_env TC_VAR: i out of bounds: ";
! print (Int.toString i); print "\n"))
| TC_ENV(tc, _, _, _) =>
(print "TC_ENV("; checkTCVAR(tc); print ")\n")
--- 73,100 ----
(let fun checkTCVAR tyc = (* GK -- debugging *)
case (tc_outX tyc)
! of TC_VAR(d,k) =>
! (case teLookup(tenv,d)
of SOME(Beta(_,ts,ks)) =>
! if k >= length ts
! then (print "tcc_env TC_VAR [Beta]: ";
! print (Int.toString k);
print ", ts length = ";
print (Int.toString (length ts));
print "\n";
! bug "Bad TC_ENV TC_VAR [Beta]")
else ()
| SOME(Lamb(_,ks)) =>
! if k >= length ks
! then (print "tcc_env TC_VAR [Lamb]: ";
! print (Int.toString k);
print ", ks length = ";
print (Int.toString (length ks));
print "\n";
! bug "Bad TC_ENV TC_VAR [Lamb]")
else ()
! | NONE => (print "tcc_env TC_VAR: d out of bounds:\n";
! print "d = "; print (Int.toString d); print "\n";
! print "ol = "; print (Int.toString ol); print "\n";
! print "length(tenv) = "; print (Int.toString(tenvLength tenv)); print "\n"))
| TC_ENV(tc, _, _, _) =>
(print "TC_ENV("; checkTCVAR(tc); print ")\n")
***************
*** 143,148 ****
(TC_SEQ tycs) => getArity (List.nth (tycs, index))
| TC_FN (params, _) => length params
! | _ => raise Fail "Malformed generator range")
! | _ => raise Fail "FIX without generator!" )
| _ => (with_pp (fn s =>
(PU.pps s "getArity?:";
--- 151,156 ----
(TC_SEQ tycs) => getArity (List.nth (tycs, index))
| TC_FN (params, _) => length params
! | _ => bug "Malformed generator range")
! | _ => bug "FIX without generator!" )
| _ => (with_pp (fn s =>
(PU.pps s "getArity?:";
***************
*** 274,278 ****
(PU.pps s "tc_lzrd.prop:"; PP.newline s;
ppTyc (!dp) s z; PP.newline s));
! raise Fail ("tc_lzrd prop"))
in (case tc_outX x
of TC_VAR (n,k) =>
--- 282,286 ----
(PU.pps s "tc_lzrd.prop:"; PP.newline s;
ppTyc (!dp) s z; PP.newline s));
! bug "tc_lzrd prop")
in (case tc_outX x
of TC_VAR (n,k) =>
***************
*** 284,288 ****
| SOME(Beta(nl',ts,ks)) => (* rule r6 *)
let val y = List.nth(ts, k)
! handle Subscript => (* kind error! *)
(with_pp(fn s =>
let val {break,newline,openHVBox,openHOVBox,
--- 292,297 ----
| SOME(Beta(nl',ts,ks)) => (* rule r6 *)
let val y = List.nth(ts, k)
! handle Subscript =>
! (* kind/arity error! *)
(with_pp(fn s =>
let val {break,newline,openHVBox,openHOVBox,
***************
*** 311,317 ****
| TC_FN (ks, tc) =>
let val tenv' = teCons(Lamb(nl,ks),tenv)
! in tcc_fn(ks,
tcc_env(tc, ol+1, nl+1, tenv')
! handle Fail _ => raise Fail "tc_lzrd TC_FN") (* rule r10 *)
end
| TC_APP (tc, tcs) => tcc_app(prop tc, map prop tcs) (* rule r9 *)
--- 320,326 ----
| TC_FN (ks, tc) =>
let val tenv' = teCons(Lamb(nl,ks),tenv)
! in tcc_fn(ks,
tcc_env(tc, ol+1, nl+1, tenv')
! handle Fail _ => bug "tc_lzrd TC_FN") (* rule r10 *)
end
| TC_APP (tc, tcs) => tcc_app(prop tc, map prop tcs) (* rule r9 *)
***************
*** 388,393 ****
(TC_SEQ tycs) => getArity (List.nth (tycs, index))
| TC_FN (params, _) => length params
! | _ => raise Fail "Malformed generator range")
! | _ => raise Fail "FIX without generator!" )
| _ => (with_pp (fn s => (PP.openHOVBox s (PP.Rel 2);
PU.pps s "getArity on:";
--- 397,402 ----
(TC_SEQ tycs) => getArity (List.nth (tycs, index))
| TC_FN (params, _) => length params
! | _ => bug "Malformed generator range")
! | _ => bug "FIX without generator!" )
| _ => (with_pp (fn s => (PP.openHOVBox s (PP.Rel 2);
PU.pps s "getArity on:";
***************
*** 407,410 ****
--- 416,420 ----
end
*)
+
(** normalizing an arbitrary tyc into a simple weak-head-normal-form *)
and tc_whnm t = if tcp_norm(t) then t else
***************
*** 425,434 ****
of TC_ENV(b', ol', nl', te') =>
(case teDest te'
! of SOME(Lamb(n,ks'), te) =>
if (n = nl'-1) andalso (ol' > 0)
then (* r12 *)
! (b', ol', n, teCons(Beta(n,tcs,ks),te))
else base()
- (* dbm: ks and ks' should be the same *)
| _ => base())
| _ => base())
--- 435,444 ----
of TC_ENV(b', ol', nl', te') =>
(case teDest te'
! of SOME(Lamb(n,ks'), te'') =>
if (n = nl'-1) andalso (ol' > 0)
then (* r12 *)
! (b', ol', n, teCons(Beta(n,tcs,ks),te''))
! (* dbm: ks and ks' should be the same *)
else base()
| _ => base())
| _ => base())
***************
*** 878,882 ****
fun lt_eqv_x(x : lty, y) =
! let val seq = lt_eqv_gen (lt_eqv_x, tc_eqv_x)
in if ((ltp_norm x) andalso (ltp_norm y)) then
(lt_eq(x, y)) orelse (seq(x, y))
--- 888,892 ----
fun lt_eqv_x(x : lty, y) =
! let val seq = lt_eqv_gen (lt_eqv_x, tc_eqv_x)
in if ((ltp_norm x) andalso (ltp_norm y)) then
(lt_eq(x, y)) orelse (seq(x, y))
***************
*** 887,891 ****
else seq(t1, t2)
end)
! end (* function lt_eqv *)
(** testing equivalence of fflags and rflags *)
--- 897,901 ----
else seq(t1, t2)
end)
! end (* function lt_eqv_x *)
(** testing equivalence of fflags and rflags *)
-------------------------------------------------------------------------
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