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

Annotation of /sml/trunk/compiler/MiscUtil/print/ppobj.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2492 - (view) (download)

1 : monnier 247 (* ppobj.sml
2 :     *
3 :     * COPYRIGHT (c) 1989 by AT&T Bell Laboratories.
4 :     *)
5 :    
6 :    
7 :     signature PPOBJ =
8 :     sig
9 :     type object
10 :     val ppObj : StaticEnv.staticEnv
11 : dbm 2492 -> PrettyPrintNew.stream
12 : monnier 247 -> object * Types.ty * int
13 :     -> unit
14 :     val debugging : bool ref
15 :     end
16 :    
17 :    
18 :     structure PPObj : PPOBJ =
19 :     struct
20 :    
21 : dbm 2492 structure PP = PrettyPrintNew
22 :     structure PU = PPUtilNew
23 : monnier 247 structure V = Vector
24 :     structure A = Access
25 :     structure T = Types
26 :     structure TU = TypesUtil
27 :     structure BT = BasicTypes
28 :     structure F = Fixity
29 :     structure Obj = Unsafe.Object
30 :    
31 : dbm 2492 open PrettyPrintNew PPUtilNew
32 : monnier 247
33 :     (* debugging *)
34 :     val say = Control.Print.say
35 :     val debugging = ref false
36 :     fun debugmsg (msg: string) =
37 :     if !debugging then (say msg; say "\n") else ()
38 :    
39 :     fun bug msg = ErrorMsg.impossible("PPObj: "^msg)
40 :    
41 :    
42 :     type object = Obj.object
43 :    
44 :     fun gettag obj = Obj.toInt (Obj.nth(obj, 0))
45 :    
46 :     exception Switch
47 :    
48 :     fun switch(obj, dcons) = let
49 :     fun chk (f, tag : int) =
50 :     (f obj = tag) handle Obj.Representation => false
51 :     fun try ((d as {name,rep,domain})::r) = (case rep
52 :     of A.TAGGED i =>
53 :     if chk(gettag, i) then d else try r
54 :     | A.CONSTANT i =>
55 :     if chk(Obj.toInt, i) then d else try r
56 :     | A.TRANSPARENT => d
57 :     | A.UNTAGGED => if Obj.boxed obj then d else try r
58 :     | A.REF => d
59 :     | A.LISTCONS => if (Obj.boxed obj) then d else try r
60 :     | A.LISTNIL => if chk(Obj.toInt, 0) then d else try r
61 :     | A.SUSP _ => d (* LAZY *)
62 :     | _ => bug "switch: funny datacon"
63 :     (* end case *))
64 :     | try [] = bug "switch: none of the datacons matched"
65 :     in
66 :     try dcons
67 :     end
68 :    
69 :     (** a temporary hack for printing UNTAGGEDREC objects *)
70 :     fun isRecTy (T.VARty(ref (T.INSTANTIATED t))) = isRecTy t
71 :     | isRecTy (T.CONty(T.RECORDtyc _, _::_)) = true
72 :     | isRecTy _ = false
73 :    
74 :     fun isUbxTy (T.VARty(ref (T.INSTANTIATED t))) = isUbxTy t
75 :     | isUbxTy (T.CONty(tc as T.GENtyc _, [])) =
76 :     (TU.eqTycon(tc, BT.int32Tycon)) orelse
77 :     (TU.eqTycon(tc, BT.word32Tycon))
78 :     | isUbxTy _ = false
79 :    
80 :     fun decon(obj, {rep,name,domain}) = (case rep
81 :     of A.UNTAGGED =>
82 :     (case domain
83 :     of SOME t =>
84 :     if (isRecTy t) orelse (isUbxTy t)
85 : mblume 1760 then obj else (Obj.nth(obj, 0) handle e => raise e)
86 : monnier 247 | _ => bug "decon -- unexpected conrep-domain")
87 :    
88 : mblume 1760 | A.TAGGED _ => (Obj.nth(obj,1) handle e => raise e)
89 : monnier 247 (* | A.TAGGEDREC _ =>
90 :     let (* skip first element, i.e. discard tag *)
91 :     val a = tuple obj
92 :     fun f i =
93 :     if i < V.length a
94 :     then V.sub(a,i) :: f(i+1)
95 :     else []
96 :     in U.cast (V.fromList (f(1)))
97 :     end
98 :     *)
99 :     | A.CONSTANT _ => Obj.toObject ()
100 :     | A.TRANSPARENT => obj
101 :     | A.REF => !(Obj.toRef obj)
102 : mblume 1760 | A.EXN _ => (Obj.nth(obj,0) handle e => raise e)
103 : monnier 247 | A.LISTCONS => obj
104 :     | A.LISTNIL => bug "decon - constant datacon in decon"
105 :     | A.SUSP _ => obj
106 :     (* end case *))
107 :    
108 :     val noparen = F.INfix(0,0)
109 :    
110 : blume 587 local
111 :     fun dconsOf (T.GENtyc
112 :     { kind = T.DATATYPE
113 :     { family =
114 :     { members = #[{dcons, ... }], ... },
115 :     ... },
116 :     ... }) = dcons
117 :     | dconsOf _ = bug "(u)listDcons"
118 :     in
119 :     val listDcons = dconsOf BT.listTycon
120 :     val ulistDcons = dconsOf BT.ulistTycon
121 :     end
122 : monnier 247
123 :     local
124 :     (* counter to generate identifier *)
125 :     val cpt = ref 0
126 :    
127 :     (* test membership in an association list and gives back
128 :     * the second element *)
129 : mblume 1335 fun mem (a: unit ref) =
130 : monnier 247 let fun m [] = NONE | m ((x,r)::l) = if a = x then SOME r else m l
131 :     in m
132 :     end
133 :    
134 :     (* verifies if an object has been seen and if yes, gives back its
135 :     * identification number, creating a new one if necessary *)
136 :     fun isSeen obj l =
137 :     let val obj' = Unsafe.cast obj : unit ref
138 :     in case mem obj' l
139 :     of NONE => (false,0)
140 :     | SOME (r as ref NONE) => let
141 :     val id = !cpt
142 :     in cpt := id+1; r := SOME id; (true,id) end
143 :     | SOME (ref (SOME id)) => (true,id)
144 :     end
145 :    
146 :     in
147 :    
148 :     (* reset the identifier counter *)
149 :     fun initCpt () = cpt := 0
150 :    
151 :     (* print with sharing if necessary. The "printer" already knows the
152 :     ppstream. *)
153 :     fun printWithSharing ppstrm (obj,accu,printer) =
154 :     if !Control.Print.printLoop then
155 :     let val (seen,nb) = isSeen obj accu
156 :     in if seen then
157 : macqueen 1344 (PP.string ppstrm "%";
158 :     PP.string ppstrm (Int.toString nb))
159 : monnier 247 else let val modif = ref NONE
160 :     val nlAccu = (Unsafe.cast obj : unit ref,modif) :: accu
161 :     in printer (obj,nlAccu);
162 :     case !modif
163 :     of NONE => ()
164 : macqueen 1344 | SOME i => (PP.string ppstrm " as %";
165 :     PP.string ppstrm (Int.toString i))
166 : monnier 247 end
167 :     end
168 :     else printer (obj,accu)
169 :    
170 :     end (* local *)
171 :    
172 :     fun interpArgs(tys,NONE) = tys
173 :     | interpArgs(tys,SOME (members,freetycs)) =
174 :     let fun subst(T.CONty(T.RECtyc n,args)) =
175 :     let val tyc' = (List.nth(members,n)
176 :     handle Subscript => bug "interpArgs 1")
177 :     in T.CONty(tyc', map subst args)
178 :     end
179 :     | subst(T.CONty(T.FREEtyc n,args)) =
180 :     let val tyc' = (List.nth(freetycs,n)
181 :     handle Subscript => bug "interpArgs 2")
182 :     in T.CONty(tyc', map subst args)
183 :     end
184 :     | subst(T.CONty(tyc,args)) = T.CONty(tyc, map subst args)
185 :     | subst(T.VARty(ref(T.INSTANTIATED ty))) = subst ty
186 :     | subst ty = ty
187 :     in map subst tys
188 :     end
189 :    
190 :     fun transMembers(stamps: Stamps.stamp vector,
191 :     freetycs: T.tycon list, root,
192 :     family as {members,...} : T.dtypeFamily) =
193 :     let fun dtmemberToTycon(n, {tycname,arity,dcons,eq,sign,lazyp}, l) =
194 :     T.GENtyc{stamp=Vector.sub(stamps,n),arity=arity,eq=ref(T.YES),
195 :     path=InvPath.IPATH[tycname],
196 :     kind=T.DATATYPE{index=n,
197 : blume 587 stamps=stamps, freetycs=freetycs,
198 :     root=root, family=family},
199 :     stub = NONE } :: l
200 : mblume 1350 in (Vector.foldri dtmemberToTycon nil members,
201 : monnier 247 freetycs)
202 :     end
203 :    
204 :    
205 :     (* main function: ppObj: staticEnv -> ppstream -> (object * ty * int) -> unit *)
206 :    
207 :     fun ppObj env ppstrm =
208 :     let fun ppValue (obj: object, ty: T.ty, depth: int) : unit =
209 :     ppVal' (obj, ty, NONE, depth, noparen, noparen, [])
210 :    
211 :     and ppValShare (obj:object, ty:T.ty, membersOp: (T.tycon list * T.tycon list) option,
212 :     depth:int, accu) =
213 :     ppVal' (obj, ty, membersOp, depth, noparen, noparen, accu)
214 :    
215 : macqueen 1344 and ppVal' (_,_,_,0,_,_,_) = PP.string ppstrm "#"
216 : monnier 247 | ppVal' (obj: object, ty: T.ty, membersOp: (T.tycon list * T.tycon list) option,
217 :     depth: int, l: F.fixity, r: F.fixity, accu) : unit =
218 :     ((case ty
219 :     of T.VARty(ref(T.INSTANTIATED t)) =>
220 :     ppVal'(obj,t,membersOp,depth,r,l,accu)
221 :     | T.POLYty{tyfun=T.TYFUN{body,arity},...} =>
222 :     if arity=0
223 :     then ppVal'(obj, body,membersOp,depth,l,r,accu)
224 :     else (let
225 :     val args = Obj.mkTuple (List.tabulate(arity, fn i => Obj.toObject 0))
226 :     val tobj : object -> object = Unsafe.cast obj
227 :     val res = tobj args
228 :     in
229 :     ppVal'(res, body, membersOp, depth, l, r, accu)
230 :     end)
231 :    
232 :    
233 : blume 587 | T.CONty(tyc as T.GENtyc { kind, stamp, eq, ... }, argtys) =>
234 :     (case (kind, !eq)
235 :     of (T.PRIMITIVE _, _) =>
236 : macqueen 1344 let fun ppWord s = PP.string ppstrm ("0wx"^s)
237 : blume 587 in
238 :     if TU.eqTycon(tyc,BT.intTycon) then
239 : macqueen 1344 PP.string ppstrm (Int.toString(Obj.toInt obj))
240 : blume 587 else if TU.eqTycon(tyc,BT.int32Tycon) then
241 : macqueen 1344 PP.string ppstrm (Int32.toString(Obj.toInt32 obj))
242 : mblume 1347 else if TU.eqTycon(tyc,BT.intinfTycon) then
243 : dbm 2492 PU.pp_intinf ppstrm (Unsafe.cast obj)
244 : blume 587 else if TU.eqTycon(tyc,BT.wordTycon) then
245 :     ppWord (Word.toString(Obj.toWord obj))
246 :     else if TU.eqTycon(tyc,BT.word8Tycon) then
247 :     ppWord (Word8.toString(Obj.toWord8 obj))
248 :     else if TU.eqTycon(tyc,BT.word32Tycon) then
249 :     ppWord (Word32.toString(Obj.toWord32 obj))
250 :     else if TU.eqTycon(tyc,BT.realTycon) then
251 : macqueen 1344 PP.string ppstrm (Real.toString(Obj.toReal obj))
252 : blume 587 else if TU.eqTycon(tyc,BT.stringTycon) then
253 : dbm 2492 PU.pp_mlstr ppstrm (Obj.toString obj)
254 : blume 587 else if TU.eqTycon(tyc,BT.charTycon) then
255 : macqueen 1344 (PP.string ppstrm "#";
256 : dbm 2492 PU.pp_mlstr ppstrm
257 : blume 587 (String.str(Char.chr(Obj.toInt obj))))
258 :     else if TU.eqTycon(tyc,BT.arrowTycon) then
259 : macqueen 1344 PP.string ppstrm "fn"
260 : blume 587 else if TU.eqTycon(tyc,BT.exnTycon) then
261 :     let val name = General.exnName(Obj.toExn obj)
262 :     in
263 : macqueen 1344 PP.string ppstrm name;
264 :     PP.string ppstrm "(-)"
265 : blume 587 end
266 :     else if TU.eqTycon(tyc,BT.contTycon) then
267 : macqueen 1344 PP.string ppstrm "cont"
268 : blume 587 else if TU.eqTycon(tyc,BT.vectorTycon) then
269 :     ppVector(Obj.toVector obj, hd argtys,
270 :     membersOp, depth,
271 :     !Control.Print.printLength, accu)
272 :     handle Obj.Representation =>
273 : macqueen 1344 PP.string ppstrm "prim?"
274 : blume 587 else if TU.eqTycon(tyc,BT.arrayTycon) then
275 :     (printWithSharing ppstrm
276 :     (obj,accu,
277 :     fn (obj,accu) =>
278 : dbm 633 (case Obj.rep obj
279 :     of Obj.PolyArray =>
280 :     ppArray(Obj.toArray obj, hd argtys,
281 :     membersOp, depth,
282 :     !Control.Print.printLength, accu)
283 :     | Obj.RealArray =>
284 :     ppRealArray(Obj.toRealArray obj,
285 : mblume 1334 !Control.Print.printLength)
286 :     | _ => bug "array (neither Real nor Poly)"
287 :     ))
288 : blume 587 handle Obj.Representation =>
289 : macqueen 1344 PP.string ppstrm "prim?")
290 :     else PP.string ppstrm "prim?"
291 : blume 587 end
292 :     | (T.DATATYPE _,T.ABS) =>
293 :     (PPTable.pp_object ppstrm stamp obj
294 : macqueen 1344 handle PP_NOT_INSTALLED => PP.string ppstrm "-" )
295 : blume 587 | (T.DATATYPE{index,stamps,
296 :     family as {members,...}, freetycs, root}, _) =>
297 :     if TU.eqTycon(tyc,BT.ulistTycon) then
298 :     ppUrList(obj,hd argtys,membersOp,depth,
299 :     !Control.Print.printLength,accu)
300 :     else if TU.eqTycon(tyc,BT.suspTycon) then
301 : macqueen 1344 PP.string ppstrm "$$" (* LAZY *)
302 : blume 587 else if TU.eqTycon(tyc,BT.listTycon) then
303 :     ppList(obj,hd argtys,membersOp,depth,
304 :     !Control.Print.printLength,accu)
305 :     else if TU.eqTycon(tyc,BT.refTycon) then
306 :     (printWithSharing ppstrm
307 :     (obj,accu,
308 :     let val argtys' = interpArgs(argtys,membersOp)
309 :     in fn (obj,accu) =>
310 :     ppDcon(obj,
311 :     (Vector.sub(stamps,index),
312 :     Vector.sub(members,index)),
313 :     SOME([BT.refTycon],[]),argtys',
314 :     depth,l,r,accu)
315 :     end))
316 :     else let val argtys' = interpArgs(argtys,membersOp)
317 :     in
318 :     ppDcon(obj,(Vector.sub(stamps,index),
319 :     Vector.sub(members,index)),
320 :     SOME(transMembers (stamps, freetycs,
321 :     root, family)),
322 :     argtys',depth,l,r,accu)
323 :     end
324 : mblume 1682 | (T.ABSTRACT _, _) =>
325 :     (if TU.eqTycon (tyc, BT.int64Tycon) then
326 : mblume 1687 case Obj.toTuple obj of
327 :     [hi, lo] =>
328 :     let val i =
329 :     InlineT.Int64.intern (Obj.toWord32 hi,
330 :     Obj.toWord32 lo)
331 :     in PP.string ppstrm (Int64.toString i)
332 :     end
333 :     | _ => PP.string ppstrm "<int64?>"
334 : mblume 1682 else if TU.eqTycon (tyc, BT.word64Tycon) then
335 : mblume 1684 case Obj.toTuple obj of
336 :     [hi, lo] =>
337 :     let val w =
338 :     InlineT.Word64.intern (Obj.toWord32 hi,
339 :     Obj.toWord32 lo)
340 : mblume 1687 in PP.string ppstrm ("0wx" ^ Word64.toString w)
341 : mblume 1684 end
342 :     | _ => PP.string ppstrm "<word64?>"
343 : mblume 1682 else PP.string ppstrm "-")
344 : macqueen 1344 | _ => PP.string ppstrm "-")
345 :     | T.CONty(tyc as T.RECORDtyc [], _) => PP.string ppstrm "()"
346 : monnier 247 | T.CONty(tyc as T.RECORDtyc labels, argtys) =>
347 :     if Tuples.isTUPLEtyc tyc
348 :     then ppTuple(Obj.toTuple obj, argtys, membersOp, depth, accu)
349 :     else ppRecord(Obj.toTuple obj, labels, argtys, membersOp, depth, accu)
350 :     | T.CONty(tyc as T.DEFtyc _, _) =>
351 :     ppVal'(obj, TU.reduceType ty, membersOp, depth, l, r,accu)
352 :     | T.CONty(tyc as T.RECtyc i,argtys) =>
353 :     (case membersOp
354 :     of SOME (memberTycs,_) =>
355 :     let val tyc' =
356 :     List.nth(memberTycs,i)
357 :     handle Subscript =>
358 : macqueen 1344 (flushStream ppstrm;
359 : monnier 247 print "#ppVal': ";
360 :     print (Int.toString i);
361 :     print " "; print(Int.toString(length memberTycs));
362 :     print "\n";
363 :     bug "ppVal': bad index for RECtyc")
364 :     in case tyc'
365 : blume 587 of T.GENtyc { kind =
366 :     T.DATATYPE{index,stamps,
367 :     family={members,...},...},
368 :     ... } =>
369 :     ppDcon(obj,(Vector.sub(stamps,index),
370 :     Vector.sub(members,index)),
371 :     membersOp, argtys,
372 :     depth,l,r,accu)
373 : monnier 247 | _ => bug "ppVal': bad tycon in members"
374 :     end
375 :     | NONE => bug "ppVal': RECtyc with no members")
376 :    
377 :     | T.CONty(tyc as T.FREEtyc i,argtys) =>
378 :     (case membersOp
379 :     of SOME (_, freeTycs) =>
380 :     let val tyc' =
381 :     List.nth(freeTycs,i)
382 :     handle Subscript =>
383 : macqueen 1344 (flushStream ppstrm;
384 : monnier 247 print "#ppVal': ";
385 :     print (Int.toString i);
386 :     print " ";
387 :     print(Int.toString(length freeTycs));
388 :     print "\n";
389 :     bug "ppVal': bad index for FREEtyc")
390 :     in ppVal'(obj, T.CONty(tyc', argtys), membersOp,
391 :     depth, l, r, accu)
392 :     end
393 :     | NONE => bug "ppVal': RECtyc with no members")
394 :    
395 : macqueen 1344 | _ => PP.string ppstrm "-")
396 : monnier 247 handle e => raise e)
397 :    
398 : macqueen 1344 and ppDcon(_,_,_,_,0,_,_,_) = PP.string ppstrm "#"
399 : monnier 247 | ppDcon(obj:object, (stamp, {tycname,dcons,...}), membersOp : (T.tycon list * T.tycon list) option,
400 :     argtys, depth:int, l:F.fixity, r:F.fixity, accu) =
401 :     PPTable.pp_object ppstrm stamp obj
402 :     (* attempt to find and apply user-defined pp on obj *)
403 :     handle PP_NOT_INSTALLED =>
404 : macqueen 1344 if length dcons = 0 then PP.string ppstrm "-"
405 : monnier 247 else
406 :     let val dcon as {name,domain,...} = switch(obj,dcons)
407 :     val dname = Symbol.name name
408 :     in case domain
409 : macqueen 1344 of NONE => PP.string ppstrm dname
410 : monnier 247 | SOME dom =>
411 :     let val fixity =
412 :     Lookup.lookFix(env,Symbol.fixSymbol dname)
413 :     (* (??) may be inaccurate *)
414 :     val dom = TU.applyTyfun(T.TYFUN{arity=length argtys,body=dom},
415 :     argtys)
416 :     val dom = TU.headReduceType dom (* unnecessary *)
417 :     fun prdcon() =
418 :     case (fixity,dom)
419 :     of (F.INfix _,T.CONty(domTyc as T.RECORDtyc _, [tyL,tyR])) =>
420 : blume 587 let val (a, b) =
421 :     case Obj.toTuple(decon(obj,dcon)) of
422 :     [a, b] => (a, b)
423 :     | _ => bug "ppDcon [a, b]"
424 : monnier 247 in if Tuples.isTUPLEtyc domTyc
425 : macqueen 1344 then (openHOVBox ppstrm (PP.Rel 0);
426 : monnier 247 ppVal'(a,tyL,
427 :     membersOp,
428 :     depth-1,F.NONfix,fixity,accu);
429 : macqueen 1344 break ppstrm {nsp=1,offset=0};
430 :     PP.string ppstrm dname;
431 :     break ppstrm {nsp=1,offset=0};
432 : monnier 247 ppVal'(b,tyR,
433 :     membersOp,
434 :     depth-1,fixity, F.NONfix,accu);
435 : macqueen 1344 closeBox ppstrm)
436 :     else (openHOVBox ppstrm (PP.Rel 2);
437 :     PP.string ppstrm dname;
438 :     break ppstrm {nsp=1,offset=0};
439 : monnier 247 ppVal'(decon(obj,dcon),dom,
440 :     membersOp, depth-1,
441 :     F.NONfix,F.NONfix,accu);
442 : macqueen 1344 closeBox ppstrm)
443 : monnier 247 end
444 : macqueen 1344 | _ => (openHOVBox ppstrm (PP.Rel 2);
445 :     PP.string ppstrm dname; break ppstrm {nsp=1,offset=0};
446 : monnier 247 ppVal'(decon(obj,dcon),dom,membersOp,depth-1,
447 :     F.NONfix,F.NONfix,accu);
448 : macqueen 1344 closeBox ppstrm)
449 : monnier 247 fun prpardcon() =
450 : macqueen 1344 (openHOVBox ppstrm (PP.Rel 0);
451 :     PP.string ppstrm "("; prdcon(); PP.string ppstrm ")";
452 :     closeBox ppstrm)
453 : monnier 247 in case(l,r,fixity)
454 :     of (F.NONfix,F.NONfix,_) => prpardcon()
455 :     | (F.INfix _,F.INfix _,_) => prdcon()
456 :     (* special case: only on first iteration, for no parens *)
457 :     | (_,_,F.NONfix) => prdcon()
458 :     | (F.INfix(_,p1),_,F.INfix(p2,_)) =>
459 :     if p1 >= p2 then prpardcon()
460 :     else prdcon()
461 :     | (_,F.INfix(p1,_),F.INfix(_,p2)) =>
462 :     if p1 > p2 then prpardcon()
463 :     else prdcon()
464 :     end
465 :     end
466 :    
467 :     and ppList(obj:object, ty:T.ty, membersOp, depth:int, length: int,accu) =
468 :     let fun list_case p =
469 :     case switch(p, listDcons)
470 :     of {domain=NONE,...} => NONE
471 : blume 587 | dcon => (case Obj.toTuple(decon(p, dcon)) of
472 :     [a, b] => SOME(a, b)
473 :     | _ => bug "ppList [a, b]")
474 : monnier 247
475 :     fun ppTail(p, len) =
476 :     case list_case p
477 :     of NONE => ()
478 :     | SOME(hd,tl) =>
479 : macqueen 1344 if len <= 0 then (PP.string ppstrm "...")
480 : monnier 247 else (case list_case tl
481 :     of NONE =>
482 :     ppValShare (hd, ty, membersOp, depth-1,accu)
483 :     | _ =>
484 :     (ppValShare (hd, ty, membersOp, depth-1,accu);
485 : macqueen 1344 PP.string ppstrm ",";
486 :     break ppstrm {nsp=0,offset=0};
487 : monnier 247 ppTail(tl,len-1)))
488 :    
489 : macqueen 1344 in openHOVBox ppstrm (PP.Rel 1);
490 :     PP.string ppstrm "[";
491 : monnier 247 ppTail(obj,length);
492 : macqueen 1344 PP.string ppstrm "]";
493 :     closeBox ppstrm
494 : monnier 247 end
495 :    
496 :     and ppUrList(obj:object, ty:T.ty, membersOp, depth:int, length: int,accu) =
497 :     let fun list_case p =
498 :     case switch(p, ulistDcons)
499 :     of {domain=NONE,...} => NONE
500 : blume 587 | dcon => (case Obj.toTuple(decon(p, dcon)) of
501 :     [a, b] => SOME (a, b)
502 :     | _ => bug "ppUrList [a, b]")
503 : monnier 247
504 :     fun ppTail(p, len) =
505 :     case list_case p
506 :     of NONE => ()
507 :     | SOME(hd,tl) =>
508 : macqueen 1344 if len <= 0 then (PP.string ppstrm "...")
509 : monnier 247 else (case list_case tl
510 :     of NONE =>
511 :     ppValShare (hd, ty, membersOp, depth-1,accu)
512 :     | _ =>
513 :     (ppValShare (hd, ty, membersOp, depth-1,accu);
514 : macqueen 1344 PP.string ppstrm ",";
515 :     break ppstrm {nsp=0,offset=0};
516 : monnier 247 ppTail(tl,len-1)))
517 :    
518 : macqueen 1344 in openHOVBox ppstrm (PP.Rel 1);
519 :     PP.string ppstrm "[ unrolled list ";
520 : monnier 247 (* ppTail(obj,length); *)
521 : macqueen 1344 PP.string ppstrm "]";
522 :     closeBox ppstrm
523 : monnier 247 end
524 :    
525 :     and ppTuple(objs: object list, tys: T.ty list, membersOp, depth:int, accu) : unit =
526 :     let fun ppFields([f],[ty]) = ppValShare (f, ty, membersOp, depth-1, accu)
527 :     | ppFields(f::restf, ty::restty) =
528 :     (ppValShare (f, ty, membersOp, depth-1, accu);
529 : macqueen 1344 PP.string ppstrm (",");
530 :     break ppstrm {nsp=0,offset=0};
531 : monnier 247 ppFields(restf,restty))
532 :     | ppFields([], []) = ()
533 :     | ppFields _ = bug "ppFields in ppval.sml"
534 : macqueen 1344 in openHOVBox ppstrm (PP.Rel 1);
535 :     PP.string ppstrm ("(");
536 : monnier 247 ppFields(objs, tys);
537 : macqueen 1344 PP.string ppstrm (")");
538 :     closeBox ppstrm
539 : monnier 247 end
540 :    
541 :     and ppRecord(objs: object list, labels: T.label list,
542 :     tys: T.ty list, membersOp, depth: int, accu) =
543 :     let fun ppFields([f],[l],[ty]) =
544 : macqueen 1344 (openHVBox ppstrm (PP.Rel 2);
545 :     PP.string ppstrm (Symbol.name l);
546 :     PP.string ppstrm ("=");
547 : monnier 247 ppValShare (f, ty, membersOp, depth-1, accu);
548 : macqueen 1344 closeBox ppstrm)
549 : monnier 247 | ppFields(f::restf, l::restl, ty::restty) =
550 : macqueen 1344 (openHVBox ppstrm (PP.Rel 2);
551 :     PP.string ppstrm (Symbol.name l);
552 :     PP.string ppstrm ("=");
553 : monnier 247 ppValShare (f,ty,membersOp,depth-1,accu);
554 : macqueen 1344 closeBox ppstrm;
555 :     PP.string ppstrm (",");
556 :     break ppstrm {nsp=0,offset=0};
557 : monnier 247 ppFields(restf,restl,restty))
558 :     | ppFields([],[],[]) = ()
559 :     | ppFields _ = bug "ppFields in ppval.sml"
560 : macqueen 1344 in openHOVBox ppstrm (PP.Rel 1);
561 :     PP.string ppstrm ("{");
562 : monnier 247 ppFields(objs,labels,tys);
563 : macqueen 1344 PP.string ppstrm ("}");
564 :     closeBox ppstrm
565 : monnier 247 end
566 :    
567 :     and ppVector(objs:object vector, ty:T.ty, membersOp, depth:int, length,accu) =
568 :     let val vectorLength = V.length objs
569 :     val (len, closing) =
570 :     if length >= vectorLength then
571 : macqueen 1344 (vectorLength,fn _ => PP.string ppstrm "]")
572 :     else (length,fn sep => (PP.string ppstrm sep;
573 :     PP.string ppstrm "...]"))
574 : monnier 247 fun printRest(sep,breaker, index) =
575 :     if index >= len then closing sep
576 : macqueen 1344 else (PP.string ppstrm sep; breaker ();
577 : monnier 247 ppValShare (V.sub (objs,index),ty,membersOp,
578 :     depth-1,accu);
579 : macqueen 1344 printRest (",",fn () => break ppstrm {nsp=0,offset=0}, index + 1))
580 :     in openHOVBox ppstrm (PP.Rel 1);
581 :     PP.string ppstrm "#["; printRest("",fn () => (), 0);
582 :     closeBox ppstrm
583 : monnier 247 end
584 :    
585 : dbm 633 and ppArray (objs: object array, ty: T.ty, membersOp, depth: int, length, accu) =
586 : monnier 247 let val vectorLength = Array.length objs
587 :     val (len, closing) =
588 :     if length >= vectorLength then
589 : macqueen 1344 (vectorLength,fn _ => PP.string ppstrm "|]")
590 :     else (length,fn sep => (PP.string ppstrm sep;
591 :     PP.string ppstrm "...|]"))
592 : monnier 247 fun printRest(sep,breaker, index) =
593 :     if index >= len then closing sep
594 : macqueen 1344 else (PP.string ppstrm sep; breaker ();
595 : monnier 247 ppValShare (Array.sub (objs,index),ty,membersOp,
596 :     depth-1,accu);
597 : macqueen 1344 printRest (",",fn () => break ppstrm {nsp=0,offset=0}, index + 1))
598 :     in openHOVBox ppstrm (PP.Rel 1);
599 :     PP.string ppstrm "[|"; printRest("",fn () => (), 0);
600 :     closeBox ppstrm
601 : monnier 247 end
602 : dbm 633 and ppRealArray (objs : Real64Array.array, length: int) =
603 :     let val vectorLength = Real64Array.length objs
604 :     val (len, closing) =
605 :     if length >= vectorLength then
606 : macqueen 1344 (vectorLength,fn _ => PP.string ppstrm "|]")
607 :     else (length,fn sep => (PP.string ppstrm sep;
608 :     PP.string ppstrm "...|]"))
609 : dbm 633 fun printRest(sep,breaker, index) =
610 :     if index >= len then closing sep
611 : macqueen 1344 else (PP.string ppstrm sep; breaker ();
612 :     PP.string ppstrm (Real.toString(Real64Array.sub(objs,index)));
613 :     printRest (",",fn () => break ppstrm {nsp=0,offset=0}, index + 1))
614 :     in openHOVBox ppstrm (PP.Rel 1);
615 :     PP.string ppstrm "[|"; printRest("",fn () => (), 0);
616 :     closeBox ppstrm
617 : dbm 633 end
618 : monnier 247 in ppValue
619 :     end (* fun ppObj *)
620 :    
621 :     end (* structure PPObj *)
622 :    
623 :    
624 :    

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