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/MiscUtil/print/ppdec.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log 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