![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to printdec.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 printdec.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / print |
1.1 root 1: (* Copyright 1989 by AT&T Bell Laboratories *)
2: (* printdec.sml *)
3:
4: structure PrintDec : PRINTDEC =
5: struct
6:
7: structure BareAbsyn = BareAbsyn
8: type object = System.Unsafe.object
9:
10: open Basics BareAbsyn PrintUtil PrintBasics PrintType PrintVal Access
11:
12: val printDepth = System.Control.Print.printDepth
13:
14: val sortBinders = Sort.sort BuildMod.binderGt
15:
16: fun printFormals 0 = ()
17: | printFormals 1 = (print "'a "; print " ")
18: | printFormals n = (printTuple (fn s => (print "'"; print s)) (typeFormals n);
19: print " ")
20:
21: local
22: fun printVb lookup (VB{pat,...}) =
23: let fun printBind(pat) =
24: case pat
25: of VARpat(VALvar{name=[n],access=LVAR lv,typ=ref ty}) =>
26: (print "val "; printSym n; print " = ";
27: printVal(lookup lv, ty, !printDepth);
28: print " : "; printType ty;
29: newline())
30: | RECORDpat{pats=ref pl,...} => app printBind pl
31: | APPpat(_,pat) => printBind pat
32: | CONSTRAINTpat(pat,_) => printBind pat
33: | LAYEREDpat(pat1,pat2) => (printBind pat1; printBind pat2)
34: | _ => ()
35: in printBind pat
36: end
37:
38: and printRvb lookup (RVB{var=VALvar{name=[n],access=LVAR lv,typ=ref ty},...}) =
39: (print "val "; printSym n; print " = ";
40: printVal(lookup lv, ty, !printDepth);
41: print " : "; printType ty; newline())
42:
43: and printTb(TB{tyc=ref(TYCON{path=name::_, arity, ...}),def}) =
44: (print "type ";
45: printFormals arity; print " ";
46: printSym name; print " = "; printType def; newline())
47:
48: and printAbsTyc(ref(TYCON{path=name::_, arity, eq, kind=ABStyc, ...})) =
49: (print(if (!eq=YES) then "eqtype" else "type");
50: printFormals arity; print " ";
51: printSym name; newline())
52:
53: and printDataTyc(ref(TYCON{path=name::_,arity,kind=DATAtyc dcons,...})) =
54: (print "datatype ";
55: printFormals arity; print " ";
56: printSym name; newline();
57: app (fn DATACON{name,typ,...} =>
58: (print "con "; printSym name; print " : ";
59: printType(!typ); newline()))
60: dcons)
61:
62: and printEb(EBgen{exn=DATACON{name,...},etype}) =
63: (print "exception "; printSym name;
64: case etype
65: of NONE => ()
66: | SOME ty' =>
67: if BasicTypes.isArrowType ty'
68: then (print " of "; printType(BasicTypes.domain ty'))
69: else ();
70: newline())
71: | printEb(EBdef{exn=DATACON{name,...},edef=DATACON{name=dname,...}}) =
72: (print "exception "; printSym name; print " = "; printSym dname;
73: newline())
74:
75: and printSigVar(SIGvar{name,binding}) =
76: (print "signature "; printSym name;
77: if !System.Control.Print.signatures
78: then (print " =\n sig"; printStr binding; print "\n end\n")
79: else newline())
80:
81: and printStrVar(STRvar{name,binding,...}) =
82: (print "structure "; print(formatQid name);
83: if !System.Control.Print.signatures
84: then (print " :\n sig"; printStr binding; print "\n end\n")
85: else newline())
86:
87: and printStr(str as STRstr{table,env,kind,...}) =
88: let val tInC = case kind
89: of STRkind _ => (fn t => TypesUtil.typeInContext(t,env))
90: | SIGkind _ => TypesUtil.printableType str
91: fun printBinder(VARbind(VALvar{name=[n],typ,...})) =
92: (nlindent 4; print "val ";
93: printSym n; print " : ";
94: printType(tInC(!typ)))
95: | printBinder(CONbind(DATACON{name,typ,rep=VARIABLE _,...})) =
96: (nlindent 4; print "exception "; printSym name;
97: if BasicTypes.isUnitTy(!typ)
98: then ()
99: else (print " of "; printType(tInC(!typ))))
100: | printBinder(TYCbind(ref(tyc))) =
101: let val TYCON{path=name::_,kind,arity,eq,...} =
102: TypesUtil.tyconInContext env tyc
103: in nlindent 4;
104: case kind
105: of DATAtyc dcons =>
106: (print "datatype ";
107: printFormals arity;
108: printSym name; nlindent(6); print "con ";
109: printvseq (6) "con "
110: (fn DATACON{name,typ,...} =>
111: (printSym name; print " : ";
112: printType(tInC(!typ))))
113: dcons)
114: | _ =>
115: (if (!eq=YES)
116: then print "eqtype "
117: else print "type ";
118: printFormals arity;
119: printSym(name))
120: end
121: | printBinder(STRbind(STRvar{name=[n],binding,...})) =
122: (nlindent 4; print "structure ";
123: printSym n; print " : sig...end")
124: | printBinder(FIXbind(FIXvar{name,binding=INfix(l,r)})) =
125: (nlindent 4;
126: print "infix "; print l; print " "; print r; print " ";
127: printSym name)
128: | printBinder _ = ()
129: val bindlist = ref nil
130: val _ = IntStrMap.app (fn x => bindlist := x ::(!bindlist)) table
131: val binders = sortBinders(!bindlist)
132: val e = Env.current()
133: in Env.openOld({path=nil,strenv=env},table); (* affects printType *)
134: app (fn (_,_,b) => printBinder b) binders;
135: Env.resetEnv e
136: end
137:
138: and printStrb(STRB{strvar,...}) =
139: printStrVar strvar
140:
141: and printFctb(FCTB{fctvar,...}) =
142: printFunctorVar fctvar
143:
144: and printFunctorVar(FCTvar{name,...}) =
145: (print "functor "; printSym name; print " : <sig>\n")
146:
147: (* not used, because of special top-level open *)
148: and printOpen(strvl) =
149: (print "open ";
150: printSequence " " (fn STRvar{name,...} => print(formatQid name)) strvl;
151: newline())
152:
153: and printBinding(b: Basics.binding): unit=
154: case b of
155: FCTbind(functorVar)=> printFunctorVar functorVar
156: | SIGbind(signatureVar)=> printSigVar signatureVar
157: | _ => print "<other binding>\n"
158:
159: in (* local *)
160:
161: fun printDec lookup dec =
162: let val printDec0 = printDec lookup
163: in
164: case (resetPrintType(); dec)
165: of VALdec vbs => app (printVb lookup) vbs
166: | VALRECdec rvbs => app (printRvb lookup) rvbs
167: | TYPEdec tbs => app printTb tbs
168: | DATATYPEdec{datatycs,withtycs} =>
169: (app printDataTyc datatycs; app printTb withtycs)
170: | ABSTYPEdec{abstycs,withtycs,body} =>
171: (app printAbsTyc abstycs;
172: app printTb withtycs;
173: printDec0 body)
174: | EXCEPTIONdec ebs => app printEb ebs
175: | STRdec strbs => app printStrb strbs
176: | FCTdec fctbs => app printFctb fctbs
177: | SIGdec sigvars => app printSigVar sigvars
178: | LOCALdec(decIn,decOut) => printDec0 decOut
179: | SEQdec decs => app printDec0 decs
180: | OPENdec strvs => printOpen strvs
181: | IMPORTdec _ => ErrorMsg.impossible "printDec(IMPORT)"
182: | MARKdec(dec,a,b) => printDec0 dec
183: end (* fun printDec *)
184:
185: fun printBindingTbl(tbl: Basics.symtable)=
186: (let val _ = resetPrintType();
187: val bindlist = ref []
188: val _ = IntStrMap.app (fn x => bindlist:= x :: (!bindlist)) tbl
189: val binders = sortBinders (!bindlist)
190: in app printBinding (map (fn(i,s,b)=> b) binders)
191: end)
192: end (* local *)
193:
194: end (* structure PrintDec *)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.