![[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.