CVS: sml-dist/src/compiler/FLINT/kernel ltykernel.sig, 1.11, 1.11.24.1 ltykernel.sml, 1.18.12.4, 1.18.12.5 pplty.sml, 1.1.2.2, 1.1.2.3
George Kuan <[email protected]> Mon, 31 Jul 2006 11:07:20 -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-serv20724/src/compiler/FLINT/kernel
Modified Files:
Tag: primop-branch-2
ltykernel.sig ltykernel.sml pplty.sml
Log Message:
PPLty complete at least for printing Ltycs
Index: ltykernel.sig
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/ltykernel.sig,v
retrieving revision 1.11
retrieving revision 1.11.24.1
diff -C2 -d -r1.11 -r1.11.24.1
*** ltykernel.sig 1 Jun 2000 18:33:26 -0000 1.11
--- ltykernel.sig 31 Jul 2006 18:07:17 -0000 1.11.24.1
***************
*** 95,98 ****
--- 95,99 ----
val initTycEnv : tycEnv
val tcInsert : tycEnv * (tyc list option * int) -> tycEnv
+ val tycEnvOut : tycEnv -> tycI
(** testing if a tyc (or lty) is in the normal form *)
Index: ltykernel.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/ltykernel.sml,v
retrieving revision 1.18.12.4
retrieving revision 1.18.12.5
diff -C2 -d -r1.18.12.4 -r1.18.12.5
*** ltykernel.sml 28 Jul 2006 22:26:07 -0000 1.18.12.4
--- ltykernel.sml 31 Jul 2006 18:07:17 -0000 1.18.12.5
***************
*** 610,614 ****
! end (* utililty function for tycEnv *)
--- 610,616 ----
! fun tycEnvOut(tenv : tycEnv) = tc_outX tenv
!
! end (* utility function for tycEnv *)
Index: pplty.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/compiler/FLINT/kernel/Attic/pplty.sml,v
retrieving revision 1.1.2.2
retrieving revision 1.1.2.3
diff -C2 -d -r1.1.2.2 -r1.1.2.3
*** pplty.sml 31 Jul 2006 16:05:41 -0000 1.1.2.2
--- pplty.sml 31 Jul 2006 18:07:17 -0000 1.1.2.3
***************
*** 10,31 ****
struct
! fun ppList {sep, pp} list =
! (ppSequence ppstrm
! {sep = fn ppstrm => (PP.break ppstrm {nsp=1, offset=0};
! PP.string ppstrm sep),
! style = INCONSISTENT,
! pr = (fn _ => fn elem =>
! (openHOVBox 1;
! pps "(";
! pp elem;
! pps ")";
! closeBox()))}
! list)
(* ppTKind : tkind -> unit
* Print a hashconsed representation of the kind *)
! fun ppTKind (tk : TK.tkind) =
! let fun ppTKindI(LK.TK_MONO) = "TK_MONO"
! | ppTKindI(LK.TK_BOX) = "TK_BOX"
| ppTKindI(LK.TK_FUN (argTkinds, resTkind)) =
(* res_tkind is a TK_SEQ wrapping some tkinds
--- 10,45 ----
struct
! local
!
! structure LK = LtyKernel
! structure PT = PrimTyc
! structure PP = PrettyPrintNew
! open PPUtilNew
! in
!
! fun ppList ppstrm {sep, pp : 'a -> unit} list =
! let val {openHOVBox, closeBox, pps, ...} = en_pp ppstrm
! in
! (ppSequence ppstrm
! {sep = fn ppstrm => (PP.break ppstrm {nsp=1, offset=0};
! PP.string ppstrm sep),
! style = INCONSISTENT,
! pr = (fn _ => fn elem =>
! (openHOVBox 1;
! pps "(";
! pp elem;
! pps ")";
! closeBox()))}
! list)
! end (* ppList *)
(* ppTKind : tkind -> unit
* Print a hashconsed representation of the kind *)
! fun ppTKind ppstrm (tk : LK.tkind) =
! let val ppTKind' = ppTKind ppstrm
! val {openHOVBox, closeBox, pps, ...} = en_pp ppstrm
! val ppList' = ppList ppstrm
! fun ppTKindI(LK.TK_MONO) = pps "TK_MONO"
! | ppTKindI(LK.TK_BOX) = pps "TK_BOX"
| ppTKindI(LK.TK_FUN (argTkinds, resTkind)) =
(* res_tkind is a TK_SEQ wrapping some tkinds
***************
*** 34,39 ****
(openHOVBox 1;
pps "TK_FUN (";
! ppList {sep="* ", pp=ppTKindI} argTkinds;
! ppTKind resTkind;
pps ")";
closeBox())
--- 48,53 ----
(openHOVBox 1;
pps "TK_FUN (";
! ppList' {sep="* ", pp=ppTKind'} argTkinds;
! ppTKind' resTkind;
pps ")";
closeBox())
***************
*** 41,53 ****
(openHOVBox 1;
pps "TK_SEQ(";
! ppList {sep=", ", pp=ppTKindI} tkinds;
pps ")";
closeBox())
in ppTKindI (LK.tk_out tk)
! end
! fun ppTyc (tycon : tyc) =
(* FLINT variables are represented using deBruijn indices *)
! let fun ppTycI (LK.TC_VAR(depth, cnt)) =
(pps "TC_VAR(";
(* depth is a deBruijn index set in elabmod.sml/instantiate.sml *)
--- 55,73 ----
(openHOVBox 1;
pps "TK_SEQ(";
! ppList' {sep=", ", pp=ppTKind'} tkinds;
pps ")";
closeBox())
in ppTKindI (LK.tk_out tk)
! end (* ppTKind *)
! fun ppTyc ppstrm (tycon : LK.tyc) =
(* FLINT variables are represented using deBruijn indices *)
! let val {openHOVBox, closeBox, pps, ...} = en_pp ppstrm
! (* eta-expansion of ppList to avoid
! value restriction *)
! val ppList' : {pp:'a -> unit, sep: string} -> 'a list -> unit = fn x => ppList ppstrm x
! val ppTKind' = ppTKind ppstrm
! val ppTyc' = ppTyc ppstrm
! fun ppTycI (LK.TC_VAR(depth, cnt)) =
(pps "TC_VAR(";
(* depth is a deBruijn index set in elabmod.sml/instantiate.sml *)
***************
*** 69,75 ****
(openHOVBox 1;
pps "TC_FN(";
! ppList {sep="* ", pp=ppTKind} argTKinds;
pps ",";
! ppTyc resultTyc;
pps ")";
closeBox())
--- 89,95 ----
(openHOVBox 1;
pps "TC_FN(";
! ppList' {sep="* ", pp=ppTKind'} argTkinds;
pps ",";
! ppTyc' resultTyc;
pps ")";
closeBox())
***************
*** 77,83 ****
(openHOVBox 1;
pps "TC_APP(";
! ppTyc contyc;
pps ",";
! ppList {sep="* ", pp=ppTycI} tys;
pps ")";
closeBox())
--- 97,103 ----
(openHOVBox 1;
pps "TC_APP(";
! ppTyc' contyc;
pps ",";
! ppList' {sep="* ", pp=ppTyc'} tys;
pps ")";
closeBox())
***************
*** 85,89 ****
(openHOVBox 1;
pps "TC_SEQ(";
! ppList {sep=", ", pp=ppTycI} tycs;
pps ")";
closeBox())
--- 105,109 ----
(openHOVBox 1;
pps "TC_SEQ(";
! ppList' {sep=", ", pp=ppTyc'} tycs;
pps ")";
closeBox())
***************
*** 91,95 ****
(openHOVBox 1;
pps "TC_PROJ(";
! ppTycI tycon;
pps ", ";
pps (Int.toString index);
--- 111,115 ----
(openHOVBox 1;
pps "TC_PROJ(";
! ppTyc' tycon;
pps ", ";
pps (Int.toString index);
***************
*** 98,102 ****
| ppTycI (LK.TC_SUM(tycs)) =
(pps "TC_SUM(";
! ppList {sep=", ", pp=ppTycI} tycs;
pps ")")
(* TC_FIX is a recursive DATATYPE *)
--- 118,122 ----
| ppTycI (LK.TC_SUM(tycs)) =
(pps "TC_SUM(";
! ppList' {sep=", ", pp=ppTyc'} tycs;
pps ")")
(* TC_FIX is a recursive DATATYPE *)
***************
*** 108,115 ****
pps ", ";
pps "datatypeFamily = ";
! ppTycI datatypeFamily;
pps ", ";
pps "freeTycs = ";
! ppList {sep = ", ", pp = ppTycI} freetycs;
pps ", ";
pps "index = ";
--- 128,135 ----
pps ", ";
pps "datatypeFamily = ";
! ppTyc' datatypeFamily;
pps ", ";
pps "freeTycs = ";
! ppList' {sep = ", ", pp = ppTyc'} freetycs;
pps ", ";
pps "index = ";
***************
*** 119,175 ****
| ppTycI (LK.TC_ABS tyc) =
(pps "TC_ABS(";
! ppTycI tyc;
pps ")")
| ppTycI (LK.TC_BOX tyc) =
(pps "TC_BOX(";
! ppTycI tyc;
pps ")")
(* rflag is a tuple kind template, a singleton datatype RF_TMP *)
| ppTycI (LK.TC_TUPLE (rflag, tycs)) =
(pps "TC_TUPLE(";
! ppList {sep="* ", pp=ppTycI} tycs;
pps ")")
(* fflag records the calling convention: either FF_FIXED or FF_VAR *)
! | ppTycI (TC_ARROW (fflag, argTycs, resTycs)) =
(pps "TC_ARROW(";
(case fflag of LK.FF_FIXED => pps "FF_FIXED"
! | LK.FF_VAR(b1, b2) => (pps "FF_VAR(";
! ppBool b1;
pps ", ";
! ppBool b2;
! pps ")"))
! ppList {sep="* ", pp=ppTycI} argTycs;
pps ", ";
! ppList {sep="* ", pp=ppTyci} resTycs;
pps ")")
(* According to ltykernel.sml comment, this arrow tyc is not used *)
! | ppTycI (TC_PARROW (argTyc, resTyc)) =
(pps "TC_PARROW(";
! ppTycI argTyc;
pps ", ";
! ppTycI resTyc;
pps ")")
! | ppTycI (TC_TOKEN (tok, tyc)) =
(pps "TC_TOKEN(";
! pps (Int.toString tok);
pps ", ";
! ppTycI tyc;
pps ")")
! | ppTycI (TC_CONT tycs) =
(pps "TC_CONT(";
! ppList {sep=", ", pp=ppTyc} tycs;
pps ")")
! | ppTycI (TC_IND (tyc, tycI)) =
(openHOVBox 1;
pps "TC_IND(";
! ppTyc tyc;
! pp ", ";
ppTycI tycI;
pps ")";
closeBox())
! | ppTycI (TC_ENV (tyc, ol, nl, tenv)) =
(openHOVBox 1;
pps "TC_ENV(";
! ppTyc tyc;
pps ", ";
pps "ol = ";
--- 139,195 ----
| ppTycI (LK.TC_ABS tyc) =
(pps "TC_ABS(";
! ppTyc' tyc;
pps ")")
| ppTycI (LK.TC_BOX tyc) =
(pps "TC_BOX(";
! ppTyc' tyc;
pps ")")
(* rflag is a tuple kind template, a singleton datatype RF_TMP *)
| ppTycI (LK.TC_TUPLE (rflag, tycs)) =
(pps "TC_TUPLE(";
! ppList' {sep="* ", pp=ppTyc'} tycs;
pps ")")
(* fflag records the calling convention: either FF_FIXED or FF_VAR *)
! | ppTycI (LK.TC_ARROW (fflag, argTycs, resTycs)) =
(pps "TC_ARROW(";
(case fflag of LK.FF_FIXED => pps "FF_FIXED"
! | LK.FF_VAR(b1, b2) => (pps "<FF_VAR>" (*;
! ppBool b1;
pps ", ";
! ppBool b2;
! pps ")"*) ));
! ppList' {sep="* ", pp=ppTyc'} argTycs;
pps ", ";
! ppList' {sep="* ", pp=ppTyc'} resTycs;
pps ")")
(* According to ltykernel.sml comment, this arrow tyc is not used *)
! | ppTycI (LK.TC_PARROW (argTyc, resTyc)) =
(pps "TC_PARROW(";
! ppTyc' argTyc;
pps ", ";
! ppTyc' resTyc;
pps ")")
! | ppTycI (LK.TC_TOKEN (tok, tyc)) =
(pps "TC_TOKEN(";
! pps (LK.token_name tok);
pps ", ";
! ppTyc' tyc;
pps ")")
! | ppTycI (LK.TC_CONT tycs) =
(pps "TC_CONT(";
! ppList' {sep=", ", pp=ppTyc'} tycs;
pps ")")
! | ppTycI (LK.TC_IND (tyc, tycI)) =
(openHOVBox 1;
pps "TC_IND(";
! ppTyc' tyc;
! pps ", ";
ppTycI tycI;
pps ")";
closeBox())
! | ppTycI (LK.TC_ENV (tyc, ol, nl, tenv)) =
(openHOVBox 1;
pps "TC_ENV(";
! ppTyc' tyc;
pps ", ";
pps "ol = ";
***************
*** 179,187 ****
pps (Int.toString nl);
pps ", ";
! ppTyc tenv;
closeBox())
in ppTycI (LK.tc_out tycon)
! end
!
end
--- 199,208 ----
pps (Int.toString nl);
pps ", ";
! (LK.tycEnvOut tenv);
closeBox())
in ppTycI (LK.tc_out tycon)
! end (* ppTyc *)
!
! end (* local *)
end
-------------------------------------------------------------------------
Take Surveys. Earn Cash. Influence the Future of IT
Join SourceForge.net's Techsay panel and you'll get the chance to share your
opinions on IT & business topics through brief surveys -- and earn cash
http://www.techsay.com/default.php?page=join.php&p=sourceforge&CID=DEVDEV