![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to printabsyn.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 / absyn|
Return to printabsyn.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / absyn |
1.1 root 1: (* Copyright 1989 by AT&T Bell Laboratories *)
2: signature PRINTABSYN =
3: sig
4: structure BareAbsyn : BAREABSYN
5: val printPat : BareAbsyn.pat * int -> unit
6: val printExp : BareAbsyn.exp * int * int -> unit
7: val printRule : BareAbsyn.rule * int * int -> unit
8: val printVB : BareAbsyn.vb * int * int -> unit
9: val printRVB : BareAbsyn.rvb * int * int -> unit
10: val printDec : BareAbsyn.dec * int * int -> unit
11: val printStrexp : BareAbsyn.strexp * int * int -> unit
12: end
13:
14: structure PrintAbsyn : PRINTABSYN = struct
15: structure BareAbsyn = BareAbsyn
16: open BareAbsyn Access Basics PrintUtil PrintType PrintBasics ErrorMsg Tuples
17:
18: fun checkpat (n,nil) = true
19: | checkpat (n, (sym,_)::fields) =
20: Symbol.eq(sym, numlabel n) andalso checkpat(n+1,fields)
21:
22: fun checkexp (n,nil) = true
23: | checkexp (n, (LABEL{name=sym,...},_)::fields) =
24: Symbol.eq(sym, numlabel n) andalso checkexp(n+1,fields)
25:
26: fun isTUPLEpat (RECORDpat{fields=[_],...}) = false
27: | isTUPLEpat (RECORDpat{flex=false,fields,...}) = checkpat(1,fields)
28: | isTUPLEpat _ = false
29:
30: fun isTUPLEexp (RECORDexp [_]) = false
31: | isTUPLEexp (RECORDexp fields) = checkexp(1,fields)
32: | isTUPLEexp _ = false
33:
34: fun printPat (_,0) = print "<pat>"
35: | printPat (VARpat v,_) = printVar v
36: | printPat (WILDpat,_) = print "_"
37: | printPat (INTpat i,_) = print i
38: | printPat (REALpat r,_) = print r
39: | printPat (STRINGpat s,_) = pr_mlstr s
40: | printPat (LAYEREDpat (v,p),d) = (printPat(v,d); print " as "; printPat(p,d-1))
41: | printPat (r as RECORDpat{fields,flex,...},d) =
42: let val (a,b) =
43: if isTUPLEpat r
44: then (("(", ",", ")"), (fn (sym,pat) => printPat(pat,d-1)))
45: else (("{", ",", (if flex then ",...}" else "}")),
46: (fn (sym,pat) => (printSym sym; print "="; printPat(pat,d-1))))
47: in printClosedSequence a b fields
48: end
49: | printPat (CONpat e,_) = printDcon e
50: | printPat (p as APPpat _, d) =
51: let val noparen = INfix(0,0)
52: in printDconPat(p,noparen,noparen,d)
53: end
54: | printPat (CONSTRAINTpat (p,t),d) = (printPat(p,d-1); print " : "; printType t)
55:
56: and printDconPat(_,_,_,0) = print "<pat>"
57: | printDconPat(CONpat(DATACON{name,...}),l:fixity,r:fixity,_) = printSym name
58: | printDconPat(CONSTRAINTpat(p,t),l,r,d) =
59: (print "("; printPat(p,d-1); print " : "; printType t; print ")")
60: | printDconPat(LAYEREDpat(v,p),l,r,d) =
61: (print "("; printPat(v,d); print " as "; printPat(p,d-1); print ")")
62: | printDconPat(APPpat(DATACON{name,...},p),l,r,d) =
63: let val dname = Symbol.name name
64: val fixity = EnvAccess.lookFIX name
65: fun prdcon() =
66: case (fixity,isTUPLEpat p,p)
67: of (INfix _,true,RECORDpat{fields=[(_,pl),(_,pr)],...}) =>
68: (printDconPat(pl,NONfix,fixity,d-1);
69: print " "; print dname; print " ";
70: printDconPat(pr,fixity,NONfix,d-1))
71: | _ => (print dname; print " "; printDconPat(p,NONfix,NONfix,d-1))
72: in case(l,r,fixity) of
73: (NONfix,NONfix,_) => (print "("; prdcon(); print ")")
74: | (INfix _,INfix _,_) => prdcon()
75: | (_,_,NONfix) => prdcon()
76: | (INfix(_,p1),_,INfix(p2,_)) => if p1 >= p2
77: then (print "("; prdcon(); print ")")
78: else prdcon()
79: | (_,INfix(p1,_),INfix(_,p2)) => if p1 > p2
80: then (print "("; prdcon(); print ")")
81: else prdcon()
82: end
83: | printDconPat (p,_,_,d) = printPat(p,d)
84:
85: fun printExp(_,_,0) = print "<exp>"
86: | printExp(VARexp(ref var),_,_) = printVar var
87: | printExp(CONexp(con),_,_) = printDcon con
88: | printExp(INTexp i,_,_) = print i
89: | printExp(REALexp r,_,_) = print r
90: | printExp(STRINGexp s,_,_) = pr_mlstr s
91: | printExp(r as RECORDexp fields,ind,d) =
92: let val (a,b) =
93: if isTUPLEexp r
94: then (("(", ",", ")"), (fn(_,exp)=>printExp(exp,ind+1,d-1)))
95: else (("{", ",", "}"),
96: (fn (LABEL{name,...},exp) =>
97: (printSym name; print "="; printExp(exp,ind+1,d))))
98: in printClosedSequence a b fields
99: end
100: | printExp(SEQexp exps,ind,d) =
101: printClosedSequence ("(", ";", ")") (fn exp => printExp(exp,ind+1,d-1)) exps
102: | printExp(e as APPexp _,ind,d) = let val noparen = INfix(0,0)
103: in printAppExp(e,noparen,noparen,ind,d)
104: end
105: | printExp(CONSTRAINTexp(e, t),ind,d) =
106: (print "("; printExp(e,ind,d); print ":"; printType t; print ")")
107: | printExp(HANDLEexp(exp, HANDLER handler),ind,d) =
108: (printExp(exp,ind,d-1); nlindent(ind); print "handle ";
109: printExp(handler,ind+7,d-1))
110: | printExp(RAISEexp exp,ind,d) = (print "raise "; printExp(exp,ind+6,d-1))
111: | printExp(LETexp(dec, exp),ind,d) =
112: (print "let "; printDec(dec,ind+4,d-1); nlindent(ind);
113: print " in "; printExp(exp,ind+4,d-1); nlindent(ind);
114: print "end")
115: | printExp(CASEexp(exp, rules),ind,d) =
116: (print "(case "; printExp(exp,ind+5,d-1); nlindent(ind+3);
117: print "of "; printvseq (ind+4) "| " (fn r => printRule(r,ind+4,d-1)) rules;
118: print ")")
119: | printExp(FNexp rules,ind,d) =
120: (print "(fn "; printvseq (ind+1) "| " (fn r => printRule(r,ind+3,d-1)) rules;
121: print ")")
122: | printExp(MARKexp (e,_,_),ind,d) = printExp(e,ind,d)
123:
124: and printAppExp(_,_,_,_,0) = print "<exp>"
125: | printAppExp arg =
126: let fun fixityprint(name,e,l,r,ind,d) =
127: let val dname = formatQid name
128: val fixity = case name of [id] => EnvAccess.lookFIX id
129: | _ => NONfix
130: fun pr() =
131: case (fixity,isTUPLEexp e,e)
132: of (INfix _,true,RECORDexp[(_,pl),(_,pr)]) =>
133: (printAppExp(pl,NONfix,fixity,ind,d-1);
134: print " "; print dname; print " ";
135: printAppExp(pr,fixity,NONfix,ind+2,d-1))
136: | _ => (print dname; print " ";
137: printAppExp(e,NONfix,NONfix,ind+2,d-1))
138: in case(l,r,fixity) of
139: (NONfix,NONfix,_) => (print "("; pr(); print ")")
140: | (INfix _,INfix _,_) => pr()
141: | (_,_,NONfix) => pr()
142: | (INfix(_,p1),_,INfix(p2,_)) =>
143: if p1 >= p2 then (print "("; pr(); print ")")
144: else pr()
145: | (_,INfix(p1,_),INfix(_,p2)) =>
146: if p1 > p2 then (print "("; pr(); print ")")
147: else pr()
148: end
149: fun appPrint(_,_,_,_,0) = print "#"
150: | appPrint(CONSTRAINTexp(e,t),l,r,ind,d) =
151: (print "("; printExp(e,ind+1,d-1);
152: print " : "; printType t; print ")")
153: | appPrint(APPexp(CONexp(DATACON{name,...}),e),l,r,ind,d) =
154: fixityprint([name],e,l,r,ind,d)
155: | appPrint(APPexp(VARexp(ref(VALvar{name,...})),e),l,r,ind,d) =
156: fixityprint(name,e,l,r,ind,d)
157: | appPrint(APPexp(VARexp(ref(OVLDvar{name,...})),e),l,r,ind,d) =
158: fixityprint([name],e,l,r,ind,d)
159: | appPrint(APPexp(app as APPexp _,rand),NONfix,NONfix,ind,d) =
160: let val yesparen = INfix(0,100000000) (* a hack *)
161: in print "("; appPrint(app,yesparen,NONfix,ind+1,d-1);
162: print " ";
163: appPrint(rand,NONfix,NONfix,ind+2,d-1); print ")"
164: end
165: | appPrint(APPexp(app as APPexp _,rand),l,r,ind,d) =
166: let val yesparen = INfix(0,100000000) (* a hack *)
167: in appPrint(app,yesparen,NONfix,ind+1,d-1);
168: print " ";
169: appPrint(rand,NONfix,NONfix,ind+2,d-1)
170: end
171: | appPrint(APPexp(rator,rand),_,_,ind,d) =
172: (printExp(rator,ind,d-1); print " "; printExp(rand,ind+2,d-1))
173: | appPrint(MARKexp(e,_,_),l,r,ind,d) = appPrint(e,l,r,ind,d)
174: | appPrint (e,_,_,ind,d) = printExp(e,ind,d)
175: in appPrint arg
176: end
177:
178: and printRule(RULE(pat,exp),ind,d) =
179: if d>0
180: then (printPat(pat,d-1); print " => "; printExp(exp,ind+2,d-1))
181: else print "<rule>"
182:
183: and printVB(VB{pat,exp,...},ind,d) =
184: if d>0
185: then (printPat(pat,d-1); print " = "; printExp(exp,ind+2,d-1))
186: else print "<binding>"
187:
188: and printRVB(RVB{var,exp,...},ind,d) =
189: if d>0
190: then (printVar var; print " = "; printExp(exp,ind+2,d-1))
191: else print "<rec binding>"
192:
193: and printDec(_,_,0) = print "<dec>"
194: | printDec(VALdec vbs,ind,d) =
195: (print "val "; printvseq ind "and " (fn vb => printVB(vb,ind+4,d-1)) vbs)
196: | printDec(VALRECdec rvbs,ind,d) =
197: (print "val rec ";
198: printvseq (ind+4) "and " (fn rvb => printRVB(rvb,ind+8,d-1)) rvbs)
199: | printDec(TYPEdec tbs,ind,d) =
200: (print "type ";
201: printvseq ind " and "
202: (fn (TB{tyc=ref(TYCON{path=name::_, arity,...}),def}) =>
203: (case arity
204: of 0 => ()
205: | 1 => (print "'a ")
206: | n => (printTuple print (typeFormals n); print " ");
207: printSym name; print " = "; printType def)
208: | _ => impossible "printabsyn.398")
209: tbs)
210: | printDec(DATATYPEdec{datatycs,withtycs},ind,d) =
211: (print "datatype ";
212: printvseq (ind+5) "and "
213: (fn (ref(TYCON{path=name::_, arity, kind=DATAtyc dcons,...})) =>
214: (case arity
215: of 0 => ()
216: | 1 => (print "'a ")
217: | n => (printTuple print (typeFormals n); print " ");
218: printSym name; print " = ";
219: printSequence " | " (fn (DATACON{name,...}) => printSym name) dcons)
220: | _ => impossible "printabsyn.8")
221: datatycs;
222: nlindent(ind); print "with"; printDec(TYPEdec withtycs,ind+4,d-1))
223: | printDec(ABSTYPEdec _,ind,d) = print "abstype"
224: | printDec(EXCEPTIONdec ebs,ind,d) =
225: (print "exception ";
226: printvseq (ind+6) "and "
227: (fn (EBgen{exn=DATACON{name,...},etype}) =>
228: (printSym name;
229: case etype of NONE => ()
230: | SOME ty' => (print " of "; printType ty'))
231: | (EBdef{exn=DATACON{name,...},edef=DATACON{name=dname,...}}) =>
232: (printSym name; print "="; printSym dname))
233: ebs)
234: | printDec(STRdec sbs,ind,d) =
235: (print "structure ";
236: printvseq ind "and "
237: (fn (STRB{strvar=STRvar{access,name,...},def,...}) =>
238: (print(formatQid name); printAccess access; print " = "; nlindent(ind+4);
239: printStrexp(def,ind+4,d-1)))
240: sbs)
241: | printDec(ABSdec sbs,ind,d) =
242: (print "abstraction ";
243: printvseq ind "and "
244: (fn (STRB{strvar=STRvar{access,name,...},def,...}) =>
245: (print(formatQid name); printAccess access; print " = "; nlindent(ind+4);
246: printStrexp(def,ind+4,d-1)))
247: sbs)
248: | printDec(SIGdec sigvars,ind,d) =
249: printvseq ind ""
250: (fn SIGvar{name,...} => (print "signature "; printSym name))
251: sigvars
252: | printDec(LOCALdec(inner,outer),ind,d) =
253: (print "local"; nlindent(ind+3);
254: printDec(inner,ind+3,d-1); nlindent(ind);
255: print "in ";
256: printDec(outer,ind+3,d-1); nlindent(ind);
257: print "end")
258: | printDec(SEQdec decs,ind,d) =
259: printvseq ind "" (fn dec => printDec(dec,ind,d)) decs
260: | printDec(OPENdec strVars,ind,d) =
261: (print "open ";
262: printSequence " " (fn STRvar{name,...} => print(formatQid name)) strVars)
263: | printDec(IMPORTdec _,_,_) = print "printDec gives up: IMPORT in abstract syntax"
264: | printDec(MARKdec(dec,_,_),ind,d) = printDec(dec,ind,d)
265: | printDec(_) = print "printDec gives up"
266:
267: and printStrexp(_,_,0) = print "<strexp>"
268: | printStrexp(VARstr(STRvar{access,name,...}),ind,d) =
269: print(formatQid name)
270: | printStrexp(STRUCTstr{body,locations},ind,d) =
271: (print "struct"; nlindent(ind+2);
272: printvseq (ind+2) "" (fn dec => printDec(dec,ind+2,d-1)) body;
273: nlindent(ind); print "end")
274: | printStrexp(APPstr{oper=FCTvar{name,...}, argexp,...},ind,d) =
275: (printSym name; print"(";
276: printStrexp(argexp,ind+4,d-1);
277: print")")
278: | printStrexp(LETstr(dec,body),ind,d) =
279: (print "let "; printDec(dec,ind+4,d-1); nlindent(ind);
280: print " in "; printStrexp(body,ind+4,d-1); nlindent(ind);
281: print "end")
282:
283: end (* structure PrintAbsyn *)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.