The Trunk: Traits-ar.272.mcz

Andreas Raab uploaded a new version of Traits to project The Trunk:
http://source.squeak.org/trunk/Traits-ar.272.mcz

==================== Summary ====================

Name: Traits-ar.272
Author: ar
Time: 1 January 2010, 7:27:09 am
UUID: 065dc8bf-9996-f345-8842-76af957c5dd9
Ancestors: Traits-ar.271

Making traits unloadable: Three new operations on class trait to support loading and unloading.
- Trait removeAllTraits flattens all classes and traits, converting traits to classes and storing supplemental information to support traits recovery.
- Trait restoreAllTraits restores traits from previously flattened classes based on the supplemental information stored via removeAllTraits.
- Trait unloadTraits first removes all traits and then unloads the traits package via Monticello.


=============== Diff against Traits-ar.271 ===============

Item was added:
+ ----- Method: Trait class>>restoreCompositionOf: (in category 'load-unload') -----
+ restoreCompositionOf: aClass
+ "Restore the trait composition for the given class"
+ | method requires composition |
+ method := aClass compiledMethodAt: #traitInfo ifAbsent:[^self].
+ aClass removeSelector: #traitInfo.
+ requires := (method pragmaAt: #traitRequires:)
+ ifNil:[#()]
+ ifNotNil:[:pragma| pragma arguments first].
+ (requires allSatisfy:[:tn| (Smalltalk at: tn ifAbsent:[nil]) isKindOf: Trait])
+ ifFalse:[^self inform: 'Cannot restore composition of ', aClass name].
+ composition := (method pragmaAt: #traitComposition:)
+ ifNil:[^self]
+ ifNotNil:[:pragma| Compiler evaluate: pragma arguments first].
+ aClass uses: composition.
+ aClass traitComposition selectorsAndMethodsDo:[:sel :meth|
+ | oldMethod newMethod |
+ newMethod := meth methodHome compiledMethodAt: sel.
+ oldMethod := aClass compiledMethodAt: sel ifAbsent:[newMethod].
+ oldMethod timeStamp = newMethod timeStamp
+ ifTrue:[aClass removeSelector: sel]].!

Item was added:
+ ----- Method: Trait class>>storeTraitInfoInClass: (in category 'load-unload') -----
+ storeTraitInfoInClass: aClass
+ "Store trait information in the given class"
+ | code |
+ code := WriteStream on: (String new: 100).
+ code nextPutAll: 'traitInfo
+ "This method contains information to restore the trait structure
+ for the receiver when traits are loaded or unloaded"'.
+ aClass isTrait ifTrue:[
+ code crtab; nextPutAll: '"This class was originally a trait"'.
+ code crtab; nextPutAll: '<traitDefinition: true>'.
+ ].
+ aClass hasTraitComposition ifTrue:[
+ code crtab; nextPutAll: '"The trait composition for the receiver"'.
+ code crtab; nextPutAll: '<traitComposition: ', aClass traitCompositionString storeString,'>'.
+ code crtab; nextPutAll: '"The required traits for this trait"'.
+ code crtab; nextPutAll: '<traitRequires: ', (aClass traits collect:[:t| t baseTrait name]),'>'.
+ ].
+ aClass compile: code contents.
+ !

Item was added:
+ ----- Method: Trait class>>convertTraitToClass: (in category 'load-unload') -----
+ convertTraitToClass: aTrait
+ "Convert the given trait to a class"
+ | aClass |
+ "Move the trait out of the way"
+ Smalltalk removeKey: aTrait name.
+ "Create the class in its place"
+ aClass := Object subclass: aTrait name
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: aTrait category.
+
+ aTrait organization commentRemoteStr ifNotNil:[
+ aClass classComment: aTrait organization classComment
+ stamp: aTrait organization commentStamp].
+
+ aTrait selectorsAndMethodsDo:[:sel :meth|
+ aClass compile: (aTrait sourceCodeAt: sel)
+ classified: (aTrait organization categoryOfElement: sel)
+ withStamp: (aTrait compiledMethodAt: sel) timeStamp
+ notifying: nil].
+
+ aTrait classSide selectorsAndMethodsDo:[:sel :meth|
+ aClass classSide compile: (aTrait classSide sourceCodeAt: sel)
+ classified: (aTrait classSide organization categoryOfElement: sel)
+ withStamp: (aTrait classSide compiledMethodAt: sel) timeStamp
+ notifying: nil].
+
+ aTrait obsolete.
+ ^aClass
+ !

Item was added:
+ ----- Method: Trait class>>unloadTraits (in category 'load-unload') -----
+ unloadTraits
+ "Trait unloadTraits"
+ Trait traitImpl == self ifTrue:[Trait traitImpl: nil].
+ self removeAllTraits.
+ Behavior compileSilently: 'updateTraits' classified: 'accessing'.
+ (MCPackage named: 'Traits') unload.
+ Behavior removeSelectorSilently: #updateTraits.
+ Compiler recompileAll.!

Item was added:
+ ----- Method: Trait class>>removeAllTraits (in category 'load-unload') -----
+ removeAllTraits "Trait removeAllTraits"
+ "Removes all traits currently in use.
+ Preserves enough information so that traits can be recovered."
+ | converted remain |
+ converted := Set new.
+ Smalltalk allClasses do:[:aClass|
+ self flattenTraitMethodsInClass: aClass classSide.
+ self flattenTraitMethodsInClass: aClass.
+ converted add: aClass.
+ ] displayingProgress: 'Flattening classes'.
+
+ remain := Smalltalk allTraits asSet.
+ (1 to: remain size) do:[:i| | trait |
+ trait := remain
+ detect:[:any| any users allSatisfy:[:aClass| converted includes: aClass]]
+ ifNone:[self error: 'Cyclic traits detected'].
+ remain remove: trait.
+ self flattenTraitMethodsInClass: trait classSide.
+ self flattenTraitMethodsInClass: trait.
+ converted add: trait.
+ ] displayingProgress: 'Flattening traits'.
+
+ "Convert all traits to classes"
+ Smalltalk allTraits
+ do:[:trait| self convertTraitToClass: trait]
+ displayingProgress:[:trait| 'Converting ', trait name].
+ !

Item was added:
+ ----- Method: Trait class>>convertClassToTrait: (in category 'load-unload') -----
+ convertClassToTrait: aClass
+ "Convert the given class to a trait"
+ | aTrait |
+ "Move the class out of the way"
+ Smalltalk removeKey: aClass name.
+
+ "Create the trait in its place"
+ aTrait := Trait named: aClass name
+ uses: {}
+ category: aClass category.
+
+ aClass organization commentRemoteStr ifNotNil:[
+ aTrait classComment: aClass organization classComment
+ stamp: aClass organization commentStamp].
+
+ aClass selectorsAndMethodsDo:[:sel :meth|
+ aTrait compile: (aClass sourceCodeAt: sel)
+ classified: (aClass organization categoryOfElement: sel)
+ withStamp: (aClass compiledMethodAt: sel) timeStamp
+ notifying: nil].
+
+ aClass classSide selectorsAndMethodsDo:[:sel :meth|
+ aTrait classSide compile: (aClass classSide sourceCodeAt: sel)
+ classified: (aClass classSide organization categoryOfElement: sel)
+ withStamp: (aClass classSide compiledMethodAt: sel) timeStamp
+ notifying: nil].
+
+ aClass obsolete.
+ ^aTrait
+ !

Item was added:
+ ----- Method: Trait class>>flattenTraitMethodsInClass: (in category 'load-unload') -----
+ flattenTraitMethodsInClass: aClass
+ "Flatten all the trait methods in the given class"
+ | oldClass |
+ (aClass isTrait or:[aClass hasTraitComposition]) ifFalse:[^self].
+ self storeTraitInfoInClass: aClass.
+ aClass selectorsAndMethodsDo:[:sel :meth|
+ (aClass includesLocalSelector: sel) ifFalse:[
+ oldClass := meth methodHome.
+ aClass compile: (aClass sourceCodeAt: sel)
+ classified: (aClass organization categoryOfElement: sel)
+ withStamp: (oldClass compiledMethodAt: sel ifAbsent:[meth]) timeStamp
+ notifying: nil]].
+ aClass traitComposition: #().!

Item was added:
+ ----- Method: Trait class>>restoreAllTraits (in category 'load-unload') -----
+ restoreAllTraits "Trait restoreAllTraits"
+ "Restores traits that had been previously removed.
+ This is the inverse operation to removeAllTraits."
+ | classes method |
+ classes := Smalltalk allClasses select:[:aClass| aClass includesSelector: #traitInfo].
+ classes do:[:aClass|
+ method := aClass compiledMethodAt: #traitInfo.
+ (method pragmaAt: #traitDefinition:) ifNotNil:[:pragma|
+ pragma arguments first
+ ifTrue:[self convertClassToTrait: aClass]].
+ ] displayingProgress:[:aClass| 'Creating trait ', aClass name].
+ classes := Smalltalk allClassesAndTraits select:[:aClass|
+ (aClass includesSelector: #traitInfo)
+ or:[aClass classSide includesSelector: #traitInfo]].
+ classes do:[:aClass|
+ self restoreCompositionOf: aClass.
+ self restoreCompositionOf: aClass classSide.
+ ] displayingProgress:[:aClass| 'Updating ', aClass name].
+ !