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

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