The Trunk: Traits-ar.275.mcz

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

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

Name: Traits-ar.275
Author: ar
Time: 2 January 2010, 3:57:10 am
UUID: 3a07fcd6-afdc-b048-bb5b-889a4655c403
Ancestors: Traits-ar.274

A bit of refactoring. Break up ClassDescription>>installTraitsFrom: since it had gotten too long. Remove the obsolete definitionST80 protocol. Move updateTraitsFrom: up into ClassDescription.

=============== Diff against Traits-ar.274 ===============

Item was changed:
  ----- Method: ClassDescription>>installTraitsFrom: (in category '*Traits-NanoKernel') -----
  installTraitsFrom: aTraitComposition
  "Install the traits from the given composition. This method implements
  the core composition method - all others are just optimizations for
  particular cases. Consequently, the optimized versions can always fall
  back to this method when things get too hairy."
+ | allTraits methods |
- | allTraits methods oldMethod removals oldCategories |
 
  (self traitComposition isEmpty and: [aTraitComposition isEmpty]) ifTrue: [^self].
 
  "Check for cycles"
  allTraits := aTraitComposition gather: [:t | t allTraits copyWith: t].
  (allTraits includes: self) ifTrue:[^self error: 'Cyclic trait definition detected'].
 
- "XXXX: addUser/removeUser should be part of setter, but subclass
- override prevents it until we've got rid of Traits mess."
- self traitComposition do:[:tc|  tc removeTraitUser: self].
  self traitComposition: aTraitComposition.
+ methods := self assembleTraitMethodsFrom: aTraitComposition.
+ self installTraitMethodDict: methods.
+ self isMeta ifFalse:[self classSide updateTraitsFrom: aTraitComposition].
+ !
- aTraitComposition do:[:tc| tc addTraitUser: self].
-
- "Assemble the methods in a new dictionary first.
- Uses a Dictionary instead of a MethodDictionary for speed (MDs grow by #become:)"
- methods := Dictionary new.
-
- "Stick in the local methods first, since this avoids generating conflict methods unnecessarily"
- self selectorsAndMethodsDo:[:sel :newMethod|
- (self isLocalMethod: newMethod)
- ifTrue:[methods at: sel put:newMethod]].
-
- "Now assemble the traits methods"
- aTraitComposition do:[:trait|
- trait selectorsAndMethodsDo:[:sel :newMethod|
- oldMethod := methods at: sel ifAbsentPut:[newMethod].
- newMethod == oldMethod ifFalse:["a conflict"
- (self isLocalMethod: oldMethod) ifFalse:[
- methods at: sel put: (self resolveTraitsConflict: sel from: oldMethod to: newMethod).
- ].
- ].
- ].
- ].
-
- "Apply the changes. We first add the new or changed methods."
- oldCategories := Set new.
- methods keysAndValuesDo:[:sel :newMethod|
- oldMethod := self compiledMethodAt: sel ifAbsent:[nil].
- oldMethod == newMethod ifFalse:[
- self traitAddSelector: sel withMethod: newMethod.
- (self organization categoryOfElement: sel) ifNotNil:[:cat| oldCategories add: cat].
- self organization classify: sel under:
- (newMethod methodHome organization categoryOfElement: newMethod selector).
- ]].
-
- "Now remove the old or obsoleted ones"
- removals := OrderedCollection new.
- self selectorsDo:[:sel| (methods includesKey: sel) ifFalse:[removals add: sel]].
- removals do:[:sel| self traitRemoveSelector: sel].
-
- "Clean out empty categories"
- oldCategories do:[:cat|
- (self organization isEmptyCategoryNamed: cat)
- ifTrue:[self organization removeCategory: cat]].
-
- self isMeta ifFalse:[self classSide updateTraitsFrom: aTraitComposition].!

Item was added:
+ ----- Method: ClassDescription>>assembleTraitMethodsFrom: (in category '*Traits-NanoKernel') -----
+ assembleTraitMethodsFrom: aTraitComposition
+ "Assemble the resulting methods for installing the given trait composition.
+ Returns a Dictionary instead of a MethodDictionary for speed (MDs grow by #become:)"
+ | methods oldMethod |
+ methods := Dictionary new.
+ "Stick in the local methods first, since this avoids generating conflict methods unnecessarily"
+ self selectorsAndMethodsDo:[:sel :newMethod|
+ (self isLocalMethod: newMethod)
+ ifTrue:[methods at: sel put:newMethod]].
+ "Now assemble the traits methods"
+ aTraitComposition do:[:trait|
+ trait selectorsAndMethodsDo:[:sel :newMethod|
+ oldMethod := methods at: sel ifAbsentPut:[newMethod].
+ newMethod == oldMethod ifFalse:["a conflict"
+ (self isLocalMethod: oldMethod) ifFalse:[
+ methods at: sel put: (self resolveTraitsConflict: sel from: oldMethod to: newMethod)]]]].
+ ^methods!

Item was added:
+ ----- Method: ClassDescription>>installTraitMethodDict: (in category '*Traits-NanoKernel') -----
+ installTraitMethodDict: methods
+ "After having assembled the trait composition, install its methods."
+ | oldCategories oldMethod removals |
+ "Apply the changes. We first add the new or changed methods."
+ oldCategories := Set new.
+ methods keysAndValuesDo:[:sel :newMethod|
+ oldMethod := self compiledMethodAt: sel ifAbsent:[nil].
+ oldMethod == newMethod ifFalse:[
+ self traitAddSelector: sel withMethod: newMethod.
+ (self organization categoryOfElement: sel) ifNotNil:[:cat| oldCategories add: cat].
+ self organization classify: sel under:
+ (newMethod methodHome organization categoryOfElement: newMethod selector)]].
+
+ "Now remove the old or obsoleted ones"
+ removals := OrderedCollection new.
+ self selectorsDo:[:sel| (methods includesKey: sel) ifFalse:[removals add: sel]].
+ removals do:[:sel| self traitRemoveSelector: sel].
+
+ "Clean out empty categories"
+ oldCategories do:[:cat|
+ (self organization isEmptyCategoryNamed: cat)
+ ifTrue:[self organization removeCategory: cat]].
+
+ !

Item was added:
+ ----- Method: ClassDescription>>updateTraitsFrom: (in category '*Traits-NanoKernel') -----
+ updateTraitsFrom: instanceTraits
+ "ClassTrait/Metaclass only. Update me from the given instance traits"
+ | map newTraits trait |
+ self isMeta ifFalse:[self error: 'This is a metaclass operation'].
+ map := Dictionary new.
+ self traitComposition do:[:composed| map at: composed trait put: composed].
+ newTraits := (instanceTraits collect:[:composed|
+ trait := composed trait classTrait.
+ map at: trait ifAbsent:[trait]]
+ ), (self traitComposition select:[:comp| comp trait isBaseTrait]).
+
+ self installTraitsFrom: newTraits!

Item was changed:
  ----- Method: ClassDescription>>traitComposition: (in category '*Traits-NanoKernel') -----
  traitComposition: aTraitComposition
  "Install my trait composition"
+ self traitComposition do:[:tc|  tc removeTraitUser: self].
  aTraitComposition isEmptyOrNil ifTrue:[
  self organization isTraitOrganizer
  ifTrue:[self organization: (ClassOrganizer newFrom: self organization)].
  ] ifFalse:[
  self organization isTraitOrganizer
  ifFalse:[self organization: (TraitOrganizer newFrom: self organization)].
  self organization traitComposition: aTraitComposition.
+ aTraitComposition do:[:tc| tc addTraitUser: self].
  ].
  !

Item was removed:
- ----- Method: Metaclass>>updateTraitsFrom: (in category '*Traits-NanoKernel') -----
- updateTraitsFrom: instanceTraits
- "Update me from the given instance traits"
- | map newTraits trait |
-
- map := Dictionary new.
- self traitComposition isEmpty ifFalse:[
- self traitComposition do:[:composed| map at: composed trait put: composed].
- ].
-
- newTraits := (instanceTraits collect:[:composed|
- trait := composed trait classTrait.
- map at: trait ifAbsent:[trait]]).
-
- self traitComposition isEmpty ifFalse:[
- newTraits := newTraits, (self traitComposition select:[:comp| comp trait isBaseTrait]).
- ].
- self installTraitsFrom: newTraits!

Item was removed:
- ----- Method: ClassTrait>>updateTraitsFrom: (in category 'initialize') -----
- updateTraitsFrom: instanceTraits
- "Update me from the given instance traits"
- | map newTraits trait |
- map := Dictionary new.
- self traitComposition do:[:composed| map at: composed trait put: composed].
- newTraits := (instanceTraits collect:[:composed|
- trait := composed trait classTrait.
- map at: trait ifAbsent:[trait]]
- ), (self traitComposition select:[:comp| comp trait isBaseTrait]).
-
- self installTraitsFrom: newTraits!

Item was removed:
- ----- Method: Trait>>definitionST80 (in category 'initialize') -----
- definitionST80
- ^String streamContents: [:stream |
- stream nextPutAll: 'Trait named: ';
- store: self name.
- stream cr; tab; nextPutAll: 'uses: ';
- nextPutAll: self traitComposition asString.
- stream cr; tab; nextPutAll: 'category: ';
- store: self category asString].!

Item was removed:
- ----- Method: ClassTrait>>definitionST80 (in category 'accessing') -----
- definitionST80
- ^String streamContents: [:stream |
- stream nextPutAll: self name.
- stream cr; tab; nextPutAll: 'uses: ';
- nextPutAll: self traitComposition asString.
- ].!