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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 7506 - (view) (download)

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

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