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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1336 - (view) (download)

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

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