![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to sharing.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 sharing.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / typing |
1.1 root 1: (* Copyright 1989 by AT&T Bell Laboratories *)
2: (* sharing.sml *)
3:
4: structure Sharing : SHARING =
5: struct
6:
7: structure Basics = Basics
8:
9: open ErrorMsg PrintUtil Basics EnvAccess TypesUtil
10:
11: (* a couple of useful iterators *)
12:
13: fun for a b = app b a
14:
15: fun upto (start,finish) f =
16: let fun loop i = if i>=finish then () else (f i; loop(i+1))
17: in loop start
18: end
19:
20: fun getStr([],str) = str
21: | getStr(id::rest,STRstr{table,env,...}) =
22: let val STRvar{binding,...} = lookSTRinTable(table,id)
23: val str = case (binding,env)
24: of (INDstr i,REL{s,...}) => s sub i
25: | (SHRstr(i::r),REL{s,...}) => getEpath(r, s sub i)
26: | (STRstr _, _) => binding
27: | _ => impossible "Sharing.getStr"
28: in getStr(rest,str)
29: end
30: handle Env.UnboundTable =>
31: condemn("unbound structure id in sharing specification: "
32: ^ Symbol.name id)
33:
34: fun findStr(id::rest,table,env) : Structure =
35: (let val STRvar{binding,...} = lookSTRinTable(table,id)
36: val str = case (binding,env)
37: of (INDstr i,REL{s,...}) => s sub i
38: | (SHRstr(i::r),REL{s,...}) => getEpath(r,s sub i)
39: | (STRstr _, _) => binding
40: | _ => impossible "Sharing.findStr"
41: in getStr(rest,str)
42: end
43: handle Env.UnboundTable => (* look for global structure *)
44: let val STRvar{binding,...} =
45: lookSTR(id) handle Env.Unbound =>
46: condemn("unbound structure id in sharing specification: "
47: ^ Symbol.name id)
48: in getStr(rest,binding)
49: end)
50: | findStr([],_,_) = impossible "Sharing.findStr with empty path"
51:
52: fun findTycon(path,table,env) : tycon =
53: let val (id::rpath) = rev path
54: in case rev rpath
55: of [] => ((case !(lookTYCinTable(table,id))
56: of INDtyc i =>
57: (case env
58: of REL{t,...} => t sub i
59: | DIR => impossible "Sharing.findTycon")
60: | SHRtyc p => getEpathTyc(p,env)
61: | tyc => tyc)
62: handle Env.UnboundTable =>
63: !(lookTYC id)
64: handle Env.Unbound =>
65: condemn("unbound type in sharing spec: "^ Symbol.name id))
66: | path' => !(lookTYCinStr(findStr(path',table,env),id))
67: end
68: (*
69: fun sameStructure(STRstr{env,...}, STRstr{env=env',...}) = (env = env')
70: | sameStructure _ = false
71:
72: (* similar to ModUtil.resetParent except for sameStructure test --
73: would ModUtil.resetParent suffice? *)
74: fun resetParent (newparent: Structure, oldparent: Structure) =
75: fn (STRstr{env=REL{s,...},...}) =>
76: ((case s sub 0
77: of NULLstr => update(s,0,newparent)
78: | _ => if sameStructure(s sub 0, oldparent)
79: then update(s,0,newparent)
80: else ())
81: handle Subscript => ())
82: | NULLstr => ()
83: | _ => impossible "Sharing.resetParent"
84: *)
85: fun doSharing(table,env as REL{s=senv,t=tenv},{strStamps,tycStamps},
86: {s=strShare,t=typeShare}) =
87: let fun freeStrStamp s = not(Stampset.member(s,strStamps))
88: fun freeTycStamp s = not(Stampset.member(s,tycStamps))
89: val {assoc,getassoc,union,find} = Siblings.new(freeStrStamp)
90: : Structure Siblings.siblingClass
91: val {union=tunion,find=tfind} = Unionfind.new(freeTycStamp)
92:
93: fun strMerge(p' as STRstr{stamp=p,...}, q' as STRstr{stamp=q,...}) =
94: if (assoc(p,p'); find p) = (assoc(q,q'); find q)
95: then ()
96: else let val pclass = getassoc p
97: and qclass = getassoc q
98: in union(p,q);
99: for pclass (fn x =>
100: for qclass (fn y =>
101: sMerge(x,y)))
102: end
103:
104: and sMerge(str1 as STRstr{stamp=s1,kind=k1,env=REL{s=senv1,t=tenv1,...},...},
105: str2 as STRstr{stamp=s2,kind=k2,
106: env=env2 as REL{s=senv2,t=tenv2,...},
107: table,...}) =
108: case (k1,k2)
109: of (STRkind _, STRkind _) =>
110: if s1 = s2
111: then ()
112: else condemn "sharing constraint - \
113: \incompatible fixed structures"
114: | (STRkind _, SIGkind _) => sMerge(str2,str1)
115: | (SIGkind{bindings,...}, _) =>
116: for bindings
117: (fn STRbind(STRvar{name=[id],binding,...}) =>
118: (let val STRvar{binding=target,...} =
119: lookSTRinTable(table,id)
120: in strMerge((case binding
121: of INDstr i => senv1 sub i
122: | _ => binding),
123: (case target
124: of INDstr i => senv2 sub i
125: | SHRstr(i::r) => getEpath(r,senv2 sub i)
126: | _ => target))
127: end
128: handle Env.UnboundTable => ())
129: | TYCbind(ref tycon) =>
130: (let val tyc1 = case tycon
131: of INDtyc i => tenv1 sub i
132: | _ => tycon
133: val tyc2 =
134: case !(lookTYCinTable(table,tycName tyc1))
135: of INDtyc i => tenv2 sub i
136: | SHRtyc p => getEpathTyc(p,env2)
137: | tyc => tyc
138: in tunion(tycStamp tyc1,tycStamp tyc2);
139: ()
140: end
141: handle Env.UnboundTable => ())
142: | _ => ())
143:
144: fun shareSig(REL{s,t}) =
145: (upto (2, Array.length s) (fn i =>
146: let val str as STRstr{stamp,sign,table,env as REL{s=s',...},kind} =
147: s sub i
148: in case kind
149: of SIGkind _ =>
150: let val stamp' = find stamp
151: in if stamp' = stamp
152: then ()
153: else let val new =
154: STRstr{stamp=stamp',sign=sign,
155: table=table,
156: env=env,kind=kind}
157: in update(s,i,new);
158: ArrayExt.app(ModUtil.resetParent new,s',1)
159: end;
160: shareSig env
161: end
162: | STRkind _ => impossible "Sharing.doSharing.shareSig"
163: end);
164: upto (0,Array.length t) (fn i =>
165: let val tycon = t sub i
166: val stamp = tycStamp tycon
167: val stamp' = tfind stamp
168: in if stamp = stamp'
169: then ()
170: else update(t,i,setTycStamp(stamp',tycon))
171: end))
172:
173: val strPathPairs = ref [] : (spath*spath) list ref
174: val typePathPairs = ref [] : (spath*spath) list ref
175:
176: in for strShare (fn p as (p1,p2) =>
177: let val str1 as STRstr{stamp=s1,...} = findStr(p1,table,env)
178: and str2 as STRstr{stamp=s2,...} = findStr(p2,table,env)
179: in if freeStrStamp s1 orelse freeStrStamp s2 then ()
180: else strPathPairs := p :: !strPathPairs;
181: strMerge(str1,str2)
182: end);
183: for typeShare (fn p as (p1,p2) =>
184: let val s1 = tycStamp(findTycon(p1,table,env))
185: and s2 = tycStamp(findTycon(p2,table,env))
186: in if freeTycStamp(s1) orelse freeTycStamp(s2)
187: then ()
188: else typePathPairs := p :: !typePathPairs;
189: tunion(s1,s2)
190: end);
191: shareSig env;
192: {s= !strPathPairs, t= !typePathPairs}
193: end (* doSharing *)
194:
195: fun checkSharing(table,env,{s=strShare,t=typeShare}) =
196: (for strShare (fn p as (p1,p2) =>
197: let val STRstr{stamp=s1,...} = findStr(p1,table,env)
198: and STRstr{stamp=s2,...} = findStr(p2,table,env)
199: in if s1 <> s2
200: then condemn "structure sharing violation"
201: else ()
202: end);
203: for typeShare (fn (p1,p2) =>
204: let val tyc1 = findTycon(p1,table,env)
205: and tyc2 = findTycon(p2,table,env)
206: in if equalTycon(tyc1,tyc2)
207: then ()
208: else (PrintType.printTycon tyc1; print "\n"; (* DEBUGGING *)
209: PrintType.printTycon tyc2; print "\n"; (* DEBUGGING *)
210: condemn "type sharing violation")
211: end))
212:
213: end (* structure Sharing *)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.