![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to sigmatch.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 / typing|
Return to sigmatch.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / typing |
1.1 ! root 1: (* Copyright 1989 by AT&T Bell Laboratories *) ! 2: (* sigmatch.sml *) ! 3: ! 4: structure SigMatch : SIGMATCH = struct ! 5: ! 6: structure Basics = Basics ! 7: ! 8: open List2 PrintUtil ErrorMsg Access Stampset Basics BareAbsyn BasicTypes ! 9: EnvAccess EnvAccess.Env TypesUtil PrintType ModUtil ! 10: ! 11: (* debug print functions *) ! 12: val prIntPath = printClosedSequence ("[",",","]") (print:int->unit) ! 13: fun prSymPath spath = printSequence "." printSym (rev spath) ! 14: ! 15: val symName = Symbol.name ! 16: val anonName = Symbol.symbol "Anon" ! 17: fun for a b = app b a ! 18: ! 19: exception CompareTypes ! 20: exception REFtyc ! 21: val refstamp = tycStamp(!refTycon) ! 22: and arraystamp = tycStamp(!arrayTycon) ! 23: ! 24: fun compType(specty, specsign:polysign, actty, actsign:polysign, actarity): unit = ! 25: let val env = array(actarity,UNDEFty) ! 26: fun comp(ty1, VARty(ref(INSTANTIATED(ty2)))) = ! 27: comp(ty1,ty2) ! 28: | comp(ty1, FLEXRECORDty(ref(CLOSED ty2))) = comp(ty1,ty2) ! 29: | comp(ty1, VARty(ref(IBOUND i))) = ! 30: (case env sub i ! 31: of UNDEFty => ! 32: let val {weakness=aw,eq=ae} = nth(actsign,i) ! 33: in if aw < infinity ! 34: then let fun checkweak(VARty(ref(IBOUND n))) = ! 35: let val {weakness=sw,...} = nth(specsign,n) ! 36: in if sw > aw then raise CompareTypes ! 37: else () ! 38: end ! 39: | checkweak(CONty(_,args)) = app checkweak args ! 40: | checkweak _ = impossible "compType/checkweak" ! 41: in checkweak ty1 ! 42: end ! 43: else (); ! 44: if ae ! 45: then checkEqTySig(ty1,specsign) ! 46: handle CHECKEQ => raise CompareTypes ! 47: else (); ! 48: update(env,i,ty1) ! 49: end ! 50: | ty => if equalType(ty1,ty) ! 51: then () ! 52: else raise CompareTypes) ! 53: | comp(ty1 as CONty(ref tycon, args), ty2 as CONty(ref tycon', args')) = ! 54: if eqTycon(tycon,tycon') ! 55: then app2 comp (args,args') ! 56: else (comp(reduceType ty1, ty2) ! 57: handle ReduceType => ! 58: comp(ty1, reduceType ty2) ! 59: handle ReduceType => raise CompareTypes) ! 60: | comp(_, ERRORty) = () ! 61: | comp _ = raise CompareTypes ! 62: in comp(specty,actty) ! 63: end ! 64: ! 65: fun compareTypes(spec: ty, actual: ty, name) : unit = ! 66: let fun error() = ! 67: (complain "value type in structure doesn't match signature spec"; ! 68: PrintType.resetPrintType(); ! 69: print (" name: " ^ symName name ^ "\n spec: "); ! 70: PrintType.printType(spec); ! 71: print "\n actual: "; ! 72: PrintType.printType(actual); newline()) ! 73: in case spec ! 74: of POLYty{sign,tyfun=TYFUN{body,...}} => ! 75: (case actual ! 76: of POLYty{sign=sign',tyfun=TYFUN{arity,body=body'}} => ! 77: (compType(body,sign,body',sign',arity) ! 78: handle CompareTypes => error()) ! 79: | _ => error()) ! 80: | ERRORty => () ! 81: | _ => ! 82: (case actual ! 83: of POLYty{sign,tyfun=TYFUN{arity,body}} => ! 84: (compType(spec,[],body,sign,arity) ! 85: handle CompareTypes => error()) ! 86: | _ => if equalType(spec,actual) ! 87: then () ! 88: else error()) ! 89: end ! 90: ! 91: ! 92: (* making abstraction structures *) ! 93: ! 94: fun abstract(sgn as STRstr{kind=SIGkind{stamps={strStamps=sigStrStamps, ! 95: tycStamps=sigTycStamps}, ! 96: ...}, ! 97: ...}, ! 98: str, {strStamps, tycStamps}) = ! 99: let val transStrStamp = join(strStamps,sigStrStamps) ! 100: val transTycStamp = join(tycStamps,sigTycStamps) ! 101: fun abstractTyc(sigtyc,strtyc) = ! 102: case sigtyc ! 103: of TYCON{kind=DATAtyc _,...} => strtyc ! 104: | _ => let val stamp = tycStamp sigtyc ! 105: in if tycFixed(stamp) ! 106: then strtyc ! 107: else setTycStamp(transTycStamp(stamp),sigtyc) ! 108: end ! 109: fun abstractStr(STRstr{stamp,sign,table,env,...}, ! 110: str as STRstr{env=env',...}) = ! 111: if strFixed stamp ! 112: then str ! 113: else let val newenv as REL{s,t} = abstractEnv(env,env') ! 114: val newstr = STRstr{stamp=transStrStamp(stamp), ! 115: env=newenv, ! 116: sign=sign,table=table, ! 117: kind=STRkind{path=[]}} (* ??? def of kind *) ! 118: in ArrayExt.app((setParent newstr), s, 2); ! 119: newstr ! 120: end ! 121: | abstractStr (INDstr i,_) = ! 122: impossible ("3437 in sigmatch: " ^makestring i) ! 123: | abstractStr _ = impossible "9833 in sigmatch (abstractStr)" ! 124: and abstractEnv(REL{s=sSig,t=tSig}:strenv, REL{s=sStr,t=tStr}:strenv) = ! 125: let val sNew = array(Array.length sSig, NULLstr) ! 126: val tNew = array(Array.length tSig, NULLtyc) ! 127: fun foreachStr i = ! 128: (update(sNew,i,abstractStr(sSig sub i, sStr sub i)); ! 129: foreachStr(i+1)) ! 130: fun foreachTyc i = ! 131: (update(tNew,i,abstractTyc(tSig sub i, tStr sub i)); ! 132: foreachTyc(i+1)) ! 133: in foreachStr 2 (* ignoring parent and parameter slots *) ! 134: handle Subscript => ! 135: foreachTyc 0 ! 136: handle Subscript => ! 137: REL{s=sNew,t=tNew} ! 138: end ! 139: in abstractStr(sgn,str) ! 140: end ! 141: | abstract _ = impossible "8375 in sigmatch (abstract)" ! 142: ! 143: (* signature matching *) ! 144: ! 145: fun matchx (parent: Structure) ! 146: (mapfns as {mapstr,mapstr1,maptyc}) ! 147: (abs, path, stamps, ! 148: sgn as STRstr{stamp,sign,...}, ! 149: str as STRstr{stamp=stamp',sign=sign',table,env,...}, ! 150: param: Structure) ! 151: : Structure * thinning = ! 152: if strFixed(stamp) andalso stamp <> stamp' ! 153: then (print "fixed signature stamp: "; print stamp; ! 154: print "\nstructure stamp: "; print stamp'; ! 155: print "\npath: "; prSymPath path; print "\n"; ! 156: condemn "fixed signature doesn't agree with structure") ! 157: else if sign = sign' ! 158: then (mapstr(sgn,str); ! 159: (if abs then abstract(sgn,str,stamps) else str, NONE)) ! 160: else let val v = mkLvar() ! 161: val _ = (openStr(); openOld({path=[v],strenv=env},table)) ! 162: val (str',transl) = ! 163: realizex parent mapfns (abs,path,stamps,stamp',sgn,param) ! 164: in closeStr(); ! 165: (str',SOME(v,transl)) ! 166: end ! 167: | matchx _ _ _ = impossible "843 in sigmatch" ! 168: ! 169: and realizex (parent: Structure) ! 170: (mapfns as {mapstr1,maptyc,mapstr}) ! 171: (abs, path, stamps, strStamp, ! 172: sgn as STRstr{stamp = boundStamp, sign, table, ! 173: env = sigenv as REL{s=sSig,t=tSig}, ! 174: kind = SIGkind{bindings,share,...},...}, ! 175: param: Structure) ! 176: : Structure * trans list = ! 177: let val sNew = array(Array.length sSig, NULLstr) ! 178: val tNew = array(Array.length tSig, NULLtyc) ! 179: val newenv = REL{s=sNew,t=tNew} ! 180: val newstr = STRstr{stamp=strStamp,sign=sign,table=table,env=newenv, ! 181: kind=STRkind{path=path}} ! 182: fun checkSpec spec = ! 183: case spec ! 184: of STRbind(STRvar{name=[id],binding=INDstr i,...}) => ! 185: let val STRvar{access,binding=str',...} = ! 186: lookSTRlocal id ! 187: handle Unbound => ! 188: condemn("unmatched structure spec: " ^ symName id) ! 189: val (str,thin) = matchx newstr mapfns ! 190: (false, id::path, stamps, ! 191: sSig sub i, str',NULLstr) ! 192: in update(sNew,i,str); ! 193: [case thin ! 194: of NONE => VALtrans access ! 195: | SOME(v,transl) => THINtrans(access,v,transl)] ! 196: end ! 197: | TYCbind(ref(INDtyc i)) => ! 198: let val sigTycon = tSig sub i ! 199: val name = tycName sigTycon ! 200: val strTycon = !(lookTYClocal name) ! 201: handle Unbound => ! 202: condemn("unmatched type spec: "^ ! 203: symName(name)) ! 204: val s = tycStamp sigTycon ! 205: val s' = tycStamp strTycon ! 206: in update(tNew,i,strTycon); ! 207: if tycFixed s andalso s <> s' ! 208: then if equalTycon(sigTycon,strTycon) ! 209: then maptyc(s,strTycon) ! 210: else condemn("bad match for fixed type spec " ! 211: ^ symName(name)) ! 212: else (case (sigTycon, strTycon) ! 213: of (TYCON{arity,kind=DATAtyc dcons,...}, ! 214: TYCON{arity=arity',kind=DATAtyc dcons',...}) => ! 215: if arity = arity' ! 216: andalso length(dcons) = length(dcons') ! 217: then maptyc(s,strTycon) ! 218: else condemn("mismatching datatype spec: " ! 219: ^ symName(name)) ! 220: | (TYCON{kind=DATAtyc _,...}, _) => ! 221: condemn("unmatched datatype spec: "^symName(name)) ! 222: | (TYCON{arity,kind=ABStyc,eq,...}, _) => ! 223: if arity <> tyconArity(strTycon) ! 224: then condemn("mismatching tycon arities: " ! 225: ^ symName(name)) ! 226: else if (!eq=YES) andalso not(isEqTycon(strTycon)) ! 227: then condemn("mismatched eqtype spec: " ! 228: ^ symName(name)) ! 229: else maptyc(s,strTycon) ! 230: | _ => impossible "realizex/checkSpec/TYCbind"); ! 231: nil ! 232: end ! 233: | CONbind(DATACON{name,typ,rep=VARIABLE _,const,...}) => ! 234: let val DATACON{typ=typ',rep=VARIABLE(access),...} = ! 235: lookCONlocal name ! 236: handle Unbound => ! 237: condemn ("unmatched exception spec: "^symName(name)) ! 238: | Bind => ! 239: condemn ("unmatched exception spec: "^symName(name)) ! 240: in compareTypes(typeInContext(!typ,newenv),!typ',name); ! 241: [VALtrans access] ! 242: end ! 243: | CONbind(DATACON{name,typ,...}) => ! 244: let val DATACON{typ=typ',...} = ! 245: lookCONlocal name ! 246: handle Unbound => ! 247: condemn ("unmatched data constructor spec: " ! 248: ^symName(name)) ! 249: in compareTypes(typeInContext(!typ,newenv),!typ',name); ! 250: nil ! 251: end ! 252: | VARbind(VALvar{name=[id],typ,...}) => ! 253: (case (lookVARCONlocal id ! 254: handle Unbound => ! 255: condemn("unmatched val spec: "^symName(id))) ! 256: of VARbind(VALvar{access,typ=typ',...}) => ! 257: (* no propagation of INLINE access!! *) ! 258: (compareTypes(typeInContext(!typ,newenv),!typ',id); ! 259: [case access of INLINE _ => VALtrans access ! 260: | PATH _ => VALtrans access ! 261: | LVAR _ => ! 262: if !ErrorMsg.anyErrors ! 263: then VALtrans access ! 264: else impossible "sigmatch.1" ! 265: | _ => impossible "sigmatch.2"]) ! 266: | CONbind(dcon as DATACON{typ=typ',...}) => ! 267: (compareTypes(typeInContext(!typ,newenv),!typ',id); ! 268: [CONtrans dcon]) ! 269: | _ => impossible "sigmatch.476") ! 270: | _ => nil (* nonchecked binding (FIXbind) *) ! 271: fun checkList (a::rest) = ! 272: (checkSpec a handle Syntax => nil) @ checkList rest ! 273: | checkList nil = nil ! 274: ! 275: val _ = update(sNew,0,parent) (* define parent before checking specs *) ! 276: val _ = update(sNew,1,param) (* ditto for param *) ! 277: val trans = checkList bindings ! 278: val _ = Sharing.checkSharing(table,newenv,share) ! 279: val str = if abs then abstract(sgn,newstr,stamps) else newstr ! 280: in mapstr1(boundStamp,str); ! 281: linkParents str; (* should be redundant *) ! 282: (str, trans) ! 283: end ! 284: | realizex _ _ _ = impossible "783 in sigmatch" ! 285: ! 286: val defaultMapfns = ! 287: let fun ignore _ = () ! 288: in {mapstr=ignore,mapstr1=ignore,maptyc=ignore} ! 289: end ! 290: ! 291: val match0 = matchx NULLstr ! 292: val match = matchx NULLstr defaultMapfns ! 293: val realize = realizex NULLstr defaultMapfns ! 294: ! 295: end (* structure SigMatch *)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.