Annotation of /sml/trunk/src/compiler/MiscUtil/print/ppdec.sml

Parent Directory | Revision Log

---

Revision 1190 - (view) (download)

1 :	monnier	245	(* Copyright 1996 by AT&T Bell Laboratories *)
2 :			(* ppdec.sml *)
3 :
4 :			signature PPDEC =
5 :			sig
6 :			val ppDec : Environment.environment -> PrettyPrint.ppstream
7 :			-> (Absyn.dec * Access.lvar list) -> unit
8 :			val debugging : bool ref
9 :			end (* signature PPDEC *)
10 :
11 :			structure PPDec : PPDEC =
12 :			struct
13 :
14 :			local
15 :			structure S = Symbol
16 :			structure IP = InvPath
17 :			structure M = Modules
18 :			structure V = VarCon
19 :			open Types VarCon Modules Bindings Fixity Absyn
20 :			PrettyPrint PPUtil PPType PPObj Access
21 :			in
22 :
23 :			(* debugging *)
24 :			val say = Control.Print.say
25 :			val debugging = ref false
26 :			fun debugmsg (msg: string) =
27 :			if !debugging then (say msg; say "\n") else ()
28 :
29 :			fun bug msg = ErrorMsg.impossible("PPDec: "^msg)
30 :
31 :
32 :			type object = Unsafe.Object.object
33 :
34 :			val signatures = Control.Print.signatures
35 :			val printOpens = Control.Print.printOpens
36 :			val printDepth = Control.Print.printDepth
37 :			val anonSym = S.strSymbol "<anonymousSig>"
38 :			val anonFsym = S.fctSymbol "<anonymousFsig>"
39 :
40 :			fun pplist_nl ppstrm pr =
41 :			let fun pp [] = ()
42 :			| pp [el] = pr el
43 :			| pp (el::rst) = (pr el; add_newline ppstrm; pp rst)
44 :			in pp
45 :			end
46 :
47 :			fun C f x y = f y x;
48 :
49 :			fun xtract (v, pos) = Unsafe.Object.nth (v, pos)
50 :
51 :			exception OVERLOAD
52 :
53 :			fun ppDec ({static,dynamic,...}: Environment.environment)
54 :			(ppstrm: ppstream) (dec: Absyn.dec, exportLvars) =
55 :			let val dec = (* pruneDec *) dec
56 :
57 :			fun isExport (x : Access.lvar, []) = false
58 :			| isExport (x, a::r) = if x = a then true else isExport(x, r)
59 :
60 :			val pps = add_string ppstrm
61 :			(* trueValType: get the type of the bound variable from static,
62 :			since the stamps in the absyn haven't been converted by the pickler *)
63 :			fun trueValType path =
64 :			let val err = fn _ => fn _ => fn _ => (bug "trueValType: unbound")
65 :			in case path
66 :			of SymPath.SPATH[id] =>
67 :			(case Lookup.lookValSym(static,id,err)
68 :			of V.VAL(V.VALvar{typ,...}) => !typ
69 :			| V.VAL(V.OVLDvar{name,scheme,...}) =>
70 :			(print ("#trueValType: OVLDvar"^Symbol.name name^"\n");
71 :			raise OVERLOAD)
72 :			| V.VAL(V.ERRORvar) =>
73 :			bug "trueValType: ERRORvar\n"
74 :			| V.CON(DATACON{name,typ,...}) =>
75 :			bug ("trueValType: DATACON"^Symbol.name name^"\n"))
76 :			| _ => bug "trueValType: not singleton path"
77 :			end
78 :
79 :			fun trueTycon (path: IP.path) =
80 :			let val err = fn _ => fn _ => fn _ => (bug "trueTycon: unbound ")
81 :			in case Lookup.lookTyc(static,ConvertPaths.invertIPath(path),err)
82 :	blume	1190	of DEFtyc x => SOME x
83 :			| _ => NONE
84 :	monnier	245	end
85 :
86 :			fun isLazyBogus (SymPath.SPATH path) =
87 :			case rev(String.explode (Symbol.name(List.last path)))
88 :			of #"$":: #","::_ => true
89 :			| _ => false
90 :
91 :			fun ppVar (VALvar{path, access, typ=(t0 as ref ty), info}) =
92 :			if isLazyBogus path then () else
93 :			(begin_block ppstrm CONSISTENT 0;
94 :			begin_block ppstrm INCONSISTENT 2;
95 :			add_string ppstrm "val ";
96 :			ppSymPath ppstrm path;
97 :			add_string ppstrm " =";
98 :			add_break ppstrm (1,0);
99 :
100 :			case access
101 :			of LVAR lv =>
102 :			(case StaticEnv.look (static, SymPath.last path)
103 :			of VALbind(VALvar{access=PATH (EXTERN pid, pos), ...}) =>
104 :			if isExport(lv, exportLvars)
105 :	blume	902	then (let val objv =
106 :			valOf (DynamicEnv.look dynamic pid)
107 :			val obj = xtract (objv, pos)
108 :	monnier	245	in ppObj static ppstrm
109 :			(obj, ty, !printDepth);
110 :			add_break ppstrm (1,0);
111 :			add_string ppstrm ": ";
112 :			ppType static ppstrm (trueValType path
113 :			handle OVERLOAD => ty)
114 :			end)
115 :			else (add_string ppstrm "<hidden-value>";
116 :			add_break ppstrm (1,0);
117 :			add_string ppstrm ": ";
118 :			ppType static ppstrm ty)
119 :	blume	587	| _ => add_string ppstrm "<PPDec.getVal failure>")
120 :	monnier	245
121 :			(*** | PRIMOP _ => add_string ppstrm "<primop>" *)
122 :			| _ => ErrorMsg.impossible "ppDec.ppVb.ppBind.VARpat";
123 :
124 :			end_block ppstrm;
125 :			add_newline ppstrm;
126 :			end_block ppstrm)
127 :
128 :			| ppVar _ = ()
129 :
130 :			fun ppVb (VB{pat,...}) =
131 :			let fun ppBind(pat) =
132 :			case pat
133 :			of VARpat v => ppVar v
134 :			| RECORDpat{fields,...} => app (ppBind o #2) fields
135 :			| VECTORpat(pats,_) => app ppBind pats
136 :			| APPpat(_,_,pat) => ppBind pat
137 :			| CONSTRAINTpat(pat,_) => ppBind pat
138 :			| LAYEREDpat(pat1,pat2) => (ppBind pat1; ppBind pat2)
139 :			| ORpat(p1, _) => ppBind p1
140 :			| _ => ()
141 :			in ppBind pat
142 :			end
143 :
144 :			and ppRvb (RVB{var, ...}) = ppVar var
145 :
146 :	blume	1190	and ppTb (DEFtyc dt) =
147 :			let val {path,tyfun=TYFUN{arity,body},...} =
148 :			getOpt (trueTycon (#path dt), dt)
149 :			in
150 :			begin_block ppstrm CONSISTENT 0;
151 :			begin_block ppstrm INCONSISTENT 2;
152 :			add_string ppstrm "type";
153 :			ppFormals ppstrm arity;
154 :			add_break ppstrm (1,0);
155 :			ppSym ppstrm (InvPath.last path);
156 :			add_string ppstrm " =";
157 :			add_break ppstrm (1,0);
158 :			ppType static ppstrm body;
159 :			end_block ppstrm;
160 :			add_newline ppstrm;
161 :			end_block ppstrm
162 :			end
163 :	blume	587	| ppTb _ = bug "ppTb:DEFtyc"
164 :
165 :			and ppAbsTyc(GENtyc { path, arity, eq, ... }) =
166 :			(case !eq of
167 :			ABS =>
168 :			(begin_block ppstrm CONSISTENT 0;
169 :			begin_block ppstrm INCONSISTENT 2;
170 :	monnier	245	add_string ppstrm "type";
171 :			ppFormals ppstrm arity;
172 :			add_break ppstrm (1,0);
173 :			ppSym ppstrm (InvPath.last path);
174 :	blume	587	end_block ppstrm;
175 :			add_newline ppstrm;
176 :			end_block ppstrm)
177 :			| _ =>
178 :			(begin_block ppstrm CONSISTENT 0;
179 :			begin_block ppstrm INCONSISTENT 2;
180 :			add_string ppstrm "type";
181 :			ppFormals ppstrm arity;
182 :			add_break ppstrm (1,0);
183 :			ppSym ppstrm (InvPath.last path);
184 :			end_block ppstrm;
185 :			add_newline ppstrm;
186 :			end_block ppstrm))
187 :	monnier	245	| ppAbsTyc _ = bug "unexpected case in ppAbsTyc"
188 :
189 :	blume	587	and ppDataTyc (GENtyc { path, arity,
190 :			kind = DATATYPE{index, freetycs,
191 :			family={members, ...},...},
192 :			... }) =
193 :	monnier	245	let fun ppDcons nil = ()
194 :			| ppDcons (first::rest) =
195 :	blume	587	let fun ppDcon ({name,domain,rep}) =
196 :			(ppSym ppstrm name;
197 :			case domain
198 :			of SOME dom =>
199 :			(add_string ppstrm " of ";
200 :			ppDconDomain (members,freetycs)
201 :			static ppstrm dom)
202 :			| NONE => ())
203 :			in
204 :			add_string ppstrm "= "; ppDcon first;
205 :			app (fn d => (add_break ppstrm (1,0);
206 :			add_string ppstrm "| "; ppDcon d))
207 :			rest
208 :			end
209 :	monnier	245	val {tycname,dcons,...} = Vector.sub(members,index)
210 :	blume	587	in
211 :			begin_block ppstrm CONSISTENT 0;
212 :			begin_block ppstrm CONSISTENT 0;
213 :			add_string ppstrm "datatype";
214 :			ppFormals ppstrm arity;
215 :			add_string ppstrm " ";
216 :			ppSym ppstrm (InvPath.last path);
217 :			add_break ppstrm (1,2);
218 :			begin_block ppstrm CONSISTENT 0;
219 :			ppDcons dcons;
220 :			end_block ppstrm;
221 :			end_block ppstrm;
222 :			add_newline ppstrm;
223 :	monnier	245	end_block ppstrm
224 :			end
225 :	blume	587	| ppDataTyc _ = bug "unexpected case in ppDataTyc"
226 :	monnier	245
227 :			and ppEb(EBgen{exn=DATACON{name,...},etype,...}) =
228 :			(begin_block ppstrm CONSISTENT 0;
229 :			begin_block ppstrm INCONSISTENT 2;
230 :			add_string ppstrm "exception ";
231 :			ppSym ppstrm name;
232 :			case etype
233 :			of NONE => ()
234 :			| SOME ty' =>
235 :			(add_string ppstrm " of";
236 :			add_break ppstrm (1,0);
237 :			ppType static ppstrm ty');
238 :			end_block ppstrm;
239 :			add_newline ppstrm;
240 :			end_block ppstrm)
241 :
242 :			| ppEb(EBdef{exn=DATACON{name,...},edef=DATACON{name=dname,...}}) =
243 :			(begin_block ppstrm CONSISTENT 0;
244 :			begin_block ppstrm INCONSISTENT 2;
245 :			add_string ppstrm "exception ";
246 :			ppSym ppstrm name;
247 :			add_string ppstrm " =";
248 :			add_break ppstrm (1,0);
249 :			ppSym ppstrm dname;
250 :			end_block ppstrm;
251 :			add_newline ppstrm;
252 :			end_block ppstrm)
253 :
254 :			and ppStrb isAbs (STRB{name,str,...}) = (* isAbs strvar *)
255 :			(begin_block ppstrm CONSISTENT 0;
256 :			begin_block ppstrm CONSISTENT 0;
257 :			pps "structure ";
258 :			ppSym ppstrm name;
259 :			pps " :";
260 :			add_break ppstrm (1,2);
261 :			PPModules.ppStructure ppstrm (str,static,!signatures);
262 :			end_block ppstrm;
263 :			add_newline ppstrm;
264 :			end_block ppstrm)
265 :
266 :			and ppFctb(FCTB{name,fct,...}) =
267 :			(begin_block ppstrm CONSISTENT 0;
268 :			pps "functor ";
269 :			ppSym ppstrm name;
270 :			pps " : <sig>"; (* DBM -- should print the signature *)
271 :			add_newline ppstrm;
272 :			end_block ppstrm)
273 :
274 :			and ppSigb sign =
275 :			let val name = case sign
276 :	blume	587	of M.SIG { name, ... } => getOpt (name, anonSym)
277 :	monnier	245	| _ => anonSym
278 :
279 :			in (begin_block ppstrm CONSISTENT 0;
280 :			begin_block ppstrm CONSISTENT 0;
281 :			pps "signature "; ppSym ppstrm name; pps " =";
282 :			add_break ppstrm (1,2);
283 :			PPModules.ppSignature ppstrm (sign,static,!signatures);
284 :			end_block ppstrm;
285 :			add_newline ppstrm;
286 :			end_block ppstrm)
287 :			end
288 :
289 :			and ppFsigb fsig =
290 :			let val name = case fsig
291 :			of M.FSIG{kind=SOME s, ...} => s
292 :			| _ => anonFsym
293 :
294 :			in (begin_block ppstrm CONSISTENT 0;
295 :			pps "funsig "; ppSym ppstrm name;
296 :			PPModules.ppFunsig ppstrm (fsig,static,!signatures);
297 :			add_newline ppstrm;
298 :			end_block ppstrm)
299 :			end
300 :
301 :			and ppFixity{fixity,ops} =
302 :			(begin_block ppstrm CONSISTENT 0;
303 :			begin_block ppstrm CONSISTENT 0;
304 :			add_string ppstrm (Fixity.fixityToString fixity);
305 :			PPUtil.ppSequence ppstrm {sep=C PrettyPrint.add_break (1,0),
306 :			pr=PPUtil.ppSym,
307 :			style=INCONSISTENT}
308 :			ops;
309 :			end_block ppstrm;
310 :			add_newline ppstrm;
311 :			end_block ppstrm)
312 :
313 :			and ppOpen(pathStrs) =
314 :			if !printOpens
315 :			then (begin_block ppstrm CONSISTENT 0;
316 :			app (fn (path,str) =>
317 :			PPModules.ppOpen ppstrm (path,str,static,!signatures))
318 :			pathStrs;
319 :			end_block ppstrm)
320 :			else (begin_block ppstrm CONSISTENT 0;
321 :			begin_block ppstrm CONSISTENT 0;
322 :			add_string ppstrm "open ";
323 :			ppSequence ppstrm {sep=C PrettyPrint.add_break (1,0),
324 :			pr=(fn ppstrm => fn (path,_)
325 :			=> ppSymPath ppstrm path),
326 :			style=INCONSISTENT}
327 :			pathStrs;
328 :			end_block ppstrm;
329 :			add_newline ppstrm;
330 :			end_block ppstrm)
331 :
332 :			and ppDec0 dec =
333 :			case (resetPPType(); dec)
334 :			of VALdec vbs => app ppVb vbs
335 :			| VALRECdec rvbs => app ppRvb rvbs
336 :			| TYPEdec tbs => app ppTb tbs
337 :			| DATATYPEdec{datatycs,withtycs} =>
338 :			(app ppDataTyc datatycs;
339 :			app ppTb withtycs)
340 :			| ABSTYPEdec{abstycs,withtycs,body} =>
341 :			(app ppAbsTyc abstycs;
342 :			app ppTb withtycs;
343 :			ppDec0 body)
344 :			| EXCEPTIONdec ebs => app ppEb ebs
345 :			| STRdec strbs => app (ppStrb false) strbs
346 :			| ABSdec strbs => app (ppStrb true) strbs
347 :			| FCTdec fctbs => app ppFctb fctbs
348 :			| SIGdec sigbs => app ppSigb sigbs
349 :			| FSIGdec fsigbs => app ppFsigb fsigbs
350 :			| LOCALdec(decIn,decOut) => ppDec0 decOut
351 :			| SEQdec decs =>
352 :			(case decs
353 :			of OPENdec pathStrs :: rest =>
354 :			ppOpen pathStrs
355 :			| _ => app ppDec0 decs)
356 :			| FIXdec fixd => ppFixity fixd
357 :			| OVLDdec _ =>
358 :			(add_string ppstrm "overload"; add_newline ppstrm)
359 :			| OPENdec pathStrs => ppOpen pathStrs
360 :			| MARKdec(dec,_) => ppDec0 dec
361 :
362 :			in begin_block ppstrm CONSISTENT 0;
363 :			ppDec0 dec;
364 :			end_block ppstrm;
365 :			flush_ppstream ppstrm
366 :			end
367 :
368 :			end (* local *)
369 :			end (* structure PPDec *)
370 :

---

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