CVS: sml-dist/src/compiler/FLINT/plambda chkplexp.sml, 1.9.10.3, 1.9.10.4 flintnm.sml, 1.17.10.16, 1.17.10.17
David MacQueen <[email protected]> Tue, 22 Aug 2006 15:54:12 -0700
| Newsgroups | gmane.comp.lang.sml.smlnj.commits |
|---|---|
| Message-ID | <[email protected]> |
Update of /cvsroot/smlnj/sml-dist/src/compiler/FLINT/plambda
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv13888/src/compiler/FLINT/plambda
Modified Files:
Tag: primop-branch-2
chkplexp.sml flintnm.sml
Log Message:
continued instrumentation and commenting for tcc_env bug
Index: chkplexp.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/plambda/chkplexp.sml,v
retrieving revision 1.9.10.3
retrieving revision 1.9.10.4
diff -C2 -d -r1.9.10.3 -r1.9.10.4
*** chkplexp.sml 21 Aug 2006 23:07:07 -0000 1.9.10.3
--- chkplexp.sml 22 Aug 2006 22:54:10 -0000 1.9.10.4
***************
*** 234,238 ****
val venv' = LT.ltInsert(venv, v, t, d)
val res = check (kenv, venv', d) e1
! (* val _ = ltyChkenv res *)
in ltFun(t, res) (* handle both functions and functors *)
end
--- 234,238 ----
val venv' = LT.ltInsert(venv, v, t, d)
val res = check (kenv, venv', d) e1
! val _ = ltyChkenv res
in ltFun(t, res) (* handle both functions and functors *)
end
***************
*** 246,250 ****
val nts = map (check (kenv, venv', d)) es
! (* val _ = map ltyChkenv nts *)
val _ = app2(ltMatch le "FIX1", ts, nts)
--- 246,250 ----
val nts = map (check (kenv, venv', d)) es
! val _ = map ltyChkenv nts
val _ = app2(ltMatch le "FIX1", ts, nts)
***************
*** 261,265 ****
| LET(v, e1, e2) =>
let val t1 = loop e1
! (* val _ = ltyChkenv t1 *)
val venv' = LT.ltInsert(venv, v, t1, d)
in check (kenv, venv', d) e2
--- 261,265 ----
| LET(v, e1, e2) =>
let val t1 = loop e1
! val _ = ltyChkenv t1
val venv' = LT.ltInsert(venv, v, t1, d)
in check (kenv, venv', d) e2
***************
*** 269,273 ****
let val kenv' = LT.tkInsert(kenv, ks)
val lt = check (kenv', venv, DI.next d) e
! (* val _ = ltyChkenv lt *)
in LT.ltc_poly(ks, [lt])
end
--- 269,273 ----
let val kenv' = LT.tkInsert(kenv, ks)
val lt = check (kenv', venv, DI.next d) e
! val _ = ltyChk (ks::kenv) lt
in LT.ltc_poly(ks, [lt])
end
***************
*** 275,279 ****
| TAPP(e, ts) =>
let val lt = loop e
! (* val _ = ltyChkenv lt *)
in ltTyApp le "TAPP" (lt, ts, kenv)
end
--- 275,280 ----
| TAPP(e, ts) =>
let val lt = loop e
! val _ = map (fn tc => ltyChkenv(LT.ltc_tyc tc)) ts (* kind check type args *)
! val _ = ltyChkenv lt
in ltTyApp le "TAPP" (lt, ts, kenv)
end
***************
*** 281,285 ****
| GENOP(dict, p, t, ts) =>
((* should type check dict also *)
! ltTyApp le "GENOP" (t, ts, kenv))
| PACK(lt, ts, nts, e) =>
--- 282,287 ----
| GENOP(dict, p, t, ts) =>
((* should type check dict also *)
! (map (fn tc => ltyChkenv(LT.ltc_tyc tc)) ts;
! ltTyApp le "GENOP" (t, ts, kenv)))
| PACK(lt, ts, nts, e) =>
***************
*** 291,297 ****
| CON((_, rep, lt), ts, e) =>
let val t1 = ltTyApp le "CON" (lt, ts, kenv)
! (* val _ = ltyChkenv t1 *)
val t2 = loop e
! (* val _ = ltyChkenv t2 *)
in ltFnApp le "CON-A" (t1, t2)
end
--- 293,299 ----
| CON((_, rep, lt), ts, e) =>
let val t1 = ltTyApp le "CON" (lt, ts, kenv)
! val _ = ltyChkenv t1
val t2 = loop e
! val _ = ltyChkenv t2
in ltFnApp le "CON-A" (t1, t2)
end
***************
*** 308,312 ****
| VECTOR (el, t) =>
let val ts = map loop el
! in app (fn x => ltMatch le "VECTOR" (x, LT.ltc_tyc t)) ts;
ltVector t
end
--- 310,316 ----
| VECTOR (el, t) =>
let val ts = map loop el
! in ltyChkenv (LT.ltc_tyc t);
! map ltyChkenv ts;
! app (fn x => ltMatch le "VECTOR" (x, LT.ltc_tyc t)) ts;
ltVector t
end
***************
*** 321,324 ****
--- 325,329 ----
end
val ts = map h cl
+ val _ = map ltyChkenv ts
in (case ts
of [] => bug "empty switch in checkLty"
***************
*** 333,336 ****
--- 338,342 ----
let val z = loop e (* what do we check on e ? *)
val _ = ltMatch le "ETAG1" (z, LT.ltc_string)
+ val _ = ltyChkenv t
in ltEtag t
end
***************
*** 355,358 ****
--- 361,365 ----
else (if b then LT.tcc_box t else LT.tcc_abs t)
val nt = LT.ltc_tyc ntc
+ val _ = ltyChkenv nt
in (ltMatch le "UNWRAP" (loop e, nt); LT.ltc_tyc t)
end)
Index: flintnm.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/plambda/flintnm.sml,v
retrieving revision 1.17.10.16
retrieving revision 1.17.10.17
diff -C2 -d -r1.17.10.16 -r1.17.10.17
*** flintnm.sml 11 Aug 2006 20:42:24 -0000 1.17.10.16
--- flintnm.sml 22 Aug 2006 22:54:10 -0000 1.17.10.17
***************
*** 28,38 ****
val say = Control_Print.say
! val debugging = ref false;
fun debugmsg (msg : string) =
if !debugging then (say msg; say "\n") else ()
! fun ppTycEnv tenv =
PP.with_default_pp
! (fn ppstrm => (PPLty.ppTycEnv 20 ppstrm tenv; PU.pps ppstrm "\n"))
val mkv = LambdaVar.mkLvar
--- 28,51 ----
val say = Control_Print.say
! val debugging = ref true
! val debugging2 = ref false
!
fun debugmsg (msg : string) =
if !debugging then (say msg; say "\n") else ()
+ val pd = 15 (* debugging print depth *)
! fun ppTycEnv (tenv: Lty.tycEnv) =
PP.with_default_pp
! (fn ppstrm => (PPLty.ppTycEnv pd ppstrm tenv; PU.pps ppstrm "\n"))
!
! fun ppLty (lty: Lty.lty) =
! PP.with_default_pp
! (fn ppstrm => (PPLty.ppLty pd ppstrm lty; PU.pps ppstrm "\n"))
!
! fun debugLty (lty: Lty.lty) =
! if !debugging then ppLty lty else ()
!
! fun debugLexp (lexp) =
! if !debugging2 then PPLexp.printLexp lexp else ()
val mkv = LambdaVar.mkLvar
***************
*** 122,129 ****
fun tofundec (venv,d,f_lv,arg_lv,arg_lty,body,isrec) =
! let val _ = (debugmsg (concat ["tofundec normalize argument: ",
! (LtyBasic.lt_print arg_lty),
! "\ntofundec normalize body: \n"]);
! if !debugging then PPLexp.printLexp body else ())
val (body',body_lty) =
(* first, we translate the body (in the extended env) *)
--- 135,142 ----
fun tofundec (venv,d,f_lv,arg_lv,arg_lty,body,isrec) =
! let val _ = (debugmsg "tofundec normalize argument:\n";
! debugLty arg_lty;
! debugmsg "\ntofundec normalize body: \n";
! debugLexp body)
val (body',body_lty) =
(* first, we translate the body (in the extended env) *)
***************
*** 275,279 ****
and tovalue (venv,d,lexp,cont) =
let val _ = debugmsg ">>tovalue"
! val _ = if !debugging then PPLexp.printLexp lexp else ()
val _ = 1
val v = case lexp of
--- 288,292 ----
and tovalue (venv,d,lexp,cont) =
let val _ = debugmsg ">>tovalue"
! val _ = debugLexp lexp
val _ = 1
val v = case lexp of
***************
*** 307,311 ****
in tolvar(venv, d, lv, lexp,
fn lty => (debugmsg ">>tovalue tolvar cont";
! if !debugging then PPLexp.printLexp lexp else ();
cont(F.VAR lv, lty)))
end
--- 320,324 ----
in tolvar(venv, d, lv, lexp,
fn lty => (debugmsg ">>tovalue tolvar cont";
! debugLexp lexp;
cont(F.VAR lv, lty)))
end
***************
*** 326,330 ****
and tovalues (venv,d,lexp,cont) =
let val _ = debugmsg ">>tovalues"
! val _ = if !debugging then PPLexp.printLexp lexp else ()
val _ = 1
val v = case lexp of
--- 339,343 ----
and tovalues (venv,d,lexp,cont) =
let val _ = debugmsg ">>tovalues"
! val _ = debugLexp lexp
val _ = 1
val v = case lexp of
***************
*** 337,347 ****
debugmsg ("tovalues cont ltys null")
else if length ltys = 1
! then debugmsg ("tovalues cont ltys singleton"^
! LtyBasic.lt_print (hd ltys))
! else debugmsg ("tovalues cont ltys > 1 "^
! "starting with "^
! LtyBasic.lt_print (hd ltys) ^
! "\nlength is "
! ^ Int.toString (length ltys))
fun scan [] = debugmsg "tovalues end of ltys"
| scan (lts) =
--- 350,360 ----
debugmsg ("tovalues cont ltys null")
else if length ltys = 1
! then (debugmsg ("tovalues cont ltys singleton:\n");
! debugLty (hd ltys))
! else (debugmsg ("tovalues cont ltys > 1\n \
! \length is: "
! ^ Int.toString (length ltys) ^
! "\nstarting with:\n");
! debugLty (hd ltys))
fun scan [] = debugmsg "tovalues end of ltys"
| scan (lts) =
***************
*** 350,356 ****
(debugmsg ("tovalues cont ltys ["^
Int.toString n ^"]:");
! if !debugging
! then PPLexp.printLexp l else ();
! debugmsg (LtyBasic.lt_print x);
scan' (xs, ls, n + 1))
| scan' _ =
--- 363,368 ----
(debugmsg ("tovalues cont ltys ["^
Int.toString n ^"]:");
! debugLexp l;
! ppLty x;
scan' (xs, ls, n + 1))
| scan' _ =
***************
*** 362,375 ****
val _ = scan ltys
val lty = LT.ltc_tuple ltys
! val _ = debugmsg ("<<tovalues cont tupled "^
! LtyBasic.lt_print lty)
val (_, ltys, _) = FL.t_pflatten lty
val _ = debugmsg "<<tovalues cont flatten"
! val _ = debugmsg (">>tovalues cont LT.lt_eqv " ^
! LtyBasic.lt_print lty ^ " eqv? ")
val _ = debugmsg ">>tovalues cont LT.ltc_tuple"
val ltyst = (LT.ltc_tuple ltys)
! val _ = debugmsg ("<<tovalues cont LT.ltc_tuple "
! ^ LtyBasic.lt_print ltyst)
val eqvLty = LT.lt_eqv(lty, LT.ltc_tuple ltys)
val _ = debugmsg "<<tovalues cont lt_eqv"
--- 374,387 ----
val _ = scan ltys
val lty = LT.ltc_tuple ltys
! val _ = (debugmsg ("<<tovalues cont tupled");
! debugLty lty)
val (_, ltys, _) = FL.t_pflatten lty
val _ = debugmsg "<<tovalues cont flatten"
! val _ = (debugmsg (">>tovalues cont LT.lt_eqv");
! debugLty lty)
val _ = debugmsg ">>tovalues cont LT.ltc_tuple"
val ltyst = (LT.ltc_tuple ltys)
! val _ = (debugmsg ("<<tovalues cont LT.ltc_tuple");
! debugLty ltyst)
val eqvLty = LT.lt_eqv(lty, LT.ltc_tuple ltys)
val _ = debugmsg "<<tovalues cont lt_eqv"
***************
*** 404,410 ****
and lexps2values (venv,d,lexps,cont) =
let val _ = debugmsg ">>lexps2values"
! val _ = if !debugging
! then ignore(map PPLexp.printLexp lexps)
! else ()
val _ = 1
--- 416,420 ----
and lexps2values (venv,d,lexps,cont) =
let val _ = debugmsg ">>lexps2values"
! val _ = map debugLexp lexps
val _ = 1
***************
*** 416,425 ****
fun f [] (vals,ltys) = cont (rev vals, rev ltys)
| f (lexp::lexps) (vals,ltys) =
! (debugmsg ("lexps2values ltys "^concat (map (fn x => ("\n"^LtyBasic.lt_print x)) ltys));
! tovalue(venv,d,lexp,
! fn (v, lty) => ((*debugmsg ">>lexps2values tovalue";
! if !debugging then PPLexp.printLexp lexp else ();
! if !debugging then debugmsg ("lty: "^ LtyBasic.lt_print lty) else ();*)
! f lexps (v::vals, lty::ltys))))
(* handle LtyKernel.tcUnbound (tenv,tyc) =>
(with_pp(fn s =>
--- 426,437 ----
fun f [] (vals,ltys) = cont (rev vals, rev ltys)
| f (lexp::lexps) (vals,ltys) =
! (debugmsg ("lexps2values ltys:");
! map debugLty ltys;
! tovalue(venv,d,lexp,
! fn (v, lty) =>
! ((* debugmsg ">>lexps2values tovalue";
! debugLexp lexp;
! debugmsg "lty:"; debugLty lty *)
! f lexps (v::vals, lty::ltys))))
(* handle LtyKernel.tcUnbound (tenv,tyc) =>
(with_pp(fn s =>
***************
*** 444,448 ****
and tolvar (venv,d,lvar,lexp,cont) =
let val _ = debugmsg ">>tolvar"
! val _ = if !debugging then PPLexp.printLexp lexp else ()
fun eta_expand (f, f_lty) =
let val lv = mkv()
--- 456,460 ----
and tolvar (venv,d,lvar,lexp,cont) =
let val _ = debugmsg ">>tolvar"
! val _ = debugLexp lexp
fun eta_expand (f, f_lty) =
let val lv = mkv()
***************
*** 503,507 ****
end
| _ => bug "unexpected case in PO_helper")
! val r = if flat then
(* ZHONG asks: is the following definitely safe ?
what would happen if ltc_raw is not an identity function ?
--- 515,519 ----
end
| _ => bug "unexpected case in PO_helper")
! val r = if flat then
(* ZHONG asks: is the following definitely safe ?
what would happen if ltc_raw is not an identity function ?
***************
*** 565,570 ****
arg_vals, lvar, c_lexp))
val _ = debugmsg "<<tolvar L.APP"
!
! val _ = if !debugging then debugmsg (LtyBasic.lt_print lty') else ()
in (lexp', lty')
end
--- 577,581 ----
arg_vals, lvar, c_lexp))
val _ = debugmsg "<<tolvar L.APP"
! val _ = debugLty lty'
in (lexp', lty')
end
-------------------------------------------------------------------------
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