![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to modutil.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 / basics|
Return to modutil.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / basics |
1.1 root 1: (* modutil.sml *)
2:
3: structure ModUtil : MODUTIL =
4: struct
5:
6: open ErrorMsg Basics TypesUtil Stampset
7:
8: fun mapSubstrs(f,senv) =
9: (* Creates a new copy of a structure environment array by applying f to
10: substructures. Leaves parent and param slots of new env undefined *)
11: let val new = array(Array.length senv, NULLstr)
12: fun loop i = (update(new,i,f(senv sub i)); loop(i+1))
13: in loop 2 handle Subscript => new
14: end
15:
16: (* setParent only sets parents that are initially NULLstr *)
17: fun setParent (parent: Structure) =
18: fn (STRstr{env=REL{s,...},...}) =>
19: ((case s sub 0
20: of NULLstr => update(s,0,parent)
21: | _ => ())
22: handle Subscript => ())
23: | (STRstr{env=DIR,...}) => ()
24: | NULLstr => ()
25: | _ => impossible "ModUtil.setParent"
26:
27: (* resetParent redefines parents unconditionally *)
28: fun resetParent (parent: Structure) =
29: fn (STRstr{env=REL{s,...},...}) =>
30: (update(s,0,parent) handle Subscript => impossible "ModUtil.resetParent 1")
31: | (STRstr{env=DIR,...}) => ()
32: | NULLstr => ()
33: | _ => impossible "ModUtil.resetParent 2"
34:
35: fun linkParents(str as STRstr{env=REL{s,...},...}) =
36: ArrayExt.app((fn str' => (setParent str str'; linkParents str')), s, 1)
37: | linkParents(STRstr{env=DIR,...}) = ()
38: | linkParents(NULLstr) = ()
39: | linkParents _ = ErrorMsg.impossible "ModUtil.linkParents"
40:
41: fun shiftStamps(transStrStamp,transTycStamp,newStamps,fixstamp,fixsign,fixstr) =
42: let fun newTyc(tyc as TYCON{stamp,arity,eq,path,kind}) =
43: if tycFixed(stamp)
44: then tyc
45: else (case kind
46: of ABStyc => setTycStamp(transTycStamp(stamp),tyc)
47: | DATAtyc _ => setTycStamp(transTycStamp(stamp),tyc)
48: | DEFtyc(TYFUN{arity,body}) =>
49: TYCON{stamp=transTycStamp(stamp),
50: arity=arity,
51: eq=eq,
52: path=path,
53: kind=DEFtyc(TYFUN{arity=arity,
54: body=newType(body)})}
55: | _ => tyc)
56: | newTyc _ = impossible "ModUtil.shiftStamps.newTyc - bad arg"
57: and newType(ty) =
58: case ty
59: of VARty(ref(INSTANTIATED ty')) => newType ty'
60: | FLEXRECORDty(ref(CLOSED ty')) => newType ty'
61: | POLYty{tyfun=TYFUN{body,arity},sign} =>
62: POLYty{tyfun=TYFUN{body=newType body,arity=arity},sign=sign}
63: | VARty _ => ty
64: | CONty(tycref as ref tyc,args) =>
65: CONty(ref(newTyc(tyc)), map newType args)
66: | ERRORty => ty
67: | _ => impossible "shiftStamps.newType"
68: fun newEnv(REL{s,t}) =
69: let val s' = array(Array.length s, NULLstr)
70: fun loop i = (update(s',i,newStr(s sub i)); loop(i+1))
71: in loop 1 handle Subscript =>
72: REL{s=s',t=ArrayExt.map(newTyc,t,0)}
73: end
74: | newEnv _ = impossible "ModUtil.shiftStamps.newEnv - bad arg"
75: and newStr(str as STRstr{stamp,sign,table,env,kind}) =
76: if Stampset.strFixed(stamp)
77: then str
78: else if stamp=fixstamp andalso sign=fixsign
79: then fixstr
80: else let val newenv as REL{s,...} = newEnv env
81: val new = STRstr{stamp=transStrStamp(stamp),
82: kind=case kind
83: of SIGkind{stamps,share,bindings} =>
84: SIGkind{stamps=newStamps,
85: share=share,
86: bindings=bindings}
87: | _ => kind,
88: env=newenv,
89: sign=sign,table=table}
90: val setpar = setParent new
91: fun loop i = (setpar(s sub i); loop(i+1))
92: in loop 1 handle Subscript => new
93: end
94: | newStr(NULLstr) = NULLstr
95: | newStr(INDstr i) = impossible("ModUtil.shiftStamps.newStr INDstr "^
96: makestring i)
97: | newStr(SHRstr _) = impossible "ModUtil.shiftStamps.newStr SHRstr"
98: in newStr
99: end
100:
101: fun shiftSigStamps(base : stampsets, sgn as STRstr{kind=SIGkind{stamps,...},...}) =
102: let val {strStamps=sbase,tycStamps=tbase} = base
103: and {strStamps=soffset,tycStamps=toffset} = stamps
104: val transStrStamp = join(sbase,soffset)
105: and transTycStamp = join(tbase,toffset)
106: in shiftStamps(transStrStamp,transTycStamp,base,~1,~1,NULLstr) sgn
107: end
108: | shiftSigStamps _ = impossible "ModUtil.shiftSigStamps -- bad arg"
109:
110: fun shiftFctStamps(FUNCTOR{paramName,paramVis,param,body,
111: stamps as {strStamps=bodyStrStamps,
112: tycStamps=bodyTycStamps}}) =
113: let val newParamStamps = newStampsets()
114: val newBodyStamps = newStampsets()
115: val STRstr{stamp=pstamp,sign=psign,
116: kind=SIGkind{stamps=pstamps as {strStamps=paramStrStamps,
117: tycStamps=paramTycStamps},
118: ...},
119: ...} =
120: param
121: val bodyStrTrans = join(#strStamps newBodyStamps, bodyStrStamps)
122: val bodyTycTrans = join(#tycStamps newBodyStamps, bodyTycStamps)
123: val paramStrTrans = join(#strStamps newParamStamps, paramStrStamps)
124: val paramTycTrans = join(#tycStamps newParamStamps, paramTycStamps)
125: fun transStrStamps x =
126: if member(x,bodyStrStamps)
127: then bodyStrTrans x
128: else if member(x,paramStrStamps)
129: then paramStrTrans x
130: else x
131: fun transTycStamps x =
132: if member(x,bodyTycStamps)
133: then bodyTycTrans x
134: else if member(x,paramTycStamps)
135: then paramTycTrans x
136: else x
137: val newparam = shiftStamps(paramStrTrans,paramTycTrans,newParamStamps,
138: ~1,~1,NULLstr)
139: param
140: val newbody = shiftStamps (transStrStamps,transTycStamps,newBodyStamps,
141: pstamp,psign,newparam)
142: body
143: in FUNCTOR{paramName=paramName,
144: paramVis=paramVis,
145: param=newparam,
146: body=newbody,
147: stamps=newBodyStamps}
148: end
149:
150: end (* structure ModUtil *)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.