![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to envaccess.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 / env|
Return to envaccess.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / env |
1.1 ! root 1: (* Copyright 1989 by AT&T Bell Laboratories *) ! 2: structure EnvAccess : ENVACCESS = struct ! 3: (* lookup and binding functions *) ! 4: ! 5: structure Access = Access ! 6: structure Basics = Basics ! 7: structure Env = Env ! 8: ! 9: open ErrorMsg PrintUtil Access Basics Basics.Symbol BasicTypes TypesUtil Env ! 10: NameSpace ! 11: ! 12: val debugBind = System.Control.debugBind ! 13: ! 14: fun openStructureVar(STRvar{access=PATH p,binding,...}) = ! 15: (case binding ! 16: of STRstr{table,env,...} => openOld({path=p,strenv=env},table) ! 17: | INDstr _ => impossible "EnvAccess.openStructureVar -- INDstr arg" ! 18: | SHRstr _ => impossible "EnvAccess.openStructureVar -- SHRstr arg" ! 19: | NULLstr => impossible "EnvAccess.openStructureVar -- NULLstr arg") ! 20: | openStructureVar _ = impossible "EnvAccess.openStructureVar -- bad access value" ! 21: ! 22: val bogusID = Symbol.symbol "bogus" ! 23: ! 24: val bogusStrStamp = Stampset.newStamp(Stampset.fixedStrStamps) ! 25: ! 26: local val b = STRstr{stamp=bogusStrStamp, sign=0, table=newTable(), env=DIR, ! 27: kind=STRkind{path=[bogusID]}} ! 28: in val bogusSTR = STRvar{name=[bogusID], access=PATH[0], binding=b} ! 29: val bogusSTR' = STRvar{name=[bogusID], access=SLOT 0, binding=b} ! 30: end ! 31: ! 32: (* type constructors *) ! 33: ! 34: val bogusTyc = mkDEFtyc([bogusID],TYFUN{arity=0,body=ERRORty},YES,Stampset.globalStamps) ! 35: ! 36: fun lookTYCinTable(table,id) = ! 37: let val TYCbind tycref = IntStrMap.map table (tycKey id) ! 38: in tycref ! 39: end ! 40: ! 41: fun lookTYCinStr(STRstr{table,env,stamp,...}: Structure, id: symbol) : tycon ref = ! 42: ((case lookTYCinTable(table,id) ! 43: of ref(INDtyc i) => ! 44: (case env ! 45: of REL{s,t} => ref(t sub i) ! 46: | DIR => impossible "EnvAccess.lookTYCinStr 1") ! 47: | ref(SHRtyc p) => ref(getEpathTyc(p,env)) ! 48: | tyc => tyc) ! 49: handle UnboundTable => ! 50: (if stamp=bogusStrStamp then () ! 51: else complain("unbound type in structure: " ^ Symbol.name id); ! 52: ref bogusTyc)) ! 53: | lookTYCinStr _ = impossible "EnvAccess.lookTYCinStr 2" ! 54: ! 55: fun lookTYC' look (id:symbol) = ! 56: case look(tycKey(id)) ! 57: of (TYCbind(tycref as ref(INDtyc i)), {strenv=REL{s,t},path}) => ! 58: (ref(t sub i) ! 59: handle Subscript => ! 60: impossible "EnvAccess.lookTYC' 1") ! 61: | (TYCbind(tycref as ref(SHRtyc p)), {strenv,path}) => ! 62: (ref(getEpathTyc(p,strenv)) ! 63: handle Subscript => ! 64: impossible "EnvAccess.lookTYC' 2") ! 65: | (TYCbind tycref, _) => tycref ! 66: | _ => impossible "EnvAccess.lookTYC' 3" ! 67: ! 68: val lookTYC = lookTYC' look ! 69: val lookTYClocal = lookTYC' lookStrLocal ! 70: ! 71: (* addzeros also defined in Parse *) ! 72: fun addzeros(0,l) = l ! 73: | addzeros(n,l) = addzeros(n-1,0::l) ! 74: ! 75: fun bindTYC(id: symbol, tc: tycon ref) = ! 76: let val binding = TYCbind tc ! 77: in add(tycIndex id, name id, binding); binding ! 78: end ! 79: ! 80: ! 81: (* tycon lookup with arity checking *) ! 82: ! 83: fun checkArity(tycon, arity) = ! 84: if tyconArity(tycon) <> arity ! 85: then complain("type constructor "^(Symbol.name(tycName(tycon)))^ ! 86: " has wrong number of arguments: "^makestring arity) ! 87: else () ! 88: ! 89: fun lookArTYC0(id,arity) = ! 90: let val tycref as ref tyc = lookTYC id ! 91: in checkArity(tyc,arity); ! 92: tycref ! 93: end ! 94: handle Unbound => ! 95: (complain("unbound type constructor: " ^ Symbol.name id); ! 96: ref bogusTyc) ! 97: ! 98: fun lookArTYCinSig (depth: int) (id: symbol, arity: int) = ! 99: (case look(tycKey id) ! 100: of (TYCbind(tycref as ref(INDtyc i)), {strenv=REL{s,t},path=h::r}) => ! 101: if h >= 0 ! 102: then let val tyc = t sub i ! 103: in checkArity(tyc,arity); ! 104: ref tyc ! 105: end ! 106: else (checkArity(t sub i, arity); ! 107: ref(RELtyc(addzeros(depth+h,r@[i])))) ! 108: | (TYCbind(tycref as ref(SHRtyc p)), {strenv,path}) => ! 109: let val tyc = getEpathTyc(p,strenv) ! 110: in checkArity(tyc,arity); ! 111: ref tyc ! 112: end ! 113: | (TYCbind tycref, _) => (checkArity(!tycref,arity); tycref) ! 114: | _ => impossible "EnvAccess.lookTYCinSig") ! 115: handle Unbound => ! 116: (complain("unbound type constructor in signature: " ^ Symbol.name id); ! 117: ref bogusTyc) ! 118: ! 119: val lookArTYC : (symbol * int -> tycon ref) ref = ref lookArTYC0 ! 120: ! 121: ! 122: (* patching type constructor references in datatype declarations *) ! 123: ! 124: fun protectDb () = ! 125: let val patchList : tycon ref list ref = ref [] ! 126: val savedLook = !lookArTYC ! 127: fun localLook(id,ary) = ! 128: let val tycref = ref (mkUNDEFtyc(id,ary)) ! 129: in patchList := tycref :: !patchList; ! 130: tycref ! 131: end ! 132: fun patch (tc::l) = ! 133: let val ref(TYCON{path=id::_,arity,kind=UNDEFtyc newpath,...}) = tc ! 134: in let val ref tycon = !lookArTYC(id,arity) ! 135: in tc := case newpath ! 136: of NONE => tycon ! 137: | SOME path => setTycPath(path,tycon) ! 138: end ! 139: handle Unbound => ! 140: complain("unbound type constructor (in datatype): " ^ ! 141: Symbol.name id); ! 142: patch l ! 143: end ! 144: | patch nil = () ! 145: in ((fn () => lookArTYC := localLook), ! 146: (fn () => (lookArTYC := savedLook; patch(!patchList)))) ! 147: end ! 148: ! 149: (* constructors *) ! 150: ! 151: fun dconApplied(DATACON{name,const,typ,rep,sign},{path,strenv}:info) : datacon = ! 152: DATACON{name = name, const = const, sign=sign, ! 153: rep = (case rep ! 154: of VARIABLE(SLOT n) => VARIABLE(PATH(n::path)) ! 155: | VARIABLE(LVAR v) => VARIABLE(PATH [v]) ! 156: | _ => rep), (* nonexception datacon *) ! 157: typ = ref(typeInContext(!typ,strenv))} ! 158: ! 159: fun lookCONinTable(table,id) = ! 160: case IntStrMap.map table (varKey(id)) ! 161: of CONbind c => c ! 162: | _ => raise UnboundTable ! 163: ! 164: fun lookCON' lookfn id = ! 165: case lookfn(varKey(id)) ! 166: of (CONbind c,info) => dconApplied(c,info) ! 167: | _ => raise Unbound ! 168: ! 169: val lookCON = lookCON' look ! 170: val lookCONlocal = lookCON' lookStrLocal ! 171: ! 172: val bogusCON = DATACON{name=bogusID,const=true,typ=ref ERRORty, ! 173: rep=UNDECIDED,sign=[]} ! 174: ! 175: fun lookCONinStr(STRstr{table,env,stamp,...},id,ap,qid): datacon = ! 176: (dconApplied(lookCONinTable(table,id),{path=ap,strenv=env}) ! 177: handle UnboundTable => ! 178: (if stamp=bogusStrStamp then () ! 179: else complain("unbound constructor in structure: " ^ Symbol.name id); ! 180: bogusCON)) ! 181: | lookCONinStr _ = impossible "EnvAccess.lookCONinStr" ! 182: ! 183: fun bindCON (id: symbol, c: datacon) = ! 184: let val binding = CONbind c ! 185: in add(conIndex id, name id, binding); binding ! 186: end ! 187: ! 188: (* variables *) ! 189: ! 190: fun unboundVAR id = (complain ("unbound variable " ^ name id); ! 191: VARbind(mkVALvar(id, ref(VARty(mkTyvar defaultMETA))))) ! 192: ! 193: fun varApplied(v: var, {path, strenv}: info, qid) : var = ! 194: case v ! 195: of VALvar{access,name,typ} => ! 196: VALvar{access = ! 197: (case access ! 198: of SLOT(n) => PATH(n::path) ! 199: | LVAR(n) => PATH([n]) ! 200: | INLINE _ => access ! 201: | PATH _ => impossible "varApplied: access = PATH"), ! 202: typ = ! 203: if Prim.special(access) ! 204: then ref(!typ) ! 205: else (case path ! 206: of [] => typ ! 207: | _ => ref(typeInContext(!typ,strenv))), ! 208: name = qid} ! 209: | _ => v ! 210: ! 211: fun lookVARinTable(table, id) = ! 212: case IntStrMap.map table (varKey id) ! 213: of VARbind v => v ! 214: | _ => raise UnboundTable ! 215: ! 216: fun lookVARCONinTable(table,id) = IntStrMap.map table (varKey id) ! 217: ! 218: fun lookVARCONinStr(STRstr{table,env,stamp,...},id,ap,qid): binding = ! 219: ((case lookVARCONinTable(table,id) ! 220: of VARbind(var) => VARbind(varApplied(var,{path=ap,strenv=env},qid)) ! 221: | CONbind(dcon) => CONbind(dconApplied(dcon,{path=ap,strenv=env})) ! 222: | _ => impossible "EnvAccess.lookVARCONinStr 1") ! 223: handle UnboundTable => ! 224: (if stamp=bogusStrStamp then () ! 225: else complain("unbound variable or constructor in structure: " ! 226: ^ Symbol.name id); ! 227: CONbind bogusCON)) ! 228: | lookVARCONinStr(NULLstr,id,_,_) = ! 229: (printSym id; print "\n"; impossible "EnvAccess.lookVARCONinStr 2") ! 230: | lookVARCONinStr(_,id,_,_) = ! 231: (printSym id; print "\n"; impossible "EnvAccess.lookVARCONinStr 3") ! 232: ! 233: fun lookVARCON id = ! 234: case lookRec(varKey id) ! 235: of LOCAL(VARbind v, info) => VARbind(varApplied(v,info,[id])) ! 236: | LOCAL(CONbind d, info) => CONbind(dconApplied(d,info)) ! 237: | GLOBAL(CONbind d, info) => CONbind(dconApplied(d,info)) ! 238: | GLOBAL(VARbind _, _) => raise Unboundrec ! 239: | _ => impossible "EnvAccess.lookVARCON" ! 240: ! 241: fun lookVARCONlocal id = ! 242: case lookStrLocal(varKey id) ! 243: of (VARbind v, info) => VARbind(varApplied(v,info,[id])) ! 244: | (CONbind d, info) => CONbind(dconApplied(d,info)) ! 245: | _ => impossible "EnvAccess.lookVARCON" ! 246: ! 247: fun lookVARRecLocal id = ! 248: case lookRecLocal(varKey id) ! 249: of (VARbind v, info) => varApplied(v,info,[id]) ! 250: | _ => impossible "EnvAccess.lookVARRecLocal" ! 251: ! 252: (* patching deferred variables *) ! 253: ! 254: val varPatchList : var ref list ref = ref nil ! 255: ! 256: fun getPatchVar id = ! 257: let val v = ref (UNKNOWNvar id) ! 258: in varPatchList := v :: !varPatchList; ! 259: v ! 260: end ! 261: ! 262: exception Patched ! 263: ! 264: fun patchVars (pl as (varRef as ref(UNKNOWNvar id))::pl', tl) = ! 265: ((varRef := lookVARRecLocal id; raise Patched) ! 266: handle Unboundrec => ! 267: patchVars(pl',varRef::tl) (* not yet bound; try later *) ! 268: | Unbound => (* no more rec layers *) ! 269: let val VARbind v = unboundVAR id ! 270: in varRef := v; patchVars(pl',tl) ! 271: end ! 272: | Patched => patchVars(pl', tl)) ! 273: | patchVars (nil, tl) = tl ! 274: | patchVars _ = impossible "EnvAccess.patchVars" ! 275: ! 276: val protectPatchList = ! 277: ((fn () => !varPatchList before (varPatchList := nil)), ! 278: (fn (vpl) => varPatchList := patchVars(!varPatchList,vpl))) ! 279: (* bug -- exit function only works right for normal exit from protect *) ! 280: ! 281: fun capitalized string = ! 282: (* string starts with a capital letter *) ! 283: let val firstchar = ordof(string,0) ! 284: in firstchar >= Ascii.uc_a andalso firstchar <= Ascii.uc_z ! 285: end ! 286: ! 287: (* Could be used to enforce the Capitalization convention, but isn't *) ! 288: fun checkBinding(id: symbol,_) = ! 289: if capitalized(Symbol.name id) ! 290: then warn("Capitalized variable in rule: "^ Symbol.name id) ! 291: else () ! 292: ! 293: ! 294: fun newVAR(bl: (symbol * var) list ref, id: symbol) : var = ! 295: let fun checkid ((i,b)::bl) = ! 296: if Symbol.eq(i,id) ! 297: then complain "repeated var in pattern" ! 298: else checkid bl ! 299: | checkid nil = () ! 300: in checkid(!bl); ! 301: let val v = mkVALvar(id,ref UNDEFty) ! 302: in bl := (id, v) :: !bl; ! 303: v ! 304: end ! 305: end ! 306: ! 307: fun bindVAR(id: symbol, v: var) = ! 308: let val binding = VARbind v ! 309: in add(varIndex id, name id, binding); binding ! 310: end ! 311: ! 312: fun bindVARs(binders: (symbol * var) list) = ! 313: app (fn b as (id,bind) => ! 314: (if !debugBind ! 315: then (print "bindVARs: "; printSym id; newline()) ! 316: else (); ! 317: bindVAR b)) ! 318: binders ! 319: ! 320: ! 321: (* type variables *) ! 322: ! 323: datatype mode = EXP | TYPEDEC ! 324: ! 325: val tyvarsMode = ref(EXP) ! 326: val boundTyvars = ref([]:tyvar list) ! 327: ! 328: fun protectTyvars NONE = ! 329: ((fn () => (!boundTyvars before (boundTyvars := []))), ! 330: (fn btv => boundTyvars := btv)) ! 331: | protectTyvars (SOME tvs) = ! 332: ((fn () => (!boundTyvars before (boundTyvars := tvs; tyvarsMode := TYPEDEC))), ! 333: (fn btv => (boundTyvars := btv; tyvarsMode := EXP))) ! 334: ! 335: fun currentTyvars () = !boundTyvars ! 336: ! 337: fun lookTYV id = ! 338: let val (TYVbind tyv, _) = lookStrLocal(tyvKey id) in tyv end ! 339: ! 340: fun lookTyvar (id: symbol) = ! 341: case !tyvarsMode ! 342: of TYPEDEC => ! 343: let fun find ((tv as ref(UBOUND{name=id',...}))::resttvs) = ! 344: if Symbol.eq(id,id') ! 345: then tv ! 346: else find(resttvs) ! 347: | find([]) = ! 348: (complain "lookTyvar -- unbound tyvar in closed scope"; ! 349: mkTyvar(INSTANTIATED UNDEFty)) ! 350: | find _ = impossible "EnvAccess.lookTyvar.find" ! 351: in find(!boundTyvars) ! 352: end ! 353: | EXP => ! 354: lookTYV id ! 355: handle Unbound => (* here we could check for weakness > 0 *) ! 356: let val tyv = mkTyvar(mkUBOUND id) ! 357: in add(tyvIndex id, name id, TYVbind tyv); ! 358: boundTyvars := tyv :: !boundTyvars; ! 359: tyv ! 360: end; ! 361: ! 362: ! 363: (* exceptions *) ! 364: ! 365: fun notInitialLowerCase string = ! 366: (* string does NOT start with lower-case alpha *) ! 367: let val firstchar = ordof(string,0) ! 368: in firstchar < Ascii.lc_a orelse firstchar > Ascii.lc_z ! 369: end ! 370: ! 371: (* Could be used to enforce the Capitalization convention *) ! 372: fun looksLikeExn sym = notInitialLowerCase(Symbol.name sym) ! 373: ! 374: fun unboundEXN id = ! 375: (complain("unbound exn: " ^ name id); bogusCON) ! 376: ! 377: fun lookEXNinStr(STRstr{table,env,stamp,...},id,ap,qid) = ! 378: (dconApplied(lookCONinTable(table,id),{path=ap,strenv=env}) ! 379: handle UnboundTable => ! 380: (if stamp=bogusStrStamp then () ! 381: else complain("unbound exception in path: " ^ Symbol.name id); ! 382: bogusCON)) ! 383: | lookEXNinStr _ = impossible "EnvAccess.lookEXNinStr" ! 384: ! 385: ! 386: (* signatures *) ! 387: ! 388: val bogusSIGStampsets = Stampset.newStampsets() ! 389: val bogusSIGbody = ! 390: STRstr{stamp=Stampset.newStamp(#strStamps bogusSIGStampsets), ! 391: sign=Stampset.newStamp(Stampset.sigStamps), ! 392: table=newTable(), ! 393: env=DIR, ! 394: kind=SIGkind{share={s=nil,t=nil}, ! 395: bindings=nil,stamps=bogusSIGStampsets}} ! 396: val bogusSIG=SIGvar{name=bogusID,binding=bogusSIGbody} ! 397: ! 398: fun lookSIG id = ! 399: let val (SIGbind sign,_) = look(sigKey id) ! 400: in sign ! 401: end ! 402: handle Unbound => (complain("unbound signature: " ^ name id); bogusSIG) ! 403: ! 404: fun bindSIG(id: symbol, s: signatureVar) = add(sigIndex id, name id, SIGbind s) ! 405: ! 406: ! 407: (* structures *) ! 408: ! 409: fun strApplied(STRvar{name,access,binding},{path=ap,strenv},qid) = ! 410: STRvar{name=qid, ! 411: binding=(case (binding,strenv) ! 412: of (INDstr i,REL{s,...}) => s sub i ! 413: | (SHRstr(i::r),REL{s,...}) => getEpath(r,s sub i) ! 414: | (STRstr _, _) => binding ! 415: | _ => impossible "strApplied: bad binding/env"), ! 416: access=(case access ! 417: of SLOT(n) => PATH(n::ap) ! 418: | LVAR(n) => PATH [n] ! 419: | _ => impossible "strApplied: access = PATH or INLINE")} ! 420: ! 421: fun lookSTRinTable(table, id) = ! 422: let val STRbind strvar = IntStrMap.map table (strKey id) in strvar end ! 423: ! 424: fun lookSTR0 id = ! 425: let val (STRbind str, info) = look(strKey id) ! 426: in (str,info) ! 427: end ! 428: ! 429: fun lookSTR' look id = ! 430: let val (STRbind str, info) = look(strKey id) ! 431: in strApplied(str,info,[id]) ! 432: end ! 433: val lookSTR = lookSTR' look ! 434: val lookSTRlocal = lookSTR' lookStrLocal ! 435: ! 436: fun lookSTRinStr(STRstr{table,env,stamp,...},id,ap,qid) = ! 437: (strApplied(lookSTRinTable(table,id),{path=ap,strenv=env},qid) ! 438: handle UnboundTable => ! 439: (if stamp=bogusStrStamp then () ! 440: else complain("unbound structure in path: " ^ Symbol.name id); ! 441: bogusSTR)) ! 442: | lookSTRinStr _ = impossible "EnvAccess.lookSTRinStr" ! 443: ! 444: fun bindSTR(id: symbol, strvar: structureVar) = ! 445: let val binding = STRbind strvar ! 446: in add(strIndex id, name id, binding); ! 447: binding ! 448: end ! 449: ! 450: ! 451: (* functors *) ! 452: ! 453: val bogusFCT = FCTvar{name=bogusID, access=PATH[0], ! 454: binding=FUNCTOR{paramName=bogusID, ! 455: param=bogusSIGbody, ! 456: body=bogusSIGbody, ! 457: paramVis=false, ! 458: stamps=Stampset.newStampsets()}} ! 459: ! 460: fun lookFCT id = ! 461: let val (FCTbind fv,_) = look(fctKey id) in fv end ! 462: handle Unbound => ! 463: (complain("unbound functor identifier: " ^ Symbol.name id); ! 464: bogusFCT) ! 465: ! 466: fun bindFCT(id: symbol, f: functorVar) = add(fctIndex id, name id, FCTbind f) ! 467: ! 468: (* fixity bindings *) ! 469: ! 470: fun lookFIX id = ! 471: if true (* !(Symbol.infixed id) *) ! 472: then let val (FIXbind(FIXvar{binding,...}),_) = look(fixKey id) ! 473: in binding ! 474: end ! 475: handle Unbound => ((* Symbol.infixed id := false; *) NONfix) ! 476: else NONfix ! 477: ! 478: fun bindFIX(id: symbol, f: fixityVar) = ! 479: let val binding = FIXbind f ! 480: in add(fixIndex id, name id, binding); binding ! 481: end ! 482: ! 483: (* lookup using symbolic path *) ! 484: fun lookPathinStr ! 485: (str: Structure, ap: Access.path, spath as _::rest : symbol list, ! 486: lookLast: Structure * symbol * Access.path * symbol list -> 'a) : 'a = ! 487: let fun getStr([id],str,ap) = lookLast(str,id,ap,spath) ! 488: | getStr(id::rest,STRstr{table,stamp,env,...},ap) = ! 489: let val STRvar{access=SLOT n,binding,...} = ! 490: lookSTRinTable(table,id) ! 491: handle UnboundTable => ! 492: (if stamp=bogusStrStamp then () ! 493: else (complain("unbound intermediate structure: " ! 494: ^ name id); ! 495: print " in path: "; ! 496: printSequence "." printSym spath; ! 497: newline()); ! 498: bogusSTR') ! 499: in getStr(rest, ! 500: (case binding ! 501: of INDstr i => ! 502: (case env ! 503: of REL{s,...} => s sub i ! 504: | DIR => impossible "lookPathinStr.getStr 1") ! 505: | SHRstr(i::r) => ! 506: (case env ! 507: of REL{s,...} => getEpath(r,s sub i) ! 508: | DIR => impossible "lookPathinStr.getStr 2") ! 509: | _ => binding), ! 510: n::ap) ! 511: end ! 512: | getStr _ = impossible "EnvAccess.lookPathinStr.getStr" ! 513: in getStr(rest,str,ap) ! 514: end ! 515: | lookPathinStr _ = impossible "EnvAccess.lookPathinStr" ! 516: ! 517: fun lookPath(spath as first::rest, ! 518: lookLast: Structure * symbol * Access.path * symbol list -> 'a) : 'a = ! 519: let val STRvar{access=PATH(ap),binding,...} = ! 520: lookSTR first ! 521: handle Unbound => ! 522: (complain("unbound head structure: " ^ name first); ! 523: print " in path: "; printSequence "." printSym spath; ! 524: newline(); ! 525: bogusSTR) ! 526: in lookPathinStr(binding,ap,spath,lookLast) ! 527: end ! 528: | lookPath _ = impossible "EnvAccess.lookPath" ! 529: ! 530: ! 531: fun lookPathArTYC0 (path: symbol list, arity: int) = ! 532: let val tycref as ref tyc = lookPath(path, fn(str,id,_,_) => lookTYCinStr(str,id)) ! 533: in checkArity(tyc,arity); ! 534: tycref ! 535: end ! 536: ! 537: (* debug print functions *) ! 538: val prIntPath = printClosedSequence ("[",",","]") (print:int->unit) ! 539: fun prSymPath spath = printSequence "." printSym (rev spath) ! 540: ! 541: fun lookPathArTYCinSig (depth: int) (spath as first::rest, arity) : tycon ref = ! 542: let fun complainUnbound() = ! 543: (complain "unbound type constructor in signature"; ! 544: print " name: "; printSequence "." printSym spath; ! 545: newline(); ! 546: raise Syntax) ! 547: (* second arg of get is expected to be a signature *) ! 548: fun get([id],STRstr{table,env as REL{t,...},...}) = ! 549: (case lookTYCinTable(table,id) ! 550: handle UnboundTable => complainUnbound() ! 551: of ref(INDtyc i) => (checkArity(t sub i, arity); [i]) ! 552: | ref(SHRtyc p) => (checkArity(getEpathTyc(p,env), arity); p) ! 553: | _ => impossible "lookPathArTYCinSig.get") ! 554: | get(id::rest,STRstr{table,env=REL{s,...},...}) = ! 555: let val STRvar{binding=INDstr k,...} = ! 556: lookSTRinTable(table,id) ! 557: handle UnboundTable => complainUnbound() ! 558: in k::get(rest, s sub k) ! 559: end ! 560: | get([],_) = impossible "EnvAccess.lookPathArTYCinSig.get - empty path" ! 561: | get(p,NULLstr) = ! 562: (prSymPath p; print "\n"; ! 563: impossible "EnvAccess.lookPathArTYCinSig.get - NULLstr") ! 564: | get(p,INDstr _) = ! 565: (prSymPath p; print "\n"; ! 566: impossible "EnvAccess.lookPathArTYCinSig.get - INDstr") ! 567: | get(p,SHRstr _) = ! 568: (prSymPath p; print "\n"; ! 569: impossible "EnvAccess.lookPathArTYCinSig.get - SHRstr") ! 570: | get _ = impossible "EnvAccess.lookPathArTYCinSig.get - bad args" ! 571: fun lookInStr(str) = ! 572: let val tycref = ! 573: lookPathinStr(str, [], spath, ! 574: (fn(str,id,_,_) => lookTYCinStr(str,id))) ! 575: in checkArity(!tycref,arity); ! 576: tycref ! 577: end ! 578: val leadStr = lookSTR0 first ! 579: handle Unbound => complainUnbound() ! 580: in case leadStr ! 581: of (STRvar{binding=INDstr i,...},{path=h::r,strenv=REL{s,...}}) => ! 582: if h < 0 (* indicates signature component *) ! 583: then ref(RELtyc(addzeros(depth+h,r@(i::get(rest, s sub i))))) ! 584: else lookInStr(s sub i) ! 585: | (STRvar{binding=SHRstr(i::r),...},{strenv=REL{s,...},...}) => ! 586: lookInStr(getEpath(r, s sub i)) ! 587: | (STRvar{binding as STRstr _,...},_) => lookInStr binding ! 588: | _ => impossible "EnvAccess.lookPathArTYCinSig - leadStr" ! 589: end ! 590: | lookPathArTYCinSig _ _ = impossible "lookPathArTYCinSig - bad arg" ! 591: ! 592: val lookPathArTYC = ref lookPathArTYC0 ! 593: ! 594: ! 595: (* functions to collect stale lvars for unbinding *) ! 596: exception LOOKLVAR ! 597: ! 598: fun lookLvar (env: env) (key: int * string) = ! 599: case lookEnv(env,key) ! 600: of (VARbind(VALvar{access=LVAR v,...}),_) => v ! 601: | (STRbind(STRvar{access=LVAR v,...}),_) => v ! 602: | (FCTbind(FCTvar{access=LVAR v,...}),_) => v ! 603: | _ => raise LOOKLVAR ! 604: ! 605: fun runbound index = ! 606: case index mod namespaces ! 607: of 0 => true (* var *) ! 608: | 4 => true (* structure *) ! 609: | 5 => true (* functor *) ! 610: | _ => false ! 611: ! 612: fun staleLvars(newenv,oldenv) : int list = ! 613: let val lvarset = ref([] : int list) ! 614: val get = lookLvar oldenv ! 615: fun collect (i,s,_) = ! 616: if runbound i ! 617: then (lvarset := get(i,s) :: !lvarset) ! 618: handle LOOKLVAR => () ! 619: | Unbound => () ! 620: else () ! 621: in appenv collect (newenv,oldenv); ! 622: !lvarset ! 623: end ! 624: ! 625: (* reset state of EnvAccess *) ! 626: fun reset() = ! 627: (varPatchList := nil; ! 628: boundTyvars := []; ! 629: tyvarsMode := EXP) ! 630: ! 631: end (* structure EnvAccess *)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.