CVS: sml-dist/src/compiler/FLINT/kernel ltybasic.sig, 1.8.26.1, 1.8.26.2 ltykernel.sig, 1.11.24.4, 1.11.24.5 ltykernel.sml, 1.18.12.13, 1.18.12.14 pplty.sml, 1.1.2.7, 1.1.2.8
George Kuan <[email protected]> Thu, 10 Aug 2006 21:09:25 -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-serv1761/src/compiler/FLINT/kernel
Modified Files:
Tag: primop-branch-2
ltybasic.sig ltykernel.sig ltykernel.sml pplty.sml
Log Message:
Narrowed down where bad suspension was built
Index: ltybasic.sig
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/ltybasic.sig,v
retrieving revision 1.8.26.1
retrieving revision 1.8.26.2
diff -C2 -d -r1.8.26.1 -r1.8.26.2
*** ltybasic.sig 31 Jul 2006 18:50:44 -0000 1.8.26.1
--- ltybasic.sig 11 Aug 2006 04:09:23 -0000 1.8.26.2
***************
*** 116,120 ****
(** utility functions on tycEnv *)
! exception tcUnbound of LtyKernel.tycEnv
type tycEnv = LtyKernel.tycEnv
val initTycEnv : tycEnv
--- 116,120 ----
(** utility functions on tycEnv *)
! exception tcUnbound of LtyKernel.tycEnv * LtyKernel.tyc
type tycEnv = LtyKernel.tycEnv
val initTycEnv : tycEnv
Index: ltykernel.sig
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/ltykernel.sig,v
retrieving revision 1.11.24.4
retrieving revision 1.11.24.5
diff -C2 -d -r1.11.24.4 -r1.11.24.5
*** ltykernel.sig 1 Aug 2006 23:01:19 -0000 1.11.24.4
--- ltykernel.sig 11 Aug 2006 04:09:23 -0000 1.11.24.5
***************
*** 92,96 ****
(** utility functions on tycEnv *)
! exception tcUnbound of tycEnv
val initTycEnv : tycEnv
val tcInsert : tycEnv * (tyc list option * int) -> tycEnv
--- 92,96 ----
(** utility functions on tycEnv *)
! exception tcUnbound of tycEnv * tyc
val initTycEnv : tycEnv
val tcInsert : tycEnv * (tyc list option * int) -> tycEnv
Index: ltykernel.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/ltykernel.sml,v
retrieving revision 1.18.12.13
retrieving revision 1.18.12.14
diff -C2 -d -r1.18.12.13 -r1.18.12.14
*** ltykernel.sml 8 Aug 2006 19:32:53 -0000 1.18.12.13
--- ltykernel.sml 11 Aug 2006 04:09:23 -0000 1.18.12.14
***************
*** 475,480 ****
fun tc_print (x : tyc) =
! (case tc_outX x
! of TC_VAR(i,j) => "TV(" ^ (DI.di_print i) ^ "," ^ (itos j) ^ ")"
| TC_NVAR v => "NTV(v" ^ (itos v) ^ ")"
| TC_PRIM pt => PT.pt_print pt
--- 475,482 ----
fun tc_print (x : tyc) =
! tci_print (tc_outX x)
!
! and tci_print (tci ) =
! (case tci of TC_VAR(i,j) => "TV(" ^ (DI.di_print i) ^ "," ^ (itos j) ^ ")"
| TC_NVAR v => "NTV(v" ^ (itos v) ^ ")"
| TC_PRIM pt => PT.pt_print pt
***************
*** 612,616 ****
in
! exception tcUnbound of tycEnv
val initTycEnv : tycEnv = tc_void
--- 614,618 ----
in
! exception tcUnbound of tycEnv * tyc
val initTycEnv : tycEnv = tc_void
***************
*** 621,625 ****
else if i = 1 then
(case tc_outX tenv of TC_ARROW(_,[x],_) => tc_interp x
! | _ => raise tcUnbound tenv)
else bug "unexpected argument in tcLookup"
--- 623,628 ----
else if i = 1 then
(case tc_outX tenv of TC_ARROW(_,[x],_) => tc_interp x
! | _ => (print "\ntcLookup\n";
! raise tcUnbound (tenv, tc_injX (TC_CONT []))))
else bug "unexpected argument in tcLookup"
***************
*** 671,675 ****
fun tcc_env(x, ol, nl, tenv) =
! let val tvs = tc_vs x
in case tvs
of NONE => tcc_env_int(x, ol, nl, tenv)
--- 674,691 ----
fun tcc_env(x, ol, nl, tenv) =
! (let fun checkTCVAR tyc = case (tc_outX tyc) of
! TC_VAR(i,j) => (case tcLookup(i,tenv)
! of (SOME ts, _) => if j >= length ts
! then (print "tcc_env TC_VAR ";
! print (Int.toString j);
! print " ts length ";
! print (Int.toString (length ts));
! raise Fail "Bad TC_ENV TC_VAR")
! else ()
! | _ => ())
! | TC_ENV(tc, _, _, _) => (print "TC_ENV("; checkTCVAR(tc); print ")\n")
! | _ => () (* print ("tcc_env OTHER " ^ tci_print tci ^"\n") *)
! in checkTCVAR(x);
! let val tvs = tc_vs x
in case tvs
of NONE => tcc_env_int(x, ol, nl, tenv)
***************
*** 678,682 ****
then tcc_env_int(x, ol, nl, tenv)
else x
! end
fun ltc_env(x, ol, nl, tenv) =
--- 694,699 ----
then tcc_env_int(x, ol, nl, tenv)
else x
! end
! end)
fun ltc_env(x, ol, nl, tenv) =
***************
*** 846,850 ****
and h (x, 0, 0, _) = g x
| h (x, ol, nl, tenv) =
! let fun prop z = tcc_env(z, ol, nl, tenv)
in (case tc_outX x
of TC_VAR (i,j) =>
--- 863,868 ----
and h (x, 0, 0, _) = g x
| h (x, ol, nl, tenv) =
! let fun prop z = tcc_env(z, ol, nl, tenv)
! handle Fail _ => raise Fail ("tc_lzrd prop "^tc_print(z)^"\n")
in (case tc_outX x
of TC_VAR (i,j) =>
***************
*** 864,868 ****
print ("ts elements: \n");
app (fn tc => (print(tc_print tc); print "\n")) ts;
! raise tcUnbound tenv)
in h(y, 0, nl - n, initTycEnv) (* rule r6 *)
end)
--- 882,886 ----
print ("ts elements: \n");
app (fn tc => (print(tc_print tc); print "\n")) ts;
! raise tcUnbound (tenv, t))
in h(y, 0, nl - n, initTycEnv) (* rule r6 *)
end)
***************
*** 873,877 ****
| TC_FN (ks, tc) =>
let val tenv' = tcInsert(tenv, (NONE, nl))
! in tcc_fn(ks, tcc_env(tc, ol+1, nl+1, tenv')) (* rule r10 *)
end
| TC_APP (tc, tcs) => tcc_app(prop tc, map prop tcs) (* rule r9 *)
--- 891,897 ----
| TC_FN (ks, tc) =>
let val tenv' = tcInsert(tenv, (NONE, nl))
! 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 *)
***************
*** 964,972 ****
(** normalizing an arbitrary tyc into a simple weak-head-normal-form *)
and tc_whnm t = if tcp_norm(t) then t else
! let (* val _ = print ">>tc_whnm not norm\n" *)
val nt = tc_lzrd t
in case (tc_outX nt)
of TC_APP(tc, tcs) =>
! (let val tc' = tc_whnm tc
in case (tc_outX tc')
of TC_FN(ks, b) =>
--- 984,993 ----
(** normalizing an arbitrary tyc into a simple weak-head-normal-form *)
and tc_whnm t = if tcp_norm(t) then t else
! let (* val _ = print ">>tc_whnm not norm\n" *)
val nt = tc_lzrd t
in case (tc_outX nt)
of TC_APP(tc, tcs) =>
! ((* print "\ntc_whnm: TC_APP\n"; *)
! (let val tc' = tc_whnm tc handle Fail _ => raise Fail "TC_APP in tc_whnm 1"
in case (tc_outX tc')
of TC_FN(ks, b) =>
***************
*** 983,988 ****
else base()
| _ => base())
! | _ => base())
! val res = tc_whnm(tcc_env sp)
in tyc_upd(nt, res); res
end
--- 1004,1010 ----
else base()
| _ => base())
! | _ => base())
! val res = tc_whnm(tcc_env sp)
! handle Fail _ => raise Fail "TC_APP in tc_whnm 2"
in tyc_upd(nt, res); res
end
***************
*** 992,998 ****
in stripInd xx
end
! end)
| TC_PROJ(tc, i) =>
! (let val tc' = tc_whnm tc
in (case (tc_outX tc')
of (TC_SEQ tcs) =>
--- 1014,1021 ----
in stripInd xx
end
! end))
| TC_PROJ(tc, i) =>
! ((* print "\ntc_whnm: TC_PROJ\n"; *)
! (let val tc' = tc_whnm tc
in (case (tc_outX tc')
of (TC_SEQ tcs) =>
***************
*** 1009,1015 ****
in stripInd xx
end)
! end)
| TC_TOKEN(k, tc) =>
! (let val tc' = tc_whnm tc
in if token_whnm k tc'
then let val xx = tcc_token(k, tc') in stripInd xx end
--- 1032,1039 ----
in stripInd xx
end)
! end))
| TC_TOKEN(k, tc) =>
! ((* print "\ntc_whnm: TC_TOKEN\n"; *)
! (let val tc' = tc_whnm tc
in if token_whnm k tc'
then let val xx = tcc_token(k, tc') in stripInd xx end
***************
*** 1018,1025 ****
in tyc_upd(nt, nres); nres
end
! end)
! | TC_IND (tc, _) => tc_whnm tc
| TC_ENV _ => bug "unexpected TC_ENV in tc_whnm"
! | _ => nt
end (* function tc_whnm *)
--- 1042,1049 ----
in tyc_upd(nt, nres); nres
end
! end))
! | TC_IND (tc, _) => ((*print "\ntc_whnm: TC_IND\n"; *) tc_whnm tc)
| TC_ENV _ => bug "unexpected TC_ENV in tc_whnm"
! | _ => ((* print "\ntc_whnm: OTHER\n"; *) nt)
end (* function tc_whnm *)
Index: pplty.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/Attic/pplty.sml,v
retrieving revision 1.1.2.7
retrieving revision 1.1.2.8
diff -C2 -d -r1.1.2.7 -r1.1.2.8
*** pplty.sml 8 Aug 2006 18:02:53 -0000 1.1.2.7
--- pplty.sml 11 Aug 2006 04:09:23 -0000 1.1.2.8
***************
*** 62,68 ****
fun tycEnvFlatten(tycenv) =
! (case LK.tcSplit(tycenv) of
NONE => []
! | SOME(elem, rest) => elem::tycEnvFlatten(rest))
fun ppTycEnvElem ppstrm (tycop, i) =
--- 62,69 ----
fun tycEnvFlatten(tycenv) =
! (print "flatten";
! (case LK.tcSplit(tycenv) of
NONE => []
! | SOME(elem, rest) => elem::tycEnvFlatten(rest)))
fun ppTycEnvElem ppstrm (tycop, i) =
***************
*** 159,162 ****
--- 160,164 ----
pps "TC_FIX(";
PP.break ppstrm {nsp=1,offset=1};
+ print "LK.tc_out";
(case (LK.tc_out datatypeFamily) of
LK.TC_FN(params, rectyc) => (* generator function *)
***************
*** 172,176 ****
pps "]")
else ();
! PP.break ppstrm {nsp=1,offset=1};
(case (LK.tc_out rectyc) of
(rectycI as LK.TC_FN _) => ppTycI rectycI
--- 174,179 ----
pps "]")
else ();
! PP.break ppstrm {nsp=1,offset=1};
! print "LK.tc_out";
(case (LK.tc_out rectyc) of
(rectycI as LK.TC_FN _) => ppTycI rectycI
***************
*** 248,251 ****
--- 251,255 ----
(pps "TC_TOKEN(";
PP.break ppstrm {nsp=1,offset=1};
+ print "LK.token_name\n";
pps (LK.token_name tok);
pps ", ";
***************
*** 284,287 ****
--- 288,292 ----
ppList' {sep=", ", pp=(ppTycEnvElem ppstrm)} (tycEnvFlatten tenv);
closeBox())
+ val _ = print "LK.tc_out 1 \n"
in ppTycI (LK.tc_out tycon)
end (* ppTyc *)
-------------------------------------------------------------------------
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