1(* 2 Copyright David C. J. Matthews 2009 3 Largely extracted from STRUCTURES_.ML 4 5 Copyright (c) 2000 6 Cambridge University Technical Services Limited 7 8 Modified D.C.J. Matthews 2001-2015, 2020 9 10 This library is free software; you can redistribute it and/or 11 modify it under the terms of the GNU Lesser General Public 12 License version 2.1 as published by the Free Software Foundation. 13 14 This library is distributed in the hope that it will be useful, 15 but WITHOUT ANY WARRANTY; without even the implied warranty of 16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 17 Lesser General Public License for more details. 18 19 You should have received a copy of the GNU Lesser General Public 20 License along with this library; if not, write to the Free Software 21 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 22*) 23 24(* 25 Title: Module Structure and Operations. 26 Author: Dave Matthews, Cambridge University Computer Laboratory 27 Copyright Cambridge University 1985 28*) 29 30functor SIGNATURES ( 31 structure LEX : LEXSIG 32 structure STRUCTVALS : STRUCTVALSIG; 33 structure EXPORTTREE: EXPORTTREESIG 34 structure PRETTY : PRETTYSIG 35 structure COPIER: COPIERSIG 36 structure TYPETREE : TYPETREESIG 37 structure PARSETREE : PARSETREESIG 38 structure VALUEOPS : VALUEOPSSIG; 39 40 structure UNIVERSALTABLE: 41 sig 42 type universal = Universal.universal 43 type univTable 44 type 'a tag = 'a Universal.tag 45 46 val univEnter: univTable * 'a tag * string * 'a -> unit; 47 val univLookup: univTable * 'a tag * string -> 'a option; 48 val univFold: univTable * (string * universal * 'a -> 'a) * 'a -> 'a; 49 end; 50 51 structure DEBUG: DEBUG 52 53 structure UTILITIES : 54 sig 55 val noDuplicates: (string * 'a * 'a -> unit) -> 56 { apply: (string * 'a -> unit) -> unit, 57 enter: string * 'a -> unit, 58 lookup: string -> 'a option }; 59 60 val searchList: unit -> { apply: (string * 'a -> unit) -> unit, 61 enter: string * 'a -> unit, 62 lookup: string -> 'a option }; 63 end; 64 65 sharing LEX.Sharing = TYPETREE.Sharing = PARSETREE.Sharing 66 = PRETTY.Sharing = EXPORTTREE.Sharing = STRUCTVALS.Sharing = COPIER.Sharing 67 = VALUEOPS.Sharing = UNIVERSALTABLE 68 69) : SIGNATURESSIG = 70struct 71 open Misc (* Open this first because it contains Value. *) 72 open LEX STRUCTVALS EXPORTTREE PRETTY COPIER TYPETREE PARSETREE UNIVERSALTABLE DEBUG 73 open VALUEOPS UTILITIES Universal 74 75 datatype sigs = 76 SignatureIdent of string * location * locationProp list ref (* A signature name *) 77 78 | SigDec of specs list * location (* sig ... end *) 79 80 | WhereType of whereTypeStruct (* type realisation. *) 81 82 and specs = 83 StructureSig of structSigBind list * location 84 85 | ValSig of (* Signature of a value. *) 86 { name: string * location, typeof: typeParsetree, line: location } 87 88 | ExSig of (* Signature of an exception. May be a nullary exception. *) 89 { name: string * location, typeof: typeParsetree option, line: location } 90 91 | CoreType of (* Any other decln. *) 92 { 93 dec: parsetree, (* The value *) 94 location: location 95 } 96 97 | Sharing of shareConstraint (* Sharing constraints. *) 98 99 | IncludeSig of sigs list * location (* Include. *) 100 101 withtype shareConstraint = 102 { 103 isType: bool, 104 shares: (string * location) list, 105 line: location 106 } 107 108 and structSigBind = 109 { 110 name: string, (* The name of the structure *) 111 nameLoc: location, 112 sigStruct: sigs * bool * location, 113 line: location 114 } 115 116 and whereTypeStruct = 117 { 118 sigExp: sigs, 119 typeVars: typeVarForm list, 120 typeName: string, 121 realisation: typeParsetree, 122 line: location 123 } 124 125 fun mkSigIdent(name, nameLoc) = SignatureIdent(name, nameLoc, ref []) 126 127 fun mkCoreType (dec, location) = 128 CoreType { dec = dec, location = location }; 129 130 fun mkValSig (nameLoc, typeof, line) = 131 ValSig 132 { 133 name = nameLoc, 134 typeof = typeof, 135 line = line 136 }; 137 138 fun mkExSig (nameLoc, typeof, line) = 139 ExSig 140 { 141 name = nameLoc, 142 typeof = typeof, 143 line = line 144 }; 145 146 fun mkSharing (isType, shares, line) = 147 Sharing { 148 isType = isType, 149 shares = shares, 150 line = line 151 }; 152 153 fun mkWhereType (sigexp, typeVars, name, types, line) = 154 WhereType { 155 sigExp = sigexp, 156 typeVars = typeVars, 157 typeName = name, 158 realisation = types, 159 line = line 160 }; 161 162 val mkInclude = IncludeSig 163 and mkStructureSig = StructureSig 164 and mkSig = SigDec 165 166 fun mkStructureSigBinding ((name, nameLoc), signat, fullLoc):structSigBind = 167 { 168 name = name, 169 nameLoc = nameLoc, 170 sigStruct = signat, 171 line = fullLoc 172 } 173 174 (* Make a signature for initialisating variables and for 175 undeclared signature variables. *) 176 val undefinedSignature = 177 makeSignature("<undefined>", makeSignatureTable(), 0, [], fn _ => raise Subscript, []); 178 179 (* We use a name that isn't otherwise valid for a signature. *) 180 fun isUndefinedSignature(Signatures{name, ...}) = name = "<undefined>" 181 182 fun displayList ([], _, _) _ = [] 183 184 | displayList ([v], _, depth) dodisplay = 185 if depth <= 0 186 then [PrettyString "..."] 187 else [dodisplay (v, depth)] 188 189 | displayList (v::vs, separator, depth) dodisplay = 190 if depth <= 0 191 then [PrettyString "..."] 192 else 193 let 194 val brk = if separator = "," orelse separator = ";" then 0 else 1 195 in 196 PrettyBlock (0, false, [], 197 [ 198 dodisplay (v, depth), 199 PrettyBreak (brk, 0), 200 PrettyString separator 201 ] 202 ) :: 203 PrettyBreak (1, 0) :: 204 displayList (vs, separator, depth - 1) dodisplay 205 end (* displayList *) 206 207 fun displaySigs (str, depth) = 208 if depth <= 0 (* elide further text. *) 209 then PrettyString "..." 210 211 else 212 case str of 213 SignatureIdent (name : string, _, _) => 214 PrettyString name 215 216 | SigDec (structList : specs list, _) => 217 PrettyBlock (0, true, [], 218 PrettyString "sig" :: 219 PrettyBreak (1, 0) :: 220 displayList (structList, "", depth) displaySpecs @ 221 [ PrettyBreak (1, 0), PrettyString "end"] 222 ) 223 224 | WhereType { sigExp, typeVars, typeName, realisation, ... } => 225 PrettyBlock (3, false, [], 226 displaySigs (sigExp, depth) :: 227 PrettyBreak (1, 0) :: 228 PrettyString "where" :: 229 PrettyBreak (1, 0) :: 230 PrettyString "type" :: 231 PrettyBreak (1, 0) :: 232 displayTypeVariables (typeVars, depth) @ 233 [ 234 PrettyString typeName, 235 PrettyBreak (1, 0), 236 PrettyString "=", 237 PrettyBreak (1, 0), 238 displayTypeParse (realisation, depth - 1, emptyTypeEnv) 239 ] 240 ) 241 242 and displaySpecs (specs, depth) = 243 if depth <= 0 (* elide further text. *) 244 then PrettyString "..." 245 246 else 247 case specs of 248 StructureSig (structList : structSigBind list, _) => 249 let 250 fun displaySigsBind ( 251 {name, sigStruct=(sigStruct, opaque, _), ...}: structSigBind, depth) = 252 PrettyBlock (3, false, [], 253 [ 254 PrettyString name, 255 PrettyString (if opaque then " :>" else " :"), 256 PrettyBreak (1, 0), 257 displaySigs (sigStruct, depth - 1) 258 ] 259 ) 260 in 261 PrettyBlock (3, false, [], 262 PrettyString "structure" :: 263 PrettyBreak (1, 0) :: 264 displayList (structList, "and", depth) displaySigsBind 265 ) 266 end 267 268 | ValSig {name = (name, _), typeof, ...} => 269 PrettyBlock (0, false, [], 270 [ 271 PrettyString "val", 272 PrettyBreak (1, 1), 273 PrettyString (name ^ " :"), 274 PrettyBreak (1, 0), 275 displayTypeParse (typeof, depth - 1, emptyTypeEnv) 276 ] 277 ) 278 279 | ExSig {name = (name, _), typeof = NONE, ...} => 280 PrettyBlock (0, false, [], 281 [ 282 PrettyString "exception", 283 PrettyBreak (1, 1), 284 PrettyString (name) 285 ] 286 ) 287 288 | ExSig {name = (name, _), typeof = SOME typeof, ...} => 289 PrettyBlock (0, false, [], 290 [ 291 PrettyString "exception", 292 PrettyBreak (1, 1), 293 PrettyString (name ^ " :"), 294 PrettyBreak (1, 0), 295 displayTypeParse (typeof, depth - 1, emptyTypeEnv) 296 ] 297 ) 298 299 | Sharing { isType, shares, ... } => 300 PrettyBlock (3, false, [], 301 PrettyString "sharing" :: 302 PrettyBreak (1, 0) :: 303 ( 304 if not isType then [] 305 else [ PrettyString "type", PrettyBreak (1, 0) ] 306 ) @ 307 displayList (shares, "=", depth) (fn ((name, _), _) => PrettyString name) 308 ) 309 310 | IncludeSig (structList : sigs list, _) => 311 PrettyBlock (3, true, [], 312 PrettyString "include" :: 313 PrettyBreak (1, 0) :: 314 displayList (structList, "", depth - 1) displaySigs 315 ) 316 317 | CoreType {dec, ...} => 318 displayParsetree (dec, depth - 1) 319 (* End displaySigs *) 320 321 fun sigExportTree(navigation, s: sigs) = 322 let 323 (* Common properties for navigation and printing. *) 324 val commonProps = 325 PTprint(fn d => displaySigs(s, d)) :: 326 exportNavigationProps navigation 327 328 fun asParent () = sigExportTree(navigation, s) 329 in 330 case s of 331 SignatureIdent(_, loc, ref decLocs) => 332 (loc, mapLocationProps decLocs @ commonProps) 333 334 | SigDec(structList, location) => 335 (location, exportList(specExportTree, SOME asParent) structList @ commonProps) 336 337 | WhereType _ => (nullLocation, commonProps) 338 end 339 340 and specExportTree(navigation, s: specs) = 341 let 342 (* Common properties for navigation and printing. *) 343 val commonProps = 344 PTprint(fn d => displaySpecs(s, d)) :: 345 exportNavigationProps navigation 346 347 fun asParent () = specExportTree(navigation, s) 348 in 349 case s of 350 StructureSig(sbl, location) => 351 let 352 fun exportSB(navigation, sb as {name, nameLoc, sigStruct=(theSig, _, _), line, ...}) = 353 let 354 fun exportThis () = exportSB(navigation, sb) 355 fun getName () = 356 getStringAsTree({parent=SOME exportThis, previous=NONE, next=SOME getSigStruct}, name, nameLoc, []) 357 358 and getSigStruct () = 359 sigExportTree({parent=SOME exportThis, previous=SOME getName, next=NONE}, theSig) 360 in 361 (line, PTfirstChild getName :: exportNavigationProps navigation) 362 end 363 364 val expChild = exportList(exportSB, SOME asParent) sbl 365 in 366 (location, expChild @ commonProps) 367 end 368 369 | ValSig{name=(name, nameLoc), typeof, line, ...} => 370 let 371 (* The first position is the value name, the second the type. *) 372 (* TODO: Include the actual type as PTtype? *) 373 fun getName () = 374 getStringAsTree({parent=SOME asParent, previous=NONE, next=SOME getType}, name, nameLoc, []) 375 and getType () = 376 typeExportTree({parent=SOME asParent, previous=SOME getName, next=NONE}, typeof) 377 in 378 (line, PTfirstChild getName :: commonProps) 379 end 380 381 | ExSig{name=(name, nameLoc), typeof = NONE, line, ...} => 382 let 383 (* The first position is the value name, the second the type. *) 384 fun getName () = 385 getStringAsTree({parent=SOME asParent, previous=NONE, next=NONE}, name, nameLoc, []) 386 in 387 (line, PTfirstChild getName :: commonProps) 388 end 389 390 | ExSig{name=(name, nameLoc), typeof = SOME typeof, line, ...} => 391 let 392 (* The first position is the value name, the second the type. *) 393 (* TODO: Include the actual type as PTtype? *) 394 fun getName () = 395 getStringAsTree({parent=SOME asParent, previous=NONE, next=SOME getType}, name, nameLoc, []) 396 and getType () = 397 typeExportTree({parent=SOME asParent, previous=SOME getName, next=NONE}, typeof) 398 in 399 (line, PTfirstChild getName :: commonProps) 400 end 401 402 | CoreType {dec, ...} => (* A value parse-tree entry. *) 403 getExportTree(navigation, dec) 404 405 | Sharing _ => (nullLocation, commonProps) 406 407 | IncludeSig (sigs, loc) => 408 (loc, exportList(sigExportTree, SOME asParent) sigs @ commonProps) 409 end 410 411 (* Puts out an error message and then prints the piece of tree. *) 412 fun errorMsgNear (lex, hard, near, lno, message) : unit = 413 let 414 val parameters = debugParams lex 415 val errorDepth = getParameter errorDepthTag parameters 416 in 417 reportError lex 418 { 419 hard = hard, location = lno, message = message, 420 context = SOME(near errorDepth) 421 } 422 end 423 424 fun errorNear(lex, hard, near, lno, message: string) = 425 errorMsgNear (lex, hard, near, lno, 426 PrettyBlock (0, false, [], [PrettyString message])) 427 428 fun giveError (sVal : sigs, lno : LEX.location, lex : lexan) : string -> unit = 429 fn (message : string) => errorNear (lex, true, fn n => displaySigs(sVal, n), lno, message) 430 431 and giveSpecError(sVal : specs, lno : LEX.location, lex : lexan) : string -> unit = 432 fn (message : string) => errorNear (lex, true, fn n => displaySpecs(sVal, n), lno, message); 433 434 val makeEnv = fn x => let val Env e = makeEnv x in e end; 435 436 fun printId(TypeId{description, ...}) = printDesc description 437 438 and printDesc{ location: location, name: string, description = "" } = 439 PrettyBlock(0, false, [ContextLocation location], [PrettyString name]) 440 | printDesc{ location: location, name: string, description: string } = 441 PrettyBlock(0, false, [ContextLocation location], 442 [PrettyString name, PrettyBreak(1, 0), PrettyString ("(*" ^ description ^ "*)")]) 443 444 (* Formal paramater to a functor - either value or exception. *) 445 fun mkFormal (name : string, class, typ, addr, locations) = 446 Value{class=class, name=name, typeOf=typ, access=Formal addr, locations=locations, 447 references = NONE, instanceTypes=NONE} 448 449 (* Get the value from a signature-returning expression 450 (either the name of a signature or sig ... end. 451 The type IDs in the signature are bound names. *) 452 fun sigVal(str : sigs, 453 initTypeId : int, 454 outerTypeIdEnv: int->typeId, 455 Env globalEnv : env, 456 lex, 457 lno : LEX.location 458 ) : signatures = 459 let 460 datatype varId = 461 SharedWith of int (* Index of shared ID, always less than current index. *) 462 | VariableSlot of { boundId: typeId, descriptions: string list } 463 | FreeSlot of typeId (* Bound to a Free type ID. *) 464 | Unset 465 466 val idCount = ref initTypeId 467 val mapArray = StretchArray.stretchArray(10 (* Guess initial size. *), Unset) 468 val sourceArray = StretchArray.stretchArray(10 (* Guess initial size. *), NONE) 469 470 fun makeVariableId(arity, isEq, isDt, requireUpdate, { location, name, description }, structPath) = 471 let 472 val fullName = structPath^name 473 val descr = { location=location, name=fullName, description=description} 474 (* Make a new bound ID after any existing ones. *) 475 val newIdNumber = !idCount before (idCount := !idCount+1) 476 val newId = 477 (if requireUpdate then makeBoundIdWithEqUpdate else makeBoundId) 478 (arity, Formal 0 (* Not used. *), newIdNumber, isEq, isDt, descr) 479 (* Enter a variable entry in the array. *) 480 val arrayEntry = VariableSlot{ boundId=newId, descriptions = [fullName] } 481 val () = StretchArray.update(mapArray, newIdNumber-initTypeId, arrayEntry) 482 val () = StretchArray.update(sourceArray, newIdNumber-initTypeId, SOME newId) 483 in 484 newId 485 end 486 487 (* Follow a chain of shared IDs. This should terminate because we always 488 point down the array. *) 489 fun realId n = 490 case StretchArray.sub(mapArray, n) of 491 SharedWith m => 492 if m >= n 493 then raise InternalError "realId: Sharing loop" 494 else realId m 495 | id => id 496 497 fun isVariableId(TypeId{idKind=Bound{offset, ...}, ...}) = 498 if offset < initTypeId then false (* Outside the signature. *) 499 else 500 ( 501 case realId(offset-initTypeId) of 502 VariableSlot _ => true 503 | FreeSlot _ => false 504 | _ => raise InternalError "isVar" 505 ) 506 | isVariableId _ (* Free or TypeFunction *) = false 507 508 (* The internal type ID map after mapping to the internal Bound IDs but before the application of 509 any "where types" or sharing. *) 510 fun typeIdEnv () = 511 let 512 val v = Vector.tabulate(!idCount-initTypeId, fn n => valOf(StretchArray.sub(sourceArray, n))) 513 in 514 fn n => 515 if n < initTypeId 516 then outerTypeIdEnv n 517 else Vector.sub(v, n-initTypeId) 518 end 519 520 fun linkFlexibleTypeIds(typeId1, typeId2) = 521 (* Link together and share two IDs. The result is an equality type if either 522 was an equality type and a datatype if either was a datatype. *) 523 case (typeId1, typeId2) of 524 (TypeId{idKind=Bound{offset=offset1, ...}, ...}, TypeId{idKind=Bound{offset=offset2, ...}, ...}) => 525 ( 526 case (realId(offset1-initTypeId), realId(offset2-initTypeId)) of 527 (VariableSlot{descriptions = desc1, 528 boundId=TypeId{ 529 idKind=Bound{eqType=eqType1, offset=off1, isDatatype=isDatatype1, arity=arity1, ...}, description, ...}}, 530 VariableSlot{descriptions = desc2, 531 boundId=TypeId{ 532 idKind=Bound{eqType=eqType2, offset=off2, isDatatype=isDatatype2, arity=arity2, ...}, ...}}) => 533 if off1 = off2 534 then () (* They may already share. *) 535 else 536 let 537 val resOffset = Int.min(off1, off2) 538 val setOffset = Int.max(off1, off2) 539 val isDatatype = isDatatype1 orelse isDatatype2 540 val _ = arity1 = arity2 orelse raise InternalError "linkFlexibleTypeIds: different arities" 541 val newId = 542 makeBoundId(arity1, Formal 0, resOffset, pling eqType1 orelse pling eqType2, 543 isDatatype, description (* Not used *)) 544 val newEntry = 545 VariableSlot{ boundId=newId, descriptions = desc1 @ desc2 } 546 in 547 StretchArray.update(mapArray, resOffset-initTypeId, newEntry); 548 StretchArray.update(mapArray, setOffset-initTypeId, SharedWith(resOffset-initTypeId)) 549 end 550 | _ => raise InternalError "linkFlexibleTypeIds: not variable" 551 ) 552 | _ => raise InternalError "linkFlexibleTypeIds: not bound" 553 554 local (* Sharing *) 555 fun shareTypes(typeA as TypeConstrSet(constrA, _), aPath, aMap, 556 typeB as TypeConstrSet(constrB, _), bPath, bMap, lno, nearStruct) = 557 let 558 fun cantShare reason = 559 let 560 fun showTypeCons(TypeConstrSet(t, _), p) = 561 let 562 val context = 563 case List.find(fn DeclaredAt _ => true | _ => false) (tcLocations t) of 564 SOME(DeclaredAt loc) => [ContextLocation loc] 565 | _ => [] 566 in 567 PrettyBlock(0, false, context, [PrettyString(p ^ tcName t)]) 568 end 569 in 570 errorMsgNear (lex, true, fn n => displaySigs(nearStruct, n), lno, 571 PrettyBlock(3, false, [], 572 [ 573 PrettyString "Cannot share type", 574 PrettyBreak(1, 2), 575 showTypeCons(typeA, aPath), 576 PrettyBreak(1, 0), 577 PrettyString "with type", 578 PrettyBreak(1, 0), 579 showTypeCons(typeB, bPath), 580 PrettyBreak(0, 0), 581 PrettyString ".", 582 PrettyBreak(1, 0), 583 reason 584 ])) 585 end 586 587 fun alreadyBound(path, typeName, tcId) = 588 cantShare ( 589 PrettyBlock(3, false, [], 590 [ 591 PrettyString(path ^ typeName), 592 PrettyBreak(1, 0), 593 PrettyString "is already defined as", 594 PrettyBreak(1, 0), 595 printId tcId 596 ])) 597 in 598 if isUndefinedTypeConstr constrA orelse isUndefinedTypeConstr constrB 599 then () 600 else if tcArity constrA <> tcArity constrB (* Check arity. *) 601 then cantShare(PrettyString "The type constructors take different numbers of arguments.") 602 else 603 let 604 fun mapId (map, TypeId{idKind=Bound{offset, ...}, ...}) = map offset 605 | mapId (_, id) = id 606 val aId = mapId(aMap, tcIdentifier constrA) 607 and bId = mapId(bMap, tcIdentifier constrB) 608 in 609 (* The type constructors are only looked up in the signature but they 610 already may be set to another type through a "where type" or they may 611 have been created with Free IDs through type t=s declarations. This 612 could be a free identifier or a type function. *) 613 if not (isVariableId aId) 614 then alreadyBound(aPath, tcName constrA, aId) 615 else if not (isVariableId bId) 616 then alreadyBound(bPath, tcName constrB, bId) 617 else linkFlexibleTypeIds(aId, bId) 618 end 619 end (* shareTypes *); 620 621 (* Find all the structures and type constructors in one structure. *) 622 fun structsAndTypes((Struct{signat=Signatures { tab, typeIdMap, ... }, ...}, path, oldMap), start) = 623 let 624 val newMap = composeMaps(typeIdMap, oldMap) 625 fun get(name, dVal, (ts, ss)) = 626 if tagIs structVar dVal 627 then (ts, (name, (tagProject structVar dVal, path ^ name ^ ".", newMap)) :: ss) 628 else if tagIs typeConstrVar dVal 629 then ((name, (tagProject typeConstrVar dVal, path, newMap)) :: ts, ss) 630 else (ts, ss) 631 in 632 univFold (tab, get, start) 633 end 634 635 (* Get all the structures and type constructors in a list of structures. *) 636 fun allStructsAndTypes structs = List.foldl structsAndTypes ([], []) structs 637 638 (* Turn a list of names and structures/types into a list of lists. Each entry in 639 the result list is all those structures/types with the same name. *) 640 fun getMatchedEntries entries = 641 let 642 (* Sort the items so that items with the same name are brought together. 643 A signature is not allowed to have items of the same kind with the 644 same name so this means that we are bringing together items from 645 different structures. Then filter the result to produce sets of items 646 with the same name. Discard singletons in the result. *) 647 val sortedEntries = quickSort (fn (s1, _) => fn (s2, _) => s1 <= s2) entries 648 (* *) 649 fun getEquals([], _, [], res) = res (* End of empty list. *) 650 | getEquals([], _, [_], res) = res (* Last item was singleton: discard *) 651 | getEquals([], _, acc, res) = acc :: res (* Return last item. *) 652 653 | getEquals((s, t) :: r, a: string, acc, res) = 654 if a = s then getEquals(r, a, t :: acc, res) (* Same name as last item. *) 655 else case acc of (* Different from last item: *) 656 [] => getEquals(r, s, [t], res) (* No previous item. *) 657 | [_] => getEquals(r, s, [t], res) (* Last was singleton: discard. *) 658 | acc => getEquals(r, s, [t], acc :: res) 659 in 660 getEquals(sortedEntries, "", [], []) 661 end 662 663 (* Recursively apply the sharing constraints to corresponding types in a list of 664 structures. *) 665 fun structureSharing(structs, line, near) = 666 let 667 fun shareStructs structs = 668 let 669 val (allTypes, allSubstructs) = allStructsAndTypes structs 670 (* Get the lists of structures and types to share. *) 671 val matchedTypes = getMatchedEntries allTypes 672 val matchedStructs = getMatchedEntries allSubstructs 673 in 674 List.app(fn types => (* Share types. *) 675 case types of 676 [] => raise List.Empty 677 | (hd, hdName, hdMap) :: tl => (* Share the rest of the list with the first item. *) 678 List.app(fn (t, tName, tMap) => 679 shareTypes(hd, hdName, hdMap, t, tName, tMap, line, near)) tl) matchedTypes; 680 List.app shareStructs matchedStructs (* Recursively share sub-structures. *) 681 end 682 in 683 shareStructs(List.map(fn (s as Struct{name=sName, ...}) => (s, sName ^ ".", typeIdEnv())) structs) 684 end 685 in 686 687 (* Process a sharing constraint. *) 688 fun applySharingConstraint({shares, isType, line}, Env tEnv, near) : unit = 689 let 690 (* When looking up the structure and type names we look only 691 in the signature in ML97. We add this to make it clear that 692 we are only looking up in the signature otherwise we get 693 confusing messages such as "type (int) has not been declared". *) 694 fun lookupFailure locn msg = 695 giveError (str, locn, lex) (msg ^ " in signature.") 696 in 697 if isType 698 then 699 let (* Type sharing. *) 700 fun lookupSharing (name, locn) = 701 lookupTyp 702 ({ 703 lookupType = #lookupType tEnv, 704 lookupStruct = #lookupStruct tEnv 705 }, 706 name, lookupFailure locn) 707 in 708 case shares of 709 nil => raise Empty 710 | hd :: tl => 711 let 712 val first = lookupSharing hd 713 in 714 if isUndefinedTypeConstr(tsConstr first) 715 then () 716 else List.app (fn typ => 717 shareTypes (lookupSharing typ, "", typeIdEnv(), first, "", typeIdEnv(), line, near)) tl 718 end 719 end 720 else 721 let (* structure sharing. *) 722 fun getStruct(name, locn) = lookupStructureAsSignature (#lookupStruct tEnv, name, lookupFailure locn) 723 in (* Now share all these signatures. *) 724 structureSharing(List.mapPartial getStruct shares, line, near) 725 end 726 end (* applySharingConstraint *) 727 end (* Sharing *) 728 729 (* Look up a signature. Signatures can only be in the global environment. *) 730 fun lookSig (name : string, lno : LEX.location) : signatures = 731 case #lookupSig globalEnv name of 732 SOME v => v 733 | NONE => 734 ( 735 giveError (str, lno, lex)("Signature (" ^ name ^ ") has not been declared"); 736 undefinedSignature 737 ) 738 739 (* Construct a signature. All the type IDs within the signature are variables. *) 740 fun sigValue (str : sigs, Env env : env, _ : LEX.location, structPath) = 741 case str of 742 SignatureIdent(name, loc, declLoc) => 743 signatureIdentValue(name, loc, declLoc, Env env, structPath) 744 745 | WhereType {sigExp, typeVars, typeName, realisation, line, ...} => 746 signatureWhereType(sigExp, typeVars, typeName, realisation, line, Env env, structPath) 747 748 | SigDec(sigList, lno) => 749 makeSigInto(sigList, Env env, lno, 0, structPath) 750 751 and signatureIdentValue(name, loc, declLocs, _, structPath) = 752 let 753 (* Look up the signature and copy it to turn bound IDs into variables. 754 This is needed because we may have sharing. *) 755 val Signatures { name, tab, typeIdMap, firstBoundIndex, boundIds, locations, ...} = lookSig(name, loc); 756 (* Remember the declaration location for possible browsing. *) 757 val () = declLocs := locations 758 val startNewIds = ! idCount 759 760 (* Create a new variable ID for each bound ID. Type functions have to be copied to 761 replace references to other bound IDs. These must be earlier in the list. *) 762 fun makeNewIds([], _) = [] 763 764 | makeNewIds( 765 (oldId as TypeId{description, idKind=Bound { isDatatype, offset, arity, ...}, ...}) :: rest, 766 typeMap 767 ) = 768 let 769 val newId = 770 makeVariableId(arity, isEquality oldId, isDatatype, false, description, structPath) 771 fun newMap(id as TypeId{idKind=Bound{offset=n, ...}, ...}) = 772 if n = offset then SOME newId else typeMap id 773 | newMap _ = NONE 774 in 775 newId :: makeNewIds(rest, newMap) 776 end 777 778 | makeNewIds _ = raise InternalError "Map does not return Bound Id" 779 780 val v = Vector.fromList(makeNewIds(boundIds, fn _ => NONE)) 781 (* Map bound IDs only. *) 782 val mapIds = 783 if firstBoundIndex = startNewIds orelse null boundIds 784 then typeIdMap (* Optimisation to reduce space: don't add map if it's not needed. *) 785 else 786 let 787 fun mapId n = 788 if n < firstBoundIndex then outerTypeIdEnv n 789 else Vector.sub (v, n - firstBoundIndex) 790 in 791 composeMaps(typeIdMap, mapId) 792 end 793 in 794 makeSignature(name, tab, !idCount, locations, mapIds, []) 795 end 796 797 and signatureWhereType(sigExp, typeVars, typeName, realisationType, line, Env globalEnv, structPath) = 798 let 799 (* We construct the signature into the result signature. When we apply the 800 "where" we need to look up the types (and structures) only within the 801 signature constrained by the "where" and not in the surrounding signature. 802 e.g. If we have sig type t include S where type t = ... end 803 we need to generate an error if S does not include t. Of course 804 if it does that's also an error since t would be rebound! 805 Equally, we must look up the right hand side of a where type 806 in the surrounding scope, which will consist of the global environment 807 and the signature excluding the entries we're adding here. *) 808 809 val resSig as Signatures { typeIdMap = idMap, tab = resTab, ... } = 810 sigValue(sigExp, Env globalEnv, lno, structPath) 811 val sigEnv = makeEnv resTab 812 813 fun lookupFailure msg = 814 giveError (str, line, lex) (msg ^ " in signature.") 815 816 (* Look up the type constructor in the signature. *) 817 val sigTypeConstr = 818 lookupTyp 819 ({ 820 lookupType = #lookupType sigEnv, 821 lookupStruct = #lookupStruct sigEnv 822 }, 823 typeName, 824 lookupFailure); 825 826 (* The type, though, is looked up in the surrounding environment. *) 827 fun lookupGlobal(s, locn) = 828 lookupTyp 829 ({ 830 lookupType = #lookupType globalEnv, 831 lookupStruct = #lookupStruct globalEnv 832 }, 833 s, 834 giveError (str, locn, lex)) 835 836 (* Process the type, looking up any type constructors. *) 837 val realisation = assignTypes (realisationType, lookupGlobal, lex); 838 839 fun cantSet(reason1, reason2) = 840 let 841 val typeEnv = 842 { 843 lookupType = fn s => case #lookupType globalEnv s of NONE => NONE | SOME t => SOME(t, NONE), 844 lookupStruct = fn s => case #lookupStruct globalEnv s of NONE => NONE | SOME t => SOME(t, NONE) 845 } 846 in 847 errorMsgNear (lex, true, fn n => displaySigs(sigExp, n), lno, 848 PrettyBlock(3, false, [], 849 [ 850 PrettyString "Cannot apply type realisation.", 851 PrettyBreak(1, 2), 852 PrettyString("``" ^ typeName ^ "''"), 853 PrettyBreak(1, 0), 854 PrettyString reason1, 855 PrettyBreak(1, 0), 856 display(realisation, 1000, typeEnv), 857 PrettyBreak(0, 0), 858 PrettyString reason2 859 ])) 860 end 861 in 862 (* Now try to set the target type to the type function. *) 863 if isUndefinedTypeConstr (tsConstr sigTypeConstr) 864 then () (* Probably because looking up the type constructor name failed. *) 865 else 866 let 867 (* Map the type identifier to be set. *) 868 val typeId = 869 case tcIdentifier (tsConstr sigTypeConstr) of 870 TypeId{idKind=Bound{offset, ...}, ...} => idMap offset 871 | id => id 872 in 873 if not (isVariableId typeId) 874 then (* May have been declared as type t=int or bound by a where type already. *) 875 errorMsgNear (lex, true, fn n => displaySigs(sigExp, n), lno, 876 PrettyBlock(3, false, [], 877 [ 878 PrettyString "Cannot apply type realisation.", 879 PrettyBreak(1, 2), 880 PrettyString("``" ^ typeName ^ "''"), 881 PrettyBreak(1, 0), 882 PrettyString " has already been set to", 883 PrettyBreak(1, 0), 884 printId typeId 885 ])) 886 else 887 case typeId of 888 TypeId{idKind=Bound { offset, ... }, ...} => 889 ( 890 case realId(offset-initTypeId) of 891 VariableSlot {boundId=varId as TypeId{idKind=Bound{eqType, offset, isDatatype, ...}, ...}, ... } => 892 ( 893 (* The rule for "where type" says that we must check that an eqtype 894 is only set to a type that permits equality and that the result 895 is "well-formed". This seems to mean that if the type we're 896 setting is a datatype (has constructors) it can only be set to 897 a type that is a type name and not a general type function. *) 898 if pling eqType andalso not(typePermitsEquality realisation) 899 then cantSet ("is an eqtype but", "does not permit equality.") 900 else case typeNameRebinding (typeVars, realisation) of 901 SOME typeId => 902 (* Renaming an existing constructor e.g. type t = s. Propagate the id. 903 "s" may be free or it may be within the signature and equivalent to 904 a sharing constraint. 905 e.g. sig type t structure S: sig type s end where type s = t end. *) 906 let 907 (* We need to check what it has been set to if it's already set. *) 908 val linkedId = 909 case typeId of 910 id as TypeId{idKind=Bound{offset, ...}, ...} => 911 if offset < initTypeId 912 then FreeSlot id (* Outside the sig: treat it as Free. *) 913 else realId(offset-initTypeId) 914 | id => FreeSlot id (* Free *) 915 in 916 case linkedId of 917 VariableSlot _ => linkFlexibleTypeIds(typeId, varId) 918 | _ => StretchArray.update(mapArray, offset-initTypeId, linkedId) 919 end 920 | NONE => 921 if isDatatype 922 (* The type we're trying to set is a datatype but the type 923 we're setting it to isn't. *) 924 then cantSet ("is a datatype but", "is not a simple type.") 925 else 926 let 927 val typeId = 928 makeTypeFunction( 929 { location = line, description = "", name = typeName }, 930 (typeVars, realisation)) 931 in 932 StretchArray.update(mapArray, offset-initTypeId, FreeSlot typeId) 933 end 934 ) 935 | _ => (* Already checked. *) raise InternalError "setWhereType" 936 ) 937 | _ => (* Already checked. *) raise InternalError "setWhereType" 938 end; 939 resSig 940 end (* signatureWhereType *) 941 942 (* Constructs a signature and inserts it into an environment at a given offset. 943 Generally offset will be zero except if we are including a signature. 944 All the type IDs corresponding to local types are variables. There may be free 945 IDs (and bound IDs?) as a result of "where type" constraints. *) 946 and makeSigInto(sigsList: specs list, 947 Env globalEnv, (* The surrounding environment excluding this sig. *) 948 lno: LEX.location, offset: int, structPath): signatures = 949 let 950 (* Make a new signature. *) 951 val newTable = makeSignatureTable(); 952 (* Copy everything into the new signature. *) 953 954 local 955 (* ML 97 does not allow multiple declarations in a signature. *) 956 fun checkAndEnter (enter, lookup, kind, locs) (s: string, v) = 957 case lookup s of 958 SOME _ => (* Already there. *) 959 let 960 fun getDecLoc(DeclaredAt loc :: _) = loc 961 | getDecLoc [] = lno 962 | getDecLoc(_::rest) = getDecLoc rest 963 (* TODO: This shows the location of the identifier that is the duplicate. 964 It would be nice if it could also show the original location. *) 965 in 966 errorNear (lex, true, fn n => displaySigs(str, n), getDecLoc(locs v), 967 kind ^ " (" ^ s ^ ") is already present in this signature.") 968 end 969 | NONE => enter(s, v) 970 971 val structEnv = makeEnv newTable; 972 in 973 val structEnv = 974 { 975 lookupVal = #lookupVal structEnv, 976 lookupType = #lookupType structEnv, 977 lookupFix = #lookupFix structEnv, 978 lookupStruct = #lookupStruct structEnv, 979 lookupSig = #lookupSig structEnv, 980 lookupFunct = #lookupFunct structEnv, 981 enterVal = 982 checkAndEnter (#enterVal structEnv, #lookupVal structEnv, "Value", 983 fn (Value{ locations, ...}) => locations), 984 enterType = 985 checkAndEnter (#enterType structEnv, #lookupType structEnv, "Type", tcLocations o tsConstr), 986 enterStruct = 987 checkAndEnter (#enterStruct structEnv, #lookupStruct structEnv, "Structure", fn Struct{locations, ...} => locations), 988 (* These next three can't occur. *) 989 enterFix = fn _ => raise InternalError "Entering fixity in signature", 990 enterSig = fn _ => raise InternalError "Entering signature in signature", 991 enterFunct = fn _ => raise InternalError "Entering functor in signature", 992 allValNames = #allValNames structEnv 993 } 994 end 995 996 (* Process the entries in the signature and allocate an address 997 to each. *) 998 fun processSig (signat: specs, offset : int, lno : LEX.location) : int = 999 case signat of 1000 StructureSig (structList : structSigBind list, _) => 1001 let 1002 (* Each element in the list should be a structure binding. *) 1003 fun pStruct [] offset = offset 1004 | pStruct (({name, sigStruct = (sigStruct, _, _), line, ...}: structSigBind) :: t) offset = 1005 let 1006 (* Create a new surrounding environment to include the surrounding 1007 structure. This is the scope for any structures or types. 1008 Specifically, if we look up a type defined by a "where type" 1009 we use this environment and not the signature we're creating. *) 1010 val newEnv = 1011 { 1012 lookupVal = #lookupVal structEnv, 1013 lookupType = 1014 lookupDefault (#lookupType structEnv) (#lookupType globalEnv), 1015 lookupFix = #lookupFix structEnv, 1016 lookupStruct = 1017 lookupDefault (#lookupStruct structEnv) (#lookupStruct globalEnv), 1018 lookupSig = #lookupSig structEnv, 1019 lookupFunct = #lookupFunct structEnv, 1020 enterVal = #enterVal structEnv, 1021 enterType = #enterType structEnv, 1022 enterStruct = #enterStruct structEnv, 1023 enterFix = #enterFix structEnv, 1024 enterSig = #enterSig structEnv, 1025 enterFunct = #enterFunct structEnv, 1026 allValNames = fn () => (#allValNames structEnv () @ #allValNames globalEnv ()) 1027 1028 }; 1029 val resSig = sigValue (sigStruct, Env newEnv, line, structPath ^ name ^ "."); 1030 (* Process the rest of the list before declaring 1031 the structure. *) 1032 val result = pStruct t (offset + 1); 1033 (* Make a structure. *) 1034 val locations = [DeclaredAt lno, SequenceNo (newBindingId lex)] 1035 val resStruct = makeFormalStruct (name, resSig, offset, locations) 1036 val () = #enterStruct structEnv (name, resStruct); 1037 in 1038 result (* One slot for each structure. *) 1039 end 1040 in 1041 pStruct structList offset 1042 end 1043 1044 | ValSig {name=(name, nameLoc), typeof, line, ...} => 1045 let 1046 val errorFn = giveSpecError (signat, line, lex); 1047 1048 fun lookup(s, locn) = 1049 lookupTyp 1050 ({ 1051 lookupType = 1052 lookupDefault (#lookupType structEnv) (#lookupType globalEnv), 1053 lookupStruct = 1054 lookupDefault (#lookupStruct structEnv) (#lookupStruct globalEnv) 1055 }, 1056 s, 1057 giveSpecError (signat, locn, lex)); 1058 (* Check for rebinding of built-ins. "it" is allowed here. *) 1059 val () = if name = "true" orelse name = "false" orelse name = "nil" 1060 orelse name = "::" orelse name = "ref" 1061 then errorFn("Specifying \"" ^ name ^ "\" is illegal.") 1062 else (); 1063 val typeof = assignTypes (typeof, lookup, lex) 1064 val locations = [DeclaredAt nameLoc, SequenceNo (newBindingId lex)] 1065 1066 in (* If the type is not found give an error. *) 1067 (* The type is copied before being entered in the environment. 1068 This isn't logically necessary but has the effect of removing 1069 ref we put in for type constructions. *) 1070 #enterVal structEnv (name, 1071 mkFormal (name, ValBound, 1072 copyType (typeof, fn x => x, fn x => x), offset, locations)); 1073 (offset + 1) 1074 end 1075 1076 | ExSig {name=(name, nameLoc), typeof, line, ...} => 1077 let 1078 val errorFn = giveSpecError (signat, line, lex); 1079 1080 fun lookup(s, _) = 1081 lookupTyp 1082 ({ 1083 lookupType = 1084 lookupDefault (#lookupType structEnv) (#lookupType globalEnv), 1085 lookupStruct = 1086 lookupDefault (#lookupStruct structEnv) (#lookupStruct globalEnv) 1087 }, 1088 s, 1089 errorFn); 1090 1091 val exType = 1092 case typeof of 1093 NONE => exnType 1094 | SOME typeof => mkFunctionType (assignTypes (typeof, lookup, lex), exnType) 1095 val locations = [DeclaredAt nameLoc, SequenceNo (newBindingId lex)] 1096 in (* If the type is not found give an error. *) 1097 (* Check for rebinding of built-ins. "it" is not allowed. *) 1098 if name = "true" orelse name = "false" orelse name = "nil" 1099 orelse name = "::" orelse name = "ref" orelse name = "it" 1100 then errorFn("Specifying \"" ^ name ^ "\" is illegal.") 1101 else (); 1102 #enterVal structEnv (name, mkFormal (name, Exception, exType, offset, locations)); 1103 (offset + 1) 1104 end 1105 1106 | IncludeSig (structList : sigs list, _) => 1107 let 1108 (* include sigid ... sigid or include sigexp. For 1109 simplicity we handle the slightly more general case 1110 of a list of signature expressions. 1111 The contents of the signature are added to the environment. *) 1112 fun includeSigExp (str: sigs, offset) = 1113 let 1114 val address = ref offset 1115 (* The environment for the signature being included must at least include local types. *) 1116 val includeEnv = 1117 { 1118 lookupVal = #lookupVal structEnv, 1119 lookupType = 1120 lookupDefault (#lookupType structEnv) (#lookupType globalEnv), 1121 lookupFix = #lookupFix structEnv, 1122 lookupStruct = 1123 lookupDefault (#lookupStruct structEnv) (#lookupStruct globalEnv), 1124 lookupSig = #lookupSig structEnv, 1125 lookupFunct = #lookupFunct structEnv, 1126 enterVal = #enterVal structEnv, 1127 enterType = #enterType structEnv, 1128 enterStruct = #enterStruct structEnv, 1129 enterFix = #enterFix structEnv, 1130 enterSig = #enterSig structEnv, 1131 enterFunct = #enterFunct structEnv, 1132 allValNames = #allValNames structEnv 1133 } 1134 1135 val resultSig = sigValue(str, Env includeEnv, lno, structPath) 1136 1137 (* Renumber the run-time offsets for Values and Structures as we enter them 1138 into the surrounding signature. *) 1139 fun newAccess(Formal _) = 1140 let val addr = !address in address := addr+1; Formal addr end 1141 | newAccess _ = raise InternalError "newAccess: Not Formal" 1142 1143 fun enterType(name, tySet as TypeConstrSet(ty, tcConstructors)) = 1144 let 1145 (* Process value constructors with the type. Because values can't 1146 be redefined within a signature we can't have overridden this 1147 with a new declaration. We don't allocate run-time IDs to 1148 type identifiers. That's done at the end when we've sorted out 1149 any sharing *) 1150 fun copyConstructor(Value { name, typeOf, access, class, locations, ... }) = 1151 Value{name=name, typeOf = typeOf, access=newAccess access, 1152 class=class, locations=locations, references=NONE, 1153 instanceTypes=NONE} 1154 val newType = 1155 case tcConstructors of 1156 [] => tySet (* Not a datatype. *) 1157 | constrs => 1158 let 1159 val newTy = 1160 makeTypeConstructor(tcName ty, tcTypeVars ty, tcIdentifier ty, tcLocations ty) 1161 in 1162 TypeConstrSet(newTy, List.map copyConstructor constrs) 1163 end; 1164 in 1165 #enterType structEnv(name, newType) 1166 end 1167 1168 and enterStruct(name, Struct{name=strName, signat, access, locations, ...}) = 1169 #enterStruct structEnv 1170 (name, Struct{ name = strName, signat = signat, 1171 access = newAccess access, locations = locations}) 1172 1173 and enterVal(dName, Value { name, typeOf, access, class, locations, ... }) = 1174 #enterVal structEnv (dName, 1175 Value{name=name, typeOf = typeOf, access=newAccess access, 1176 class=class, locations=locations, references=NONE, 1177 instanceTypes=NONE}) 1178 1179 val tsvEnv = 1180 { enterType = enterType, enterStruct = enterStruct, enterVal = enterVal } 1181 val () = openSignature(resultSig, tsvEnv, "") 1182 in 1183 ! address 1184 end 1185 in 1186 List.foldl includeSigExp offset structList 1187 end 1188 1189 | Sharing (share : shareConstraint) => 1190 (* Sharing constraint. *) 1191 let 1192 (* In ML90 it was possible to share with any identifier 1193 in scope. In ML97 sharing is restricted to identifiers 1194 in the "spec". *) 1195 val envForSharing = Env structEnv 1196 in 1197 applySharingConstraint (share, envForSharing, str); 1198 offset (* No entry *) 1199 end 1200 1201 | CoreType {dec, ...} => 1202 let (* datatype or type binding(s) *) 1203 (* This pass puts the data constructors into the environment. *) 1204 val addrs = ref offset 1205 (* Pass2 creates value constructors of datatypes as global values. 1206 Rather than complicate pass2 by trying to make formal values 1207 in this case it's easier to trap the value constructors at 1208 this point. N.B. We may get constructors from a datatype 1209 declaration or from datatype replication. *) 1210 fun convertValueConstr(Value{class=class, typeOf, locations, name, ...}) = 1211 Value{class=class, typeOf=typeOf, access=Formal(!addrs before (addrs := !addrs+1)), name=name, 1212 locations=locations, references=NONE, instanceTypes=NONE} 1213 1214 fun enterVal(name, v) = (#enterVal structEnv)(name, convertValueConstr v) 1215 1216 (* Record all the types and enter them later. *) 1217 val datatypeList = searchList () 1218 val enterType = #enter datatypeList 1219 1220 val newEnv = 1221 { 1222 lookupVal = #lookupVal structEnv, 1223 lookupType = 1224 lookupDefault (#lookup datatypeList) 1225 (lookupDefault (#lookupType structEnv) (#lookupType globalEnv)), 1226 lookupFix = #lookupFix structEnv, 1227 lookupStruct = 1228 lookupDefault (#lookupStruct structEnv) (#lookupStruct globalEnv), 1229 lookupSig = #lookupSig structEnv, 1230 lookupFunct = #lookupFunct structEnv, 1231 enterVal = enterVal, 1232 enterType = enterType, 1233 enterStruct = #enterStruct structEnv, 1234 enterFix = #enterFix structEnv, 1235 enterSig = #enterSig structEnv, 1236 enterFunct = #enterFunct structEnv, 1237 allValNames = #allValNames structEnv 1238 }; 1239 1240 fun makeId (eq, isdt, (args, EmptyType), loc) = 1241 makeVariableId(length args, eq, isdt, true, loc, structPath) 1242 1243 | makeId (_, _, (typeVars, decType), { location, name, description }) = 1244 makeTypeFunction( 1245 { location = location, name = structPath ^ name, description = description }, 1246 (typeVars, decType)) 1247 1248 (* We need a map to look up types. This is only used in one place: 1249 if the item we're processing is a datatype then we need to look 1250 at the bindings of type identifiers to compute equality correctly. 1251 e.g. type t = int*int datatype s = X of t . *) 1252 fun equalityForId(TypeId{idKind=TypeFn(_, equiv), ...}) = typePermitsEquality equiv 1253 | equalityForId id = isEquality id 1254 1255 fun findEquality n = 1256 if n < initTypeId 1257 then equalityForId(outerTypeIdEnv n) 1258 else case realId(n-initTypeId) of 1259 FreeSlot t => equalityForId t 1260 | VariableSlot { boundId, ...} => equalityForId boundId 1261 | _ => raise InternalError "internalMap: Not bound or Free" 1262 1263 val _ : types = pass2 (dec, makeId, Env newEnv, lex, findEquality); 1264 (* Replace the constructor list for the datatype with a new set. 1265 We need to have separate addresses for the constructors in the 1266 datatype environment from those in the value environment. This 1267 is needed for compatibility with the "signature" constructed 1268 from a struct...end block. *) 1269 fun enterFinalType (name, TypeConstrSet(tyCons, constrs)) = 1270 #enterType structEnv (name, TypeConstrSet(tyCons, List.map convertValueConstr constrs)) 1271 val _ = #apply datatypeList enterFinalType 1272 in 1273 ! addrs 1274 end 1275 (* end processSig *); 1276 1277 val _ = 1278 List.foldl (fn (signat, offset) => processSig (signat, offset, lno)) 1279 offset sigsList 1280 val locations = [DeclaredAt lno, SequenceNo (newBindingId lex)] 1281 in 1282 makeSignature("", newTable, ! idCount, locations, typeIdEnv (), []) 1283 end 1284 1285 (* Process the contents of the signature. *) 1286 val resultSig = sigValue (str, Env globalEnv, lno, "") 1287 1288 (* After the signature has been built and any sharing or "where type" 1289 constraints have been applied we replace the remaining variable stamps 1290 by bound stamps. *) 1291 val nextAddress = getNextRuntimeOffset resultSig 1292 val typeCounter = ref initTypeId; 1293 val addrCounter = ref nextAddress 1294 1295 (* Construct final bound IDs for each distinct type ID in the array. *) 1296 local 1297 fun mapIds n = 1298 if n = !idCount-initTypeId 1299 then ([], []) 1300 else 1301 ( 1302 (* Process lowest numbered IDs first since they represent 1303 the result of any sharing. *) 1304 case realId n of 1305 VariableSlot { 1306 boundId = 1307 TypeId{ 1308 idKind=Bound{eqType, isDatatype, arity, ... }, 1309 description = { name, location, description}, ...}, 1310 descriptions, ...} => 1311 let (* Need to make a new ID. *) 1312 (* If we have sharing we want to produce a description that expresses that. *) 1313 val descript = 1314 case descriptions of 1315 descs as _ :: _ :: _ => "sharing " ^ String.concatWith "," descs 1316 | _ => description (* Original description. *) 1317 val newId = 1318 let 1319 (* For each ID we need a new entry in the ID vector. We also 1320 need an entry in the run-time vector for the structure so that 1321 we can pass the equality/print value at run-time. *) 1322 val n = !typeCounter 1323 val () = typeCounter := n + 1 1324 val addr = ! addrCounter 1325 val () = addrCounter := addr + 1 1326 val description = 1327 { name = name, location = location, description = descript } 1328 in 1329 makeBoundId(arity, Formal addr, n, pling eqType, isDatatype, description) 1330 end 1331 (* Update the entry for any sharing. *) 1332 val () = StretchArray.update(mapArray, n, FreeSlot newId) 1333 val (distinctIds, mappedIds) = mapIds (n+1) 1334 in 1335 (newId :: distinctIds, newId :: mappedIds) 1336 end 1337 1338 | FreeSlot (TypeId{idKind=TypeFn(args, equiv), description, ...}) => 1339 let 1340 (* Generally, IDs in a FreeSlot will be either Bound or Free but 1341 they could be TypeFunctions as a result of a "where type" and 1342 the function could involve type IDs within the signature. We 1343 have to copy the ID now after all the new IDs have been created. *) 1344 fun copyId(TypeId{idKind=Bound { offset, ...}, ...}) = 1345 if offset < initTypeId then NONE 1346 else (* At this stage we've overwritten all entries with FreeSlots. *) 1347 ( 1348 case realId(offset-initTypeId) of 1349 FreeSlot id => SOME id 1350 | _ => raise InternalError "mapIds:copyTypeConstr" 1351 ) 1352 | copyId _ = NONE 1353 1354 val copiedEquiv = 1355 copyType(equiv, fn x => x, 1356 fn tcon => copyTypeConstr (tcon, copyId, fn x => x, fn s => s)) 1357 (* For the moment always use a Free ID here. *) 1358 val copiedId = makeTypeFunction(description, (args, copiedEquiv)) 1359 (* Update the array with this copied version. If other subsequent type functions 1360 use this entry they will then pick up the copied version. Because "where type" 1361 constraints can only refer to earlier types we have to process this from earlier 1362 to later. *) 1363 val () = StretchArray.update(mapArray, n, FreeSlot copiedId) 1364 val (distinctIds, mappedIds) = mapIds (n+1) 1365 in 1366 (distinctIds, copiedId :: mappedIds) 1367 end 1368 1369 | FreeSlot id => (* Free or shares with existing type ID. *) 1370 let 1371 val (distinctIds, mappedIds) = mapIds (n+1) 1372 in 1373 (distinctIds, id :: mappedIds) 1374 end 1375 1376 | _ => raise InternalError "mapIds" 1377 ) 1378 val (distinctIds, mappedIds) = mapIds 0 1379 val mapVector = Vector.fromList mappedIds 1380 val resVector = Vector.fromList distinctIds 1381 in 1382 fun mapFunction n = 1383 if n < initTypeId 1384 then outerTypeIdEnv n 1385 else Vector.sub(mapVector, n-initTypeId) 1386 val distinctIds = distinctIds 1387 val allMapped = Vector.length mapVector = Vector.length resVector 1388 end 1389 in 1390 let 1391 val Signatures { tab, name, locations, typeIdMap, ... } = resultSig 1392 (* We have allocated Bound Ids starting at initTypeId. If there has not been any sharing or 1393 where type constraints these Ids will correspond exactly to the bound Ids of the signature 1394 and we can use the result without any further mapping. This is particularly the case if 1395 we have simply used a named signature here. If there have been some sharing or where type 1396 we have to produce a new map so that the boundId list consists of contiguously numbered 1397 items. This is an optimisation to reduce the space of the final signature. *) 1398 val finalMap = 1399 if allMapped then typeIdMap else composeMaps(typeIdMap, mapFunction) 1400 in 1401 makeSignature(name, tab, initTypeId, locations, finalMap, distinctIds) 1402 end 1403 end (* sigVal *); 1404 1405 structure Sharing = 1406 struct 1407 type sigs = sigs 1408 type structSigBind = structSigBind 1409 type parsetree = parsetree 1410 type typeParsetree = typeParsetree 1411 type typeVarForm = typeVarForm 1412 type pretty = pretty 1413 type ptProperties = ptProperties 1414 type env = env 1415 type signatures = signatures 1416 type lexan = lexan 1417 type typeId = typeId 1418 type specs = specs 1419 end 1420 1421end; 1422 1423