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/pptype.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (view) (download)

1 : monnier 16 (* Copyright 1991 by AT&T Bell Laboratories *)
2 :    
3 :     signature PPTYPE =
4 :     sig
5 :     val typeFormals : int -> string list
6 :     val tyvarPrintname : Types.tyvar -> string
7 :     val ppTycon : StaticEnv.staticEnv -> PrettyPrint.ppstream
8 :     -> Types.tycon -> unit
9 :     val ppTyfun : StaticEnv.staticEnv -> PrettyPrint.ppstream
10 :     -> Types.tyfun -> unit
11 :     val ppType : StaticEnv.staticEnv -> PrettyPrint.ppstream
12 :     -> Types.ty -> unit
13 :     val ppDconDomain : (Types.dtmember vector * Types.tycon list)
14 :     -> StaticEnv.staticEnv
15 :     -> PrettyPrint.ppstream -> Types.ty -> unit
16 :     val ppDataconTypes : StaticEnv.staticEnv -> PrettyPrint.ppstream
17 :     -> Types.tycon -> unit
18 :     val resetPPType : unit -> unit
19 :     val ppFormals : PrettyPrint.ppstream -> int -> unit
20 :    
21 :     val debugging : bool ref
22 :     val unalias : bool ref
23 :    
24 :     end (* signature PPTYPE *)
25 :    
26 :     structure PPType : PPTYPE =
27 :     struct
28 :    
29 :     local
30 :     structure SP = SymPath
31 :     structure BT = BasicTypes
32 :     structure T = Types
33 :     structure TU = TypesUtil
34 :     structure PP = PrettyPrint
35 :     open Types PPUtil
36 :     in
37 :    
38 :     val debugging = ref false
39 :     val unalias = ref true
40 :    
41 :     fun bug s = ErrorMsg.impossible ("PPType: " ^ s)
42 :     val pps = PP.add_string
43 :    
44 :     fun C f x y = f y x
45 :    
46 :     val internals = Control.internals
47 :    
48 :     fun boundTyvarName k =
49 :     let val a = Char.ord #"a"
50 :     in if k < 26
51 :     then String.str(Char.chr(k+a))
52 :     else implode[Char.chr(Int.div(k,26) + a),
53 :     Char.chr(Int.mod(k,26) + a)]
54 :     end
55 :    
56 :     fun metaTyvarName' k =
57 :     let val a = Char.ord #"Z" (* use reverse order for meta vars *)
58 :     in if k < 26
59 :     then String.str(Char.chr(a - k))
60 :     else implode[Char.chr(a - (Int.div(k,26))),
61 :     Char.chr(a - (Int.mod(k,26)))]
62 :     end
63 :    
64 :     fun typeFormals n =
65 :     let fun loop i =
66 :     if i>=n then []
67 :     else (boundTyvarName i)::loop(i+1)
68 :     in loop 0
69 :     end
70 :    
71 :     fun litKindPrintName (lk: T.litKind) =
72 :     case lk
73 :     of T.INT => "int" (* or "INT" *)
74 :     | T.WORD => "word" (* or "WORD" *)
75 :     | T.REAL => "real" (* or "REAL" *)
76 :     | T.CHAR => "char" (* or "CHAR" *)
77 :     | T.STRING => "string" (* or "STRING" *)
78 :    
79 :     local (* WARNING -- compiler global variables *)
80 :     val count = ref(~1)
81 :     val metaTyvars = ref([]:tyvar list)
82 :     in
83 :     fun metaTyvarName(tv: tyvar) =
84 :     let fun find([],_) =
85 :     (metaTyvars := tv::(!metaTyvars);
86 :     count := !count+1;
87 :     !count)
88 :     | find(tv'::rest,k) =
89 :     if tv = tv'
90 :     then !count - k
91 :     else find(rest,k+1)
92 :     in metaTyvarName' (find(!metaTyvars,0))
93 :     end
94 :     fun resetPPType() = (count := ~1; metaTyvars := [])
95 :     end
96 :    
97 :     fun tvHead (eq,base) =
98 :     (if eq then "''" else "'")^base
99 :    
100 :     fun annotate (name,annotation,depthOp) =
101 :     if !internals
102 :     then concat(name::"."::annotation::
103 :     (case depthOp
104 :     of SOME depth => ["[",(Int.toString depth),"]"]
105 :     | NONE => nil))
106 :     else name
107 :    
108 :     fun tyvarPrintname (tyvar as ref info) =
109 :     case info
110 :     of INSTANTIATED(VARty(tyvar)) => tyvarPrintname tyvar
111 :     | OPEN{depth,eq,kind} =>
112 :     tvHead(eq, annotate(metaTyvarName tyvar,
113 :     case kind of META => "M" | FLEX _ => "F",
114 :     SOME depth))
115 :     | UBOUND{name,depth,eq} =>
116 :     tvHead(eq,annotate(Symbol.name name,"U",SOME depth))
117 :     | LITERAL{kind,...} =>
118 :     annotate(litKindPrintName kind,"L",NONE)
119 :     | SCHEME eq =>
120 :     tvHead(eq,annotate(metaTyvarName tyvar,"S",NONE))
121 :     | LBOUND _ => "<LBOUND tyvar>"
122 :     (*
123 :     fun ppkind ppstrm kind =
124 :     pps ppstrm
125 :     (case kind
126 :     of PRIMITIVE _ => "PRIMITIVE" | FORMAL => "FORMAL"
127 :     | FLEXTYC _ => "FLEXTYC" | ABSTRACT _ => "ABSTYC"
128 :     | DATATYPE _ => "DATATYPE" | TEMP => "TEMP")
129 :     *)
130 :     fun ppkind ppstrm kind =
131 :     pps ppstrm
132 :     (case kind
133 :     of PRIMITIVE _ => "P" | FORMAL => "F"
134 :     | FLEXTYC _ => "X" | ABSTRACT _ => "A"
135 :     | DATATYPE _ => "D" | TEMP => "T")
136 :    
137 :     fun effectivePath(path,tyc,env) : string =
138 :     let fun tycPath (GENtyc{path,...}) = SOME path
139 :     | tycPath (DEFtyc{path,...}) = SOME path
140 :     | tycPath (PATHtyc{path, ...}) = SOME path
141 :     | tycPath _ = NONE
142 :     fun find(path,tyc) =
143 :     (findPath(path,
144 :     (fn tyc' => TU.equalTycon(tyc',tyc)),
145 :     (fn x => Lookup.lookTyc(env,x,(fn _ => raise Env.Unbound)))))
146 :     fun search(path,tyc) =
147 :     let val (suffix,found) = find(path,tyc)
148 :     in if found then (suffix,true)
149 :     else if not (!unalias) then (suffix, false)
150 :     else case TU.unWrapDef1 tyc
151 :     of SOME tyc' =>
152 :     (case tycPath tyc'
153 :     of SOME path' =>
154 :     let val x as (suffix',found') = search(path',tyc')
155 :     in if found' then x
156 :     else (suffix,false)
157 :     end
158 :     | NONE => (suffix,false))
159 :     | NONE => (suffix,false)
160 :     end
161 :     val (suffix,found) = search(path,tyc)
162 :     val name = SP.toString(SP.SPATH suffix)
163 :     in if found
164 :     then name
165 :     else "?."^name
166 :     end
167 :    
168 :     val GENtyc{stamp=arrowStamp,...} = BT.arrowTycon
169 :    
170 :     fun strength(ty) =
171 :     case ty
172 :     of VARty(ref(INSTANTIATED ty')) => strength(ty')
173 :     | CONty(tycon, args) =>
174 :     (case tycon
175 :     of GENtyc{kind=PRIMITIVE _, stamp,...} =>
176 :     if Stamps.eq(stamp,arrowStamp) then 0 else 2
177 :     | RECORDtyc (_::_) => (* excepting type unit *)
178 :     if Tuples.isTUPLEtyc(tycon) then 1 else 2
179 :     | _ => 2)
180 :     | _ => 2
181 :    
182 :     fun ppEqProp ppstrm p =
183 :     let val a = case p
184 :     of NO => "NO"
185 :     | YES => "YES"
186 :     | IND => "IND"
187 :     | OBJ => "OBJ"
188 :     | DATA => "DATA"
189 :     | ABS => "ABS"
190 :     | UNDEF => "UNDEF"
191 :     in pps ppstrm a
192 :     end
193 :    
194 :     fun ppInvPath ppstream (InvPath.IPATH path: InvPath.path) =
195 :     PP.add_string ppstream (SymPath.toString (SymPath.SPATH(rev path)))
196 :    
197 :     fun ppTycon1 env ppstrm membersOp =
198 :     let val {begin_block,end_block,pps,add_break,...} = en_pp ppstrm
199 :     fun ppTyc (tyc as GENtyc{path,stamp,eq,kind,...}) =
200 :     if !internals
201 :     then (begin_block PP.INCONSISTENT 1;
202 :     ppInvPath ppstrm path;
203 :     pps "[";
204 :     pps "G"; ppkind ppstrm kind; pps ";";
205 :     pps (Stamps.stampToShortString stamp);
206 :     pps ";";
207 :     ppEqProp ppstrm (!eq);
208 :     pps "]";
209 :     end_block())
210 :     else pps(effectivePath(path,tyc,env))
211 :     | ppTyc(tyc as DEFtyc{path,tyfun=TYFUN{body,...},...}) =
212 :     if !internals
213 :     then (begin_block PP.INCONSISTENT 1;
214 :     ppInvPath ppstrm path;
215 :     pps "["; pps "D;";
216 :     ppType env ppstrm body;
217 :     pps "]";
218 :     end_block())
219 :     else pps(effectivePath(path,tyc,env))
220 :     | ppTyc(RECORDtyc labels) =
221 :     ppClosedSequence ppstrm
222 :     {front=C PP.add_string "{",
223 :     sep=fn ppstrm => (PP.add_string ppstrm ",";
224 :     PP.add_break ppstrm (0,0)),
225 :     back=C PP.add_string "}",
226 :     style=PP.INCONSISTENT,
227 :     pr=ppSym} labels
228 :    
229 :     | ppTyc (RECtyc n) =
230 :     (case membersOp
231 :     of SOME (members,_) =>
232 :     let val {tycname,dcons,...} = Vector.sub(members,n)
233 :     in ppSym ppstrm tycname
234 :     end
235 :     | NONE => pps (String.concat ["<RECtyc ",Int.toString n,">"]))
236 :    
237 :     | ppTyc (FREEtyc n) =
238 :     (case membersOp
239 :     of SOME (_, freetycs) =>
240 :     let val tyc = (List.nth(freetycs, n) handle _ =>
241 :     bug "unexpected freetycs in ppTyc")
242 :     in ppTyc tyc
243 :     end
244 :     | NONE =>
245 :     pps (String.concat ["<FREEtyc ",Int.toString n,">"]))
246 :    
247 :     | ppTyc (tyc as PATHtyc{arity,entPath,path}) =
248 :     if !internals
249 :     then (begin_block PP.INCONSISTENT 1;
250 :     ppInvPath ppstrm path; pps "[P;";
251 :     pps (EntPath.entPathToString entPath);
252 :     pps "]";
253 :     end_block())
254 :     else ppInvPath ppstrm path
255 :    
256 :     | ppTyc ERRORtyc = pps "[E]"
257 :     in ppTyc
258 :     end
259 :    
260 :    
261 :     and ppType1 env ppstrm (ty: ty, sign: T.polysign,
262 :     membersOp: (T.dtmember vector * T.tycon list) option) : unit =
263 :     let val {begin_block,end_block,pps,add_break,add_newline} = en_pp ppstrm
264 :     fun prty ty =
265 :     case ty
266 :     of VARty(ref(INSTANTIATED ty')) => prty(ty')
267 :     | VARty(tv) => ppTyvar tv
268 :     | IBOUND n =>
269 :     let val eq = List.nth(sign,n)
270 :     handle Subscript => false
271 :     in pps (tvHead(eq,(boundTyvarName n)))
272 :     end
273 :     | CONty(tycon, args) =>
274 :     (case tycon
275 :     of GENtyc{kind=PRIMITIVE _, stamp,...} =>
276 :     if Stamps.eq(stamp,arrowStamp)
277 :     then case args
278 :     of [domain,range] =>
279 :     (begin_block PP.CONSISTENT 0;
280 :     if strength domain = 0
281 :     then (begin_block PP.CONSISTENT 1;
282 :     pps "(";
283 :     prty domain;
284 :     pps ")";
285 :     end_block())
286 :     else prty domain;
287 :     add_break(1,0);
288 :     pps "-> ";
289 :     prty range;
290 :     end_block())
291 :     | _ => bug "CONty:arity"
292 :     else (begin_block PP.INCONSISTENT 2;
293 :     ppTypeArgs args;
294 :     add_break(0,0);
295 :     ppTycon1 env ppstrm membersOp tycon;
296 :     end_block())
297 :     | RECORDtyc labels =>
298 :     if Tuples.isTUPLEtyc(tycon)
299 :     then ppTUPLEty args
300 :     else ppRECORDty(labels, args)
301 :     | _ =>
302 :     (begin_block PP.INCONSISTENT 2;
303 :     ppTypeArgs args;
304 :     add_break(0,0);
305 :     ppTycon1 env ppstrm membersOp tycon;
306 :     end_block()))
307 :     | POLYty{sign,tyfun=TYFUN{arity,body}} =>
308 :     ppType1 env ppstrm (body,sign, membersOp)
309 :     | WILDCARDty => pps "_"
310 :     | UNDEFty => pps "undef"
311 :    
312 :     and ppTypeArgs [] = ()
313 :     | ppTypeArgs [ty] =
314 :     (if strength ty <= 1
315 :     then (begin_block PP.INCONSISTENT 1;
316 :     pps "(";
317 :     prty ty;
318 :     pps ")";
319 :     end_block())
320 :     else prty ty;
321 :     add_break(1,0))
322 :     | ppTypeArgs tys =
323 :     ppClosedSequence ppstrm
324 :     {front=C PP.add_string "(",
325 :     sep=fn ppstrm => (PP.add_string ppstrm ",";
326 :     PP.add_break ppstrm (0,0)),
327 :     back=C PP.add_string ") ",
328 :     style=PP.INCONSISTENT,
329 :     pr=fn _ => fn ty => prty ty}
330 :     tys
331 :    
332 :     and ppTUPLEty [] = pps "unit"
333 :     | ppTUPLEty tys =
334 :     ppSequence ppstrm
335 :     {sep = fn ppstrm => (PP.add_break ppstrm (1,0);
336 :     PP.add_string ppstrm "* "),
337 :     style = PP.INCONSISTENT,
338 :     pr = (fn _ => fn ty =>
339 :     if strength ty <= 1
340 :     then (begin_block PP.INCONSISTENT 1;
341 :     pps "(";
342 :     prty ty;
343 :     pps ")";
344 :     end_block())
345 :     else prty ty)}
346 :     tys
347 :    
348 :     and ppField(lab,ty) = (begin_block PP.CONSISTENT 0;
349 :     ppSym ppstrm lab;
350 :     pps ":";
351 :     prty ty;
352 :     end_block())
353 :    
354 :     and ppRECORDty([],[]) = pps "unit"
355 :     | ppRECORDty(lab::labels, arg::args) =
356 :     (begin_block PP.INCONSISTENT 1;
357 :     pps "{";
358 :     ppField(lab,arg);
359 :     ListPair.app
360 :     (fn field => (pps ","; add_break(1,0);ppField field))
361 :     (labels,args);
362 :     pps "}";
363 :     end_block())
364 :     | ppRECORDty _ = bug "PPType.ppRECORDty"
365 :    
366 :     and ppTyvar (tv as (ref info) :tyvar) :unit =
367 :     let val printname = tyvarPrintname tv
368 :     in case info
369 :     of OPEN{depth,eq,kind} =>
370 :     (case kind
371 :     of FLEX fields =>
372 :     (case fields
373 :     of [] => (pps "{"; pps printname; pps "}")
374 :     | field::fields =>
375 :     (begin_block PP.INCONSISTENT 1;
376 :     pps "{";
377 :     ppField field;
378 :     app (fn x => (pps ",";
379 :     add_break(1,0);
380 :     ppField x))
381 :     fields;
382 :     pps ";";
383 :     add_break(1,0);
384 :     pps printname;
385 :     pps "}";
386 :     end_block()))
387 :     | _ => pps printname)
388 :     | _ => pps printname
389 :     end
390 :     in prty ty
391 :     end (* ppType1 *)
392 :    
393 :     and ppType (env:StaticEnv.staticEnv) ppstrm (ty:ty) : unit =
394 :     (PP.begin_block ppstrm PP.INCONSISTENT 1;
395 :     ppType1 env ppstrm (ty,[],NONE);
396 :     PP.end_block ppstrm)
397 :    
398 :     fun ppDconDomain members (env:StaticEnv.staticEnv)
399 :     ppstrm (ty:ty) : unit =
400 :     (PP.begin_block ppstrm PP.INCONSISTENT 1;
401 :     ppType1 env ppstrm (ty,[],SOME members);
402 :     PP.end_block ppstrm)
403 :    
404 :     fun ppTycon env ppstrm tyc = ppTycon1 env ppstrm NONE tyc
405 :    
406 :     fun ppTyfun env ppstrm (TYFUN{arity,body}) =
407 :     let val {begin_block, end_block, pps, add_break,...} = en_pp ppstrm
408 :     in begin_block PP.INCONSISTENT 2;
409 :     pps "TYFUN({arity=";
410 :     ppi ppstrm arity; add_comma ppstrm;
411 :     add_break(0,0);
412 :     pps "body=";
413 :     ppType env ppstrm body;
414 :     pps "})";
415 :     end_block()
416 :     end
417 :    
418 :     fun ppFormals ppstrm =
419 :     let fun ppF 0 = ()
420 :     | ppF 1 = pps ppstrm " 'a"
421 :     | ppF n = (pps ppstrm " ";
422 :     ppTuple ppstrm (fn ppstrm => fn s => pps ppstrm ("'"^s))
423 :     (typeFormals n))
424 :     in ppF
425 :     end
426 :    
427 :     fun ppDataconTypes env ppstrm (GENtyc{kind=DATATYPE{index,freetycs,family={members,...},...},...}) =
428 :     let val {begin_block, end_block, pps, add_break,...} = en_pp ppstrm
429 :     val {dcons,...} = Vector.sub(members,index)
430 :     in begin_block PP.CONSISTENT 0;
431 :     app (fn {name,domain,...} =>
432 :     (pps (Symbol.name name); pps ":";
433 :     case domain
434 :     of SOME ty => ppType1 env ppstrm (ty,[],SOME (members,freetycs))
435 :     | NONE => pps "CONST";
436 :     add_break(1,0)))
437 :     dcons;
438 :     end_block()
439 :     end
440 :     | ppDataconTypes env ppstrm _ = bug "ppDataconTypes"
441 :    
442 :     end (* toplevel local *)
443 :     end (* structure PPType *)
444 :    
445 :     (*
446 :     * $Log: pptype.sml,v $
447 :     * Revision 1.8 1997/10/01 18:15:26 dbm
448 :     * Added debugging and unalias flags to signature.
449 :     * unalias flag controls whether to unalias a DEFtyc if its path is
450 :     * not visible.
451 :     *
452 :     * Revision 1.7 1997/09/23 04:03:17 dbm
453 :     * More accurate type path printing (suppression of ?).
454 :     *
455 :     * Revision 1.6 1997/07/17 20:41:57 dbm
456 :     * Added ppDataconTypes for printing constructor domain types of a datatype.
457 :     *
458 :     * Revision 1.5 1997/05/22 03:31:16 dbm
459 :     * Changed internals printing of FLEXTYC variant of GENtyc to use letter
460 :     * "X" instead of "F", which was already assigned to FORMAL.
461 :     *
462 :     * Revision 1.4 1997/03/27 23:08:00 dbm
463 :     * Fixed bug 1176 by completing cases in tyvarPrintname.
464 :     *
465 :     * Revision 1.3 1997/03/22 18:20:15 dbm
466 :     * Revised printing of type variables; required for revised representation
467 :     * of type variables associated with improved literal overloading and fix
468 :     * for bug 905/952.
469 :     *
470 :     * Revision 1.2 1997/03/17 18:59:42 dbm
471 :     * Changes in datatype representation to support datatype replication.
472 :     *
473 :     * Revision 1.1.1.1 1997/01/14 01:38:44 george
474 :     * Version 109.24
475 :     *
476 :     *)

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