![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to mc.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 mc.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / translate |
1.1 ! root 1: (* Copyright 1989 by AT&T Bell Laboratories *) ! 2: signature MC = sig ! 3: structure A : BAREABSYN ! 4: structure L : LAMBDA ! 5: val matchCompile : (A.pat * L.lexp) list -> L.lexp ! 6: val bindCompile : (A.pat * L.lexp) list -> L.lexp ! 7: end ! 8: ! 9: structure MC : MC = struct ! 10: ! 11: structure A : BAREABSYN = BareAbsyn ! 12: structure L : LAMBDA = Lambda ! 13: ! 14: open A L ! 15: open Access Basics ErrorMsg ! 16: ! 17: val printDepth = System.Control.Print.printDepth ! 18: ! 19: val patsUsed : int list ref = ref [] ! 20: val maybeUsed : int list ref = ref [] ! 21: val results : (lvar * lvar list) list ref = ref [] ! 22: ! 23: fun mark(taglist,tag : int) = ! 24: let fun newtag[] = [tag] ! 25: | newtag(taglist as (t::more)) = ! 26: if tag = t then taglist ! 27: else if tag < t then tag :: taglist ! 28: else t :: newtag more ! 29: in taglist := newtag (!taglist) ! 30: end ! 31: ! 32: fun unused rules = ! 33: let fun find([],[],_) = [] ! 34: | find([],_::r,i) = i :: find([],r,i+1) ! 35: | find(taglist as tag::tags,_::r,i) = ! 36: if tag = i ! 37: then find(tags,r,i+1) ! 38: else i :: find(taglist,r,i+1) ! 39: | find _ = ErrorMsg.impossible "unused in mc" ! 40: in find(!patsUsed,rules,0) ! 41: end ! 42: fun redundant rules = ! 43: if length rules = length (!patsUsed) then [] ! 44: else unused rules ! 45: fun areNotRedundant () = ! 46: case !maybeUsed of ! 47: [] => () ! 48: | (tag::_) => (mark(patsUsed,tag); maybeUsed := []) ! 49: fun areRedundant () = maybeUsed := [] ! 50: ! 51: fun bind(x,v,(bindings,tag)) = ((v,x)::bindings,tag) ! 52: ! 53: fun layer (x,CONSTRAINTpat(pat,_),rhs) = layer(x,pat,rhs) ! 54: | layer (x,VARpat(VALvar{access=LVAR v,...}),rhs) = bind(x,v,rhs) ! 55: | layer _ = impossible "bad layered pattern in mc" ! 56: ! 57: fun convert(bindings,tag) = ! 58: let val (f,free) = nth(!results,tag) ! 59: fun order [] = [] ! 60: | order (v::tl) = ! 61: let fun f [] = ErrorMsg.impossible "convert in translate/mc.sml" ! 62: | f ((w,z)::tl) = if v=w then z else f tl ! 63: in f bindings :: order tl ! 64: end ! 65: val args = order free ! 66: in mark(patsUsed,tag); APP(VAR f,RECORD(map VAR args)) ! 67: end ! 68: fun convertDefault(bindings,tag) = ! 69: let val (f,free) = nth(!results,tag) ! 70: fun order [] = [] ! 71: | order (v::tl) = ! 72: let fun f [] = ErrorMsg.impossible "convertD in translate/mc.sml" ! 73: | f ((w,z)::tl) = if v=w then z else f tl ! 74: in f bindings :: order tl ! 75: end ! 76: val args = order free ! 77: in mark(maybeUsed,tag); APP(VAR f,RECORD(map VAR args)) ! 78: end ! 79: ! 80: val rec freevars = ! 81: fn VARpat(VALvar{access=LVAR v,...}) => [v] ! 82: | RECORDpat{pats=ref pats,...} => SortedList.foldmerge(map freevars pats) ! 83: | APPpat(_,pat) => freevars pat ! 84: | CONSTRAINTpat(pat,_) => freevars pat ! 85: | LAYEREDpat(l,r) => SortedList.merge(freevars l,freevars r) ! 86: | _ => [] ! 87: ! 88: fun setup rules = ! 89: let val arg = mkLvar() ! 90: fun t(i,(pat,result)::more) = ! 91: let val (header,r) = t(i+1,more) ! 92: val record = mkLvar() ! 93: val returnit = mkLvar() ! 94: val free = freevars pat ! 95: fun f(_,[]) = result ! 96: | f(i,v::tl) = APP(FN(v,f(i+1,tl)),SELECT(i,VAR record)) ! 97: in results := (returnit,free) :: !results; ! 98: (fn l => header(APP(FN(returnit,l),FN(record,f(0,free)))), ! 99: (pat,([],i)) :: r) ! 100: end ! 101: | t _ = (fn x => x,[]) ! 102: in patsUsed := []; maybeUsed := []; ! 103: let val (header,r) = t(0,rules) ! 104: in (fn l => FN(arg,header(APP(l,VAR arg))),r) ! 105: end ! 106: end ! 107: ! 108: fun bindfields(record,fields,e)= ! 109: let fun select(i, []) = e ! 110: | select(i, x::xs) = APP(FN(x,select(i+1,xs)),SELECT(i,VAR record)) ! 111: in select(0,fields) ! 112: end ! 113: ! 114: fun andSwitch x = ! 115: let ! 116: fun andS [] = ([],[]) ! 117: | andS ((p::fields,rhs)::more) = ! 118: (case p of ! 119: INTpat i => ! 120: let val (cases,default) = andS more ! 121: fun addto ((switch as (INTcon j,pats))::more) = ! 122: if i = j then ((INTcon i,(fields,rhs)::pats)::more) ! 123: else switch :: addto more ! 124: | addto [] = [(INTcon i,(fields,rhs)::default)] ! 125: | addto _ = impossible "983 type error in match compiler" ! 126: in (addto cases,default) ! 127: end ! 128: | REALpat r => ! 129: let val (cases,default) = andS more ! 130: fun addto ((switch as (REALcon s,pats))::more) = ! 131: if r = s then ((REALcon r,(fields,rhs)::pats)::more) ! 132: else switch :: addto more ! 133: | addto [] = [(REALcon r,(fields,rhs)::default)] ! 134: | addto _ = impossible "48 type error in match compiler" ! 135: in (addto cases,default) ! 136: end ! 137: | STRINGpat s => ! 138: let val (cases,default) = andS more ! 139: fun addto ((switch as (STRINGcon t,pats))::more) = ! 140: if s = t then ((STRINGcon s,(fields,rhs)::pats)::more) ! 141: else switch :: addto more ! 142: | addto [] = [(STRINGcon s,(fields,rhs)::default)] ! 143: | addto _ = impossible "482 type error in match compiler" ! 144: in (addto cases,default) ! 145: end ! 146: | CONpat(dcon as DATACON{name=r1,...}) => ! 147: let val (cases,default) = andS more ! 148: fun addto ((switch as (DATAcon(DATACON {name=r2,...}),pats))::more) = ! 149: if Symbol.eq(r1,r2) ! 150: then (DATAcon dcon,(fields,rhs)::pats)::more ! 151: else switch :: addto more ! 152: | addto [] = [(DATAcon dcon,(fields,rhs)::default)] ! 153: | addto _ = impossible "87 type error in match compiler" ! 154: in (addto cases,default) ! 155: end ! 156: | APPpat(dcon as DATACON{name=r1,...},p) => ! 157: let val (cases,default) = andS more ! 158: fun addto ((switch as (DATAcon(DATACON {name=r2,...}),pats))::more) = ! 159: if Symbol.eq(r1,r2) ! 160: then ((DATAcon dcon,(p::fields,rhs)::pats)::more) ! 161: else switch :: addto more ! 162: | addto [] = ! 163: let fun addwild (fields,rhs) = (WILDpat::fields,rhs) ! 164: in [(DATAcon dcon,(p::fields,rhs)::(map addwild default))] ! 165: end ! 166: | addto _ = impossible "444 type error in match compiler" ! 167: in (addto cases,default) ! 168: end ! 169: | WILDpat => ! 170: let val (cases,default) = andS more ! 171: fun addto (((con as DATAcon(DATACON{const=false,...})),pats)::more) = ! 172: (con,(WILDpat::fields,rhs)::pats) :: addto more ! 173: | addto ((con,pats)::more) = ! 174: (con,(fields,rhs)::pats) :: addto more ! 175: | addto [] = [] ! 176: in (addto cases,(fields,rhs)::default) ! 177: end ! 178: | VARpat(VALvar{access=LVAR v,...}) => ! 179: andS ((WILDpat::fields,bind(x,v,rhs))::more) ! 180: | LAYEREDpat(v,p) => andS((p::fields,layer(x,v,rhs))::more) ! 181: | CONSTRAINTpat(p,_) => andS((p::fields,rhs)::more) ! 182: | _ => impossible "andS in mc") ! 183: | andS _ = impossible "andS2 in mc" ! 184: in andS ! 185: end ! 186: ! 187: fun orSwitch x = ! 188: let fun diffPats samefn = ! 189: let fun diff [] = [] ! 190: | diff ((hd as (p,rhs))::more) = ! 191: case p of ! 192: WILDpat => [hd] ! 193: | VARpat(VALvar{access=LVAR v,...}) => [(WILDpat,bind(x,v,rhs))] ! 194: | LAYEREDpat(v,p) => ! 195: diff ((p,layer(x,v,rhs))::more) ! 196: | CONSTRAINTpat(p,_) => ! 197: diff ((p,rhs)::more) ! 198: | _ => (if samefn p then diff more else hd::diff more) ! 199: handle Match => ! 200: impossible "orS.diff: type error in match compiler" ! 201: in diff ! 202: end ! 203: fun orS [] = impossible "orSwitch [] in mc" ! 204: | orS (arg as (p,rhs)::more) = ! 205: case p of ! 206: INTpat i => ! 207: let val (cases,default) = orS (diffPats (fn INTpat j => i=j) arg) ! 208: in ((INTcon i,convert rhs)::cases,default) ! 209: end ! 210: | REALpat r => ! 211: let val (cases,default) = orS (diffPats (fn REALpat s => r=s) arg) ! 212: in ((REALcon r,convert rhs)::cases,default) ! 213: end ! 214: | STRINGpat s => ! 215: let val (cases,default) = orS (diffPats (fn STRINGpat t => s=t) arg) ! 216: in ((STRINGcon s,convert rhs)::cases,default) ! 217: end ! 218: | WILDpat => ([],SOME(convert rhs)) ! 219: | VARpat(VALvar{access=LVAR v,...}) => ([],SOME(convert(bind(x,v,rhs)))) ! 220: | CONSTRAINTpat(p,_) => orS ((p,rhs)::more) ! 221: | LAYEREDpat(v,p) => orS ((p,layer(x,v,rhs))::more) ! 222: | _ => impossible "orS in mc" ! 223: in orS ! 224: end ! 225: ! 226: fun mcand (arg as ([_],_)::_,[x]) = ! 227: let val singlelist = fn ([pat],rhs) => (pat,rhs) ! 228: | _ => impossible "singlelist in match compiler" ! 229: in APP(mcor (map singlelist arg), VAR x) ! 230: end ! 231: | mcand (arg as (p::fields,rhs)::more,xl as x::xs) = ! 232: let fun mconto (con as DATAcon(con1 as DATACON{const = false,...}),pats) = ! 233: let val new = mkLvar () ! 234: in (con,APP(FN(new,mcand (MCopt.opt (pats,new::xs))),DECON (con1,VAR x))) ! 235: end ! 236: | mconto (con as DATAcon(DATACON {const = true,...}),pats) = ! 237: (con,mcand (MCopt.opt (pats,xs))) ! 238: | mconto _ = impossible "mconto in mc" ! 239: in ! 240: case p of ! 241: WILDpat => mcand([(fields,rhs)],xs) ! 242: | VARpat(VALvar{access=LVAR v,...}) => mcand([(fields,bind(x,v,rhs))],xs) ! 243: | LAYEREDpat(v,p) => mcand(((p::fields,layer(x,v,rhs))::more),xl) ! 244: | CONSTRAINTpat(p,_) => mcand((p::fields,rhs)::more,xl) ! 245: | APPpat(DATACON{sign = [_],...},_) => ! 246: let val newx = mkLvar() ! 247: val ([(DATAcon dcon,list)],_) = andSwitch x arg ! 248: in APP(FN(newx,mcand(MCopt.opt(list,newx::xs))),DECON(dcon,VAR x)) ! 249: end ! 250: | APPpat(DATACON{sign,...},_) => ! 251: let val (cases,default) = andSwitch x arg ! 252: in SWITCH(VAR x, ! 253: map mconto cases, ! 254: if length cases = length sign then NONE ! 255: else SOME (mcand (MCopt.opt (default,xs)))) ! 256: end ! 257: | CONpat(DATACON{sign=[_],...}) => mcand([(fields,rhs)],xs) ! 258: | CONpat(DATACON{sign,...}) => ! 259: let val (cases,default) = andSwitch x arg ! 260: in SWITCH(VAR x, ! 261: map mconto cases, ! 262: if length cases = length sign then NONE ! 263: else SOME (mcand (MCopt.opt (default,xs)))) ! 264: end ! 265: | RECORDpat{pats=ref [],...} => mcand([(fields,rhs)],xs) ! 266: | RECORDpat{pats,...} => ! 267: let val newfields = map (fn _ => mkLvar()) (!pats) ! 268: val wild = map (fn _ => WILDpat) newfields ! 269: fun expand [] = [] ! 270: | expand ((p::fields,rhs)::more) = ! 271: (case p of ! 272: RECORDpat{pats,...} => (!pats@fields,rhs) :: expand more ! 273: | LAYEREDpat(v,p) => expand ((p::fields,layer(x,v,rhs))::more) ! 274: | CONSTRAINTpat(p,_) => expand ((p::fields,rhs)::more) ! 275: | WILDpat => (wild@fields,rhs) :: expand more ! 276: | VARpat(VALvar{access=LVAR v,...}) => ! 277: (wild@fields,bind(x,v,rhs)) :: expand more ! 278: | _ => impossible "mcand.expand in mc") ! 279: | expand _ = impossible "mcand.expand2 in mc" ! 280: in bindfields(x,newfields,mcand(MCopt.opt(expand arg,newfields@xs))) ! 281: end ! 282: | _ => (* INTpat,REALpat,STRINGpat; possibly bad VARpats *) ! 283: let val (cases,default) = andSwitch x arg ! 284: in SWITCH(VAR x, ! 285: map (fn (con,pats) => (con,mcand(MCopt.opt(pats,xs)))) cases, ! 286: SOME(mcand(MCopt.opt(default,xs)))) ! 287: end ! 288: end ! 289: | mcand _ = impossible "mcand in mc" ! 290: ! 291: and conSwitch x = ! 292: let ! 293: fun conS [] = ([],NONE) ! 294: | conS (arg as (p,rhs)::more) = ! 295: case p of ! 296: CONpat(dcon as DATACON{name=r1,...}) => ! 297: let fun diff [] = [] ! 298: | diff ((hd as (p,rhs))::more) = ! 299: case p of ! 300: CONpat(DATACON{name=r2,...}) => ! 301: if Symbol.eq(r1,r2) then diff more ! 302: else (hd::diff more) ! 303: | APPpat (_,_) => hd::diff more ! 304: | WILDpat => [hd] ! 305: | VARpat _ => [hd] ! 306: | CONSTRAINTpat(p,_) => diff ((p,rhs)::more) ! 307: | LAYEREDpat(v,p) => diff ((p,layer(x,v,rhs))::more) ! 308: | _ => impossible "conS.diff: type error in match compiler" ! 309: val (cases,default) = conS (diff more) ! 310: in ((DATAcon dcon,convert rhs)::cases,default) ! 311: end ! 312: | APPpat(dcon as DATACON{name=r1,...},_) => ! 313: let fun divide [] = ([],[]) ! 314: | divide ((hd as (p,rhs))::more) = ! 315: case p of ! 316: CONpat _ => ! 317: let val (same,diff) = divide more ! 318: in (same,hd::diff) ! 319: end ! 320: | APPpat(DATACON{name=r2,...},p) => ! 321: let val (same,diff) = divide more ! 322: in if Symbol.eq(r1,r2) ! 323: then ((p,rhs)::same,diff) ! 324: else (same,hd::diff) ! 325: end ! 326: | WILDpat => ([hd],[hd]) ! 327: | VARpat(VALvar{access=LVAR v,...}) => ! 328: ([(WILDpat,bind(x,v,rhs))],[hd]) ! 329: | CONSTRAINTpat(p,_) => divide ((p,rhs)::more) ! 330: | LAYEREDpat(v,p) => divide ((p,layer(x,v,rhs))::more) ! 331: | _ => impossible "conS.divide: type error in match compiler" ! 332: val con = DATAcon dcon ! 333: val (same,diff) = divide arg ! 334: val lexp = mcor same (* Order imp. here: side- *) ! 335: val (cases,default) = conS diff (* effects in redund. chk. *) ! 336: in ((con,APP(lexp,DECON(dcon,VAR x)))::cases,default) ! 337: end ! 338: | WILDpat => ([],SOME(convertDefault rhs)) ! 339: | VARpat(VALvar{access=LVAR v,...}) => ! 340: ([],SOME(convertDefault(bind(x,v,rhs)))) ! 341: | LAYEREDpat(v,p) => conS ((p,layer(x,v,rhs))::more) ! 342: | CONSTRAINTpat(p,_) => conS ((p,rhs)::more) ! 343: | _ => impossible "conS: type error in match compiler" ! 344: in conS ! 345: end ! 346: ! 347: and mcor [] = impossible "mcor.[] in mc" ! 348: | mcor (arg as (p,rhs)::more) = ! 349: let val x = mkLvar() ! 350: in case p of ! 351: CONpat(DATACON{sign=[],...}) => (* exception *) ! 352: let val (cases,default) = conSwitch x arg ! 353: in areNotRedundant(); ! 354: FN(x,SWITCH(VAR x,cases,default)) ! 355: end ! 356: | APPpat (DATACON{sign=[],...},_) => (* exn *) ! 357: let val (cases,default) = conSwitch x arg ! 358: in areNotRedundant(); ! 359: FN(x,SWITCH(VAR x,cases,default)) ! 360: end ! 361: | CONpat(DATACON{sign=[_],...}) => FN(x, convert rhs) ! 362: | CONpat(DATACON{sign,...}) => ! 363: let val (cases,default) = conSwitch x arg ! 364: in FN(x,SWITCH(VAR x, cases, ! 365: (if length cases = length sign ! 366: then (areRedundant(); NONE) ! 367: else (areNotRedundant(); default)))) ! 368: end ! 369: | APPpat(DATACON{sign=[_],...},_) => ! 370: let val ([(con,lexp)],_) = conSwitch x arg ! 371: in areRedundant(); ! 372: FN(x,lexp) ! 373: end ! 374: | APPpat(DATACON{sign,...},_) => ! 375: let val (cases,default) = conSwitch x arg ! 376: in FN(x,SWITCH(VAR x, cases, ! 377: (if length cases = length sign ! 378: then (areRedundant(); NONE) ! 379: else (areNotRedundant(); default)))) ! 380: end ! 381: | INTpat _ => ! 382: let val (cases,default) = orSwitch x arg ! 383: in FN(x,SWITCH(VAR x,cases,default)) ! 384: end ! 385: | REALpat _ => ! 386: let val (cases,default) = orSwitch x arg ! 387: in FN(x,SWITCH(VAR x,cases,default)) ! 388: end ! 389: | STRINGpat _ => ! 390: let val (cases,default) = orSwitch x arg ! 391: in FN(x,SWITCH(VAR x,cases,default)) ! 392: end ! 393: | RECORDpat{pats=ref [],...} => FN(x, convert rhs) ! 394: | RECORDpat{pats,...} => ! 395: let val newfields = map (fn _ => mkLvar()) (!pats) ! 396: val wild = map (fn _ => WILDpat) newfields ! 397: fun expand [] = [] ! 398: | expand ((p,rhs)::more) = ! 399: case p of ! 400: RECORDpat{pats,...} => (!pats,rhs) :: expand more ! 401: | LAYEREDpat(v,p) => expand ((p,layer(x,v,rhs))::more) ! 402: | CONSTRAINTpat(p,_) => expand ((p,rhs)::more) ! 403: | WILDpat => [(wild,rhs)] ! 404: | VARpat(VALvar{access=LVAR v,...}) => ! 405: [(wild,bind(x,v,rhs))] ! 406: | _ => impossible "mcor.expand in mc" ! 407: in FN(x,bindfields(x,newfields,mcand(MCopt.opt(expand arg,newfields)))) ! 408: end ! 409: | WILDpat => FN(x, convert rhs) ! 410: | VARpat(VALvar{access=LVAR v,...}) => FN(x,convert(bind(x,v,rhs))) ! 411: | LAYEREDpat(v,p) => FN(x,APP(mcor((p,layer(x,v,rhs))::more),VAR x)) ! 412: | CONSTRAINTpat(p,_) => mcor((p,rhs)::more) ! 413: | _ => impossible "mcor: type error in match compiler" ! 414: end (* fun mcor *) ! 415: ! 416: open PrintUtil ! 417: fun matchPrint [] _ _ = () ! 418: | matchPrint [(pat,_)] _ _ = () (* never print last rule *) ! 419: | matchPrint ((pat,_)::more) [] _ = ! 420: (print " "; PrintAbsyn.printPat(pat,!printDepth); print " => ...\n"; ! 421: matchPrint more [] 0) ! 422: | matchPrint ((pat,_)::more) (taglist as (tag::tags)) i = ! 423: if i = tag ! 424: then (print " --> "; PrintAbsyn.printPat(pat,!printDepth); ! 425: print " => ...\n"; matchPrint more tags (i+1)) ! 426: else (print " "; PrintAbsyn.printPat(pat,!printDepth); ! 427: print " => ...\n"; matchPrint more taglist (i+1)) ! 428: ! 429: fun bindPrint ((pat,_)::_) = ! 430: (print " "; PrintAbsyn.printPat(pat,!printDepth); print " = ...\n") ! 431: | bindPrint _ = impossible "bindPrint in mc" ! 432: ! 433: fun noVarsIn ((pat,_)::_) = ! 434: let fun var WILDpat = true (* might want to flag this *) ! 435: | var (VARpat _) = true ! 436: | var (LAYEREDpat _) = true ! 437: | var (CONSTRAINTpat(p,_)) = var p ! 438: | var (APPpat(_,p)) = var p ! 439: | var (RECORDpat{pats=ref patlist,...}) = exists var patlist ! 440: | var _ = false ! 441: in not(var pat) ! 442: end ! 443: | noVarsIn _ = impossible "noVarsIn in mc" ! 444: ! 445: open System.Control.MC ! 446: ! 447: fun genCompile(flag1,warning1,flag2,test,warning2,printer) rules = ! 448: let val (header,rules') = setup rules ! 449: val match = header(mcor rules') ! 450: val unused = redundant rules ! 451: val last = length rules - 1 ! 452: val printit = if !flag1 andalso not(exists (fn i => i=last) unused) ! 453: then (warn(warning1 ^ " not exhaustive"); true) ! 454: else false ! 455: val printit = if !flag2 andalso test(rules,unused,last) ! 456: then (warn warning2; true) ! 457: else printit ! 458: in if !printArgs ! 459: then (warn "MC called with:"; MCprint.printMatch rules) ! 460: else (); ! 461: if printit ! 462: then printer(rules,unused) ! 463: else (); ! 464: if !printRet ! 465: then (print "MC: returns with\n"; MCprint.printLexp match; newline()) ! 466: else (); ! 467: match ! 468: end handle Syntax => (warn "MC called with:"; MCprint.printMatch rules; ! 469: raise Syntax) ! 470: ! 471: val bindCompile = ! 472: genCompile(bindExhaustive, ! 473: "binding", ! 474: bindContainsVar, ! 475: fn (rules,unused,last) => noVarsIn rules, ! 476: "binding contains no variables", ! 477: fn(rules,unused) => bindPrint rules) ! 478: ! 479: val matchCompile = ! 480: genCompile(matchExhaustive, ! 481: "match", ! 482: matchRedundant, ! 483: fn(rules,unused,last) => exists (fn i => i<last) unused, ! 484: "redundant patterns in match", ! 485: fn(rules,unused) => matchPrint rules unused 0) ! 486: ! 487: end (* struct MC *)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.