CVS: sml-dist/src/compiler/FLINT/kernel ltybasic.sml, 1.13.24.6, 1.13.24.7 ltyextern.sml, 1.19.24.15, 1.19.24.16 ltykindchk.sml, 1.1.2.4, 1.1.2.5 pplty.sml, 1.1.2.16, 1.1.2.17
David MacQueen <[email protected]> Thu, 24 Aug 2006 16:03:13 -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-serv18516/src/compiler/FLINT/kernel
Modified Files:
Tag: primop-branch-2
ltybasic.sml ltyextern.sml ltykindchk.sml pplty.sml
Log Message:
refining debugging instrumentation
Index: ltybasic.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/ltybasic.sml,v
retrieving revision 1.13.24.6
retrieving revision 1.13.24.7
diff -C2 -d -r1.13.24.6 -r1.13.24.7
*** ltybasic.sml 24 Aug 2006 19:28:40 -0000 1.13.24.6
--- ltybasic.sml 24 Aug 2006 23:03:10 -0000 1.13.24.7
***************
*** 143,146 ****
--- 143,147 ----
val lt_eqv_x : lty * lty -> bool = LK.lt_eqv_x
+
(***************************************************************************
* UTILITY FUNCTIONS FOR PRETTY PRINTING *
***************
*** 209,212 ****
--- 210,214 ----
| LT.LT_ENV _ => bug "unexpected LT_ENV in lt_print")
+
(** finding out the depth for a tyc's innermost-bound free variables *)
val tc_depth : tyc * depth -> depth = LK.tc_depth
Index: ltyextern.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/ltyextern.sml,v
retrieving revision 1.19.24.15
retrieving revision 1.19.24.16
diff -C2 -d -r1.19.24.15 -r1.19.24.16
*** ltyextern.sml 24 Aug 2006 19:28:40 -0000 1.19.24.15
--- ltyextern.sml 24 Aug 2006 23:03:10 -0000 1.19.24.16
***************
*** 35,38 ****
--- 35,42 ----
in
+ structure PP = PrettyPrintNew
+ structure PU = PPUtilNew
+ val with_pp = PP.with_default_pp
+
open LtyBasic
***************
*** 64,69 ****
val tkc_arg = Lty.tkc_arg
! fun tc_bug tc s = bug (s ^ "\n\n" ^ (tc_print tc) ^ "\n\n")
! fun lt_bug lt s = bug (s ^ "\n\n" ^ (lt_print lt) ^ "\n\n")
val ltKindChk = LtyKindChk.ltKindCheckGen ()
--- 68,82 ----
val tkc_arg = Lty.tkc_arg
! fun tc_bug tc msg =
! (with_pp (fn ppstm =>
! (PU.pps ppstm msg; PP.newline ppstm;
! PPLty.ppTyc 20 ppstm tc; PP.newline ppstm));
! bug "LtyExtern.tc_bug")
!
! fun lt_bug lt msg =
! (with_pp (fn ppstm =>
! (PU.pps ppstm msg; PP.newline ppstm;
! PPLty.ppLty 20 ppstm lt; PP.newline ppstm));
! bug "LtyExtern.lt_bug")
val ltKindChk = LtyKindChk.ltKindCheckGen ()
***************
*** 90,95 ****
| (_, []) => [nt] (* this requires further clarifications !!! *)
| (lt,ts) =>
! (print "lt_inst arg: "; print(lt_print (lt_inj lt)); print "\n";
! print ("ts length: "); print(Int.toString(length ts)); print "\n";
bug "incorrect lty instantiation in lt_inst"))
end
--- 103,111 ----
| (_, []) => [nt] (* this requires further clarifications !!! *)
| (lt,ts) =>
! (with_pp (fn ppstm =>
! (PU.pps ppstm "lt_inst arg:"; PP.newline ppstm;
! PPLty.ppLty 20 ppstm (lt_inj lt); PP.newline ppstm;
! PU.pps ppstm "ts length: ";
! PU.ppi ppstm (length ts); PP.newline ppstm));
bug "incorrect lty instantiation in lt_inst"))
end
***************
*** 191,198 ****
| _ => h lt)
-
- fun tc_bug tc s = bug (s ^ "\n\n" ^ (tc_print tc) ^ "\n\n")
- fun lt_bug lt s = bug (s ^ "\n\n" ^ (lt_print lt) ^ "\n\n")
-
(** other misc utility functions *)
fun tc_select(tc, i) =
--- 207,210 ----
Index: ltykindchk.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/Attic/ltykindchk.sml,v
retrieving revision 1.1.2.4
retrieving revision 1.1.2.5
diff -C2 -d -r1.1.2.4 -r1.1.2.5
*** ltykindchk.sml 24 Aug 2006 19:28:40 -0000 1.1.2.4
--- ltykindchk.sml 24 Aug 2006 23:03:10 -0000 1.1.2.5
***************
*** 42,45 ****
--- 42,46 ----
fun bug s = ErrorMsg.impossible ("LtyKindChk:" ^ s)
+ val pd = ref 10
val with_pp = PP.with_default_pp
***************
*** 227,232 ****
(with_pp (fn s =>
(PU.pps s "KindChk: unbound tv: ";
! PPLty.ppTyc 10 s (tc_injX tycI);
! PP.newline s));
raise KindChk "unbound tv"))
| TC_NVAR _ =>
--- 228,238 ----
(with_pp (fn s =>
(PU.pps s "KindChk: unbound tv: ";
! PPLty.ppTyc (!pd) s (tc_injX tycI);
! PP.newline s;
! PU.pps s "kenv: ";
! PP.openHOVBox s (PP.Rel 0);
! PPLty.ppKindEnv (!pd) s kenv;
! PP.newline s;
! PP.closeBox s));
raise KindChk "unbound tv"))
| TC_NVAR _ =>
***************
*** 316,319 ****
--- 322,326 ----
end
| TC_CONT _ => bug "unexpected TC_CONT in tcKindChk"
+
fun mk () =
mkI (tc_outX t)
***************
*** 365,375 ****
| LT_FCT(paramLtys, rngLtys) =>
let val paramks = map (ltyChk' kenv) paramLtys
! val tenv' = paramks :: kenv
in
tkc_fun(paramks,
! tkc_seq(map (ltyChk' tenv') rngLtys))
end
| LT_POLY(ks, ltys) =>
! tkc_seq(map (ltyChk' (ks::kenv)) ltys)
(* ??? *)
| LT_CONT(ltys) =>
--- 372,382 ----
| LT_FCT(paramLtys, rngLtys) =>
let val paramks = map (ltyChk' kenv) paramLtys
! (* val kenv' = tkInsert(kenv,paramks) *)
in
tkc_fun(paramks,
! tkc_seq(map (ltyChk' kenv) rngLtys))
end
| LT_POLY(ks, ltys) =>
! tkc_seq(map (ltyChk' (tkInsert(kenv,ks))) ltys)
(* ??? *)
| LT_CONT(ltys) =>
***************
*** 392,396 ****
| bindToKinds(Beta(_,_,ks)) = ks
fun addBindToKEnv(b,ke) =
! bindToKinds b :: ke
val bodyKenv =
foldr addBindToKEnv kenv' (teToBinders env)
--- 399,403 ----
| bindToKinds(Beta(_,_,ks)) = ks
fun addBindToKEnv(b,ke) =
! tkInsert(ke,bindToKinds b)
val bodyKenv =
foldr addBindToKEnv kenv' (teToBinders env)
***************
*** 398,404 ****
ltyChk' bodyKenv body
end))
! and ltyChk' kenv lty = ltyIChk kenv (lt_outX lty)
in ltyChk'
end (* function ltKindCheckGen *)
! end (* structure LtyKindChk *)
\ No newline at end of file
--- 405,416 ----
ltyChk' bodyKenv body
end))
! and ltyChk' kenv lty =
! ltyIChk kenv (lt_outX lty)
! handle x =>
! (with_pp (fn ppstrm => (PPLty.ppLty (!pd) ppstrm lty;
! PP.newline ppstrm));
! raise x)
in ltyChk'
end (* function ltKindCheckGen *)
! end (* structure LtyKindChk *)
Index: pplty.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/Attic/pplty.sml,v
retrieving revision 1.1.2.16
retrieving revision 1.1.2.17
diff -C2 -d -r1.1.2.16 -r1.1.2.17
*** pplty.sml 24 Aug 2006 19:28:40 -0000 1.1.2.16
--- pplty.sml 24 Aug 2006 23:03:10 -0000 1.1.2.17
***************
*** 39,43 ****
back = fn ppstrm => (PP.string ppstrm "]"),
sep = fn ppstrm => (PP.string ppstrm sep;
! PP.break ppstrm {nsp=1, offset=0}),
style = INCONSISTENT,
pr = pp}
--- 39,43 ----
back = fn ppstrm => (PP.string ppstrm "]"),
sep = fn ppstrm => (PP.string ppstrm sep;
! PP.break ppstrm {nsp=0, offset=0}),
style = INCONSISTENT,
pr = pp}
***************
*** 51,56 ****
val ppTKind' = ppTKind (pd-1) ppstrm
val ppList' = ppList ppstrm
! fun ppTKindI(Lty.TK_MONO) = pps "MK"
! | ppTKindI(Lty.TK_BOX) = pps "BK"
| ppTKindI(Lty.TK_FUN (argTkinds, resTkind)) =
(* res_tkind is a TK_SEQ wrapping some tkinds
--- 51,56 ----
val ppTKind' = ppTKind (pd-1) ppstrm
val ppList' = ppList ppstrm
! fun ppTKindI(Lty.TK_MONO) = pps "M"
! | ppTKindI(Lty.TK_BOX) = pps "B"
| ppTKindI(Lty.TK_FUN (argTkinds, resTkind)) =
(* res_tkind is a TK_SEQ wrapping some tkinds
***************
*** 65,69 ****
| ppTKindI(Lty.TK_SEQ tkinds) =
(openHOVBox 1;
! pps "SK";
ppList' {sep=",", pp=ppTKind (pd-1)} tkinds;
closeBox())
--- 65,69 ----
| ppTKindI(Lty.TK_SEQ tkinds) =
(openHOVBox 1;
! pps "S";
ppList' {sep=",", pp=ppTKind (pd-1)} tkinds;
closeBox())
***************
*** 82,90 ****
if pd < 1 then pps ppstrm "<tkenv>" else
let val {openHOVBox, openHVBox, closeBox, pps, ppi, ...} = en_pp ppstrm
! in pps "[";
! openHOVBox 1;
ppList ppstrm {sep=",",pp=ppKeFrame (pd-1)} kenv;
! closeBox ();
! pps "]"
end
--- 82,88 ----
if pd < 1 then pps ppstrm "<tkenv>" else
let val {openHOVBox, openHVBox, closeBox, pps, ppi, ...} = en_pp ppstrm
! in openHOVBox 1;
ppList ppstrm {sep=",",pp=ppKeFrame (pd-1)} kenv;
! closeBox ()
end
***************
*** 269,272 ****
--- 267,271 ----
PP.break ppstrm {nsp=1,offset=0};
ppList' {sep=",", pp=ppTEBinder (pd-1)} (tycEnvFlatten tenv);
+ pps ")";
closeBox())
in ppTycI (Lty.tc_outX tycon)
***************
*** 296,300 ****
fun ppLtyI (Lty.LT_TYC tc) =
! (pps "TYC("; ppTyc pd ppstrm tc; pps "0")
| ppLtyI (Lty.LT_STR ltys) =
(pps "STR("; ppList' {sep=",",pp=ppLty (pd-1)} ltys; pps ")")
--- 295,299 ----
fun ppLtyI (Lty.LT_TYC tc) =
! (pps "TYC("; ppTyc pd ppstrm tc; pps ")")
| ppLtyI (Lty.LT_STR ltys) =
(pps "STR("; ppList' {sep=",",pp=ppLty (pd-1)} ltys; pps ")")
***************
*** 305,309 ****
| ppLtyI (Lty.LT_POLY (ks,ltys)) =
(openHOVBox 1;
! pps "FN(";
ppList' {sep="*", pp=ppTKind (pd-1)} ks;
pps ",";
--- 304,308 ----
| ppLtyI (Lty.LT_POLY (ks,ltys)) =
(openHOVBox 1;
! pps "P0L(";
ppList' {sep="*", pp=ppTKind (pd-1)} ks;
pps ",";
***************
*** 332,335 ****
--- 331,335 ----
PP.break ppstrm {nsp=1,offset=0};
ppList' {sep=",", pp=ppTEBinder (pd-1)} (tycEnvFlatten tenv);
+ pps ")";
closeBox())
in ppLtyI (Lty.lt_outX lty)
-------------------------------------------------------------------------
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