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