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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2000 - (view) (download)

1 : georgekuan 1999 (* pplty.sml
2 :     *
3 :     * (c) 2006 SML/NJ Fellowship
4 :     *
5 : georgekuan 1998 * Pretty Printer for PLambda types using the new SMLNJ-lib new pretty printer
6 :     *
7 :     *)
8 :    
9 :     structure PPLTy =
10 :     struct
11 :    
12 : georgekuan 2000 local
13 : georgekuan 1999
14 : georgekuan 2000 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
24 :     {sep = fn ppstrm => (PP.break ppstrm {nsp=1, offset=0};
25 :     PP.string ppstrm sep),
26 :     style = INCONSISTENT,
27 :     pr = (fn _ => fn elem =>
28 :     (openHOVBox 1;
29 :     pps "(";
30 :     pp elem;
31 :     pps ")";
32 :     closeBox()))}
33 :     list)
34 :     end (* ppList *)
35 :    
36 : georgekuan 1998 (* ppTKind : tkind -> unit
37 :     * Print a hashconsed representation of the kind *)
38 : georgekuan 2000 fun ppTKind ppstrm (tk : LK.tkind) =
39 :     let val ppTKind' = ppTKind ppstrm
40 :     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 : georgekuan 1999 | ppTKindI(LK.TK_FUN (argTkinds, resTkind)) =
45 :     (* res_tkind is a TK_SEQ wrapping some tkinds
46 :     * These are produced by Elaborate/modules/instantiate.sml
47 :     *)
48 : georgekuan 1998 (openHOVBox 1;
49 :     pps "TK_FUN (";
50 : georgekuan 2000 ppList' {sep="* ", pp=ppTKind'} argTkinds;
51 :     ppTKind' resTkind;
52 : georgekuan 1999 pps ")";
53 :     closeBox())
54 : georgekuan 1998 | ppTKindI(LK.TK_SEQ tkinds) =
55 :     (openHOVBox 1;
56 : georgekuan 1999 pps "TK_SEQ(";
57 : georgekuan 2000 ppList' {sep=", ", pp=ppTKind'} tkinds;
58 : georgekuan 1999 pps ")";
59 :     closeBox())
60 : georgekuan 1998 in ppTKindI (LK.tk_out tk)
61 : georgekuan 2000 end (* ppTKind *)
62 : georgekuan 1998
63 : georgekuan 2000 fun ppTyc ppstrm (tycon : LK.tyc) =
64 : georgekuan 1999 (* FLINT variables are represented using deBruijn indices *)
65 : georgekuan 2000 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 : georgekuan 1999 (pps "TC_VAR(";
73 :     (* depth is a deBruijn index set in elabmod.sml/instantiate.sml *)
74 :     pps (DebIndex.di_print depth);
75 :     pps ",";
76 :     (* cnt is computed in instantiate.sml sigToInst *)
77 :     pps (Int.toString cnt);
78 :     pps ")")
79 :     (* Named tyc VAR; is actually an lvar *)
80 :     | ppTycI (LK.TC_NVAR tvar) =
81 :     (pps "TC_NVAR(";
82 :     pps (Int.toString tvar);
83 :     pps ")")
84 :     | ppTycI (LK.TC_PRIM primtycon) =
85 :     (pps "TC_PRIM(";
86 :     pps (PT.pt_print primtycon);
87 :     pps ")")
88 :     | ppTycI (LK.TC_FN (argTkinds, resultTyc)) =
89 :     (openHOVBox 1;
90 :     pps "TC_FN(";
91 : georgekuan 2000 ppList' {sep="* ", pp=ppTKind'} argTkinds;
92 : georgekuan 1999 pps ",";
93 : georgekuan 2000 ppTyc' resultTyc;
94 : georgekuan 1999 pps ")";
95 :     closeBox())
96 :     | ppTycI (LK.TC_APP(contyc, tys)) =
97 :     (openHOVBox 1;
98 :     pps "TC_APP(";
99 : georgekuan 2000 ppTyc' contyc;
100 : georgekuan 1999 pps ",";
101 : georgekuan 2000 ppList' {sep="* ", pp=ppTyc'} tys;
102 : georgekuan 1999 pps ")";
103 :     closeBox())
104 :     | ppTycI (LK.TC_SEQ tycs) =
105 :     (openHOVBox 1;
106 :     pps "TC_SEQ(";
107 : georgekuan 2000 ppList' {sep=", ", pp=ppTyc'} tycs;
108 : georgekuan 1999 pps ")";
109 :     closeBox())
110 :     | ppTycI (LK.TC_PROJ(tycon, index)) =
111 :     (openHOVBox 1;
112 :     pps "TC_PROJ(";
113 : georgekuan 2000 ppTyc' tycon;
114 : georgekuan 1999 pps ", ";
115 :     pps (Int.toString index);
116 :     pps ")";
117 :     closeBox())
118 :     | ppTycI (LK.TC_SUM(tycs)) =
119 :     (pps "TC_SUM(";
120 : georgekuan 2000 ppList' {sep=", ", pp=ppTyc'} tycs;
121 : georgekuan 1999 pps ")")
122 :     (* TC_FIX is a recursive DATATYPE *)
123 :     | ppTycI (LK.TC_FIX((numStamps, datatypeFamily, freetycs), index)) =
124 :     (openHOVBox 1;
125 :     pps "TC_FIX(";
126 :     pps "nStamps = ";
127 :     pps (Int.toString numStamps);
128 :     pps ", ";
129 :     pps "datatypeFamily = ";
130 : georgekuan 2000 ppTyc' datatypeFamily;
131 : georgekuan 1999 pps ", ";
132 :     pps "freeTycs = ";
133 : georgekuan 2000 ppList' {sep = ", ", pp = ppTyc'} freetycs;
134 : georgekuan 1999 pps ", ";
135 :     pps "index = ";
136 :     pps (Int.toString index);
137 :     pps ")";
138 :     closeBox())
139 :     | ppTycI (LK.TC_ABS tyc) =
140 :     (pps "TC_ABS(";
141 : georgekuan 2000 ppTyc' tyc;
142 : georgekuan 1999 pps ")")
143 :     | ppTycI (LK.TC_BOX tyc) =
144 :     (pps "TC_BOX(";
145 : georgekuan 2000 ppTyc' tyc;
146 : georgekuan 1999 pps ")")
147 :     (* rflag is a tuple kind template, a singleton datatype RF_TMP *)
148 :     | ppTycI (LK.TC_TUPLE (rflag, tycs)) =
149 :     (pps "TC_TUPLE(";
150 : georgekuan 2000 ppList' {sep="* ", pp=ppTyc'} tycs;
151 : georgekuan 1999 pps ")")
152 :     (* fflag records the calling convention: either FF_FIXED or FF_VAR *)
153 : georgekuan 2000 | ppTycI (LK.TC_ARROW (fflag, argTycs, resTycs)) =
154 : georgekuan 1999 (pps "TC_ARROW(";
155 :     (case fflag of LK.FF_FIXED => pps "FF_FIXED"
156 : georgekuan 2000 | LK.FF_VAR(b1, b2) => (pps "<FF_VAR>" (*;
157 :     ppBool b1;
158 : georgekuan 1999 pps ", ";
159 : georgekuan 2000 ppBool b2;
160 :     pps ")"*) ));
161 :     ppList' {sep="* ", pp=ppTyc'} argTycs;
162 : georgekuan 1999 pps ", ";
163 : georgekuan 2000 ppList' {sep="* ", pp=ppTyc'} resTycs;
164 : georgekuan 1999 pps ")")
165 :     (* According to ltykernel.sml comment, this arrow tyc is not used *)
166 : georgekuan 2000 | ppTycI (LK.TC_PARROW (argTyc, resTyc)) =
167 : georgekuan 1999 (pps "TC_PARROW(";
168 : georgekuan 2000 ppTyc' argTyc;
169 : georgekuan 1999 pps ", ";
170 : georgekuan 2000 ppTyc' resTyc;
171 : georgekuan 1999 pps ")")
172 : georgekuan 2000 | ppTycI (LK.TC_TOKEN (tok, tyc)) =
173 : georgekuan 1999 (pps "TC_TOKEN(";
174 : georgekuan 2000 pps (LK.token_name tok);
175 : georgekuan 1999 pps ", ";
176 : georgekuan 2000 ppTyc' tyc;
177 : georgekuan 1999 pps ")")
178 : georgekuan 2000 | ppTycI (LK.TC_CONT tycs) =
179 : georgekuan 1999 (pps "TC_CONT(";
180 : georgekuan 2000 ppList' {sep=", ", pp=ppTyc'} tycs;
181 : georgekuan 1999 pps ")")
182 : georgekuan 2000 | ppTycI (LK.TC_IND (tyc, tycI)) =
183 : georgekuan 1999 (openHOVBox 1;
184 :     pps "TC_IND(";
185 : georgekuan 2000 ppTyc' tyc;
186 :     pps ", ";
187 : georgekuan 1999 ppTycI tycI;
188 :     pps ")";
189 :     closeBox())
190 : georgekuan 2000 | ppTycI (LK.TC_ENV (tyc, ol, nl, tenv)) =
191 : georgekuan 1999 (openHOVBox 1;
192 :     pps "TC_ENV(";
193 : georgekuan 2000 ppTyc' tyc;
194 : georgekuan 1999 pps ", ";
195 :     pps "ol = ";
196 :     pps (Int.toString ol);
197 :     pps ", ";
198 :     pps "nl = ";
199 :     pps (Int.toString nl);
200 :     pps ", ";
201 : georgekuan 2000 (LK.tycEnvOut tenv);
202 : georgekuan 1999 closeBox())
203 :     in ppTycI (LK.tc_out tycon)
204 : georgekuan 2000 end (* ppTyc *)
205 :    
206 :     end (* local *)
207 : georgekuan 1999
208 : georgekuan 1998 end

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