![[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.