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

Annotation of /sml/branches/temi-branch/compiler/Elaborator/print/pptype.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3020 - (view) (download)

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

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