![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to mcprint.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 / translate|
Return to mcprint.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / translate |
1.1 ! root 1: (* Copyright 1989 by AT&T Bell Laboratories *) ! 2: (* mcprint.sml *) ! 3: ! 4: signature MCprint = ! 5: sig ! 6: structure Access : ACCESS ! 7: structure A : BAREABSYN ! 8: structure L : LAMBDA ! 9: val printCon : L.con -> unit ! 10: val printLexp : L.lexp -> unit ! 11: val printMatch : (A.pat * L.lexp) list -> unit ! 12: val printFun : L.lexp -> Access.lvar -> unit ! 13: end ! 14: ! 15: structure MCprint : MCprint = struct ! 16: ! 17: structure Access = Access ! 18: structure A = BareAbsyn ! 19: structure L = Lambda ! 20: ! 21: open Access Basics A L PrintUtil PrintBasics PrintAbsyn ErrorMsg ! 22: val margin = ref 0 ! 23: ! 24: fun indent i = margin := !margin + i ! 25: ! 26: exception Undent ! 27: ! 28: fun undent i = (margin := !margin - i; if !margin < 0 then raise Undent else ()) ! 29: ! 30: fun dent () = tab(!margin) ! 31: ! 32: fun printCon (DATAcon dcon) = printDcon dcon ! 33: | printCon (INTcon i) = print i ! 34: | printCon (REALcon r) = print r ! 35: | printCon (STRINGcon s) = pr_mlstr s ! 36: ! 37: (* use of complex in printLexp may lead to stupid n^2 behavior. *) ! 38: val rec complex = ! 39: fn VAR w => false ! 40: | FN(_,b) => complex b ! 41: | FIX(vl,ll,b) => true ! 42: | APP(FN _,_) => true ! 43: | APP(l,r) => complex l orelse complex r ! 44: | SWITCH (l,ls,d) => true ! 45: | RECORD l => let fun f nil = false | f (hd::tl) = complex hd orelse f tl ! 46: in f l ! 47: end ! 48: | SELECT(_,l) => complex l ! 49: | HANDLE _ => true | RAISE l => complex l ! 50: | INT _ => false | STRING _ => false | REAL _ => false ! 51: | PRIM _ => false ! 52: fun printLexp (VAR v) = print(lvarName v) ! 53: | printLexp (INT i) = print i ! 54: | printLexp (REAL s) = print s ! 55: | printLexp (STRING s) = pr_mlstr s ! 56: | printLexp (r as RECORD l) = ! 57: if complex r ! 58: then (print "RECORD"; ! 59: indent 7; ! 60: printTuple (fn l => (printLexp l; newline(); dent())) l; ! 61: undent 7) ! 62: else (print "RECORD"; printTuple printLexp l) ! 63: | printLexp (PRIM p) = print ("PRIM "^Prim.inLineName p) ! 64: | printLexp (l as SELECT(i,_)) = ! 65: let fun gather(SELECT(i,l)) = ! 66: let val (more,root) = gather l ! 67: in (i :: more,root) ! 68: end ! 69: | gather l = (nil,l) ! 70: val (path,root) = gather l ! 71: fun ipr (i:int) = print i ! 72: in printLexp root; ! 73: printClosedSequence ("[",",","]") ipr (rev path) ! 74: end ! 75: | printLexp (FN(v,l)) = ! 76: (print "FN("; print(lvarName v); print ","; ! 77: if complex l then (newline(); indent 3; dent(); ! 78: printLexp l; print ")"; undent 3) ! 79: else (printLexp l; print ")") ! 80: ) ! 81: | printLexp (APP(FN(v,l),r)) = ! 82: let val lv = lvarName v ! 83: val len = size lv + 3 ! 84: in print lv; print " = "; ! 85: indent len ; printLexp r; undent len; ! 86: newline(); dent(); printLexp l ! 87: end ! 88: | printLexp (APP(l,r)) = ! 89: (print "APP("; ! 90: if complex l orelse complex r ! 91: then (indent 4; printLexp l; print ",\n"; dent(); ! 92: printLexp r; print ")"; undent 4) ! 93: else (printLexp l; print ","; ! 94: printLexp r; print ")")) ! 95: | printLexp (SWITCH (l,llist,default)) = ! 96: let fun switch [(c,l)] = ! 97: (printCon c; print " => "; ! 98: indent 8; printLexp l; undent 8) ! 99: | switch ((c,l)::more) = ! 100: (printCon c; print " => "; ! 101: indent 8; printLexp l; undent 8; newline(); dent(); ! 102: switch more) ! 103: in print "SWITCH "; ! 104: indent 7; ! 105: printLexp l; ! 106: undent 6; ! 107: newline(); dent(); ! 108: print "of "; indent 3; ! 109: switch llist; ! 110: case (default,llist) ! 111: of (NONE,_) => () ! 112: | (SOME l,nil) => ! 113: (print "_ => "; ! 114: indent 5; printLexp l; undent 5) ! 115: | (SOME l,_) => ! 116: (newline(); dent(); print "_ => "; ! 117: indent 5; printLexp l; undent 5); ! 118: undent 4 ! 119: end ! 120: | printLexp (FIX (varlist,lexplist,lexp)) = ! 121: let fun flist([v],[l]) = ! 122: let val lv = lvarName v ! 123: val len = size lv + 2 ! 124: in print lv; print ": "; ! 125: indent len ; printLexp l; undent len ! 126: end ! 127: | flist(v::vs,l::ls) = ! 128: let val lv = lvarName v ! 129: val len = size lv + 2 ! 130: in print lv; print ": "; ! 131: indent len ; printLexp l; undent len; ! 132: newline(); dent(); flist(vs,ls) ! 133: end ! 134: | flist(nil,nil) = () ! 135: in print "FIX("; indent 4; flist(varlist,lexplist); undent 4; ! 136: newline(); dent(); print "IN "; ! 137: indent 4; printLexp lexp; print ")"; undent 4 ! 138: end ! 139: | printLexp (RAISE l) = (print "RAISE "; indent 6; printLexp l; undent 6) ! 140: | printLexp (HANDLE (lexp,withlexp)) = ! 141: (print "HANDLE "; indent 7; printLexp lexp; ! 142: undent 5; newline(); dent(); ! 143: print "WITH "; indent 5; printLexp withlexp; undent 7) ! 144: ! 145: fun printMatch ((p,r)::more) = ! 146: (printPat(p,!System.Control.Print.printDepth); ! 147: print " => "; printLexp r; newline(); printMatch more) ! 148: | printMatch nil = () ! 149: ! 150: fun printFun l v = ! 151: let val rec findit = ! 152: fn VAR w => if v=w ! 153: then (print("VAR " ^ lvarName v ^ " is free in <lexp>\n"); ! 154: ()) ! 155: else () ! 156: | l as FN(w,b) => if v=w then printLexp l else findit b ! 157: | l as FIX(vl,ll,b) => if exists (fn w => v=w) vl ! 158: then printLexp l ! 159: else (app findit ll; findit b) ! 160: | APP(l,r) => (findit l; findit r) ! 161: | SWITCH (l,ls,d) => ! 162: (findit l; ! 163: app (fn(_,l) => findit l) ls; ! 164: case d of NONE => () | SOME l => findit l) ! 165: | RECORD l => app findit l | SELECT(_,l) => findit l ! 166: | HANDLE(e,h) => (findit e; findit h) | RAISE l => findit l ! 167: | INT _ => () | STRING _ => () | REAL _ => () ! 168: | PRIM _ => () ! 169: in findit l ! 170: end ! 171: ! 172: ! 173: end (* struct MCprint *)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.