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

Parent Directory | Revision Log

---

Revision 17 - (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 :

---

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