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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

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