![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to env.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 env.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 Env : ENV = ! 3: struct ! 4: open PrintUtil ErrorMsg Symbol Access (* also uses: IntStrMap, Basics *) ! 5: type binding = Basics.binding ! 6: ! 7: type info = {path: int list, strenv: Basics.strenv} ! 8: type symtable = binding IntStrMap.intstrmap ! 9: type key = int * string ! 10: ! 11: val debugLook = System.Control.debugLook ! 12: val debugCollect = System.Control.debugCollect ! 13: ! 14: val defaultInfo = {path = []:int list, strenv = Basics.DIR} ! 15: ! 16: fun name(_,s) = s ! 17: ! 18: exception Unbound ! 19: and Unboundrec ! 20: exception UnboundTable = System.Unsafe.Assembly.UnboundTable ! 21: ! 22: datatype 'a locality = LOCAL of 'a | GLOBAL of 'a ! 23: ! 24: datatype env ! 25: = TBL of ! 26: {info: info, table: symtable, prev: env ref, isopen: bool} ! 27: | REC of env ref ! 28: | STR of env ref ! 29: | NIL ! 30: ! 31: fun prevEnv(TBL{prev,...}) = prev ! 32: | prevEnv(REC prev) = prev ! 33: | prevEnv(STR prev) = prev ! 34: | prevEnv _ = impossible "prevEnv" ! 35: ! 36: fun printEnv(TBL{prev,...}) = (print "TBL\n "; printEnv(!prev)) ! 37: | printEnv(REC prev) = (print "REC\n "; printEnv(!prev)) ! 38: | printEnv(STR prev) = (print "STR\n "; printEnv(!prev)) ! 39: | printEnv(NIL) = () ! 40: ! 41: fun printEnvs(e) = (print "Env:\n "; printEnv e) ! 42: ! 43: fun eqEnv(NIL,NIL) = true ! 44: | eqEnv(REC r, REC r') = r = r' ! 45: | eqEnv(STR r, STR r') = r = r' ! 46: | eqEnv(TBL{prev=r,...}, TBL{prev=r',...}) = r = r' ! 47: | eqEnv _ = false ! 48: ! 49: fun appenv f (newenv,oldenv) = ! 50: let fun loop env = ! 51: if eqEnv(env,oldenv) ! 52: then () ! 53: else case env ! 54: of TBL{table,prev=ref env',...} => (IntStrMap.app f table; loop env') ! 55: | REC(ref env') => loop env' ! 56: | STR(ref env') => loop env' ! 57: | NIL => () ! 58: in loop newenv ! 59: end ! 60: ! 61: (* the global variable containing the current environment *) ! 62: val env = ref(NIL) ! 63: fun current() = !env ! 64: ! 65: fun closeCurrentNewEnv() = ! 66: case current() ! 67: of TBL{info,table,prev,isopen=true} => ! 68: TBL{info=info,table=table,prev=prev,isopen=false} ! 69: | _ => impossible "Env.closeCurrentNewEnv()" ! 70: ! 71: fun newTable() = IntStrMap.new(32, UnboundTable) : symtable ! 72: ! 73: fun openOld (info: info, table: symtable) : unit = ! 74: env := TBL{info=info, table=table, prev=ref(!env), isopen=false} ! 75: ! 76: fun openNew (info: info, table: symtable) : unit = ! 77: env := TBL{info=info, table=table, prev=ref(!env), isopen=true} ! 78: ! 79: fun openRec () : unit = ! 80: env := REC(ref(!env)) ! 81: ! 82: fun openStr () : unit = ! 83: env := STR(ref(!env)) ! 84: ! 85: fun popSTR(STR(ref e)) = e ! 86: | popSTR(TBL{prev=ref e,...}) = popSTR e ! 87: | popSTR(REC(ref e)) = popSTR e ! 88: | popSTR NIL = impossible "popSTR" ! 89: ! 90: fun closeStr () = env := popSTR(!env) ! 91: ! 92: fun openScope () : env = ! 93: let val oldenv = !env ! 94: in env := TBL{info=defaultInfo,table=newTable(),prev=ref oldenv,isopen=true}; ! 95: oldenv ! 96: end ! 97: ! 98: fun resetEnv (e) = env := e ! 99: ! 100: fun add (binder) = ! 101: case !env ! 102: of TBL{table,isopen=true,...} => IntStrMap.add table binder ! 103: | e => ! 104: let val table = newTable() : symtable ! 105: in IntStrMap.add table binder; ! 106: env := TBL{info=defaultInfo,table=table,prev=ref e,isopen=true} ! 107: end ! 108: ! 109: fun collectTable (collector) = ! 110: let fun save (REC(ref e)) = save e ! 111: | save (TBL{info,table,prev=ref e,...}) = ! 112: (save e; ! 113: IntStrMap.app (fn (binder) => collector(binder,info)) table) ! 114: | save (STR(ref e)) = env := e ! 115: | save _ = impossible "Env.collectTable.save" ! 116: in save(!env) ! 117: end ! 118: ! 119: fun splice (local':env, in':env) = ! 120: (* remove bindings between env in' and env local' *) ! 121: prevEnv(in') := local' ! 122: ! 123: fun lookEnv (e:env, (key: key)) = ! 124: let fun look1 (TBL{info,table,prev=ref e,...}) = ! 125: ((IntStrMap.map table key, info) ! 126: handle UnboundTable => look1 e) ! 127: | look1 (REC(ref e)) = look1 e ! 128: | look1 (STR(ref e)) = look1 e ! 129: | look1 NIL = ! 130: (ErrorMsg.flaggedmsg debugLook ! 131: ("lookEnv failed (global): "^name(key)^"\n"); ! 132: raise Unbound) ! 133: in look1(e) ! 134: end ! 135: ! 136: fun look k = lookEnv (!env, k) ! 137: ! 138: fun lookStrLocal (key: key) = ! 139: let fun look1 (TBL{info,table,prev=ref e,...}) = ! 140: ((IntStrMap.map table key, info) ! 141: handle UnboundTable => look1 e) ! 142: | look1 (REC(ref e)) = look1 e ! 143: | look1 (STR(ref e)) = ! 144: (ErrorMsg.flaggedmsg debugLook ! 145: ("lookStrLocal failed (structure): "^name(key)^"\n"); ! 146: raise Unbound) ! 147: | look1 NIL = ! 148: (ErrorMsg.flaggedmsg debugLook ! 149: ("lookStrLocal failed (global): "^name(key)^"\n"); ! 150: raise Unbound) ! 151: in look1(!env) ! 152: end ! 153: ! 154: fun lookRec (key : key) = ! 155: (* searches global env for index id ! 156: marks result as LOCAL or GLOBAL depending on whether binding is ! 157: found within rec boundary or not ! 158: used for initial var/con lookup in expressions (namespace=0) *) ! 159: let fun look1 (TBL{info,table,prev=ref e,...}) = ! 160: (LOCAL(IntStrMap.map table key, info) ! 161: handle UnboundTable => look1 e) ! 162: | look1 (REC(ref e)) = ! 163: (GLOBAL(lookEnv(e,key)) ! 164: handle Unbound => raise Unboundrec) ! 165: | look1 (STR(ref e)) = look1 e ! 166: | look1 NIL = ! 167: (ErrorMsg.flaggedmsg debugLook ! 168: ("lookRec failed : "^name(key)^"\n"); ! 169: raise Unbound) ! 170: in look1(!env) ! 171: end ! 172: ! 173: fun lookRecLocal (key: key) = ! 174: (* searches global env upto nearest rec boundary ! 175: used when attempting to patch variables in expressions *) ! 176: let fun look1 (TBL{info,table,prev=ref e,...}) = ! 177: ((IntStrMap.map table key, info) ! 178: handle UnboundTable => look1 e) ! 179: | look1 (REC(ref e)) = raise Unboundrec ! 180: | look1 (STR(ref e)) = look1 e ! 181: | look1 NIL = raise Unbound ! 182: in look1(!env) ! 183: end ! 184: ! 185: (* environment management for toplevel loop *) ! 186: val restoreEnv : env ref = ref NIL ! 187: fun restore () = resetEnv(!restoreEnv) ! 188: fun commit () = restoreEnv := openScope() ! 189: fun previous () = !restoreEnv ! 190: ! 191: (* consolidating adjacent open tables *) ! 192: fun consolidateEnv(e as TBL{table,prev=ref(pre),isopen=true,...}) = ! 193: (case pre ! 194: of TBL{isopen=true,...} => ! 195: let val ans as (_, adder) = consolidateEnv pre ! 196: in IntStrMap.app adder table; ans ! 197: end ! 198: | _ => (e,IntStrMap.add table)) ! 199: | consolidateEnv(e) = (e,(fn x => ())) ! 200: ! 201: fun consolidate () = ! 202: env := let val (x,_) = consolidateEnv(!env) in x end ! 203: ! 204: fun foldEnv (f: env * 'a -> 'a) (newenv:env) (oldenv:env) (base:'a) : 'a = ! 205: if eqEnv(newenv,oldenv) ! 206: then base ! 207: else f(newenv, foldEnv f (!(prevEnv newenv)) oldenv base) ! 208: ! 209: fun collectEnv(newenv, oldenv) = ! 210: foldEnv (fn (TBL{table,...},acc) => ! 211: (IntStrMap.app (IntStrMap.add acc) table; acc) ! 212: | (REC _,acc) => acc ! 213: | (STR _,acc) => acc ! 214: | (NIL,acc) => acc ! 215: ) newenv oldenv (newTable()) ! 216: ! 217: fun reset() = (env := NIL; restoreEnv := NIL) ! 218: ! 219: fun popModule(oldenv:env): symtable = ! 220: (* Extract prefix of environment above oldenv (corresponding ! 221: to module bindings). oldenv will normally be pervasiveEnv. ! 222: Then reset env to savedEnv. *) ! 223: collectEnv(!env,oldenv) ! 224: ! 225: end (* EnvFunc *)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.