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/trunk/src/compiler/FLINT/flint/ppflint.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/FLINT/flint/ppflint.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 40 - (view) (download)

1 : monnier 16 (* COPYRIGHT (c) 1997 YALE FLINT PROJECT *)
2 :     (* ppflint.sml -- Pretty printer for Flint IL. *)
3 :    
4 :    
5 :     structure PPFlint :> PPFLINT =
6 :     struct
7 :     (** frequently used structures *)
8 :     structure F = FLINT
9 :     structure S = Symbol
10 :     structure LV = LambdaVar
11 :     structure LT = LtyExtern
12 :     structure PO = PrimOp
13 :     structure PU = PrintUtil
14 :    
15 :     (** some print utilities **)
16 :     val say = Control.Print.say
17 :     val margin = ref 0
18 :     exception Undent
19 :     fun indent n = margin := !margin + n
20 :     fun undent n = (margin := !margin - n;
21 :     if !margin < 0 then raise Undent
22 :     else ())
23 :     fun dent () = PU.tab(!margin)
24 :     val newline = PU.newline
25 :    
26 :     infix &
27 :     fun op& (f1,f2) () = (f1(); f2())
28 :    
29 : monnier 24
30 : monnier 16 (** classifications of various kinds of functions: not used *)
31 : monnier 24 fun toStringFKind ({isrec=SOME _, ...} : F.fkind) = "FK_REC"
32 :     | toStringFKind {isrec=_, ...} = "FK_ESCAPE"
33 : monnier 16 (*
34 :     fun toStringFKind F.FK_ESCAPE = "FK_ESCAPE"
35 :     | toStringFKind F.FK_KNOWN = "FK_KNOWN"
36 :     | toStringFKind F.FK_KREC = "FK_KREC"
37 :     | toStringFKind F.FK_KTAIL = "FK_KTAIL"
38 :     | toStringFKind F.FK_NOINL = "FK_NOINL"
39 :     | toStringFKind F.FK_HANDLER = "FK_HANDLER"
40 :     *)
41 :    
42 :     val printFKind = say o toStringFKind
43 :    
44 :     (** classifications of various kinds of records *)
45 :     fun toStringRKind (F.RK_VECTOR tyc) = "VECTOR[" ^ LT.tc_print tyc ^ "]"
46 : monnier 24 | toStringRKind F.RK_RECORD = "RECORD"
47 : monnier 16 | toStringRKind F.RK_STRUCT = "STRUCT"
48 :    
49 :     val printRKind = say o toStringRKind
50 :    
51 :     (** con: used to specify all possible switching statements. *)
52 :     fun toStringCon (F.DATAcon((symbol,_,_),_,_)) = S.name symbol
53 :     | toStringCon (F.INTcon i) = "(I)" ^ (Int.toString i)
54 :     | toStringCon (F.INT32con i) = "(I32)" ^ (Int32.toString i)
55 :     | toStringCon (F.WORDcon i) = "(W)" ^ (Word.toString i)
56 :     | toStringCon (F.WORD32con i) = "(W32)" ^ (Word32.toString i)
57 :     | toStringCon (F.REALcon r) = r
58 :     | toStringCon (F.STRINGcon s) = PU.mlstr s
59 :     | toStringCon (F.VLENcon n) = Int.toString n
60 :    
61 :     val printCon = say o toStringCon
62 :    
63 :     (** simple values, including variables and static constants. *)
64 :     fun toStringValue (F.VAR v) = LV.lvarName v
65 :     | toStringValue (F.INT i) = "(I)" ^ Int.toString i
66 :     | toStringValue (F.INT32 i) = "(I32)" ^ Int32.toString i
67 :     | toStringValue (F.WORD i) = "(W)" ^ Word.toString i
68 :     | toStringValue (F.WORD32 i) = "(W32)" ^ Word32.toString i
69 :     | toStringValue (F.REAL r) = r
70 :     | toStringValue (F.STRING s) = PU.mlstr s
71 :    
72 :     val printSval = say o toStringValue
73 : monnier 40 val LVarString = ref LV.lvarName
74 : monnier 16
75 : monnier 40 fun printVar v = say (!LVarString v)
76 : monnier 16 val printTyc = say o LT.tc_print
77 :     val printLty = say o LT.lt_print
78 :     fun printTvTk (tv:LT.tvar,tk) =
79 :     say (LT.tk_print tk)
80 :    
81 :     val parenCommaSep = ("(", ",", ")")
82 :     val printValList = PU.printClosedSequence ("[",",","]") printSval
83 :     val printVarList = PU.printClosedSequence ("[",",","]") printVar
84 :     val printTycList = PU.printClosedSequence ("[",",","]") printTyc
85 :     val printLtyList = PU.printClosedSequence parenCommaSep printLty
86 :     val printTvTkList = PU.printClosedSequence ("[",",","]") printTvTk
87 :    
88 : monnier 24 fun appPrint prfun sepfun [] = ()
89 :     | appPrint prfun sepfun (x::xs) =
90 :     (prfun x; app (fn y => (sepfun(); prfun y)) xs)
91 :    
92 :     fun printDecon (F.DATAcon(_,_,[])) = ()
93 :     | printDecon (F.DATAcon((symbol,conrep,lty),tycs,lvars)) =
94 :     (* [<lvars>] = DECON(<symbol>,<conrep>,<lty>,[<tycs>]) *)
95 :     (printVarList lvars;
96 : monnier 16 say " = DECON(";
97 :     say (S.name symbol); say ",";
98 :     say (Access.prRep conrep); say ",";
99 :     printLty lty; say ",";
100 :     printTycList tycs; say ")";
101 :     newline(); dent())
102 :     | printDecon _ = ()
103 :    
104 :     (** the definitions of the lambda expressions *)
105 :    
106 :     fun complex (F.LET _) = true
107 :     | complex (F.FIX _) = true
108 :     | complex (F.TFN _) = true
109 :     | complex (F.SWITCH _) = true
110 :     | complex (F.CON _) = true
111 :     | complex (F.HANDLE _) = true
112 :     | complex _ = false
113 :    
114 :     fun pLexp (F.RET values) =
115 :     (* RETURN [values] *)
116 :     (say "RETURN "; printValList values)
117 :    
118 :     | pLexp (F.APP (f, args)) =
119 :     (* APP(f, [args]) *)
120 :     (say "APP(";
121 :     printSval f;
122 :     say ",";
123 :     printValList args;
124 :     say ")")
125 :    
126 :     | pLexp (F.TAPP (tf, tycs)) =
127 :     (* TAPP(tf, [tycs]) *)
128 :     (say "TAPP(";
129 :     printSval tf;
130 :     say ",";
131 :     printTycList tycs;
132 :     say ")")
133 :    
134 :     | pLexp (F.LET (vars, lexp, body)) =
135 :     (* [vars] = lexp OR [vars] =
136 :     * body lexp
137 :     * body
138 :     *)
139 :     (printVarList vars; say " = ";
140 :     if complex lexp then
141 :     (indent 2; newline(); dent(); pLexp lexp; undent 2)
142 :     else
143 :     let val len = (3 (* for the " = " *)
144 :     + 2 (* for the "[]" *)
145 :     + (length vars) (* for each comma *)
146 :     + (foldl (* sum of varname lengths *)
147 : monnier 40 (fn (v,n) => n + (size (!LVarString v)))
148 : monnier 16 0 vars))
149 :     in
150 :     indent len; pLexp lexp; undent len
151 :     end;
152 :     newline(); dent(); pLexp body)
153 :    
154 :     | pLexp (F.FIX (fundecs, body)) =
155 :     (* FIX(<fundec1>,
156 :     * <fundec2>,
157 :     * <fundec3>)
158 :     * <body>
159 :     *)
160 :     (say "FIX(";
161 :     indent 4;
162 :     appPrint printFundec (newline & dent) fundecs;
163 :     undent 4; say ")"; newline();
164 :     dent();
165 :     pLexp body)
166 :    
167 :     | pLexp (F.TFN ((lvar, tv_tk_list, tfnbody), body)) =
168 :     (* v =
169 :     * TFN([tk],lty,
170 :     * <tfnbody>)
171 :     * <body>
172 :     *)
173 :     (printVar lvar; say " = "; newline();
174 :     indent 2; dent();
175 :     say "TFN(";
176 :     printTvTkList tv_tk_list; say ",";
177 :     (*** printLty lty; say ","; *** lty no longer available ***)
178 :     newline();
179 :     indent 2;
180 :     dent();
181 :     pLexp tfnbody;
182 :     undent 4; say ")"; newline();
183 :     dent();
184 :     pLexp body)
185 :    
186 :     (** NOTE: I'm ignoring the consig here **)
187 :     | pLexp (F.SWITCH (value, consig, con_lexp_list, lexpOption)) =
188 :     (* SWITCH <value>
189 :     * <con> =>
190 :     * <lexp>
191 :     * <con> =>
192 :     * <lexp>
193 :     *)
194 :     (say "SWITCH "; printSval value; newline();
195 :     indent 2; dent();
196 :     appPrint printCase (newline & dent) con_lexp_list;
197 :     case lexpOption of
198 :     NONE => ()
199 :     | SOME lexp => (* default case *)
200 :     (newline(); dent(); say "_ => ";
201 :     indent 4; newline(); dent();
202 :     pLexp lexp; undent 4);
203 :     undent 2)
204 :    
205 : monnier 24 | pLexp (F.CON ((symbol,_,_), tycs, values, lvar, body)) =
206 :     (* <lvar> = CON(<symbol>, <tycs>, <values>)
207 : monnier 16 * <body>
208 :     *)
209 :     (printVar lvar; say " = CON(";
210 :     say (S.name symbol); say ", ";
211 :     printTycList tycs; say ", ";
212 : monnier 24 printValList values; say ")";
213 : monnier 16 newline(); dent(); pLexp body)
214 :    
215 :     | pLexp (F.RECORD (rkind, values, lvar, body)) =
216 :     (* <lvar> = RECORD(<rkind>, <values>)
217 :     * <body>
218 :     *)
219 :     (printVar lvar; say " = ";
220 :     printRKind rkind; say " ";
221 :     printValList values;
222 :     newline(); dent(); pLexp body)
223 :    
224 :     | pLexp (F.SELECT (value, int, lvar, body)) =
225 :     (* <lvar> = SELECT(<value>, <int>)
226 :     * <body>
227 :     *)
228 :     (printVar lvar; say " = SELECT(";
229 :     printSval value; say ", ";
230 :     say (Int.toString int); say ")";
231 :     newline(); dent(); pLexp body)
232 :    
233 :     | pLexp (F.RAISE (value, ltys)) =
234 :     (* NOTE: I'm ignoring the lty list here. It is the return type
235 : monnier 24 * of the raise expression.
236 : monnier 16 *)
237 :     (* RAISE(<value>) *)
238 :     (say "RAISE(";
239 : monnier 24 printSval value; say ")")
240 : monnier 16
241 :     | pLexp (F.HANDLE (body, value)) =
242 :     (* <body>
243 :     * HANDLE(<value>)
244 :     *)
245 :     (pLexp body;
246 :     newline(); dent();
247 :     say "HANDLE("; printSval value; say ")")
248 : monnier 24
249 :     | pLexp (F.ETAG (tyc, value, lvar, body)) =
250 :     (* <lvar> = ETAG(<value>[<tyc>])
251 :     * <body>
252 : monnier 16 *)
253 : monnier 24 (printVar lvar; say " = ETAG(";
254 :     printSval value; say "[";
255 :     printTyc tyc; say "])";
256 :     newline(); dent(); pLexp body)
257 :    
258 :     | pLexp (F.PRIMOP ((primop, lty, tycs), values, lvar, body)) =
259 :     (* <lvar> = PRIM(<primop>, <lty>, [<tycs>]) [<values>]
260 :     * <body>
261 :     *)
262 :     (printVar lvar; say " = PRIMOP(";
263 : monnier 16 say (PO.prPrimop primop); say ", ";
264 :     printLty lty; say ", ";
265 :     printTycList tycs; say ") ";
266 :     printValList values;
267 : monnier 24 newline(); dent(); pLexp body)
268 : monnier 16
269 : monnier 24 | pLexp (F.GENOP (dict, (primop, lty, tycs), values, lvar, body)) =
270 :     (* NOTE: I'm ignoring the `dict' here. *)
271 :     (* <lvar> = GENOP(<primop>, <lty>, [<tycs>]) [<values>]
272 : monnier 16 * <body>
273 :     *)
274 : monnier 24 (printVar lvar; say " = GENOP(";
275 :     say (PO.prPrimop primop); say ", ";
276 :     printLty lty; say ", ";
277 :     printTycList tycs; say ") ";
278 :     printValList values;
279 : monnier 16 newline(); dent(); pLexp body)
280 : monnier 24
281 :     | pLexp (F.WRAP (tyc, value, lvar, body)) =
282 : monnier 16 (* <lvar> = WRAP(<tyc>, <value>)
283 :     * <body>
284 :     *)
285 :     (printVar lvar; say " = WRAP(";
286 : monnier 24 printTyc tyc; say ", ";
287 : monnier 16 printSval value; say ")";
288 :     newline(); dent(); pLexp body)
289 : monnier 24
290 :     | pLexp (F.UNWRAP (tyc, value, lvar, body)) =
291 : monnier 16 (* <lvar> = UNWRAP(<tyc>, <value>)
292 :     * <body>
293 :     *)
294 :     (printVar lvar; say " = UNWRAP(";
295 : monnier 24 printTyc tyc; say ", ";
296 : monnier 16 printSval value; say ")";
297 :     newline(); dent(); pLexp body)
298 :    
299 :     and printFundec (fkind, lvar, lvar_lty_list, body) =
300 :     (* <lvar> : (<fkind>) <lty> =
301 :     * FN([v1 : lty1,
302 :     * v2 : lty2],
303 :     * <body>)
304 :     *)
305 :     (printVar lvar; say " : ";
306 :     say "("; printFKind fkind; say ") ";
307 :     (*** the return-result lty no longer available ---- printLty lty; **)
308 :     say " = "; newline();
309 :     indent 2;
310 :     dent();
311 :     say "FN([";
312 :     indent 4;
313 :     (case lvar_lty_list of
314 :     [] => ()
315 :     | ((lvar,lty)::L) =>
316 :     (printVar lvar; say " : "; printLty lty;
317 :     app (fn (lvar,lty) =>
318 :     (say ","; newline(); dent();
319 :     printVar lvar; say " : "; printLty lty)) L));
320 : monnier 24 print "],"; newline();
321 : monnier 16 undent 2; dent();
322 : monnier 24 pLexp body;
323 : monnier 40 undent 4; say ")")
324 : monnier 16
325 :     and printCase (con, lexp) =
326 :     (printCon con;
327 :     say " => ";
328 :     indent 4; newline(); dent();
329 :     printDecon con;
330 :     pLexp lexp; undent 4)
331 :    
332 :     fun printLexp lexp = pLexp lexp before (newline(); newline())
333 :    
334 :    
335 :     end (* structure PPFlint *)
336 :    

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