[Pkg] The Trunk: Traits-nice.250.mcz
commits at source.squeak.org
commits at source.squeak.org
Sun Dec 27 02:31:30 UTC 2009
Nicolas Cellier uploaded a new version of Traits to project The Trunk:
http://source.squeak.org/trunk/Traits-nice.250.mcz
==================== Summary ====================
Name: Traits-nice.250
Author: nice
Time: 27 December 2009, 3:31:13 am
UUID: 121eb9a8-6167-4270-8fb5-a81e4e064440
Ancestors: Traits-nice.249
Cosmetic: move or remove a few temps inside closures
=============== Diff against Traits-nice.249 ===============
Item was changed:
----- Method: RequiredSelectorsChangesCalculator>>findRootsAndRoutes (in category 'calculating') -----
findRootsAndRoutes
"Based on the
1. target classes (ones considered interesting by our clients) and the
2. modifiedBehaviors (ones we are told might have changed),
decide the
A. rootClasses (superclasses of target classes that include methods from modifiedBehaviors)
B. classesToUpdate (classes that may have been affected AND are on an inheritance path between a root class and a target class, will be updated by the algorithm. This includes the every target class that may have been affected).
C. mapping from root classes to its classesToUpdate."
+ | modifiedClasses |
- | highestSuperclassOfCurrentTarget modifiedClasses |
classesToUpdate := IdentitySet new.
rootClasses := IdentitySet new.
modifiedClasses := (modifiedBehaviors gather: [:mb | mb classesComposedWithMe]) asIdentitySet.
+ targetClasses do: [:currentTargetClass | | highestSuperclassOfCurrentTarget |
- targetClasses do: [:currentTargetClass |
highestSuperclassOfCurrentTarget := nil.
currentTargetClass withAllSuperclassesDo: [:sc |
(modifiedClasses includes: sc) ifTrue:
[highestSuperclassOfCurrentTarget := sc.
self noteRoot: sc possiblyAffected: currentTargetClass]].
highestSuperclassOfCurrentTarget ifNotNil: [:highestRoot |
self addUpdatePathTo: currentTargetClass from: highestRoot]]!
Item was changed:
----- Method: TTraitsCategorisingDescription>>noteRecategorizedSelectors:oldComposition: (in category 'organization updating') -----
noteRecategorizedSelectors: aCollection oldComposition: aTraitComposition
+
+ aCollection do: [:each | | oldCategory newCategory |
- | oldCategory newCategory |
- aCollection do: [:each |
oldCategory := self organization categoryOfElement: each.
newCategory := (self traitComposition methodDescriptionForSelector: each) effectiveMethodCategory.
self noteRecategorizedSelector: each from: oldCategory to: newCategory]!
Item was changed:
----- Method: TFileInOutDescription>>fileOutChangedMessages:on:moveSource:toFile: (in category 'fileIn/Out') -----
fileOutChangedMessages: aSet on: aFileStream moveSource: moveSource toFile: fileIndex
"File a description of the messages of this class that have been
changed (i.e., are entered into the argument, aSet) onto aFileStream. If
moveSource, is true, then set the method source pointer to the new file position.
Note when this method is called with moveSource=true, it is condensing the
.changes file, and should only write a preamble for every method."
+ | org |
- | org sels |
(org := self organization) categories do:
+ [:cat | | sels |
- [:cat |
sels := (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel].
sels do:
[:sel | self printMethodChunk: sel withPreamble: true on: aFileStream
moveSource: moveSource toFile: fileIndex]]!
Item was changed:
----- Method: RequiredSelectorsChangesCalculator>>removeRequirements:thatAreNotIn:ifIn: (in category 'calculating') -----
removeRequirements: oldRequiredSelectorsByClass thatAreNotIn: requiredSelectorsByClass ifIn: rootsHandledBySel
- | cache newRequirements unconfirmedRequirements roots affected |
oldRequiredSelectorsByClass keysAndValuesDo:
[:class :oldRequirements |
+ | cache newRequirements unconfirmedRequirements |
newRequirements := requiredSelectorsByClass at: class
ifAbsent: [#()].
cache := class requiredSelectorsCache.
unconfirmedRequirements := oldRequirements copyWithoutAll: newRequirements.
unconfirmedRequirements do: [:sel |
+ | roots |
roots := rootsHandledBySel at: sel ifAbsent: [#()].
(roots anySatisfy: [:rc |
+ | affected |
affected := possiblyAffectedPerRoot at: rc ifAbsent: #().
(affected includes: class)]) ifTrue: [cache removeRequirement: sel]]]!
Item was changed:
----- Method: RequiredSelectorsChangesCalculator>>findOriginalSins (in category 'calculating') -----
findOriginalSins
+ | checkedClasses |
- | sinnedSelectors sinners checkedClasses |
checkedClasses := IdentitySet new.
originalSinsPerSelector := IdentityDictionary new.
rootClasses do:
[:rootClass |
rootClass withAllSuperclassesDo: [:superClass |
+ | sinnedSelectors |
(checkedClasses includes: superClass) ifFalse: [
checkedClasses add: superClass.
sinnedSelectors := self sinsIn: superClass.
sinnedSelectors do:
[:sinSel |
+ | sinners |
sinners := originalSinsPerSelector at: sinSel
ifAbsentPut: [IdentitySet new].
sinners add: superClass]]]]!
Item was changed:
----- Method: RequiredSelectorsChangesCalculator>>storeRequirementsUnder:for:in: (in category 'calculating') -----
storeRequirementsUnder: rc for: selector in: requiredSelectorsByClass
+ | requiringClasses |
- | requiringClasses selectorsForClass |
requiringClasses := rc updateRequiredStatusFor: selector
inSubclasses: (self possiblyAffectedForRoot: rc).
^requiringClasses do:
[:requiringClass |
+ | selectorsForClass |
selectorsForClass := requiredSelectorsByClass at: requiringClass
ifAbsentPut: [IdentitySet new].
selectorsForClass add: selector]!
Item was changed:
----- Method: TCompilingBehavior>>spaceUsed (in category 'private') -----
spaceUsed
"Answer a rough estimate of number of bytes used by this class and its metaclass. Does not include space used by class variables."
+ | space |
- | space method |
space := 0.
+ self selectorsDo: [:sel | | method |
- self selectorsDo: [:sel |
space := space + 16. "dict and org'n space"
method := self compiledMethodAt: sel.
space := space + (method size + 6 "hdr + avg pad").
method literals do: [:lit |
(lit isMemberOf: Array) ifTrue: [space := space + ((lit size + 1) * 4)].
(lit isMemberOf: Float) ifTrue: [space := space + 12].
(lit isMemberOf: ByteString) ifTrue: [space := space + (lit size + 6)].
(lit isMemberOf: LargeNegativeInteger) ifTrue: [space := space + ((lit size + 1) * 4)].
(lit isMemberOf: LargePositiveInteger) ifTrue: [space := space + ((lit size + 1) * 4)]]].
^ space!
Item was changed:
----- Method: LocalSends>>newCacheFor: (in category 'as yet unclassified') -----
newCacheFor: aClass
"Creates an instance of SendCaches, assigns it to the instance variable sendCaches and fills it with all the self-sends class-sends and super-sends that occur in methods defined in this class (or by used traits)."
+ | localSendCache |
- | localSendCache info |
localSendCache := SendCaches new.
aClass selectorsAndMethodsDo:
[:sender :m |
+ | info |
info := (SendInfo on: m) collectSends.
info selfSentSelectors
do: [:sentSelector | localSendCache addSelfSender: sender of: sentSelector].
info superSentSelectors
do: [:sentSelector | localSendCache addSuperSender: sender of: sentSelector].
info classSentSelectors
do: [:sentSelector | localSendCache addClassSender: sender of: sentSelector]].
^localSendCache!
Item was changed:
----- Method: RequiresSpeedTestCase>>performanceTestSwitchToMorphClassCategoryScenario (in category 'as yet unclassified') -----
performanceTestSwitchToMorphClassCategoryScenario
"When changing in one browser the selected category, we add some interesting classes, remove some others, and calculate some values. So this is a pretty full life cycle test."
- | noLongerInteresting newInteresting |
RequiredSelectors doWithTemporaryInstance:
[LocalSends doWithTemporaryInstance:
[ProvidedSelectors doWithTemporaryInstance:
+ [| noLongerInteresting newInteresting |
+ self prepareAllCaches.
- [self prepareAllCaches.
noLongerInteresting := self classesInCategories: {'Morphic-Basic'}.
newInteresting := self classesInCategories: {'Morphic-Kernel'}.
self measure:
[self noteInterestInClasses: newInteresting.
self loseInterestInClasses: noLongerInteresting.
newInteresting do: [:cl | cl hasRequiredSelectors].
self loseInterestInClasses: newInteresting.
self noteInterestInClasses: noLongerInteresting.].
self assert: realTime < 500]]]!
Item was changed:
----- Method: RequiredSelectorsChangesCalculator>>doWork (in category 'calculating') -----
doWork
+ | requiredSelectorsByClass oldRequiredSelectorsByClass classWithOldRequirementsRecorded rootsHandledBySel |
- | requiredSelectorsByClass oldRequiredSelectorsByClass classWithOldRequirementsRecorded rootsHandledBySel rootsHandled |
requiredSelectorsByClass := IdentityDictionary new.
oldRequiredSelectorsByClass := IdentityDictionary new.
classWithOldRequirementsRecorded := IdentitySet new.
rootsHandledBySel := IdentityDictionary new.
originalSinsPerSelector keysAndValuesDo:
[:selector :sinners |
+ | rootsHandled |
rootsHandled := rootsHandledBySel at: selector put: IdentitySet new.
rootClasses do:
[:rc |
(self shouldProcess: rc forSinsIn: sinners)
ifTrue:
[rootsHandled add: rc.
self
storeOldRequirementsUnder: rc
into: oldRequiredSelectorsByClass
ignoreSet: classWithOldRequirementsRecorded.
self
storeRequirementsUnder: rc
for: selector
in: requiredSelectorsByClass]]].
self
removeRequirements: oldRequiredSelectorsByClass
thatAreNotIn: requiredSelectorsByClass
ifIn: rootsHandledBySel.
self setFoundRequirements: requiredSelectorsByClass!
Item was changed:
----- Method: TraitTest>>testTraitMethodSelector (in category 'testing') -----
testTraitMethodSelector
"Tests that the #selector of a trait method isn't screwed up when aliasing traits"
+ | baseTrait classA classB |
+ [ | methodA traitMethod methodB |baseTrait := Trait named: #TraitTestBaseTrait uses:{} category: self class category.
- | baseTrait classA methodA classB methodB traitMethod |
- [baseTrait := Trait named: #TraitTestBaseTrait uses:{} category: self class category.
baseTrait compileSilently: 'traitMethod' classified: 'tests'.
traitMethod := baseTrait compiledMethodAt: #traitMethod.
self assert: traitMethod selector == #traitMethod.
classA := Object subclass: #TraitTestMethodClassA
uses: {baseTrait @ {#methodA -> #traitMethod}}
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: self class category.
methodA := classA compiledMethodAt: #methodA.
self assert: traitMethod selector == #traitMethod.
self assert: methodA selector == #methodA.
classB := Object subclass: #TraitTestMethodClassB
uses: {baseTrait @ {#methodB -> #traitMethod}}
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: self class category.
methodB := classB compiledMethodAt: #methodB.
self assert: traitMethod selector == #traitMethod.
self assert: methodA selector == #methodA.
self assert: methodB selector == #methodB.
] ensure:[
classA ifNotNil:[classA removeFromSystem: false].
classB ifNotNil:[classB removeFromSystem: false].
baseTrait ifNotNil:[baseTrait removeFromSystem: false].
].!
Item was changed:
----- Method: TraitsTestCase>>tearDown (in category 'running') -----
tearDown
+
- | behaviorName |
TraitsResource resetIfDirty.
self createdClassesAndTraits do:
+ [:aClassOrTrait | | behaviorName |
- [:aClassOrTrait |
behaviorName := aClassOrTrait name.
Smalltalk at: behaviorName
ifPresent: [:classOrTrait | classOrTrait removeFromSystem].
ChangeSet current removeClassChanges: behaviorName].
createdClassesAndTraits := nil!
Item was changed:
----- Method: TTraitsCategorisingDescription>>updateOrganizationSelector:oldCategory:newCategory: (in category 'organization updating') -----
updateOrganizationSelector: aSymbol oldCategory: oldCategoryOrNil newCategory: newCategoryOrNil
+ | changedCategories composition |
- | currentCategory effectiveCategory sel changedCategories composition |
changedCategories := IdentitySet new.
composition := self hasTraitComposition
ifTrue: [self traitComposition]
ifFalse: [TraitComposition new].
+ (composition methodDescriptionsForSelector: aSymbol) do: [:each | | effectiveCategory currentCategory sel |
- (composition methodDescriptionsForSelector: aSymbol) do: [:each |
sel := each selector.
(self includesLocalSelector: sel) ifFalse: [
currentCategory := self organization categoryOfElement: sel.
effectiveCategory := each effectiveMethodCategoryCurrent: currentCategory new: newCategoryOrNil.
effectiveCategory isNil ifTrue: [
currentCategory ifNotNil: [changedCategories add: currentCategory].
self organization removeElement: sel.
] ifFalse: [
((currentCategory isNil or: [currentCategory == ClassOrganizer ambiguous or: [currentCategory == oldCategoryOrNil]]) and: [currentCategory ~~ effectiveCategory]) ifTrue: [
currentCategory ifNotNil: [changedCategories add: currentCategory].
self organization
classify: sel
under: effectiveCategory
suppressIfDefault: false]]]].
^ changedCategories!
Item was changed:
----- Method: Behavior>>computeTranslationsAndUpdateUnreachableSet: (in category '*Traits-requires') -----
computeTranslationsAndUpdateUnreachableSet: unreachableCollection
"This method computes the set of unreachable selectors in the superclass by altering the set of unreachable selectors in this class. In addition, it builds a dictionary mapping super-sent selectors to the selectors of methods sending these selectors."
+ | translations oldUnreachable |
- | translations reachableSenders oldUnreachable |
oldUnreachable := unreachableCollection copy.
translations := IdentityDictionary new.
"Add selectors implemented in this class to unreachable set."
self methodDict keysDo: [:s | unreachableCollection add: s].
"Fill translation dictionary and remove super-reachable selectors from unreachable."
self sendCaches superSentSelectorsAndSendersDo: [:sent :senders |
+ | reachableSenders |
reachableSenders := FixedIdentitySet readonlyWithAll: senders notIn: oldUnreachable.
reachableSenders isEmpty ifFalse: [
translations at: sent put: reachableSenders.
unreachableCollection remove: sent ifAbsent: [].
].
].
^ translations!
Item was changed:
----- Method: TUpdateTraitsBehavior>>updateMethodDictionarySelector: (in category 'traits') -----
updateMethodDictionarySelector: aSymbol
"A method with selector aSymbol in myself or my traitComposition has been changed.
Do the appropriate update to my methodDict (remove or update method) and
return all affected selectors of me so that my useres get notified."
+ | modifiedSelectors descriptions |
- | effectiveMethod modifiedSelectors descriptions selector |
modifiedSelectors := IdentitySet new.
descriptions := self hasTraitComposition
ifTrue: [ self traitComposition methodDescriptionsForSelector: aSymbol ]
ifFalse: [ #() ].
+ descriptions do: [:methodDescription | | effectiveMethod selector |
- descriptions do: [:methodDescription |
selector := methodDescription selector.
(self includesLocalSelector: selector) ifFalse: [
methodDescription isEmpty
ifTrue: [
self removeTraitSelector: selector.
modifiedSelectors add: selector]
ifFalse: [
effectiveMethod := methodDescription effectiveMethod.
(self compiledMethodAt: selector ifAbsent: [nil]) ~~ effectiveMethod ifTrue: [
self addTraitSelector: selector withMethod: effectiveMethod.
modifiedSelectors add: selector]]]].
^modifiedSelectors!
Item was changed:
----- Method: TraitTest>>testTraitMethodClass (in category 'testing') -----
testTraitMethodClass
"Tests that the #methodClass of a trait method isn't screwed up"
+ | baseTrait classA classB |
+ [ | methodB traitMethod methodA |baseTrait := Trait named: #TraitTestBaseTrait uses:{} category: self class category.
- | baseTrait classA methodA classB methodB traitMethod |
- [baseTrait := Trait named: #TraitTestBaseTrait uses:{} category: self class category.
baseTrait compileSilently: 'traitMethod' classified: 'tests'.
traitMethod := baseTrait compiledMethodAt: #traitMethod.
self assert: traitMethod methodClass == baseTrait.
classA := Object subclass: #TraitTestMethodClassA
uses: baseTrait
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: self class category.
methodA := classA compiledMethodAt: #traitMethod.
self assert: traitMethod methodClass == baseTrait.
self assert: methodA methodClass == classA.
classB := Object subclass: #TraitTestMethodClassB
uses: baseTrait
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: self class category.
methodB := classB compiledMethodAt: #traitMethod.
self assert: traitMethod methodClass == baseTrait.
self assert: methodA methodClass == classA.
self assert: methodB methodClass == classB.
] ensure:[
classA ifNotNil:[classA removeFromSystem: false].
classB ifNotNil:[classB removeFromSystem: false].
baseTrait ifNotNil:[baseTrait removeFromSystem: false].
].!
Item was changed:
----- Method: TraitMethodDescription>>effectiveMethodCategoryCurrent:new: (in category 'accessing') -----
effectiveMethodCategoryCurrent: currentCategoryOrNil new: newCategoryOrNil
+ | result size isCurrent isConflict |
- | isCurrent result cat size isConflict |
size := self size.
size = 0 ifTrue: [^ nil].
result := self locatedMethods anyOne category.
size = 1 ifTrue: [^ result].
isCurrent := currentCategoryOrNil isNil.
isConflict := false.
+ self locatedMethods do: [:each | | cat |
- self locatedMethods do: [:each |
cat := each category.
isCurrent := isCurrent or: [cat == currentCategoryOrNil].
isConflict := isConflict or: [cat ~~ result]].
isConflict ifFalse: [^ result].
(isCurrent not and: [newCategoryOrNil notNil]) ifTrue: [^ newCategoryOrNil].
^ ClassOrganizer ambiguous.!
Item was changed:
----- Method: RequiredSelectorsChangesCalculator>>removeRequirements:thatAreNotIn: (in category 'calculating') -----
removeRequirements: oldRequiredSelectorsByClass thatAreNotIn: requiredSelectorsByClass
- | cache newRequirements |
oldRequiredSelectorsByClass keysAndValuesDo:
[:class :requirements |
+ | cache newRequirements |
newRequirements := requiredSelectorsByClass at: class
ifAbsent:
[#()].
cache := class requiredSelectorsCache.
requirements
do: [:sel | (newRequirements includes: sel) ifFalse: [cache removeRequirement: sel]]]!
Item was changed:
----- Method: TraitComposition>>changedSelectorsComparedTo: (in category 'enquiries') -----
changedSelectorsComparedTo: oldComposition
+ | changedSelectors traits |
- | changedSelectors oldTransformation traits newTransformation |
changedSelectors := IdentitySet new.
traits := self traits asIdentitySet addAll: oldComposition traits asIdentitySet; yourself.
+ traits do: [:each | | oldTransformation newTransformation |
- traits do: [:each |
newTransformation := self transformationOfTrait: each.
oldTransformation := oldComposition transformationOfTrait: each.
(newTransformation isNil or: [oldTransformation isNil])
ifTrue: [
changedSelectors addAll: each selectors]
ifFalse: [
changedSelectors addAll:
(newTransformation changedSelectorsComparedTo: oldTransformation)]].
^changedSelectors!
Item was changed:
----- Method: Behavior>>translateReachableSelfSenders:translations: (in category '*Traits-requires') -----
translateReachableSelfSenders: senderCollection translations: translationDictionary
+ | result |
- | result superSenders |
(translationDictionary isEmptyOrNil or: [senderCollection isEmpty]) ifTrue: [^ senderCollection].
+ result := FixedIdentitySet new: senderCollection size * 2.
- result := FixedIdentitySet new.
senderCollection do: [:s |
+ | superSenders |
superSenders := translationDictionary at: s ifAbsent: [nil].
+ superSenders
+ ifNil: [result add: s]
+ ifNotNil: [result addAll: superSenders].
- superSenders isNil
- ifTrue: [result add: s]
- ifFalse: [result addAll: superSenders].
- result isFull ifTrue: [^ result].
].
^ result.!
Item was changed:
----- Method: TCompilingBehavior>>selectorsWithArgs: (in category 'accessing method dictionary') -----
selectorsWithArgs: numberOfArgs
"Return all selectors defined in this class that take this number of arguments. Could use String.keywords. Could see how compiler does this."
+ | list |
- | list num |
list := OrderedCollection new.
+ self selectorsDo: [:aSel | | num |
- self selectorsDo: [:aSel |
num := aSel count: [:char | char == $:].
num = 0 ifTrue: [aSel last isLetter ifFalse: [num := 1]].
num = numberOfArgs ifTrue: [list add: aSel]].
^ list!
Item was changed:
----- Method: LocatedMethod>>argumentNames (in category 'comparing') -----
argumentNames
"Return an array with the argument names of the method's selector"
+ | keywords stream argumentNames delimiters |
- | keywords stream argumentNames argumentName delimiters |
delimiters := {Character space. Character cr}.
keywords := self selector keywords.
stream := self source readStream.
argumentNames := OrderedCollection new.
+ keywords do: [ :each | | argumentName |
- keywords do: [ :each |
stream match: each.
[stream peekFor: Character space] whileTrue.
argumentName := ReadWriteStream on: String new.
[(delimiters includes: stream peek) or: [stream peek isNil]]
whileFalse: [argumentName nextPut: stream next].
argumentName isEmpty ifFalse: [
argumentNames add: argumentName contents withBlanksTrimmed]].
^(argumentNames copyFrom: 1 to: self method numArgs) asArray!
Item was changed:
----- Method: Behavior>>classAndMethodFor:do:ifAbsent: (in category '*Traits-requires') -----
classAndMethodFor: aSymbol do: binaryBlock ifAbsent: absentBlock
"Looks up the selector aSymbol in the class chain. If it is found, binaryBlock is evaluated
with the class that defines the selector and the associated method. Otherwise
absentBlock is evaluated."
- | method |
self withAllSuperclassesDo: [:class |
+ | method |
method := class compiledMethodAt: aSymbol ifAbsent: [nil].
method ifNotNil: [^ binaryBlock value: class value: method].
].
^ absentBlock value.!
Item was changed:
----- Method: TPureBehavior>>selfSentSelectorsFromSelectors: (in category 'traits') -----
selfSentSelectorsFromSelectors: interestingSelectors
+ | result |
- | m result info |
result := IdentitySet new.
interestingSelectors collect:
[:sel |
+ | m info |
m := self compiledMethodAt: sel ifAbsent: [].
m ifNotNil:
[info := (SendInfo on: m) collectSends.
info selfSentSelectors do: [:sentSelector | result add: sentSelector]]].
^result!
Item was changed:
----- Method: TraitsResource>>tearDown (in category 'as yet unclassified') -----
tearDown
+
- | behaviorName |
SystemChangeNotifier uniqueInstance noMoreNotificationsFor: self.
self createdClassesAndTraits do:
+ [:aClassOrTrait | | behaviorName |
- [:aClassOrTrait |
behaviorName := aClassOrTrait name.
Smalltalk at: behaviorName
ifPresent: [:classOrTrait | classOrTrait removeFromSystem].
ChangeSet current removeClassChanges: behaviorName].
createdClassesAndTraits := self t1: (self
t2: (self t3: (self
t4: (self t5: (self
t6: (self c1: (self
c2: (self c3: (self c4: (self c5: (self c6: (self c7: (self c8: nil)))))))))))))!
Item was changed:
----- Method: CodeModelExtension>>for: (in category 'access to cache') -----
for: aClass
- | newSendCache |
^perClassCache at: aClass
ifAbsent:
+ [| newSendCache |
+ newSendCache := self newCacheFor: aClass.
- [newSendCache := self newCacheFor: aClass.
(self haveInterestsIn: aClass)
ifTrue: [perClassCache at: aClass put: newSendCache].
newSendCache]!
More information about the Packages
mailing list