1(* 2 Copyright (c) 2009-2015 David C.J. Matthews 3 4 This library is free software; you can redistribute it and/or 5 modify it under the terms of the GNU Lesser General Public 6 License version 2.1 as published by the Free Software Foundation. 7 8 This library is distributed in the hope that it will be useful, 9 but WITHOUT ANY WARRANTY; without even the implied warranty of 10 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 11 Lesser General Public License for more details. 12 13 You should have received a copy of the GNU Lesser General Public 14 License along with this library; if not, write to the Free Software 15 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 16*) 17 18(* 19 Derived from the STRUCTURES module: 20 Copyright (c) 2000-9 21 Cambridge University Technical Services Limited 22 Title: Module Structure and Operations. 23 Author: Dave Matthews, Cambridge University Computer Laboratory 24 Copyright Cambridge University 1985 25 26*) 27 28functor COPIER( 29 structure STRUCTVALS : STRUCTVALSIG; 30 structure TYPETREE : TYPETREESIG 31 32 structure UNIVERSALTABLE: 33 sig 34 type universal = Universal.universal 35 type univTable 36 type 'a tag = 'a Universal.tag 37 38 val univEnter: univTable * 'a tag * string * 'a -> unit; 39 val univLookup: univTable * 'a tag * string -> 'a option; 40 val univFold: univTable * (string * universal * 'a -> 'a) * 'a -> 'a; 41 end; 42 43 structure UTILITIES: 44 sig 45 val splitString: string -> { first:string,second:string } 46 end 47 48sharing STRUCTVALS.Sharing = TYPETREE.Sharing 49 50sharing type 51 UNIVERSALTABLE.univTable 52= STRUCTVALS.univTable 53) 54:COPIERSIG = 55struct 56 open STRUCTVALS TYPETREE UNIVERSALTABLE UTILITIES 57 open Universal; (* for tag record selectors *) 58 59 type tsvEnv = { enterType: string * typeConstrSet -> unit, 60 enterStruct: string * structVals -> unit, 61 enterVal : string * values -> unit }; 62 63 (* Type constructor cache. This maps typeIDs in the copied signature to 64 type constructors. More importantly, it identifies a type constructor 65 that carries that type ID so that when we copy the values the string 66 name is appropriate. *) 67 68 (* Generate new entries for all the elements of the signature. 69 As well as copying the signature it also keeps track of addresses used in 70 the signature for values. This is needed because when we're constructing a signature 71 we need to know the maximum address used. 72 This is used to two cases only: when we have a named signature with possible sharing or 73 "where types" or when including a signature. Really these cases should renumber the 74 value entries. *) 75 fun localCopySig(sourceTab, resEnv, mapTypeId, singleLevel, strName, newMap, cacheTail): unit = 76 let 77 78 fun buildTypeCache(sourceTab, strName, mapTypeId, buildDatatypes, initialCache, cacheTail) = 79 let 80 (* Process sub-directories first. That way they will be further down the list. *) 81 fun foldSubStructs(dName, dVal, rest) = 82 if tagIs structVar dVal 83 then 84 let 85 val Struct { signat = Signatures { tab, typeIdMap, ...}, ...} = tagProject structVar dVal 86 in 87 buildTypeCache(tab, strName ^ dName ^ "." (* Add structure names. *), 88 composeMaps(typeIdMap, mapTypeId), buildDatatypes, initialCache, rest) 89 end 90 else rest 91 92 (* Then the types within this structure. *) 93 fun foldTypes(_, dVal, rest) = 94 if tagIs typeConstrVar dVal 95 then 96 let 97 val TypeConstrSet(tcon, _) = tagProject typeConstrVar dVal 98 fun makeName s = strName ^ s 99 fun copyId(TypeId{idKind=Bound{ offset, ...}, ...}) = SOME(mapTypeId offset) 100 | copyId _ = NONE 101 in 102 (* On the first pass we build datatypes, on the second type abbreviations 103 using the copied datatypes. *) 104 case tcIdentifier tcon of 105 TypeId{idKind=TypeFn(args, equiv), access, description, ...} => 106 if buildDatatypes then rest (* Not on this pass. *) 107 else (* Build a new entry whether the typeID has changed or not. *) 108 let 109 val copiedEquiv = 110 copyType(equiv, fn x => x, 111 fn tcon => 112 copyTypeConstrWithCache(tcon, copyId, fn x => x, makeName, initialCache)) 113 val copiedId = 114 TypeId{idKind=TypeFn(args, copiedEquiv), access=access, description=description} 115 in 116 makeTypeConstructor(makeName(tcName tcon), args, copiedId, tcLocations tcon) :: rest 117 end 118 119 | id => 120 if not buildDatatypes then rest (* Not on this pass. *) 121 else 122 ( 123 case copyId id of 124 NONE => rest (* Skip (or add to cache?) *) 125 | SOME newId => 126 makeTypeConstructor 127 (makeName(tcName tcon), tcTypeVars tcon, newId, tcLocations tcon) :: rest 128 ) 129 end 130 else rest 131 in 132 univFold(sourceTab, foldTypes, 133 univFold(sourceTab, foldSubStructs, cacheTail)) 134 end 135 136 (* Process datatypes. While processing these we make new entries for every 137 datatype even if they are already in the cache. That way we end up with 138 the last entry in the list being the most local and that's the one we want 139 to use for type abbreviations and values. *) 140 val datatypeCache = 141 buildTypeCache(sourceTab, strName, mapTypeId, true, (* Datatypes *) [], cacheTail) 142 (* Now add any type abbreviations. These can refer to datatypes we added in the 143 previous pass but don't reuse type abbreviations we add elsewhere. *) 144 val typeCache = 145 buildTypeCache(sourceTab, strName, mapTypeId, false, (* Type abbreviations. *)datatypeCache, datatypeCache) 146 147 fun copyTypeCons (tcon : typeConstrs) : typeConstrs = 148 let 149 fun copyId(TypeId{idKind=Bound{ offset, ...}, ...}) = SOME(mapTypeId offset) 150 | copyId _ = NONE 151 in 152 copyTypeConstrWithCache (tcon, copyId, fn x => x, fn s => strName ^ s, typeCache) 153 end 154 155 fun copyTyp (t : types) : types = 156 copyType (t, fn x => x, (* Don't bother with type variables. *) copyTypeCons) 157 158 in 159 univFold 160 (sourceTab, 161 fn (dName: string, dVal: universal, _) => 162 if tagIs structVar dVal 163 then 164 let 165 val Struct { signat, name=structName, access, locations=structLocs, ...} = tagProject structVar dVal 166 val Signatures { name=sigName, tab, typeIdMap, firstBoundIndex, locations=sigLocs, ...} = signat 167 168 val newSig = 169 if singleLevel 170 then (* Just compose the maps. *) 171 makeSignature(sigName, tab, firstBoundIndex, sigLocs, composeMaps(typeIdMap, mapTypeId), []) 172 else (* Recursive copy. *) 173 let 174 (* Make a new sub-structure. *) 175 val newTab = makeSignatureTable (); 176 (* Copy everything into the new signature. *) 177 val () = 178 localCopySig 179 (tab, 180 { 181 enterType = fn (s,v) => univEnter (newTab, typeConstrVar, s, v), 182 enterStruct = fn (s,v) => univEnter (newTab, structVar, s, v), 183 enterVal = fn (s,v) => univEnter (newTab, valueVar, s, v) 184 }, 185 composeMaps(typeIdMap, mapTypeId), false, strName ^ dName ^ ".", newMap, typeCache) 186 in 187 (* If we're copying it all set the resulting map to the new map. *) 188 makeSignature(sigName, newTab, firstBoundIndex, sigLocs, newMap, []) 189 end 190 val newStruct = 191 Struct { name = structName, signat = newSig, access = access, locations = structLocs} 192 in 193 #enterStruct resEnv (dName, newStruct) 194 end (* structures *) 195 196 else if tagIs typeConstrVar dVal 197 then 198 let 199 val TypeConstrSet(oldConstr, tcConstructors) = tagProject typeConstrVar dVal 200 val newConstr = copyTypeCons oldConstr; 201 (* Copy the value constructors for a datatype. *) 202 203 fun copyValueConstr( 204 v as Value{name, typeOf, class, access, locations, references, instanceTypes, ...}) = 205 let 206 (* Copy its type and make a new constructor if the type has changed. *) 207 val newType = copyTyp typeOf; 208 in 209 if not (identical (newType, typeOf)) 210 then Value{name=name, typeOf=newType, class=class, 211 access=access, locations = locations, references = references, 212 instanceTypes=instanceTypes} 213 else v 214 end; 215 216 val copiedConstrs = map copyValueConstr tcConstructors 217 in 218 #enterType resEnv (dName, TypeConstrSet(newConstr, copiedConstrs)) 219 end 220 221 (* Finally the values and exceptions. *) 222 else if tagIs valueVar dVal 223 then 224 let 225 val v as Value {typeOf, class, name, access, locations, references, instanceTypes, ...} = 226 tagProject valueVar dVal; 227 val newType = copyTyp typeOf; 228 (* Can save creating a new object if the address and type 229 are the same as they were. *) 230 val res = 231 if not (identical (newType, typeOf)) 232 then Value {typeOf=newType, class=class, name=name, instanceTypes=instanceTypes, 233 access=access,locations=locations, references = references} 234 else v 235 in 236 #enterVal resEnv (name, res) 237 end 238 else (), 239 () 240 ) 241 end (* fullCopySig *) 242 243 (* Exported versions of these. *) 244 245 (* Open a structure or include a signature. *) 246 fun openSignature(Signatures{ tab, typeIdMap, ...}, resEnv, strName) = 247 localCopySig(tab, resEnv, typeIdMap, true (* One level. *), strName, typeIdMap, []) 248 249 and fullCopyDatatype(oldConstr:typeConstrSet, mapTypeId, strName) = 250 let 251 val sigSpace = makeSignatureTable() 252 val Env { enterType, ...} = makeEnv sigSpace 253 val () = enterType(tcName(tsConstr oldConstr), oldConstr) 254 val resType = ref NONE 255 val resEnv = 256 { 257 enterType = fn (_, tc) => resType := SOME tc, 258 enterStruct = fn (s, _) => raise Misc.InternalError ("enterStruct "^s), 259 enterVal = fn (s, _) => raise Misc.InternalError ("enterVal "^s) 260 } 261 val () = localCopySig(sigSpace, resEnv, mapTypeId, true, strName, fn _ => raise Subscript, []) 262 in 263 valOf(! resType) 264 end 265 266 fun replaceMap(Signatures{tab=sourceTab, name = sourceName, locations, ...}, 267 mapTypeId: int -> typeId, min, boundIds, newMap): signatures = 268 let 269 (* Make a new signature. *) 270 val tab = makeSignatureTable (); 271 272 val tsvEnv = 273 { 274 enterType = fn (s,v) => univEnter (tab, typeConstrVar, s, v), 275 enterStruct = fn (s,v) => univEnter (tab, structVar, s, v), 276 enterVal = fn (s, v) => univEnter (tab, valueVar, s, v) 277 } 278 (* Copy everything into the new signature. *) 279 val () = localCopySig(sourceTab, tsvEnv, mapTypeId, false, "", newMap, []) 280 in 281 makeSignature(sourceName, tab, min, locations, newMap, boundIds) 282 end (* replaceMap *) 283 284 (* Find the maximum run-time offset used for a value or structure in a signature. 285 This excludes type IDs. *) 286 fun getNextRuntimeOffset(Signatures{tab, ...}): int = 287 let 288 fun getOffset(_, dVal, m) = 289 if tagIs valueVar dVal 290 then case tagProject valueVar dVal of 291 Value { access = Formal addr, ...} => Int.max(addr+1, m) 292 | _ => m 293 else if tagIs structVar dVal 294 then case tagProject structVar dVal of 295 Struct{access=Formal addr, ...} => Int.max(addr+1, m) 296 | _ => m 297 else if tagIs typeConstrVar dVal 298 then 299 let 300 fun getConstrOffset(Value { access = Formal addr, ...}, m) = Int.max(addr+1, m) 301 | getConstrOffset(_, m) = m 302 in 303 List.foldl getConstrOffset m (tsConstructors (tagProject typeConstrVar dVal)) 304 end 305 else m 306 in 307 univFold(tab, getOffset, 0) 308 end 309 310 structure Sharing = 311 struct 312 type signatures = signatures 313 type typeConstrSet = typeConstrSet 314 type structVals = structVals 315 type values = values 316 type typeId = typeId 317 type valAccess = valAccess 318 type types = types 319 type univTable = univTable 320 end 321 322end; 323