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

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