Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/branches/primop-branch-2/src/compiler/FLINT/kernel/pplty.sml
ViewVC logotype

Diff of /sml/branches/primop-branch-2/src/compiler/FLINT/kernel/pplty.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1999, Mon Jul 31 16:05:41 2006 UTC revision 2000, Mon Jul 31 18:07:17 2006 UTC
# Line 9  Line 9 
9  structure PPLTy =  structure PPLTy =
10  struct  struct
11    
12  fun ppList {sep, pp} list =  local
13    
14        structure LK = LtyKernel
15        structure PT = PrimTyc
16        structure PP = PrettyPrintNew
17        open PPUtilNew
18    in
19    
20    fun ppList ppstrm {sep, pp : 'a -> unit} list =
21        let val {openHOVBox, closeBox, pps, ...} = en_pp ppstrm
22        in
23      (ppSequence ppstrm      (ppSequence ppstrm
24                  {sep = fn ppstrm => (PP.break ppstrm {nsp=1, offset=0};                  {sep = fn ppstrm => (PP.break ppstrm {nsp=1, offset=0};
25                                       PP.string ppstrm sep),                                       PP.string ppstrm sep),
# Line 21  Line 31 
31                                      pps ")";                                      pps ")";
32                                      closeBox()))}                                      closeBox()))}
33                  list)                  list)
34        end (* ppList *)
35    
36  (* ppTKind : tkind -> unit  (* ppTKind : tkind -> unit
37   * Print a hashconsed representation of the kind *)   * Print a hashconsed representation of the kind *)
38  fun ppTKind (tk : TK.tkind) =  fun ppTKind ppstrm (tk : LK.tkind) =
39      let fun ppTKindI(LK.TK_MONO) = "TK_MONO"      let val ppTKind' = ppTKind ppstrm
40            | ppTKindI(LK.TK_BOX) = "TK_BOX"          val {openHOVBox, closeBox, pps, ...} = en_pp ppstrm
41            val ppList' = ppList ppstrm
42            fun ppTKindI(LK.TK_MONO) = pps "TK_MONO"
43              | ppTKindI(LK.TK_BOX) = pps "TK_BOX"
44            | ppTKindI(LK.TK_FUN (argTkinds, resTkind)) =            | ppTKindI(LK.TK_FUN (argTkinds, resTkind)) =
45                (* res_tkind is a TK_SEQ wrapping some tkinds                (* res_tkind is a TK_SEQ wrapping some tkinds
46                 * These are produced by Elaborate/modules/instantiate.sml                 * These are produced by Elaborate/modules/instantiate.sml
47                 *)                 *)
48               (openHOVBox 1;               (openHOVBox 1;
49                pps "TK_FUN (";                pps "TK_FUN (";
50                ppList {sep="* ", pp=ppTKindI} argTkinds;                ppList' {sep="* ", pp=ppTKind'} argTkinds;
51                ppTKind resTkind;                ppTKind' resTkind;
52                pps ")";                pps ")";
53                closeBox())                closeBox())
54            | ppTKindI(LK.TK_SEQ tkinds) =            | ppTKindI(LK.TK_SEQ tkinds) =
55              (openHOVBox 1;              (openHOVBox 1;
56               pps "TK_SEQ(";               pps "TK_SEQ(";
57               ppList {sep=", ", pp=ppTKindI} tkinds;               ppList' {sep=", ", pp=ppTKind'} tkinds;
58               pps ")";               pps ")";
59               closeBox())               closeBox())
60      in ppTKindI (LK.tk_out tk)      in ppTKindI (LK.tk_out tk)
61      end      end (* ppTKind *)
62    
63  fun ppTyc (tycon : tyc) =  fun ppTyc ppstrm (tycon : LK.tyc) =
64      (* FLINT variables are represented using deBruijn indices *)      (* FLINT variables are represented using deBruijn indices *)
65      let fun ppTycI (LK.TC_VAR(depth, cnt)) =      let val {openHOVBox, closeBox, pps, ...} = en_pp ppstrm
66                                                   (* eta-expansion of ppList to avoid
67                                                      value restriction *)
68            val ppList' : {pp:'a -> unit, sep: string} -> 'a list -> unit = fn x => ppList ppstrm x
69            val ppTKind' = ppTKind ppstrm
70            val ppTyc' = ppTyc ppstrm
71            fun ppTycI (LK.TC_VAR(depth, cnt)) =
72              (pps "TC_VAR(";              (pps "TC_VAR(";
73               (* depth is a deBruijn index set in elabmod.sml/instantiate.sml *)               (* depth is a deBruijn index set in elabmod.sml/instantiate.sml *)
74               pps (DebIndex.di_print depth);               pps (DebIndex.di_print depth);
# Line 68  Line 88 
88            | ppTycI (LK.TC_FN (argTkinds, resultTyc)) =            | ppTycI (LK.TC_FN (argTkinds, resultTyc)) =
89              (openHOVBox 1;              (openHOVBox 1;
90               pps "TC_FN(";               pps "TC_FN(";
91               ppList {sep="* ", pp=ppTKind} argTKinds;               ppList' {sep="* ", pp=ppTKind'} argTkinds;
92               pps ",";               pps ",";
93               ppTyc resultTyc;               ppTyc' resultTyc;
94               pps ")";               pps ")";
95               closeBox())               closeBox())
96            | ppTycI (LK.TC_APP(contyc, tys)) =            | ppTycI (LK.TC_APP(contyc, tys)) =
97              (openHOVBox 1;              (openHOVBox 1;
98               pps "TC_APP(";               pps "TC_APP(";
99               ppTyc contyc;               ppTyc' contyc;
100               pps ",";               pps ",";
101               ppList {sep="* ", pp=ppTycI} tys;               ppList' {sep="* ", pp=ppTyc'} tys;
102               pps ")";               pps ")";
103               closeBox())               closeBox())
104            | ppTycI (LK.TC_SEQ tycs) =            | ppTycI (LK.TC_SEQ tycs) =
105              (openHOVBox 1;              (openHOVBox 1;
106               pps "TC_SEQ(";               pps "TC_SEQ(";
107               ppList {sep=", ", pp=ppTycI} tycs;               ppList' {sep=", ", pp=ppTyc'} tycs;
108               pps ")";               pps ")";
109               closeBox())               closeBox())
110            | ppTycI (LK.TC_PROJ(tycon, index)) =            | ppTycI (LK.TC_PROJ(tycon, index)) =
111              (openHOVBox 1;              (openHOVBox 1;
112               pps "TC_PROJ(";               pps "TC_PROJ(";
113               ppTycI tycon;               ppTyc' tycon;
114               pps ", ";               pps ", ";
115               pps (Int.toString index);               pps (Int.toString index);
116               pps ")";               pps ")";
117               closeBox())               closeBox())
118            | ppTycI (LK.TC_SUM(tycs)) =            | ppTycI (LK.TC_SUM(tycs)) =
119              (pps "TC_SUM(";              (pps "TC_SUM(";
120               ppList {sep=", ", pp=ppTycI} tycs;               ppList' {sep=", ", pp=ppTyc'} tycs;
121               pps ")")               pps ")")
122              (* TC_FIX is a recursive DATATYPE *)              (* TC_FIX is a recursive DATATYPE *)
123            | ppTycI (LK.TC_FIX((numStamps, datatypeFamily, freetycs), index)) =            | ppTycI (LK.TC_FIX((numStamps, datatypeFamily, freetycs), index)) =
# Line 107  Line 127 
127               pps (Int.toString numStamps);               pps (Int.toString numStamps);
128               pps ", ";               pps ", ";
129               pps "datatypeFamily = ";               pps "datatypeFamily = ";
130               ppTycI datatypeFamily;               ppTyc' datatypeFamily;
131               pps ", ";               pps ", ";
132               pps "freeTycs = ";               pps "freeTycs = ";
133               ppList {sep = ", ", pp = ppTycI} freetycs;               ppList' {sep = ", ", pp = ppTyc'} freetycs;
134               pps ", ";               pps ", ";
135               pps "index = ";               pps "index = ";
136               pps (Int.toString index);               pps (Int.toString index);
# Line 118  Line 138 
138               closeBox())               closeBox())
139            | ppTycI (LK.TC_ABS tyc) =            | ppTycI (LK.TC_ABS tyc) =
140              (pps "TC_ABS(";              (pps "TC_ABS(";
141               ppTycI tyc;               ppTyc' tyc;
142               pps ")")               pps ")")
143            | ppTycI (LK.TC_BOX tyc) =            | ppTycI (LK.TC_BOX tyc) =
144              (pps "TC_BOX(";              (pps "TC_BOX(";
145               ppTycI tyc;               ppTyc' tyc;
146               pps ")")               pps ")")
147              (* rflag is a tuple kind template, a singleton datatype RF_TMP *)              (* rflag is a tuple kind template, a singleton datatype RF_TMP *)
148            | ppTycI (LK.TC_TUPLE (rflag, tycs)) =            | ppTycI (LK.TC_TUPLE (rflag, tycs)) =
149              (pps "TC_TUPLE(";              (pps "TC_TUPLE(";
150               ppList {sep="* ", pp=ppTycI} tycs;               ppList' {sep="* ", pp=ppTyc'} tycs;
151               pps ")")               pps ")")
152              (* fflag records the calling convention: either FF_FIXED or FF_VAR *)              (* fflag records the calling convention: either FF_FIXED or FF_VAR *)
153            | ppTycI (TC_ARROW (fflag, argTycs, resTycs)) =            | ppTycI (LK.TC_ARROW (fflag, argTycs, resTycs)) =
154              (pps "TC_ARROW(";              (pps "TC_ARROW(";
155               (case fflag of LK.FF_FIXED => pps "FF_FIXED"               (case fflag of LK.FF_FIXED => pps "FF_FIXED"
156                            | LK.FF_VAR(b1, b2) => (pps "FF_VAR(";                            | LK.FF_VAR(b1, b2) => (pps "<FF_VAR>" (*;
157                                                    ppBool b1;                                                    ppBool b1;
158                                                    pps ", ";                                                    pps ", ";
159                                                    ppBool b2;                                                    ppBool b2;
160                                                    pps ")"))                                                    pps ")"*) ));
161               ppList {sep="* ", pp=ppTycI} argTycs;               ppList' {sep="* ", pp=ppTyc'} argTycs;
162               pps ", ";               pps ", ";
163               ppList {sep="* ", pp=ppTyci} resTycs;               ppList' {sep="* ", pp=ppTyc'} resTycs;
164               pps ")")               pps ")")
165              (* According to ltykernel.sml comment, this arrow tyc is not used *)              (* According to ltykernel.sml comment, this arrow tyc is not used *)
166            | ppTycI (TC_PARROW (argTyc, resTyc)) =            | ppTycI (LK.TC_PARROW (argTyc, resTyc)) =
167              (pps "TC_PARROW(";              (pps "TC_PARROW(";
168               ppTycI argTyc;               ppTyc' argTyc;
169               pps ", ";               pps ", ";
170               ppTycI resTyc;               ppTyc' resTyc;
171               pps ")")               pps ")")
172            | ppTycI (TC_TOKEN (tok, tyc)) =            | ppTycI (LK.TC_TOKEN (tok, tyc)) =
173              (pps "TC_TOKEN(";              (pps "TC_TOKEN(";
174               pps (Int.toString tok);               pps (LK.token_name tok);
175               pps ", ";               pps ", ";
176               ppTycI tyc;               ppTyc' tyc;
177               pps ")")               pps ")")
178            | ppTycI (TC_CONT tycs) =            | ppTycI (LK.TC_CONT tycs) =
179              (pps "TC_CONT(";              (pps "TC_CONT(";
180               ppList {sep=", ", pp=ppTyc} tycs;               ppList' {sep=", ", pp=ppTyc'} tycs;
181               pps ")")               pps ")")
182            | ppTycI (TC_IND (tyc, tycI)) =            | ppTycI (LK.TC_IND (tyc, tycI)) =
183              (openHOVBox 1;              (openHOVBox 1;
184               pps "TC_IND(";               pps "TC_IND(";
185               ppTyc tyc;               ppTyc' tyc;
186               pp ", ";               pps ", ";
187               ppTycI tycI;               ppTycI tycI;
188               pps ")";               pps ")";
189               closeBox())               closeBox())
190            | ppTycI (TC_ENV (tyc, ol, nl, tenv)) =            | ppTycI (LK.TC_ENV (tyc, ol, nl, tenv)) =
191              (openHOVBox 1;              (openHOVBox 1;
192               pps "TC_ENV(";               pps "TC_ENV(";
193               ppTyc tyc;               ppTyc' tyc;
194               pps ", ";               pps ", ";
195               pps "ol = ";               pps "ol = ";
196               pps (Int.toString ol);               pps (Int.toString ol);
# Line 178  Line 198 
198               pps "nl = ";               pps "nl = ";
199               pps (Int.toString nl);               pps (Int.toString nl);
200               pps ", ";               pps ", ";
201               ppTyc tenv;                (LK.tycEnvOut tenv);
202               closeBox())               closeBox())
203      in ppTycI (LK.tc_out tycon)      in ppTycI (LK.tc_out tycon)
204      end      end (* ppTyc *)
205    
206    end (* local *)
207    
208  end  end

Legend:
Removed from v.1999  
changed lines
  Added in v.2000

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0