![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to printval.sml CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / sml / src / print|
Return to printval.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / print |
1.1 root 1: (* Copyright 1989 by AT&T Bell Laboratories *)
2: (* printval.sml *)
3:
4: structure PrintVal: PRINTVAL =
5: struct
6:
7: structure Basics = Basics
8:
9: open System System.Unsafe Basics BasicTypes TypesUtil ErrorMsg PrintUtil
10:
11: fun gettag obj = int (tuple obj sub 1)
12:
13: exception Switch
14:
15: fun switch(obj, TYCON{kind=DATAtyc dcons,...}) =
16: let fun try ((d as DATACON{rep,...})::r) =
17: (case rep
18: of TAGGED i => if (gettag obj = i handle Boxity => false)
19: then d else try r
20: | CONSTANT i => if (int obj = i handle Boxity => false)
21: then d else try r
22: | TRANSPARENT =>
23: if ((tuple obj; true) handle Boxity => false)
24: then d else (try r handle Switch => d)
25: | TRANSB => if ((tuple obj; true) handle Boxity => false)
26: then d else try r
27: | TRANSU => if ((int obj; true) handle Boxity => false)
28: then d else try r
29: | REF => d
30: | _ => ErrorMsg.impossible "PrintVal.switch: funny datacon")
31: | try nil = raise Switch
32: in try dcons
33: handle Switch =>
34: ErrorMsg.impossible "PrintVal.switch: none of the datacons matched"
35: end
36:
37: fun decon(obj, DATACON{rep,...}) =
38: case rep
39: of UNDECIDED => ErrorMsg.impossible "undecided datacon in decon"
40: | TAGGED _ => tuple obj sub 0
41: | CONSTANT _ => ErrorMsg.impossible "constant datacon in decon"
42: | TRANSPARENT => obj
43: | TRANSU => obj
44: | TRANSB => obj
45: | REF => tuple obj sub 0
46: | VARIABLE _ => tuple obj sub 0
47:
48: val noparen = INfix(0,0)
49:
50: fun printVal(obj: object, ty: ty, depth: int) : unit =
51: printVal'(obj, ty, depth, noparen, noparen)
52:
53: and printVal'(_,_,0,_,_) = print "#"
54: | printVal'(obj: object, ty: ty, depth: int, l: fixity, r: fixity) : unit =
55: case ty
56: of VARty(ref(INSTANTIATED t)) => printVal'(obj,t,depth,r,l)
57: | FLEXRECORDty(ref(CLOSED t)) => printVal'(obj,t,depth,r,l)
58: | CONty(ref(tyc as TYCON{kind,...}), argtys) => (* wrong!? *)
59: (case kind
60: of ABStyc =>
61: if eqTycon(tyc,!intTycon) then print(makestring(int obj))
62: else if eqTycon(tyc,!realTycon) then print(makestring(real obj))
63: else if eqTycon(tyc,!stringTycon) then pr_mlstr(string obj)
64: else if eqTycon(tyc,!arrowTycon) then print "fn"
65: else print "-"
66: | DEFtyc _ =>
67: printVal'(obj, reduceType ty, depth, l, r)
68: | DATAtyc _ =>
69: if eqTycon(tyc,!listTycon)
70: then printList(obj, hd argtys, depth)
71: else printDcon(obj, tyc, argtys, depth, l, r)
72: | RECORDtyc [] => print "()"
73: | RECORDtyc labels =>
74: if Tuples.isTUPLEtyc tyc
75: then printTuple(tuple(obj), argtys, depth)
76: else printRecord(tuple(obj), labels, argtys, depth))
77: | POLYty{tyfun=TYFUN{body,...},...} => printVal'(obj,body,depth,l,r)
78: | _ => print "-"
79:
80: and printDcon(_,_,_,0,_,_) = print "#"
81: | printDcon(obj:object, tyc as TYCON{arity,...}, argtys,
82: depth:int, l:fixity, r:fixity) =
83: let val dcon as DATACON{name,const,typ,...} = switch(obj,tyc)
84: val dname = Symbol.name name
85: in if const
86: then print dname
87: else
88: let val fixity = EnvAccess.lookFIX name (* may be inaccurate *)
89: val dom = case !typ
90: of CONty(_,dom::_) => dom
91: | POLYty{tyfun=TYFUN{body=CONty(_,dom::_),...},...} =>
92: applyTyfun(TYFUN{arity=arity,body=dom},argtys)
93: val dom = headReduceType(dom)
94: fun prdcon() =
95: case (fixity,dom)
96: of (INfix _,CONty(ref(domTyc as TYCON{kind=RECORDtyc _,...}),
97: [tyL,tyR])) =>
98: let val twoTuple = tuple(decon(obj,dcon))
99: in if Tuples.isTUPLEtyc domTyc
100: then (
101: printVal'(twoTuple sub 0,tyL,depth-1,NONfix,fixity);
102: print " "; print dname; print " ";
103: printVal'(twoTuple sub 1,tyR,depth-1,fixity,NONfix))
104: else (
105: print dname; print " ";
106: printVal'(decon(obj,dcon),dom,depth-1,NONfix,NONfix))
107: end
108: | _ =>
109: (print dname; print " ";
110: printVal'(decon(obj,dcon),dom,depth-1,NONfix,NONfix))
111: fun prpardcon() = (print "("; prdcon(); print ")")
112: in case(l,r,fixity)
113: of (NONfix,NONfix,_) => prpardcon()
114: | (INfix _,INfix _,_) => prdcon()
115: (* special case: only on first iteration, for no parens *)
116: | (_,_,NONfix) => prdcon()
117: | (INfix(_,p1),_,INfix(p2,_)) =>
118: if p1 >= p2 then prpardcon()
119: else prdcon()
120: | (_,INfix(p1,_),INfix(_,p2)) =>
121: if p1 > p2 then prpardcon()
122: else prdcon()
123: end
124: end
125:
126: and printList(obj:object, ty:ty, depth:int) : unit =
127: let fun printTail(separator, p) =
128: let val dcon as DATACON{name,...} = switch(p, !listTycon)
129: in case (Symbol.name name)
130: of "nil" => print "]"
131: | "::" =>
132: let val pair = tuple(decon(p, dcon))
133: in print separator;
134: printVal(pair sub 0, ty, depth-1);
135: printTail (",", pair sub 1)
136: end
137: end
138: in print "["; printTail("",obj)
139: end
140:
141: and printTuple(objs: object array, tys: ty list, depth:int) : unit =
142: let fun printFields(nf,[ty]) = printVal(objs sub nf,ty,depth-1)
143: | printFields(nf, ty::restty) =
144: (printVal(objs sub nf,ty,depth-1); print(",");
145: printFields(nf+1,restty))
146: | printFields(nf,[]) = ()
147: in print("("); printFields(0,tys); print(")")
148: end
149:
150: and printRecord(objs: object array, labels: label list, tys: ty list, depth:int) =
151: let fun printFields(nf,[l],[ty]) =
152: (print(Symbol.name l); print("="); printVal(objs sub nf,ty,depth-1))
153: | printFields(nf, l::restl, ty::restty) =
154: (print(Symbol.name l); print("="); printVal(objs sub nf,ty,depth-1);
155: print(","); printFields(nf+1,restl,restty))
156: | printFields(nf,[],[]) = ()
157: in print("{"); printFields(0,labels,tys); print("}")
158: end
159:
160: end (* structure PrintVal *)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.