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/SMLNJ/src/compiler/FLINT/plambda/pplexp.sml
ViewVC logotype

Annotation of /sml/branches/SMLNJ/src/compiler/FLINT/plambda/pplexp.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 93 - (view) (download)

1 : monnier 16 (* Copyright 1997 by Bell Laboratories *)
2 :     (* pplexp.sml *)
3 :    
4 :     signature PPLEXP =
5 :     sig
6 :    
7 :     val printCon : PLambda.con -> unit
8 :     val printLexp : PLambda.lexp -> unit
9 :     val printMatch : StaticEnv.staticEnv ->
10 :     (Absyn.pat * PLambda.lexp) list -> unit
11 :     val printFun : PLambda.lexp -> LambdaVar.lvar -> unit
12 :    
13 :     val stringTag : PLambda.lexp -> string
14 :    
15 :     end (* signature PPLEXP *)
16 :    
17 :    
18 :     structure PPLexp : PPLEXP =
19 :     struct
20 :    
21 :     local structure A = Absyn
22 :     structure DA = Access
23 :     structure S = Symbol
24 :     structure PP = PrettyPrint
25 :     structure PU = PrintUtil
26 :     structure LT = PLambdaType
27 :     open PLambda PrintUtil
28 :     in
29 :    
30 :     val say = Control.Print.say
31 :     fun sayrep rep = say (DA.prRep rep)
32 :     val lvarName = LambdaVar.lvarName
33 :    
34 :     fun bug s = ErrorMsg.impossible ("MCprint: "^s)
35 :    
36 :     fun app2(f, [], []) = ()
37 :     | app2(f, a::r, b::z) = (f(a, b); app2(f, r, z))
38 :     | app2(f, _, _) = bug "unexpected list arguments in function app2"
39 :    
40 :     val margin = ref 0
41 :     fun indent i = margin := !margin + i
42 :    
43 :     exception Undent
44 :    
45 :     fun undent i =
46 :     (margin := !margin - i; if !margin < 0 then raise Undent else ())
47 :    
48 :     fun dent () = tab(!margin)
49 :    
50 :     fun whitespace() =
51 :     let fun ws(n) =
52 :     if n < 0 then raise Undent
53 :     else if n >= 8 then "\t" :: ws(n-8)
54 :     else let val str = case n of 0 => "" | 1 => " " | 2 => " "
55 :     | 3 => " " | 4 => " "
56 :     | 5 => " " | 6 => " "
57 :     | _ => " "
58 :     in [str]
59 :     end
60 :     in concat(ws(!margin))
61 :     end
62 :    
63 :     fun prCon (DATAcon((sym, _, _), _, v)) = ((S.name sym) ^ " " ^ (lvarName v))
64 :     | prCon (INTcon i) = Int.toString i
65 :     | prCon (INT32con i) = "(I32)" ^ (Int32.toString i)
66 :     | prCon (WORDcon i) = "(W)" ^ (Word.toString i)
67 :     | prCon (WORD32con i) = "(W32)" ^ (Word32.toString i)
68 :     | prCon (REALcon r) = r
69 :     | prCon (STRINGcon s) = PU.mlstr s (* was PU.pr_mlstr s *)
70 :     | prCon (VLENcon n) = Int.toString n
71 :    
72 :     fun printCon x = say (prCon x)
73 :    
74 :     (** use of complex in printLexp may lead to stupid n^2 behavior. *)
75 :     fun complex le =
76 :     let fun h [] = false
77 :     | h (a::r) = g a orelse h r
78 :    
79 :     and g (FN(_, _, b)) = g b
80 :     | g (FIX(vl, _, ll, b)) = true
81 :     | g (APP(FN _, _)) = true
82 :     | g (APP(l, r)) = g l orelse g r
83 :    
84 :     | g (LET _) = true
85 :     | g (TFN(_, b)) = g b
86 :     | g (TAPP(l, [])) = g l
87 :     | g (TAPP(l, _)) = true
88 :     | g (GENOP(_,_,_,_)) = true
89 :     | g (PACK(_, _, _, l)) = g l
90 :    
91 :     | g (RECORD l) = h l
92 :     | g (SRECORD l) = h l
93 :     | g (VECTOR (l, _)) = h l
94 :     | g (SELECT(_, l)) = g l
95 :    
96 :     | g (SWITCH _) = true
97 :     | g (CON(_, _, l)) = true
98 :     (* | g (DECON(_, _, l)) = true *)
99 :    
100 :     | g (HANDLE _) = true
101 :     | g (RAISE(l, _)) = g l
102 :     | g (ETAG (l, _)) = g l
103 :    
104 :     | g (WRAP(_, _, l)) = g l
105 :     | g (UNWRAP(_, _, l)) = g l
106 :     | g _ = false
107 :    
108 :     in g le
109 :     end
110 :    
111 :     fun printLexp l =
112 :     let fun prLty t = say (LT.lt_print t)
113 :     fun prTyc t = say (LT.tc_print t)
114 :     fun prKnd k = say (LT.tk_print k)
115 :    
116 :     fun plist (p, [], sep) = ()
117 :     | plist (p, a::r, sep) =
118 :     (p a; app (fn x => (say sep; p x)) r)
119 :    
120 :     fun g (VAR v) = say(lvarName v)
121 :     | g (INT i) = say(Int.toString i)
122 :     | g (WORD i) = (say "(W)"; say(Word.toString i))
123 :     | g (INT32 i) = (say "(I32)"; say(Int32.toString i))
124 :     | g (WORD32 i) = (say "(W32)"; say(Word32.toString i))
125 :     | g (REAL s) = say s
126 :     | g (STRING s) = say (mlstr s)
127 :     | g (ETAG (l,_)) = g l
128 :    
129 :     | g (r as RECORD l) =
130 :     if complex r
131 :     then (say "RECORD";
132 :     indent 7;
133 :     PU.printClosedSequence ("(",",\n"^whitespace(),")") g l;
134 :     undent 7)
135 :     else (say "RECORD"; PU.printClosedSequence ("(", ",", ")") g l)
136 :    
137 :     | g (r as SRECORD l) =
138 :     if complex r
139 :     then (say "SRECORD";
140 :     indent 7;
141 :     PU.printClosedSequence ("(",",\n"^whitespace(),")") g l;
142 :     undent 7)
143 :     else (say "SRECORD"; PU.printClosedSequence ("(", ",", ")") g l)
144 :    
145 :     | g (r as VECTOR (l, _)) =
146 :     if complex r
147 :     then (say "VECTOR";
148 :     indent 7;
149 :     PU.printClosedSequence ("(",",\n"^whitespace(),")") g l;
150 :     undent 7)
151 :     else (say "VECTOR"; PU.printClosedSequence ("(", ",", ")") g l)
152 :    
153 :     | g (PRIM(p,t,ts)) =
154 :     (say ("PRIM (" ^ (PrimOp.prPrimop p) ^ ", "); prLty t;
155 :     say ", ["; plist(prTyc, ts, ","); say "])")
156 :    
157 :     | g (l as SELECT(i, _)) =
158 :     let fun gather(SELECT(i,l)) =
159 :     let val (more,root) = gather l
160 :     in (i :: more,root)
161 :     end
162 :     | gather l = (nil, l)
163 :    
164 :     val (path,root) = gather l
165 :     fun ipr (i:int) = say(Int.toString i)
166 :     in g root;
167 :     PU.printClosedSequence ("[",",","]") ipr (rev path)
168 :     end
169 :    
170 :     | g (FN(v,t,l)) =
171 :     (say "FN("; say(lvarName v); say " : "; prLty t; say ", ";
172 :     if complex l then (newline(); indent 3; dent();
173 :     g l; say ")"; undent 3)
174 :     else (g l; say ")"))
175 :    
176 :     | g (CON((s, c, lt), ts, l)) =
177 :     (say "CON(("; say(S.name s); say ","; sayrep c; say ",";
178 :     prLty lt; say "), ["; plist(prTyc, ts, ","); say "], ";
179 :     if complex l then (indent 4; g l; say ")"; undent 4)
180 :     else (g l; say ")"))
181 :     (*
182 :     | g (DECON((s, c, lt), ts, l)) =
183 :     (say "DECON(("; say(S.name s); say ","; sayrep c; say ",";
184 :     prLty lt; say "), ["; plist(prTyc, ts, ","); say "], ";
185 :     if complex l then (indent 4; g l; say ")"; undent 4)
186 :     else (g l; say ")"))
187 :     *)
188 :     | g (APP(FN(v,_,l),r)) = (say "(APP) "; g (LET(v, r, l)))
189 :    
190 :     | g (LET(v, r, l)) =
191 :     let val lv = lvarName v
192 :     val len = size lv + 3
193 :     in say lv; say " = ";
194 :     if complex r
195 :     then (indent 2; newline(); dent(); g r; undent 2)
196 :     else (indent len ; g r; undent len);
197 :     newline(); dent(); g l
198 :     end
199 :    
200 :     | g (APP(l, r)) =
201 :     (say "APP(";
202 :     if complex l orelse complex r
203 :     then (indent 4; g l; say ",\n"; dent();
204 :     g r; say ")"; undent 4)
205 :     else (g l; say ",";
206 :     g r; say ")"))
207 :    
208 :     | g (TFN(ks, b)) =
209 :     (say "TFN("; app (fn k => (prKnd k; say ",")) ks;
210 :     if complex b
211 :     then (newline(); indent 3; dent(); g b; say ")"; undent 3)
212 :     else (g b; say ")"))
213 :    
214 :     | g (TAPP(l, ts)) =
215 :     (say "TAPP(";
216 :     if complex l
217 :     then (indent 4; g l; say ",\n"; dent(); say "[";
218 :     plist(prTyc, ts, ","); say "])"; undent 4)
219 :     else (g l; say ", ["; plist(prTyc, ts, ","); say "])"))
220 :    
221 :     | g (GENOP(dict, p, t, ts)) =
222 :     (say ("GENOP (" ^ (PrimOp.prPrimop p) ^ ", "); prLty t;
223 :     say ", ["; plist(prTyc, ts, ","); say "])")
224 :    
225 :     | g (PACK(lt, ts, nts, l)) =
226 :     (say "PACK(";
227 :     app2 (fn (tc,ntc) => (say "<"; prTyc tc; say ","; prTyc ntc;
228 :     say ">,"), ts, nts);
229 :     say " "; prLty lt; say ", ";
230 :     if complex l
231 :     then (newline(); indent 3; dent(); g l; say ")"; undent 3)
232 :     else (g l; say ")"))
233 :    
234 :     | g (SWITCH (l,_,llist,default)) =
235 :     let fun switch [(c,l)] =
236 :     (printCon c; say " => "; indent 8; g l; undent 8)
237 :     | switch ((c,l)::more) =
238 :     (printCon c; say " => ";
239 :     indent 8; g l; undent 8; newline(); dent(); switch more)
240 :     | switch [] = bug "unexpected case in switch"
241 :    
242 :     in say "SWITCH ";
243 :     indent 7; g l; undent 6; newline(); dent();
244 :     say "of "; indent 3; switch llist;
245 :    
246 :     case (default,llist)
247 :     of (NONE,_) => ()
248 :     | (SOME l,nil) => (say "_ => "; indent 5; g l; undent 5)
249 :     | (SOME l,_) => (newline(); dent(); say "_ => ";
250 :     indent 5; g l; undent 5);
251 :    
252 :     undent 4
253 :     end
254 :    
255 :     | g (FIX(varlist,ltylist,lexplist,lexp)) =
256 :     let fun flist([v],[t],[l]) =
257 :     let val lv = lvarName v
258 :     val len = size lv + 2
259 :     in say lv; say " : ";prLty t;say " :: ";
260 :     indent len ; g l; undent len
261 :     end
262 :     | flist(v::vs,t::ts,l::ls) =
263 :     let val lv = lvarName v
264 :     val len = size lv + 2
265 :     in say lv; say " : "; prLty t; say " :: ";
266 :     indent len ; g l; undent len;
267 :     newline(); dent(); flist(vs,ts,ls)
268 :     end
269 :     | flist(nil,nil,nil) = ()
270 :     | flist _ = bug "unexpected cases in flist"
271 :    
272 :     in say "FIX("; indent 4; flist(varlist,ltylist,lexplist);
273 :     undent 4; newline(); dent(); say "IN ";
274 :     indent 4; g lexp; say ")"; undent 4
275 :     end
276 :    
277 :     | g (RAISE(l,t)) =
278 :     (say "RAISE("; prLty t; say ", "; indent 6; g l; say ")"; undent 6)
279 :    
280 :     | g (HANDLE (lexp,withlexp)) =
281 :     (say "HANDLE "; indent 7; g lexp; undent 5; newline(); dent();
282 :     say "WITH "; indent 5; g withlexp; undent 7)
283 :    
284 :     | g (WRAP(t, _, l)) =
285 :     (say "WRAP("; prTyc t; say ","; indent 5; newline(); dent(); g l;
286 :     say ")"; undent 5)
287 :    
288 :     | g (UNWRAP(t, _, l)) =
289 :     (say "UNWRAP("; prTyc t; say ","; indent 7;
290 :     newline(); dent(); g l; say ")"; undent 7)
291 :    
292 :     in g l; newline(); newline()
293 :     end
294 :    
295 :     fun printMatch env ((p,r)::more) =
296 :     (PP.with_pp (ErrorMsg.defaultConsumer())
297 :     (fn ppstrm =>
298 :     (PPAbsyn.ppPat env ppstrm (p,!Control.Print.printDepth);
299 :     PP.add_newline ppstrm));
300 :     say " => "; printLexp r; printMatch env more)
301 :     | printMatch _ [] = ()
302 :    
303 :     fun printFun l v =
304 :     let fun last (DA.LVAR x) = x
305 :     | last (DA.PATH(r,_)) = last r
306 :     | last _ = bug "unexpected access in last"
307 :    
308 :     val rec find =
309 :     fn VAR w => if (v=w)
310 :     then (say("VAR " ^ lvarName v ^ " is free in <lexp>\n");())
311 :     else ()
312 :     | l as FN(w,_,b) => if v=w then printLexp l else find b
313 :     | l as FIX(vl,_,ll,b) =>
314 :     if List.exists (fn w => v=w) vl then printLexp l
315 :     else (app find ll; find b)
316 :     | APP(l,r) => (find l; find r)
317 :     | LET(w,l,r) => (if v=w then printLexp l else find l; find r)
318 :     | PACK(_,_,_,r) => find r
319 :     | TFN(_, r) => find r
320 :     | TAPP(l, _) => find l
321 :     | SWITCH (l,_,ls,d) =>
322 :     (find l; app (fn(_,l) => find l) ls;
323 :     case d of NONE => () | SOME l => find l)
324 :     | RECORD l => app find l
325 :     | SRECORD l => app find l
326 :     | VECTOR (l, t) => app find l
327 :     | SELECT(_,l) => find l
328 :     | CON((_, DA.EXN p, _), _, e) => (find(VAR(last p)); find e)
329 :     | CON(_,_,e) => find e
330 :     (*
331 :     | DECON((_, DA.EXN p, _), _, e) => (find(VAR(last p)); find e)
332 :     | DECON(_,_,e) => find e
333 :     *)
334 :     | HANDLE(e,h) => (find e; find h)
335 :     | RAISE(l,_) => find l
336 :     | INT _ => () | WORD _ => ()
337 :     | INT32 _ => () | WORD32 _ => ()
338 :     | STRING _ => () | REAL _ => ()
339 :     | ETAG (e,_) => find e
340 :     | PRIM _ => ()
341 :     | GENOP ({default=e1,table=es}, _, _, _) =>
342 :     (find e1; app (fn (_, x) => find x) es)
343 :     | WRAP(_, _, e) => find e
344 :     | UNWRAP(_, _, e) => find e
345 :    
346 :     in find l
347 :     end
348 :    
349 :     fun stringTag (VAR _) = "VAR"
350 :     | stringTag (INT _) = "INT"
351 :     | stringTag (INT32 _) = "INT32"
352 :     | stringTag (WORD _) = "WORD"
353 :     | stringTag (WORD32 _) = "WORD32"
354 :     | stringTag (REAL _) = "REAL"
355 :     | stringTag (STRING _) = "STRING"
356 :     | stringTag (PRIM _) = "PRIM"
357 :     | stringTag (GENOP _) = "GENOP"
358 :     | stringTag (FN _) = "FN"
359 :     | stringTag (FIX _) = "FIX"
360 :     | stringTag (APP _) = "APP"
361 :     | stringTag (LET _) = "LET"
362 :     | stringTag (TFN _) = "TFN"
363 :     | stringTag (TAPP _) = "TAPP"
364 :     | stringTag (ETAG _) = "ETAG"
365 :     | stringTag (RAISE _) = "RAISE"
366 :     | stringTag (HANDLE _) = "HANDLE"
367 :     | stringTag (CON _) = "CON"
368 :     | stringTag (SWITCH _) = "SWITCH"
369 :     | stringTag (VECTOR _) = "VECTOR"
370 :     | stringTag (RECORD _) = "RECORD"
371 :     | stringTag (SRECORD _) = "SRECORD"
372 :     | stringTag (SELECT _) = "SELECT"
373 :     | stringTag (PACK _) = "PACK"
374 :     | stringTag (WRAP _) = "WRAP"
375 :     | stringTag (UNWRAP _) = "UNWRAP"
376 :    
377 :     end (* toplevel local *)
378 :     end (* struct PPLexp *)
379 :    
380 : monnier 93
381 :     (*
382 :     * $Log: pplexp.sml,v $
383 :     * Revision 1.1.1.1 1998/04/08 18:39:38 george
384 :     * Version 110.5
385 :     *
386 :     *)

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