CVS: sml-dist/src/compiler/FLINT/kernel ltykernel.sml, 1.18.12.23, 1.18.12.24 ltykindchk.sml, 1.1.2.5, 1.1.2.6 primtyc.sig, 1.4, 1.4.18.1 primtyc.sml, 1.5.10.1, 1.5.10.2
David MacQueen <[email protected]> Tue, 29 Aug 2006 16:17:49 -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-serv18457/src/compiler/FLINT/kernel
Modified Files:
Tag: primop-branch-2
ltykernel.sml ltykindchk.sml primtyc.sig primtyc.sml
Log Message:
various debugging changes
Index: ltykernel.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/ltykernel.sml,v
retrieving revision 1.18.12.23
retrieving revision 1.18.12.24
diff -C2 -d -r1.18.12.23 -r1.18.12.24
*** ltykernel.sml 28 Aug 2006 22:57:53 -0000 1.18.12.23
--- ltykernel.sml 29 Aug 2006 23:17:47 -0000 1.18.12.24
***************
*** 318,322 ****
end);
raise teUnbound2)
! in h(y, 0, nl - nl', teEmpty) (* rule r6 *)
end)
else tcc_var(n-ol+nl, k) (* rule r4 *)
--- 318,327 ----
end);
raise teUnbound2)
! in if nl' > nl then
! (print ("ERROR: tc_lzrd (r6): nl ="^
! Int.toString nl ^ ", nl' = " ^
! Int.toString nl' ^ "\n");
! bug "tc_lzrd - nl' > nl")
! else h(y, 0, nl - nl', teEmpty) (* rule r6 *)
end)
else tcc_var(n-ol+nl, k) (* rule r4 *)
***************
*** 812,817 ****
*)
fun tc_eqv_gen (eqop1, eqop2, hyp) (t1, t2) =
! case (tc_outX t1, tc_outX t2) of
! (TC_FIX _, TC_FIX _) => eqop2 (eqop1, hyp) (t1, t2)
| (TC_FN(ks1, b1), TC_FN(ks2, b2)) =>
eqlist tk_eqv (ks1, ks2) andalso eqop1 hyp (b1, b2)
--- 817,822 ----
*)
fun tc_eqv_gen (eqop1, eqop2, hyp) (t1, t2) =
! case (tc_outX t1, tc_outX t2)
! of (TC_FIX _, TC_FIX _) => eqop2 (eqop1, hyp) (t1, t2)
| (TC_FN(ks1, b1), TC_FN(ks2, b2)) =>
eqlist tk_eqv (ks1, ks2) andalso eqop1 hyp (b1, b2)
***************
*** 839,842 ****
--- 844,849 ----
| (TC_CONT ts1, TC_CONT ts2) =>
eqlist (eqop1 hyp) (ts1, ts2)
+ | (TC_PRIM ptyc1, TC_PRIM ptyc2) =>
+ PT.pt_eq(ptyc1,ptyc2)
| _ => false
***************
*** 885,894 ****
fun lt_eqv(x : lty, y) =
let val seq = lt_eqv_gen (lt_eqv, tc_eqv)
! in if ((ltp_norm x) andalso (ltp_norm y)) then (if not (lt_eq(x,y)) then (print "norm first\n"; lt_eq(x,y)) else true)
! else (let val t1 = lt_whnm x
! val t2 = lt_whnm y
! in if (ltp_norm t1) andalso (ltp_norm t2) then lt_eq(t1, t2)
! else seq(t1, t2)
! end)
end (* function lt_eqv *)
--- 892,900 ----
fun lt_eqv(x : lty, y) =
let val seq = lt_eqv_gen (lt_eqv, tc_eqv)
! in let val t1 = lt_whnm x
! val t2 = lt_whnm y
! in if (ltp_norm t1) andalso (ltp_norm t2) then lt_eq(t1, t2)
! else seq(t1, t2)
! end
end (* function lt_eqv *)
Index: ltykindchk.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/Attic/ltykindchk.sml,v
retrieving revision 1.1.2.5
retrieving revision 1.1.2.6
diff -C2 -d -r1.1.2.5 -r1.1.2.6
*** ltykindchk.sml 24 Aug 2006 23:03:10 -0000 1.1.2.5
--- ltykindchk.sml 29 Aug 2006 23:17:47 -0000 1.1.2.6
***************
*** 11,15 ****
(* tkAssertSubkind(k1,k2): assert that k1 is a subkind of k2 *)
! val tkAssertIsMono : Lty.tkind -> unit
(* assert that a kind is monomorphic *)
--- 11,15 ----
(* tkAssertSubkind(k1,k2): assert that k1 is a subkind of k2 *)
! val tkAssertIsMono : Lty.tkind * string -> unit
(* assert that a kind is monomorphic *)
***************
*** 56,62 ****
(* assert that a kind is monomorphic *)
! fun tkAssertIsMono k =
if tkIsMono k then ()
! else raise KindChk "Mono assertion failed!"
(* select the ith element (0 based) from a kind sequence *)
--- 56,62 ----
(* assert that a kind is monomorphic *)
! fun tkAssertIsMono (k,msg) =
if tkIsMono k then ()
! else raise KindChk ("Mono assertion failed! "^msg)
(* select the ith element (0 based) from a kind sequence *)
***************
*** 249,253 ****
tkSel(g tc, i)
| TC_SUM tcs =>
! (List.app (tkAssertIsMono o g) tcs;
tkc_mono)
| TC_FIX {family={size=n, gen=tc, params=ts,...},index=i} =>
--- 249,253 ----
tkSel(g tc, i)
| TC_SUM tcs =>
! (List.app (fn tc => (tkAssertIsMono(g tc,"TC_SUM"))) tcs;
tkc_mono)
| TC_FIX {family={size=n, gen=tc, params=ts,...},index=i} =>
***************
*** 278,295 ****
end
| TC_ABS tc =>
! (tkAssertIsMono (g tc);
tkc_mono)
| TC_BOX tc =>
! (tkAssertIsMono (g tc);
tkc_mono)
| TC_TUPLE (_,tcs) =>
! (List.app (tkAssertIsMono o g) tcs;
tkc_mono)
! | TC_ARROW (_, ts1, ts2) =>
! (List.app (tkAssertIsMono o g) ts1;
! List.app (tkAssertIsMono o g) ts2;
tkc_mono)
| TC_TOKEN(_, tc) =>
! (tkAssertIsMono (g tc);
tkc_mono)
| TC_PARROW _ => bug "unexpected TC_PARROW in tcKindChk"
--- 278,295 ----
end
| TC_ABS tc =>
! (tkAssertIsMono(g tc, "TC_ABS");
tkc_mono)
| TC_BOX tc =>
! (tkAssertIsMono (g tc, "TC_BOX");
tkc_mono)
| TC_TUPLE (_,tcs) =>
! (List.app (fn tc => (tkAssertIsMono(g tc, "TC_TUPLE"))) tcs;
tkc_mono)
! | TC_ARROW (_, tcs1, tcs2) =>
! (List.app (fn tc => (tkAssertIsMono(g tc, "TC_ARROW domain"))) tcs1;
! List.app (fn tc => (tkAssertIsMono(g tc, "TC_ARROW range"))) tcs2;
tkc_mono)
| TC_TOKEN(_, tc) =>
! (tkAssertIsMono (g tc, "TC_TOKEN");
tkc_mono)
| TC_PARROW _ => bug "unexpected TC_PARROW in tcKindChk"
***************
*** 298,302 ****
(tcKindChk (List.drop(kenv,j)) body
handle Subscript =>
! bug "[Env]: dropping too many frames")
| TC_ENV(body, i, j, env) =>
(let val kenv' =
--- 298,307 ----
(tcKindChk (List.drop(kenv,j)) body
handle Subscript =>
! (if j < 0 then print ("KindChk: negative j: "^Int.toString j^"\n")
! else if j >= (length kenv) then
! (print ("KindChk: drop to large: "^Int.toString j^
! ", |kenv| = "^Int.toString(length kenv)^"\n"))
! else ();
! bug "KindChk: TC_ENV: dropping frames"))
| TC_ENV(body, i, j, env) =>
(let val kenv' =
***************
*** 367,376 ****
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) =>
let val paramks = map (ltyChk' kenv) paramLtys
- (* val kenv' = tkInsert(kenv,paramks) *)
in
tkc_fun(paramks,
--- 372,379 ----
fun ltyIChk (kenv : tkindEnv) (ltyI : ltyI) =
(case ltyI
! of LT_TYC(tyc) => tcKindChk kenv tyc
| LT_STR(ltys) => tkc_seq(map (ltyChk' kenv) ltys)
| LT_FCT(paramLtys, rngLtys) =>
let val paramks = map (ltyChk' kenv) paramLtys
in
tkc_fun(paramks,
Index: primtyc.sig
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/primtyc.sig,v
retrieving revision 1.4
retrieving revision 1.4.18.1
diff -C2 -d -r1.4 -r1.4.18.1
*** primtyc.sig 20 Aug 2001 19:34:05 -0000 1.4
--- primtyc.sig 29 Aug 2006 23:17:47 -0000 1.4.18.1
***************
*** 48,51 ****
--- 48,54 ----
val pt_fromint : int -> primtyc
+ (** equality of primtycs *)
+ val pt_eq : primtyc * primtyc -> bool
+
(** check the boxity of values of each prim tyc *)
val unboxed : primtyc -> bool
Index: primtyc.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/primtyc.sml,v
retrieving revision 1.5.10.1
retrieving revision 1.5.10.2
diff -C2 -d -r1.5.10.1 -r1.5.10.2
*** primtyc.sml 3 Aug 2006 03:11:32 -0000 1.5.10.1
--- primtyc.sml 29 Aug 2006 23:17:47 -0000 1.5.10.2
***************
*** 110,113 ****
--- 110,115 ----
end
+ fun pt_eq ((_,_,ptn1): primtyc, (_,_,ptn2): primtyc) = (ptn1 = ptn2)
+
(** printing out the primitive type constructor *)
fun pt_print (pt, _, _) =
-------------------------------------------------------------------------
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