![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to sigmatch.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 sigmatch.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / typing |
1.1 root 1: (* Copyright 1989 by AT&T Bell Laboratories *)
2: (* sigmatch.sml *)
3:
4: structure SigMatch : SIGMATCH = struct
5:
6: structure Basics = Basics
7:
8: open List2 PrintUtil ErrorMsg Access Stampset Basics BareAbsyn BasicTypes
9: EnvAccess EnvAccess.Env TypesUtil PrintType ModUtil
10:
11: (* debug print functions *)
12: val prIntPath = printClosedSequence ("[",",","]") (print:int->unit)
13: fun prSymPath spath = printSequence "." printSym (rev spath)
14:
15: val symName = Symbol.name
16: val anonName = Symbol.symbol "Anon"
17: fun for a b = app b a
18:
19: exception CompareTypes
20: exception REFtyc
21: val refstamp = tycStamp(!refTycon)
22: and arraystamp = tycStamp(!arrayTycon)
23:
24: fun compType(specty, specsign:polysign, actty, actsign:polysign, actarity): unit =
25: let val env = array(actarity,UNDEFty)
26: fun comp(ty1, VARty(ref(INSTANTIATED(ty2)))) =
27: comp(ty1,ty2)
28: | comp(ty1, FLEXRECORDty(ref(CLOSED ty2))) = comp(ty1,ty2)
29: | comp(ty1, VARty(ref(IBOUND i))) =
30: (case env sub i
31: of UNDEFty =>
32: let val {weakness=aw,eq=ae} = nth(actsign,i)
33: in if aw < infinity
34: then let fun checkweak(VARty(ref(IBOUND n))) =
35: let val {weakness=sw,...} = nth(specsign,n)
36: in if sw > aw then raise CompareTypes
37: else ()
38: end
39: | checkweak(CONty(_,args)) = app checkweak args
40: | checkweak _ = impossible "compType/checkweak"
41: in checkweak ty1
42: end
43: else ();
44: if ae
45: then checkEqTySig(ty1,specsign)
46: handle CHECKEQ => raise CompareTypes
47: else ();
48: update(env,i,ty1)
49: end
50: | ty => if equalType(ty1,ty)
51: then ()
52: else raise CompareTypes)
53: | comp(ty1 as CONty(ref tycon, args), ty2 as CONty(ref tycon', args')) =
54: if eqTycon(tycon,tycon')
55: then app2 comp (args,args')
56: else (comp(reduceType ty1, ty2)
57: handle ReduceType =>
58: comp(ty1, reduceType ty2)
59: handle ReduceType => raise CompareTypes)
60: | comp(_, ERRORty) = ()
61: | comp _ = raise CompareTypes
62: in comp(specty,actty)
63: end
64:
65: fun compareTypes(spec: ty, actual: ty, name) : unit =
66: let fun error() =
67: (complain "value type in structure doesn't match signature spec";
68: PrintType.resetPrintType();
69: print (" name: " ^ symName name ^ "\n spec: ");
70: PrintType.printType(spec);
71: print "\n actual: ";
72: PrintType.printType(actual); newline())
73: in case spec
74: of POLYty{sign,tyfun=TYFUN{body,...}} =>
75: (case actual
76: of POLYty{sign=sign',tyfun=TYFUN{arity,body=body'}} =>
77: (compType(body,sign,body',sign',arity)
78: handle CompareTypes => error())
79: | _ => error())
80: | ERRORty => ()
81: | _ =>
82: (case actual
83: of POLYty{sign,tyfun=TYFUN{arity,body}} =>
84: (compType(spec,[],body,sign,arity)
85: handle CompareTypes => error())
86: | _ => if equalType(spec,actual)
87: then ()
88: else error())
89: end
90:
91:
92: (* making abstraction structures *)
93:
94: fun abstract(sgn as STRstr{kind=SIGkind{stamps={strStamps=sigStrStamps,
95: tycStamps=sigTycStamps},
96: ...},
97: ...},
98: str, {strStamps, tycStamps}) =
99: let val transStrStamp = join(strStamps,sigStrStamps)
100: val transTycStamp = join(tycStamps,sigTycStamps)
101: fun abstractTyc(sigtyc,strtyc) =
102: case sigtyc
103: of TYCON{kind=DATAtyc _,...} => strtyc
104: | _ => let val stamp = tycStamp sigtyc
105: in if tycFixed(stamp)
106: then strtyc
107: else setTycStamp(transTycStamp(stamp),sigtyc)
108: end
109: fun abstractStr(STRstr{stamp,sign,table,env,...},
110: str as STRstr{env=env',...}) =
111: if strFixed stamp
112: then str
113: else let val newenv as REL{s,t} = abstractEnv(env,env')
114: val newstr = STRstr{stamp=transStrStamp(stamp),
115: env=newenv,
116: sign=sign,table=table,
117: kind=STRkind{path=[]}} (* ??? def of kind *)
118: in ArrayExt.app((setParent newstr), s, 2);
119: newstr
120: end
121: | abstractStr (INDstr i,_) =
122: impossible ("3437 in sigmatch: " ^makestring i)
123: | abstractStr _ = impossible "9833 in sigmatch (abstractStr)"
124: and abstractEnv(REL{s=sSig,t=tSig}:strenv, REL{s=sStr,t=tStr}:strenv) =
125: let val sNew = array(Array.length sSig, NULLstr)
126: val tNew = array(Array.length tSig, NULLtyc)
127: fun foreachStr i =
128: (update(sNew,i,abstractStr(sSig sub i, sStr sub i));
129: foreachStr(i+1))
130: fun foreachTyc i =
131: (update(tNew,i,abstractTyc(tSig sub i, tStr sub i));
132: foreachTyc(i+1))
133: in foreachStr 2 (* ignoring parent and parameter slots *)
134: handle Subscript =>
135: foreachTyc 0
136: handle Subscript =>
137: REL{s=sNew,t=tNew}
138: end
139: in abstractStr(sgn,str)
140: end
141: | abstract _ = impossible "8375 in sigmatch (abstract)"
142:
143: (* signature matching *)
144:
145: fun matchx (parent: Structure)
146: (mapfns as {mapstr,mapstr1,maptyc})
147: (abs, path, stamps,
148: sgn as STRstr{stamp,sign,...},
149: str as STRstr{stamp=stamp',sign=sign',table,env,...},
150: param: Structure)
151: : Structure * thinning =
152: if strFixed(stamp) andalso stamp <> stamp'
153: then (print "fixed signature stamp: "; print stamp;
154: print "\nstructure stamp: "; print stamp';
155: print "\npath: "; prSymPath path; print "\n";
156: condemn "fixed signature doesn't agree with structure")
157: else if sign = sign'
158: then (mapstr(sgn,str);
159: (if abs then abstract(sgn,str,stamps) else str, NONE))
160: else let val v = mkLvar()
161: val _ = (openStr(); openOld({path=[v],strenv=env},table))
162: val (str',transl) =
163: realizex parent mapfns (abs,path,stamps,stamp',sgn,param)
164: in closeStr();
165: (str',SOME(v,transl))
166: end
167: | matchx _ _ _ = impossible "843 in sigmatch"
168:
169: and realizex (parent: Structure)
170: (mapfns as {mapstr1,maptyc,mapstr})
171: (abs, path, stamps, strStamp,
172: sgn as STRstr{stamp = boundStamp, sign, table,
173: env = sigenv as REL{s=sSig,t=tSig},
174: kind = SIGkind{bindings,share,...},...},
175: param: Structure)
176: : Structure * trans list =
177: let val sNew = array(Array.length sSig, NULLstr)
178: val tNew = array(Array.length tSig, NULLtyc)
179: val newenv = REL{s=sNew,t=tNew}
180: val newstr = STRstr{stamp=strStamp,sign=sign,table=table,env=newenv,
181: kind=STRkind{path=path}}
182: fun checkSpec spec =
183: case spec
184: of STRbind(STRvar{name=[id],binding=INDstr i,...}) =>
185: let val STRvar{access,binding=str',...} =
186: lookSTRlocal id
187: handle Unbound =>
188: condemn("unmatched structure spec: " ^ symName id)
189: val (str,thin) = matchx newstr mapfns
190: (false, id::path, stamps,
191: sSig sub i, str',NULLstr)
192: in update(sNew,i,str);
193: [case thin
194: of NONE => VALtrans access
195: | SOME(v,transl) => THINtrans(access,v,transl)]
196: end
197: | TYCbind(ref(INDtyc i)) =>
198: let val sigTycon = tSig sub i
199: val name = tycName sigTycon
200: val strTycon = !(lookTYClocal name)
201: handle Unbound =>
202: condemn("unmatched type spec: "^
203: symName(name))
204: val s = tycStamp sigTycon
205: val s' = tycStamp strTycon
206: in update(tNew,i,strTycon);
207: if tycFixed s andalso s <> s'
208: then if equalTycon(sigTycon,strTycon)
209: then maptyc(s,strTycon)
210: else condemn("bad match for fixed type spec "
211: ^ symName(name))
212: else (case (sigTycon, strTycon)
213: of (TYCON{arity,kind=DATAtyc dcons,...},
214: TYCON{arity=arity',kind=DATAtyc dcons',...}) =>
215: if arity = arity'
216: andalso length(dcons) = length(dcons')
217: then maptyc(s,strTycon)
218: else condemn("mismatching datatype spec: "
219: ^ symName(name))
220: | (TYCON{kind=DATAtyc _,...}, _) =>
221: condemn("unmatched datatype spec: "^symName(name))
222: | (TYCON{arity,kind=ABStyc,eq,...}, _) =>
223: if arity <> tyconArity(strTycon)
224: then condemn("mismatching tycon arities: "
225: ^ symName(name))
226: else if (!eq=YES) andalso not(isEqTycon(strTycon))
227: then condemn("mismatched eqtype spec: "
228: ^ symName(name))
229: else maptyc(s,strTycon)
230: | _ => impossible "realizex/checkSpec/TYCbind");
231: nil
232: end
233: | CONbind(DATACON{name,typ,rep=VARIABLE _,const,...}) =>
234: let val DATACON{typ=typ',rep=VARIABLE(access),...} =
235: lookCONlocal name
236: handle Unbound =>
237: condemn ("unmatched exception spec: "^symName(name))
238: | Bind =>
239: condemn ("unmatched exception spec: "^symName(name))
240: in compareTypes(typeInContext(!typ,newenv),!typ',name);
241: [VALtrans access]
242: end
243: | CONbind(DATACON{name,typ,...}) =>
244: let val DATACON{typ=typ',...} =
245: lookCONlocal name
246: handle Unbound =>
247: condemn ("unmatched data constructor spec: "
248: ^symName(name))
249: in compareTypes(typeInContext(!typ,newenv),!typ',name);
250: nil
251: end
252: | VARbind(VALvar{name=[id],typ,...}) =>
253: (case (lookVARCONlocal id
254: handle Unbound =>
255: condemn("unmatched val spec: "^symName(id)))
256: of VARbind(VALvar{access,typ=typ',...}) =>
257: (* no propagation of INLINE access!! *)
258: (compareTypes(typeInContext(!typ,newenv),!typ',id);
259: [case access of INLINE _ => VALtrans access
260: | PATH _ => VALtrans access
261: | LVAR _ =>
262: if !ErrorMsg.anyErrors
263: then VALtrans access
264: else impossible "sigmatch.1"
265: | _ => impossible "sigmatch.2"])
266: | CONbind(dcon as DATACON{typ=typ',...}) =>
267: (compareTypes(typeInContext(!typ,newenv),!typ',id);
268: [CONtrans dcon])
269: | _ => impossible "sigmatch.476")
270: | _ => nil (* nonchecked binding (FIXbind) *)
271: fun checkList (a::rest) =
272: (checkSpec a handle Syntax => nil) @ checkList rest
273: | checkList nil = nil
274:
275: val _ = update(sNew,0,parent) (* define parent before checking specs *)
276: val _ = update(sNew,1,param) (* ditto for param *)
277: val trans = checkList bindings
278: val _ = Sharing.checkSharing(table,newenv,share)
279: val str = if abs then abstract(sgn,newstr,stamps) else newstr
280: in mapstr1(boundStamp,str);
281: linkParents str; (* should be redundant *)
282: (str, trans)
283: end
284: | realizex _ _ _ = impossible "783 in sigmatch"
285:
286: val defaultMapfns =
287: let fun ignore _ = ()
288: in {mapstr=ignore,mapstr1=ignore,maptyc=ignore}
289: end
290:
291: val match0 = matchx NULLstr
292: val match = matchx NULLstr defaultMapfns
293: val realize = realizex NULLstr defaultMapfns
294:
295: end (* structure SigMatch *)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.