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

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