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

Parent Directory | 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