![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to signs.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 / parse|
Return to signs.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / parse |
1.1 root 1: (* Copyright 1989 by AT&T Bell Laboratories *)
2: signature SIGNS =
3: sig type spectype
4: type signtype
5: type symbol type 'a pathstamped type tyvar type ty type 'a susp
6: type fixity type tycon
7: val makeSIGid: symbol -> signtype
8: val makeSIG: spectype -> signtype
9: val make_includespec: symbol -> spectype
10: val make_strspec: symbol * signtype -> spectype
11: val make_dtyspec: tycon ref list pathstamped -> spectype
12: val make_tyspec: Basics.bool3 * tyvar list * symbol -> spectype
13: val make_valspec: symbol * ty susp -> spectype
14: val make_exnspec: symbol -> spectype
15: val make_exnspecOF: symbol * ty susp-> spectype
16: val make_fixityspec: fixity * symbol list -> spectype
17: val make_type_sharespec: symbol list list -> spectype
18: val make_str_sharespec: symbol list list -> spectype
19: end
20:
21: structure Signs : SIGNS = struct
22:
23: open ErrorMsg Symbol PrintUtil
24: open Access Basics BasicTypes TypesUtil Absyn
25: open Env
26: open EnvAccess
27: open ModUtil
28: open SigMatch
29: open Misc
30: (* open CoreLang *)
31:
32: type signContext = {stamps: Stampset.stampsets, nextSlot: unit->int,
33: sNext: Structure->Structure, tNext: tycon->tycon,
34: sCount: int ref, tCount: int ref,
35: tempenv: strenv, depth: int,
36: typeSharing: spath list list ref,
37: strSharing: spath list list ref}
38:
39: type stampsets = Stampset.stampsets
40: type 'a stamped = stampsets -> 'a
41: type 'a pathstamped = symbol list * stampsets -> 'a
42: type 'a susp = unit -> 'a
43: type spectype = signContext -> binding list
44: type signtype = int * stampsets -> Structure
45:
46: fun includeSig({nextSlot,sNext,tNext,sCount,tCount,...}: signContext,
47: {strStamps=strStamps0, tycStamps=tycStamps0}: stampsets,
48: STRstr{kind=SIGkind{bindings,stamps={strStamps,tycStamps},...},
49: env=REL{s=senv,t=tenv},...}) =
50: let val transStrStamp = Stampset.join(strStamps0,strStamps)
51: val transTycStamp = Stampset.join(tycStamps0,tycStamps)
52: val sOffset = !sCount - 2 (* offset for structure indices *)
53: val tOffset = !tCount (* offset for tycon indices *)
54:
55: (* adjustPath(depth: int, path: int list) *)
56: fun adjustPath(0,[i]) = [i+tOffset]
57: | adjustPath(0,i::r) = (i+sOffset) :: r
58: | adjustPath(0,[]) = impossible "sigBody.includeSig.adjustPath"
59: | adjustPath(d,0::(r as _::_)) = 0 :: adjustPath(d-1,r)
60: | adjustPath(d,p) = p
61:
62: fun adjustType(depth,ty) =
63: let fun adjust(CONty(ref(RELtyc(p)),args)) =
64: CONty(ref(RELtyc(adjustPath(depth,p))), map adjust args)
65: | adjust(CONty(reftyc,args)) =
66: CONty(reftyc, map adjust args)
67: | adjust(POLYty{sign,tyfun=TYFUN{arity,body}}) =
68: POLYty{sign=sign,
69: tyfun=TYFUN{arity=arity,body=adjust body}}
70: | adjust ty = ty
71: in adjust ty
72: end
73:
74: fun transTBinding depth binding =
75: case binding
76: of VARbind(VALvar{name,typ,access}) =>
77: VARbind(VALvar{name=name,access=access,
78: typ=ref(adjustType(depth,!typ))})
79: | CONbind(DATACON{name,typ,const,rep,sign}) =>
80: CONbind(DATACON{name=name, const=const, sign=sign, rep=rep,
81: typ=ref(adjustType(depth,!typ))})
82: | _ => binding
83:
84: fun transLBinding table binding =
85: case binding
86: of VARbind(VALvar{name=[n],typ,access}) =>
87: IntStrMap.map table (NameSpace.varKey n)
88: | CONbind(DATACON{name,typ,const,rep,sign}) =>
89: IntStrMap.map table (NameSpace.conKey name)
90: | _ => binding
91:
92: fun newTyc(tyc as TYCON{stamp,kind,...}) =
93: if Stampset.tycFixed(stamp)
94: then tyc
95: else (case kind
96: of ABStyc => setTycStamp(transTycStamp(stamp),tyc)
97: | DATAtyc _ => setTycStamp(transTycStamp(stamp),tyc)
98: | _ => tyc)
99: | newTyc _ = impossible "Parse.includeSig.newTyc"
100:
101: fun newEnv(depth,REL{s,t}) =
102: REL{s=mapSubstrs(newStr depth,s), t=ArrayExt.map(newTyc,t,0)}
103: | newEnv _ = impossible "Parse.includeSig.newEnv"
104:
105: and newStr depth (str as STRstr{stamp,sign,table,env,
106: kind=SIGkind{stamps,share,bindings}}) =
107: if Stampset.strFixed(stamp)
108: then str
109: else let val newenv as REL{s,t} = newEnv(depth+1,env)
110: val newtable =
111: IntStrMap.transform (transTBinding depth) table
112: val new =
113: STRstr{stamp=transStrStamp(stamp),
114: table=newtable,
115: kind=SIGkind{stamps=stamps,share=share,
116: bindings=map
117: (transLBinding newtable)
118: bindings},
119: env=newenv, sign=sign}
120: in ArrayExt.app(ModUtil.resetParent new, s, 2);
121: new
122: end
123: | newStr _ (INDstr i) = impossible("sigbody.newStr INDstr "^
124: makestring i)
125: | newStr _ (SHRstr _) = impossible "sigbody.newStr SHRstr"
126: | newStr _ (NULLstr) = impossible "sigbody.newStr NULLstr"
127: | newStr _ _ = impossible "sigbody.newStr STRkind"
128:
129: fun adjustBinding binding =
130: case binding
131: of VARbind(VALvar{name=[n],typ,...}) =>
132: bindVAR(n,VALvar{name=[n],typ=ref(adjustType(0,!typ)),
133: access=SLOT(nextSlot())})
134: | CONbind(DATACON{name,typ,const,rep as VARIABLE(SLOT _),sign}) =>
135: bindCON(name,DATACON{name=name,
136: const=const,
137: sign=sign,
138: typ=ref(adjustType(0,!typ)),
139: rep=VARIABLE(SLOT(nextSlot()))})
140: | CONbind(DATACON{name,typ,const,rep,sign}) =>
141: bindCON(name,DATACON{name=name,
142: const=const,
143: sign=sign,
144: typ=ref(adjustType(0,!typ)),
145: rep=rep})
146: | TYCbind(ref(INDtyc i)) =>
147: let val tyc = tenv sub i
148: val name = tycName tyc
149: in bindTYC(name,ref(tNext(newTyc(tyc))))
150: end
151: | STRbind(STRvar{name as [n],binding=INDstr i,...}) =>
152: bindSTR(n,STRvar{name=name,
153: binding=sNext(newStr 1 (senv sub i)),
154: access=SLOT(nextSlot())})
155: | FIXbind(fixvar as FIXvar{name,...}) =>
156: bindFIX(name,fixvar)
157: | _ => impossible "sigBody.adjustBinding"
158:
159: in map adjustBinding bindings
160: end (* includeSig *)
161: | includeSig _ = impossible "Parse.includeSig - bad arg"
162:
163:
164: fun makeSIGid ID (depth,stamps) =
165: let val SIGvar{binding,...}=lookSIG ID
166: in if depth>0 then ModUtil.shiftSigStamps(stamps,binding) else binding
167: end
168:
169: val maxTypSpecs = 100 (*maximum number of type specs in a signature *)
170: val maxStrSpecs = 100 (*maximum number of structure specs in a signature *)
171:
172: fun makeSIG(specs) (depth,stamps) =
173: let val tComps = array(maxTypSpecs,NULLtyc)
174: and tCount = ref 0
175: fun tNext x = (update(tComps,!tCount,x);
176: INDtyc(!tCount before inc tCount))
177: val sComps = array(maxStrSpecs,NULLstr)
178: and sCount = ref 2 (* slots 0,1 reserved for parent, fct param (if any) *)
179: fun sNext x = (update(sComps,!sCount,x);
180: INDstr(!sCount before inc sCount))
181: val tempenv = REL{t=tComps,s=sComps}
182: fun pairs (nil : spath list list) : (spath*spath) list = nil
183: | pairs ((a::b::r) :: s) = (a,b) :: pairs((b::r) :: s)
184: | pairs ( _ :: s ) = pairs s
185: val strSharing : spath list list ref = ref nil
186: val typeSharing : spath list list ref = ref nil
187:
188: val slot = ref 0
189: fun nextSlot() = (!slot before inc slot)
190:
191: val signContext : signContext =
192: {stamps=stamps,nextSlot=nextSlot, tempenv=tempenv,
193: sNext=sNext,tNext=tNext, depth=depth,
194: sCount=sCount,tCount=tCount,
195: typeSharing=typeSharing,strSharing=strSharing}
196:
197: val stamp = Stampset.newStamp(#strStamps stamps)
198: val _ = openStr() (* this is out of date, check parse.sml *)
199: val table = newTable()
200: val _ = openNew({path=[~depth],strenv=tempenv},table)
201: val savedlookArTYC = !lookArTYC
202: val savedlookPathArTYC = !lookPathArTYC
203: val bindings = protect(
204: ((fn () => (lookArTYC := lookArTYCinSig depth;
205: lookPathArTYC :=
206: lookPathArTYCinSig depth)),
207: (fn () => (lookArTYC := savedlookArTYC;
208: lookPathArTYC := savedlookPathArTYC))),
209: fn() => specs signContext)
210: val _ = closeStr()
211: val senv = ArrayExt.copy(sComps,!sCount)
212: val env = REL{s=senv, t=ArrayExt.copy(tComps,!tCount)}
213: val sShare = pairs(!strSharing)
214: val tShare = pairs(!typeSharing)
215: val shareSpec =
216: if null sShare andalso null tShare
217: then {s=[],t=[]}
218: else Sharing.doSharing(table,env,stamps,{s=sShare,t=tShare})
219: val result =
220: STRstr{stamp=stamp,
221: sign=Stampset.newStamp(Stampset.sigStamps),
222: table=table,
223: env=env,
224: kind=SIGkind{share=shareSpec,
225: bindings=bindings,
226: stamps=stamps}}
227: in ArrayExt.app((ModUtil.setParent result),senv,2);
228: result
229: end
230:
231:
232: fun make_includespec name ($ as {stamps,...}:signContext) =
233: let val SIGvar{binding,...} = lookSIG name in includeSig($,stamps,binding) end
234:
235: fun make_strspec(name,sign) ({depth,stamps,nextSlot,sNext,...}:signContext) =
236: let val sgn = sign(depth+1,stamps)
237: in [bindSTR(name,STRvar{name=[name],access=SLOT(nextSlot()),
238: binding=sNext(sgn)})]
239: end
240:
241: fun make_dtyspec db ({stamps,tempenv,tNext,...}:signContext) =
242: let val dtycs =
243: (protect(protectDb(), fn() =>
244: map (fn (r as ref tyc) =>
245: (r := tNext tyc; (TYCbind r, tyc)))
246: (db1(ty,[],stamps))))
247: val tycbinds = map (fn (x,_) => x) dtycs
248: val tycons = map (fn (_,y) => y) dtycs
249: fun collectdcons(tyc::rest,dcbinds) =
250: let val TYCON{kind=DATAtyc(dcons),...} = tyc
251: fun binddcons(DATACON{name,...}::rest',dcbs) =
252: binddcons(rest',
253: (let val (b,_) = Env.look(NameSpace.conKey(name))
254: in b::dcbs
255: end
256: handle Unbound => dcbs))
257: | binddcons([],dcbs) = dcbs
258: in collectdcons(rest,binddcons(dcons,dcbinds))
259: end
260: | collectdcons([],dcbinds) = dcbinds
261: in app (defineEqTycon (tyconInContext tempenv)) tycons;
262: tycbinds @ collectdcons(tycons,[])
263: end
264:
265: fun make_tyspec(eq,tyvars,name) ({stamps,tNext,...}:signContext) =
266: [bindTYC(name, ref(tNext(mkABStyc([name],length tyvars,eq,stamps))))]
267:
268: fun make_valspec(name,ty) ({nextSlot,...}:signContext) =
269: let val typ = protect(protectScope, fn () =>
270: protect(protectTyvars NONE, fn () =>
271: let val body = ty()
272: val tvs = currentTyvars()
273: in case tvs
274: of [] => body
275: | _ =>
276: let val sign = TypesUtil.bindTyvars1 tvs
277: in POLYty
278: {sign = sign,
279: tyfun = TYFUN{arity = length tvs,
280: body = body}}
281: end
282: end))
283: in [bindVAR(name,VALvar{name=[name],typ=ref typ,access=SLOT(nextSlot())})]
284: end
285:
286: fun make_exnspec name ({nextSlot,...}:signContext) =
287: [bindCON(name,DATACON{name=name,const=true,typ=ref exnTy,sign=[],
288: rep=VARIABLE(SLOT(nextSlot()))})]
289:
290: fun make_exnspecOF(name,ty) ({nextSlot,...}:signContext) =
291: let val typ = protect(protectScope, fn()=>
292: protect(protectTyvars NONE, fn()=>
293: let val body = ty()
294: val tvs = currentTyvars()
295: in case length tvs
296: of 0 => body --> exnTy
297: | n => (TypesUtil.bindTyvars tvs;
298: POLYty{sign = mkPolySign n,
299: tyfun = TYFUN{arity = n,
300: body = body --> exnTy}})
301: end))
302: in [bindCON(name, DATACON{name=name, const=false, typ= ref typ,sign=[],
303: rep=VARIABLE(SLOT(nextSlot()))})]
304: end
305:
306: fun make_fixityspec(fixity,ops) _ =
307: (app(fn i => bindFIX(i,FIXvar{name=i,binding=fixity})) ops; nil)
308:
309: fun make_type_sharespec patheqn ({typeSharing,...}:signContext) =
310: (typeSharing := patheqn :: !typeSharing; nil)
311:
312: fun make_str_sharespec patheqn ({strSharing,...}:signContext) =
313: (strSharing := patheqn :: !strSharing; nil)
314: end
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.