'From Squeak3.2alpha of 1 November 2001 [latest update: #4586] on 12 December 2001 at 10:37:52 am'! "Change Set: preserveAssociations-hg Date: 4 December 2001 Author: Henrik Gedenryd Some tweaks to preserve associations when moving across dictionaries, when renaming, and so on. Under the hood much of the system depends on preserving the individual Association objects that are used for global (now module) variables."! TestCase subclass: #ModuleTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Modules-Tests'! !Browser methodsFor: 'class functions' stamp: 'hg 12/10/2001 11:35'! renameClass | oldName newName | classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. oldName _ self selectedClass name. newName _ self request: 'Please type new class name' initialAnswer: oldName. newName = '' ifTrue: [^ self]. " Cancel returns '' " newName _ newName asSymbol. newName = oldName ifTrue: [^ self]. Module root browseAllReferencesTo: oldName. [self selectedClass rename: newName] on: AttemptToWriteReadOnlyGlobal do: [:ex | ex resume: true].. self changed: #classList. self classListIndex: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) indexOf: newName).! ! !Module methodsFor: 'changing defined names' stamp: 'hg 12/5/2001 09:38'! addAssoc: assoc export: exportIt self adoptIfUndeclared: assoc key. definedNames _ self definedNames add: assoc; yourself. exportIt ifTrue: [self exportName: assoc key]. self invalidateCaches! ! !Module methodsFor: 'changing defined names' stamp: 'hg 12/5/2001 09:45'! adoptIfUndeclared: aName | isUndeclared | isUndeclared _ (self localAssocFor: aName ifAbsent: [nil]) notNil and: [ Undeclared includesKey: aName]. isUndeclared ifTrue: [definedNames _ self definedNames declare: aName from: Undeclared].! ! !Module methodsFor: 'changing defined names' stamp: 'hg 12/8/2001 21:22'! changeName: oldName to: newName forValue: value | reusedAssoc shouldExport changeInSmalltalk | "with weak modules, retain compatibility by also renaming value in Smalltalk" changeInSmalltalk _ Preferences strongModules not and: [Module smalltalk notNil and: [self ~~ Module smalltalk]]. reusedAssoc _ self localAssocFor: oldName ifAbsent: []. shouldExport _ self exportsName: oldName. self removeName: oldName. changeInSmalltalk ifTrue: [Module smalltalk removeName: oldName]. reusedAssoc key: newName. self addAssoc: reusedAssoc export: shouldExport. changeInSmalltalk ifTrue: [Module smalltalk addAssoc: reusedAssoc export: false]. ! ! !Module methodsFor: 'changing defined names' stamp: 'hg 12/10/2001 11:06'! exportName: aString | assoc | assoc _ self localAssocFor: aString asSymbol ifAbsent: [self error: 'name not defined']. exportedNames _ self exportedNames removeKey: assoc key ifAbsent: []; add: assoc; yourself! ! !Module methodsFor: 'changing defined names' stamp: 'hg 12/8/2001 15:13'! moveName: aName toModule: newModule "make sure to preserve the association for the name across the modules, as it is used in method literals" | export assoc | assoc _ self localAssocFor: aName ifAbsent: [self error: 'name not defined']. export _ self exportsName: aName. self simplyRemoveName: aName. newModule addAssoc: assoc export: export. (assoc value respondsTo: #module:) ifTrue: [assoc value module: newModule]. self invalidateCaches ! ! !Module methodsFor: 'changing defined names' stamp: 'hg 12/8/2001 21:22'! redefineName: aString as: value export: exportIt "Be careful about the identity of the associations used, so as to preserve literal bindings of capitalized variable references. " | reusedAssoc key putInSmalltalk | aString first isUppercase ifFalse: [ self notify: 'Global names should be Capitalized, but "', aString asText allBold, '" is not. This could cause various problems. Cancel to avoid creating this global name.']. key _ aString asSymbol. self adoptIfUndeclared: key. reusedAssoc _ self localAssocFor: key ifAbsent: [ ReadOnlyVariableBinding key: key value: value]. "with weak modules, retain compatibility by also putting globals in Smalltalk. " putInSmalltalk _ Preferences strongModules not and: [Module smalltalk notNil and: [(value isKindOf: Module) not]]. putInSmalltalk ifTrue: [ Module smalltalk redefineName: aString as: value export: false. reusedAssoc _ Module smalltalk localAssocFor: key ifAbsent: []]. self addAssoc: reusedAssoc export: exportIt. ! ! !Module methodsFor: 'changing defined names' stamp: 'hg 12/8/2001 15:12'! removeName: aString | weakModules sameAssocInSmalltalk alsoRemoveFromSmalltalk | "with weak modules, retain compatibility by also removing value from Smalltalk" weakModules _ Preferences strongModules not and: [Module smalltalk notNil]. sameAssocInSmalltalk _ (Module smalltalk localAssocFor: aString ifAbsent: [nil]) == (self localAssocFor: aString ifAbsent: [nil]). alsoRemoveFromSmalltalk _ weakModules & sameAssocInSmalltalk and: [self ~~ Module smalltalk]. alsoRemoveFromSmalltalk ifTrue: [ Module smalltalk removeName: aString]. self simplyRemoveName: aString! ! !Module methodsFor: 'changing defined names' stamp: 'hg 12/8/2001 15:12'! simplyRemoveName: aString self definedNames removeKey: aString asSymbol ifAbsent: []. self exportedNames removeKey: aString asSymbol ifAbsent: []. self invalidateCaches ! ! !Module methodsFor: 'compatibility' stamp: 'hg 12/5/2001 09:46'! removeClassFromSystem: aClass logged: aBool "Delete the class, aClass, from the system, but log the removal neither to the current change set nor to the changes log" aBool ifTrue:[ aClass wantsChangeSetLogging ifTrue: [self changes noteRemovalOf: aClass]. aClass acceptsLoggingOfCompilation ifTrue: [Smalltalk logChange: self pathAsMessages, ' removeClassNamed: #', aClass name]. ]. "self organization removeElement: aClass name." Smalltalk removeFromStartUpList: aClass. Smalltalk removeFromShutDownList: aClass. (self localAssocFor: aClass name ifAbsent: [nil]) ifNotNil: [self removeName: aClass name]. Smalltalk flushClassNameCache ! ! !ModuleRefactorer methodsFor: 'converting pools' stamp: 'hg 12/9/2001 12:30'! convertPoolNamed: poolName inModule: homePath toPoolModule: poolModuleName "pool dictionaries are now redundant, as modules can be used to collect shared variables. Change current pools to modules" | poolModule users homeModule poolDictionary | homeModule _ Module fromPath: homePath forceCreate: true. poolDictionary _ homeModule definitionFor: poolName ifAbsent: [nil]. [poolModule _ Module fromPath: (homePath copyWith: poolModuleName) forceCreate: true] on: Warning do: [:ex | ex resume: true]. poolModuleName = #Constants ifFalse: [ "Make pool module name reachable, e.g. TextConstants" poolModule parentModule exportName: poolModuleName. Module smalltalk redefineName: poolModuleName as: poolModule export: false]. poolName ~= poolModuleName ifTrue: [ homeModule removeName: poolName]. "use low-level method to avoid adding pool vars to Smalltalk" poolDictionary associationsDo: [:ass | "apply violence to the aberrant Alice pool names" (ass key isMemberOf: Symbol) ifFalse: [ass key: ass key asSymbol]. poolModule addAssoc: ass export: true]. users _ Set new. Module root deepClassesDo: [:class | (class sharedPools identityIncludes: poolDictionary) ifTrue: [users add: class]]. users do: [:class | (class module hasNeighborModule: poolModule) ifFalse: [ class module externalModule: poolModule alias: nil version: nil importNames: true]. class privateRemoveSharedPool: poolDictionary]. "self testRecompileClasses: users." "methodRefs _ Smalltalk allCallsOn: (Smalltalk associationAt: k)"! ! !ModuleRefactorer methodsFor: 'utilities' stamp: 'hg 12/5/2001 10:07'! transferBindingsNamedIn: nameList from: oldModule to: newModule nameList do: [:aName | oldModule moveName: aName toModule: newModule]! ! !ModuleTests methodsFor: 'system integrity tests' stamp: 'hg 12/9/2001 14:02'! testIntegrityOfAllLiterals "check that global literals in CompiledMethods will be bound to the exact same association object if recompiled (this is stronger than just the same name or value)" | badOnes globalRefs badRefs ok | badOnes _ OrderedCollection new. Module @ #(Squeak Language) deepClassesDo: [:c | "Transcript show: '.'." {c. c class } do: [:cl | cl methodDict valuesDo: [:cm | globalRefs _ cm literals select: [:lit | (lit isKindOf: LookupKey) and: [lit key notNil] and: [ (c definesName: lit key lookInSuper: true ifTrue: [:a |]) not]]. badRefs _ globalRefs reject: [:lit | (cl module definesName: lit key ifTrue: [:ass | ok _ ass == lit]) and: [ok]]. badOnes addAll: badRefs]]]. self should: [badOnes isEmpty] ! ! !ModuleTests methodsFor: 'system integrity tests' stamp: 'hg 12/9/2001 14:07'! testIntegrityOfModuleOfClasses "check that each class points to the module it is defined in" "this is really a test of the current state of the image" | good allBad | allBad _ OrderedCollection new. Module root deepSubmodulesDo: [:mod | mod == Module smalltalk ifFalse: [ mod allClassesDo: [:cl | good _ cl module == mod. good ifFalse: [allBad add: {cl. cl module. mod}]]]]. self should: [allBad isEmpty]! ! !ModuleTests methodsFor: 'system integrity tests' stamp: 'hg 12/9/2001 14:02'! testIntegrityOfReadOnlyModuleDefinitions "all modular name defs shoud use read-only associations" "this is really a test of the current state of the image" | good allBad | allBad _ OrderedCollection new. self allAssociationsEverywhereDo: [:ass :mod | good _ ass isMemberOf: ReadOnlyVariableBinding. good ifFalse: [allBad add: {ass. mod}]]. self should: [allBad isEmpty]! ! !ModuleTests methodsFor: 'system integrity tests' stamp: 'hg 12/9/2001 14:02'! testIntegrityOfWeakClassBindings "all classes under Squeak should also appear in Smalltalk" "this is really a test of the current state of the image, and only applies to weak modules" | good allBad binding | Preferences strongModules ifTrue: [^self]. allBad _ OrderedCollection new. Module squeak deepClassesDo: [:cl | binding _ Module smalltalk localAssocFor: cl name ifAbsent: [nil]. good _ binding value == cl. good ifFalse: [allBad add: {cl. binding}]]. self should: [allBad isEmpty]! ! !ModuleTests methodsFor: 'system integrity tests' stamp: 'hg 12/9/2001 13:54'! testIntegrityOfWeakNameDefinitions "check that same def in Smalltalk and modules have same association" "this is really a test of the current state of the image, and applies only to weak modules" | good allBad | Preferences strongModules ifTrue: [^self]. allBad _ OrderedCollection new. self allAssociationsEverywhereDo: [:ass :mod | (Module smalltalk localAssocFor: ass key ifAbsent: [nil]) ifNotNilDo: [:sass | sass value == ass value ifTrue: [ good _ ass == sass and: [ (mod localExportedAssocFor: ass key ifAbsent: [sass]) == sass]. good ifFalse: [allBad add: {ass. mod}]]]]. self should: [allBad isEmpty]! ! !ModuleTests methodsFor: 'utility' stamp: 'hg 12/9/2001 11:10'! allAssociationsEverywhereDo: aBlock Module root deepSubmodulesDo: [:mod | mod ~~ Module smalltalk ifTrue: [ mod definedNames associationsDo: [:ass | aBlock value: ass value: mod]]]! ! !TransitionalSmalltalkModule methodsFor: 'changing defined names' stamp: 'hg 12/5/2001 10:20'! addAssoc: assoc export: exportIt "If a new object, signal exception. Always reuse old assoc." | oldAssoc isAChange isNewObject isRecompiledClass | self adoptIfUndeclared: assoc key. oldAssoc _ self definedNames associationAt: assoc key ifAbsent: [nil]. isAChange _ true. "try always signalling to see what happens" "oldAssoc notNil and: [ isNewObject _ oldAssoc value ~~ assoc value. isRecompiledClass _ oldAssoc value isBehavior & assoc value isBehavior and: [oldAssoc value name = assoc value name and: [oldAssoc value module == assoc value module]]. isNewObject & isRecompiledClass not]". isAChange ifTrue: [ "Transcript cr; show: 'Smalltalk at: #', assoc key, ' was redefined from ', (oldAssoc value printStringLimitedTo: 50), ' to ', (assoc value printStringLimitedTo: 50)." self definedNames add: assoc] ifFalse: [ [self definedNames add: assoc] on: AttemptToWriteReadOnlyGlobal do:[:ex| ex resume: true]. ]. exportIt ifTrue: [self exportName: assoc key]. self invalidateCaches ! ! !TransitionalSmalltalkModule methodsFor: 'changing defined names' stamp: 'hg 12/5/2001 10:14'! moveName: aName toModule: newModule "This method doesn't remove the definition from Smalltalk, just from the exports of this module. Make sure to preserve the association for the name across the modules, as it is used in method literals." | export assoc | assoc _ self localAssocFor: aName ifAbsent: [self error: 'name not defined']. export _ self exportsName: aName. export ifTrue: [self exportedNames removeKey: aName]. newModule addAssoc: assoc export: export. (assoc value respondsTo: #module:) ifTrue: [assoc value module: newModule]. self invalidateCaches ! ! !TransitionalSmalltalkModule methodsFor: 'changing defined names' stamp: 'hg 12/8/2001 15:12'! removeName: aString self simplyRemoveName: aString! ! !VirtualRootModule methodsFor: 'accessing defined names' stamp: 'hg 12/8/2001 21:15'! classNames "Answer a SortedCollection of all class names." ^cachedClassNames ifNil: [cachedClassNames _ self computeClassNames]. ! ! !VirtualRootModule methodsFor: 'name queries' stamp: 'hg 10/31/2001 13:11'! modulesExporting: varName "Answer a dictionary of module->value pairs. Search all modules in the system." | defs | defs _ Dictionary new. self allDefinitionsFor: varName onlyExported: true detect: [:value :module | defs at: module put: value]. ^defs ! ! TransitionalSmalltalkModule removeSelector: #changeName:to:forValue:! !ModuleTests reorganize! ('system integrity tests' testIntegrityOfAllLiterals testIntegrityOfModuleOfClasses testIntegrityOfReadOnlyModuleDefinitions testIntegrityOfWeakClassBindings testIntegrityOfWeakNameDefinitions) ('utility' allAssociationsEverywhereDo:) ! Module removeSelector: #removeSimplyName:!