A new version of Traits was added to project DeltaStreams: http://www.squeaksource.com/DeltaStreams/Traits-gk.230.mcz
==================== Summary ====================
Name: Traits-gk.230 Author: gk Time: 4 September 2009, 10:02:45 am UUID: e3ab9332-888a-4b0e-9ea7-b62cba0f53c7 Ancestors: Traits-dc.229
Small fixes for SystemChangeNotification.
==================== Snapshot ====================
SystemOrganization addCategory: #'Traits-Composition'! SystemOrganization addCategory: #'Traits-Kernel'! SystemOrganization addCategory: #'Traits-Kernel-Traits'! SystemOrganization addCategory: #'Traits-LocalSends'! SystemOrganization addCategory: #'Traits-Requires'! SystemOrganization addCategory: #'Traits-Tests'!
----- Method: TAccessingMethodDictDescription>>addAndClassifySelector:withMethod:inProtocol:notifying: (in category 'accessing method dictionary') ----- addAndClassifySelector: selector withMethod: compiledMethod inProtocol: category notifying: requestor | priorMethodOrNil oldProtocol newProtocol | priorMethodOrNil := self compiledMethodAt: selector ifAbsent: [nil]. self addSelectorSilently: selector withMethod: compiledMethod. oldProtocol := self organization categoryOfElement: selector. SystemChangeNotifier uniqueInstance doSilently: [self organization classify: selector under: category]. newProtocol := self organization categoryOfElement: selector. priorMethodOrNil isNil ifTrue: [SystemChangeNotifier uniqueInstance methodAdded: compiledMethod selector: selector inProtocol: category class: self requestor: requestor] ifFalse: [SystemChangeNotifier uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: self oldProtocol: oldProtocol newProtocol: newProtocol requestor: requestor].!
----- Method: TAccessingMethodDictDescription>>addSelector:withMethod:notifying: (in category 'accessing method dictionary') ----- addSelector: selector withMethod: compiledMethod notifying: requestor | priorMethodOrNil | priorMethodOrNil _ self compiledMethodAt: selector ifAbsent: [nil]. self addSelectorSilently: selector withMethod: compiledMethod. priorMethodOrNil isNil ifTrue: [SystemChangeNotifier uniqueInstance methodAdded: compiledMethod selector: selector inClass: self requestor: requestor] ifFalse: [SystemChangeNotifier uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: self requestor: requestor].!
----- Method: TAccessingMethodDictDescription>>addSelectorSilently:withMethod: (in category 'accessing method dictionary') ----- addSelectorSilently: selector withMethod: compiledMethod super addSelectorSilently: selector withMethod: compiledMethod. self instanceSide noteAddedSelector: selector meta: self isMeta.!
----- Method: TAccessingMethodDictDescription>>noteAddedSelector:meta: (in category 'accessing method dictionary') ----- noteAddedSelector: aSelector meta: isMeta "A hook allowing some classes to react to adding of certain selectors"!
----- Method: TAccessingMethodDictDescription>>removeSelector: (in category 'accessing method dictionary') ----- removeSelector: selector "Remove the message whose selector is given from the method dictionary of the receiver, if it is there. Answer nil otherwise." | priorMethod priorProtocol | priorMethod _ self compiledMethodAt: selector ifAbsent: [^ nil]. priorProtocol _ self whichCategoryIncludesSelector: selector. super removeSelector: selector. SystemChangeNotifier uniqueInstance doSilently: [self updateOrganizationSelector: selector oldCategory: priorProtocol newCategory: nil]. SystemChangeNotifier uniqueInstance methodRemoved: priorMethod selector: selector inProtocol: priorProtocol class: self.!
Error subclass: #TraitException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Traits-Kernel'!
!TraitException commentStamp: '<historical>' prior: 0! General exception used for example to signal invalid trait compositions!
TraitException subclass: #TraitCompositionException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Traits-Composition'!
!TraitCompositionException commentStamp: '<historical>' prior: 0! Signal invalid trait compositions.!
Object subclass: #LocatedMethod instanceVariableNames: 'location selector' classVariableNames: '' poolDictionaries: '' category: 'Traits-Composition'!
!LocatedMethod commentStamp: '<historical>' prior: 0! I identify a method in the system by its selector and location (class or trait) where it is defined.!
----- Method: LocatedMethod class>>location:selector: (in category 'instance creation') ----- location: aPureBehavior selector: aSymbol ^self new location: aPureBehavior selector: aSymbol; yourself!
----- Method: LocatedMethod>>= (in category 'comparing') ----- = aLocatedMethod ^ self method == aLocatedMethod method !
----- Method: LocatedMethod>>argumentNames (in category 'comparing') ----- argumentNames "Return an array with the argument names of the method's selector"
| keywords stream argumentNames argumentName delimiters | delimiters _ {Character space. Character cr}. keywords _ self selector keywords. stream _ self source readStream. argumentNames _ OrderedCollection new. 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!
----- Method: LocatedMethod>>category (in category 'convenience') ----- category ^self location whichCategoryIncludesSelector: self selector!
----- Method: LocatedMethod>>hash (in category 'comparing') ----- hash ^ self method identityHash!
----- Method: LocatedMethod>>isBinarySelector (in category 'testing') ----- isBinarySelector ^self selector allSatisfy: [:each | each isSpecial]!
----- Method: LocatedMethod>>location (in category 'accessing') ----- location ^location!
----- Method: LocatedMethod>>location:selector: (in category 'accessing') ----- location: aPureBehavior selector: aSymbol location _ aPureBehavior. selector _ aSymbol!
----- Method: LocatedMethod>>method (in category 'convenience') ----- method ^self location >> self selector!
----- Method: LocatedMethod>>selector (in category 'accessing') ----- selector ^selector!
----- Method: LocatedMethod>>source (in category 'convenience') ----- source ^(self method getSourceFor: self selector in: self location) asString!
Object subclass: #ModelExtension instanceVariableNames: 'interests lock' classVariableNames: '' poolDictionaries: '' category: 'Traits-LocalSends'! ModelExtension class instanceVariableNames: 'current'!
ModelExtension subclass: #CodeModelExtension instanceVariableNames: 'perClassCache' classVariableNames: '' poolDictionaries: '' category: 'Traits-LocalSends'!
----- Method: CodeModelExtension class>>isAbstract (in category 'initialize-release') ----- isAbstract ^self == CodeModelExtension!
----- Method: CodeModelExtension>>cacheFor: (in category 'access to cache') ----- cacheFor: aClass ^perClassCache at: aClass ifAbsentPut: [self newCacheFor: aClass]!
----- Method: CodeModelExtension>>classChanged: (in category 'invalidation') ----- classChanged: modificationEvent "We dont want to provide an out of date reply" modificationEvent itemClass ifNil: [self]. self clearOut: modificationEvent itemClass !
----- Method: CodeModelExtension>>clearOut: (in category 'access to cache') ----- clearOut: aClass ^perClassCache removeKey: aClass ifAbsent: []!
----- Method: CodeModelExtension>>for: (in category 'access to cache') ----- for: aClass | newSendCache | ^perClassCache at: aClass ifAbsent: [newSendCache := self newCacheFor: aClass. (self haveInterestsIn: aClass) ifTrue: [perClassCache at: aClass put: newSendCache]. newSendCache]!
----- Method: CodeModelExtension>>initialize (in category 'access to cache') ----- initialize super initialize. perClassCache := IdentityDictionary new.!
CodeModelExtension subclass: #LocalSends instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Traits-LocalSends'!
!LocalSends commentStamp: '<historical>' prior: 0! This class provide the model extension describing local sends for a given class. These are described in the comment for SendInfo, which is the class that actually computes this information.!
----- 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 info | localSendCache := SendCaches new. aClass selectorsAndMethodsDo: [:sender :m | 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!
CodeModelExtension subclass: #ProvidedSelectors instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Traits-Requires'!
----- Method: ProvidedSelectors>>isSelector:providedIn: (in category 'as yet unclassified') ----- isSelector: selector providedIn: aClass ^(self haveInterestsIn: aClass) ifFalse: [aClass classAndMethodFor: selector do: [:c :m | m isProvided] ifAbsent: [false]] ifTrue: [(self for: aClass) includes: selector] !
----- Method: ProvidedSelectors>>newCacheFor: (in category 'as yet unclassified') ----- newCacheFor: aClass
| cache | aClass ifNil: [^IdentitySet new]. cache := self for: aClass superclass copy. aClass selectorsAndMethodsDo: [:s :m | m isProvided ifTrue: [cache add: s] ifFalse: [cache remove: s ifAbsent: []]]. ^cache!
CodeModelExtension subclass: #RequiredSelectors instanceVariableNames: 'dirty dirtyClasses newlyInterestingClasses' classVariableNames: '' poolDictionaries: '' category: 'Traits-Requires'!
----- Method: RequiredSelectors>>calculateForClass: (in category 'access to cache') ----- calculateForClass: aClass | rscc | self clearOut: aClass. rscc := RequiredSelectorsChangesCalculator onModificationOf: { aClass } withTargets: { aClass }. rscc doWork!
----- Method: RequiredSelectors>>classChanged: (in category 'invalidation') ----- classChanged: modificationEvent self dirtyWithChange: modificationEvent!
----- Method: RequiredSelectors>>classesOfInterest (in category 'as yet unclassified') ----- classesOfInterest ^interests asIdentitySet!
----- Method: RequiredSelectors>>dirtyClasses (in category 'accessing') ----- dirtyClasses dirtyClasses ifNil: [dirtyClasses := WeakSet new]. ^dirtyClasses!
----- Method: RequiredSelectors>>dirtyWithChange: (in category 'as yet unclassified') ----- dirtyWithChange: anEvent dirty := true. self dirtyClasses add: anEvent itemClass!
----- Method: RequiredSelectors>>ensureClean (in category 'as yet unclassified') ----- ensureClean | rscc | dirty ifTrue: [rscc := RequiredSelectorsChangesCalculator onModificationOf: self dirtyClasses withTargets: self classesOfInterest. rscc doWork. dirtyClasses := nil]. dirty := false!
----- Method: RequiredSelectors>>for: (in category 'access to cache') ----- for: aClass "Somewhat weird control flow, and populates the dictionary even with non-interesting things, which it probably shouldn't" perClassCache at: aClass ifAbsentPut: [RequirementsCache new]. (self haveInterestsIn: aClass) ifTrue: [self ensureClean] ifFalse: [self calculateForClass: aClass]. ^(perClassCache at: aClass) requirements!
----- Method: RequiredSelectors>>lostInterest:inAll: (in category 'access to cache') ----- lostInterest: client inAll: classes ProvidedSelectors current lostInterest: self inAll: (classes gather: [:cl | cl withAllSuperclasses]). LocalSends current lostInterest: self inAll: (classes gather: [:cl | cl withAllSuperclasses]). super lostInterest: client inAll: classes !
----- Method: RequiredSelectors>>lostOneInterestIn: (in category 'access to cache') ----- lostOneInterestIn: aClass self lostInterest: nil in: aClass. !
----- Method: RequiredSelectors>>newCacheFor: (in category 'access to cache') ----- newCacheFor: aClass ^RequirementsCache new!
----- Method: RequiredSelectors>>newlyInteresting: (in category 'as yet unclassified') ----- newlyInteresting: aClass dirty := true. self dirtyClasses add: aClass!
----- Method: RequiredSelectors>>newlyInterestingClasses (in category 'accessing') ----- newlyInterestingClasses newlyInterestingClasses ifNil: [newlyInterestingClasses _ IdentitySet new]. ^newlyInterestingClasses!
----- Method: RequiredSelectors>>newlyInterestingClasses: (in category 'accessing') ----- newlyInterestingClasses: anObject newlyInterestingClasses := anObject!
----- Method: RequiredSelectors>>noteInterestOf:inAll: (in category 'access to cache') ----- noteInterestOf: client inAll: classes | newlyInteresting | LocalSends current noteInterestOf: self inAll: (classes gather: [:cl | cl withAllSuperclasses]). ProvidedSelectors current noteInterestOf: self inAll: (classes gather: [:cl | cl withAllSuperclasses]). newlyInteresting _ classes copyWithoutAll: self classesOfInterest. super noteInterestOf: client inAll: classes. newlyInteresting do: [:cl | self newlyInteresting: cl]!
----- Method: RequiredSelectors>>registerLifelongInterestOf:inAll: (in category 'access to cache') ----- registerLifelongInterestOf: client inAll: classes self noteInterestOf: client inAll: classes. classes do: [:cl | client toFinalizeSend: #lostOneInterestIn: to: self with: cl].!
----- Method: ModelExtension class>>current (in category 'accessing') ----- current ^current!
----- Method: ModelExtension class>>current: (in category 'accessing') ----- current: anObject ^current := anObject!
----- Method: ModelExtension class>>doWithTemporaryInstance: (in category 'instance creation') ----- doWithTemporaryInstance: aBlock | singleton | singleton := self current. [self current: self new. aBlock value] ensure: [self current: singleton]!
----- Method: ModelExtension class>>initialize (in category 'initialize-release') ----- initialize self isAbstract not ifTrue: [self current: self new]!
----- Method: ModelExtension class>>isAbstract (in category 'initialize-release') ----- isAbstract ^self == ModelExtension!
----- Method: ModelExtension>>haveInterestsIn: (in category 'access to cache') ----- haveInterestsIn: aClass lock critical: [^interests includes: aClass] !
----- Method: ModelExtension>>initialize (in category 'invalidation') ----- initialize lock := Semaphore forMutualExclusion. interests := IdentityBag new. SystemChangeNotifier uniqueInstance notify: self ofSystemChangesOfItem: #class using: #classChanged:. SystemChangeNotifier uniqueInstance notify: self ofSystemChangesOfItem: #method using: #classChanged:. !
----- Method: ModelExtension>>lostInterest:in: (in category 'interests') ----- lostInterest: client in: class self lostInterest: client inAll: {class}!
----- Method: ModelExtension>>lostInterest:inAll: (in category 'interests') ----- lostInterest: client inAll: classes lock critical: [interests removeAll: classes]!
----- Method: ModelExtension>>noteInterestOf:in: (in category 'interests') ----- noteInterestOf: client in: class self noteInterestOf: client inAll: {class}!
----- Method: ModelExtension>>noteInterestOf:inAll: (in category 'interests') ----- noteInterestOf: client inAll: classes lock critical: [interests addAll: classes].!
Object subclass: #RequiredSelectorsChangesCalculator instanceVariableNames: 'targetBehaviors classesToUpdate traitsToUpdate rootClasses modifiedBehaviors possiblyAffectedPerRoot originalSinsPerSelector targetClasses targetTraits' classVariableNames: '' poolDictionaries: '' category: 'Traits-Requires'!
!RequiredSelectorsChangesCalculator commentStamp: 'dvf 9/22/2005 14:20' prior: 0! Nathanael implemented an efficient algorithm for updating the requirement status of a single selector for an inheritance subtree. However, the algorithm is not efficient enough to use as is for displaying abstractness of all the classes in a few class categories.
To get to that performance level: 1. The RequiredSelectors class coordinates recalculation requests and tracks what classes have changed, and what classes are interesting. 2. The current class handles a such request, by running the algorithm only on classes and selectors that may potentially be requirements.!
----- Method: RequiredSelectorsChangesCalculator class>>onModificationOf:withTargets: (in category 'as yet unclassified') ----- onModificationOf: behaviors withTargets: targetBehaviors | i | i := self new. i targetBehaviors: targetBehaviors; modifiedBehaviors: behaviors; decideParameters. ^i!
----- Method: RequiredSelectorsChangesCalculator>>addUpdatePathTo:from: (in category 'as yet unclassified') ----- addUpdatePathTo: aClass from: highRoot aClass withAllSuperclassesDo: [:sc | classesToUpdate add: sc. highRoot = sc ifTrue: [^self]]!
----- Method: RequiredSelectorsChangesCalculator>>classesToUpdate (in category 'accessing') ----- classesToUpdate ^classesToUpdate!
----- Method: RequiredSelectorsChangesCalculator>>classesToUpdate: (in category 'accessing') ----- classesToUpdate: anObject classesToUpdate := anObject!
----- Method: RequiredSelectorsChangesCalculator>>decideParameters (in category 'calculating') ----- decideParameters "decide whos who"
targetClasses := IdentitySet new. targetTraits := IdentitySet new. self targetBehaviors do: [:b | b isTrait ifTrue: [targetTraits add: b] ifFalse: [targetClasses add: b]]. self findAffectedTraitsFrom: targetTraits. self findRootsAndRoutes. self findOriginalSins!
----- Method: RequiredSelectorsChangesCalculator>>doWork (in category 'calculating') ----- doWork | requiredSelectorsByClass oldRequiredSelectorsByClass classWithOldRequirementsRecorded rootsHandledBySel rootsHandled | requiredSelectorsByClass := IdentityDictionary new. oldRequiredSelectorsByClass := IdentityDictionary new. classWithOldRequirementsRecorded := IdentitySet new. rootsHandledBySel := IdentityDictionary new. originalSinsPerSelector keysAndValuesDo: [:selector :sinners | 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!
----- Method: RequiredSelectorsChangesCalculator>>findAffectedTraitsFrom: (in category 'calculating') ----- findAffectedTraitsFrom: targetTraitsCollection traitsToUpdate := targetTraitsCollection select: [:t | modifiedBehaviors anySatisfy: [:mb | t traitCompositionIncludes: mb]]!
----- Method: RequiredSelectorsChangesCalculator>>findOriginalSins (in category 'calculating') ----- findOriginalSins | sinnedSelectors sinners checkedClasses | checkedClasses _ IdentitySet new. originalSinsPerSelector := IdentityDictionary new. rootClasses do: [:rootClass | rootClass withAllSuperclassesDo: [:superClass | (checkedClasses includes: superClass) ifFalse: [ checkedClasses add: superClass. sinnedSelectors := self sinsIn: superClass. sinnedSelectors do: [:sinSel | sinners := originalSinsPerSelector at: sinSel ifAbsentPut: [IdentitySet new]. sinners add: superClass]]]]!
----- 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."
| highestSuperclassOfCurrentTarget modifiedClasses | classesToUpdate := IdentitySet new. rootClasses := IdentitySet new. modifiedClasses := (modifiedBehaviors gather: [:mb | mb classesComposedWithMe]) asIdentitySet. targetClasses do: [:currentTargetClass | highestSuperclassOfCurrentTarget _ nil. currentTargetClass withAllSuperclassesDo: [:sc | (modifiedClasses includes: sc) ifTrue: [highestSuperclassOfCurrentTarget := sc. self noteRoot: sc possiblyAffected: currentTargetClass]]. highestSuperclassOfCurrentTarget ifNotNilDo: [:highestRoot | self addUpdatePathTo: currentTargetClass from: highestRoot]]!
----- Method: RequiredSelectorsChangesCalculator>>initialize (in category 'calculating') ----- initialize possiblyAffectedPerRoot _ IdentityDictionary new.!
----- Method: RequiredSelectorsChangesCalculator>>modifiedBehaviors (in category 'accessing') ----- modifiedBehaviors ^modifiedBehaviors!
----- Method: RequiredSelectorsChangesCalculator>>modifiedBehaviors: (in category 'accessing') ----- modifiedBehaviors: anObject modifiedBehaviors := anObject!
----- Method: RequiredSelectorsChangesCalculator>>noteRoot:possiblyAffected: (in category 'calculating') ----- noteRoot: rootClass possiblyAffected: targetClass rootClasses add: rootClass. targetClass withAllSuperclassesDo: [:sc | (self possiblyAffectedForRoot: rootClass) add: sc. rootClass = sc ifTrue: [^self]] !
----- Method: RequiredSelectorsChangesCalculator>>possiblyAffectedForRoot: (in category 'calculating') ----- possiblyAffectedForRoot: rootClass ^possiblyAffectedPerRoot at: rootClass ifAbsentPut: [IdentitySet new].!
----- Method: RequiredSelectorsChangesCalculator>>removeRequirements:thatAreNotIn: (in category 'calculating') ----- removeRequirements: oldRequiredSelectorsByClass thatAreNotIn: requiredSelectorsByClass | cache newRequirements | oldRequiredSelectorsByClass keysAndValuesDo: [:class :requirements | newRequirements := requiredSelectorsByClass at: class ifAbsent: [#()]. cache := class requiredSelectorsCache. requirements do: [:sel | (newRequirements includes: sel) ifFalse: [cache removeRequirement: sel]]]!
----- Method: RequiredSelectorsChangesCalculator>>removeRequirements:thatAreNotIn:ifIn: (in category 'calculating') ----- removeRequirements: oldRequiredSelectorsByClass thatAreNotIn: requiredSelectorsByClass ifIn: rootsHandledBySel | cache newRequirements unconfirmedRequirements roots affected | oldRequiredSelectorsByClass keysAndValuesDo: [:class :oldRequirements | newRequirements := requiredSelectorsByClass at: class ifAbsent: [#()]. cache := class requiredSelectorsCache. unconfirmedRequirements := oldRequirements copyWithoutAll: newRequirements. unconfirmedRequirements do: [:sel | roots := rootsHandledBySel at: sel ifAbsent: [#()]. (roots anySatisfy: [:rc | affected := possiblyAffectedPerRoot at: rc ifAbsent: #(). (affected includes: class)]) ifTrue: [cache removeRequirement: sel]]]!
----- Method: RequiredSelectorsChangesCalculator>>rootClasses (in category 'accessing') ----- rootClasses ^rootClasses!
----- Method: RequiredSelectorsChangesCalculator>>rootClasses: (in category 'accessing') ----- rootClasses: anObject rootClasses := anObject!
----- Method: RequiredSelectorsChangesCalculator>>selectorsToUpdateIn: (in category 'calculating') ----- selectorsToUpdateIn: aClass ^originalSinsPerSelector keys !
----- Method: RequiredSelectorsChangesCalculator>>setFoundRequirements: (in category 'calculating') ----- setFoundRequirements: requiredSelectorsByClass | cache | requiredSelectorsByClass keysAndValuesDo: [:class :requirements | cache := class requiredSelectorsCache. requirements do: [:sel | cache addRequirement: sel]]. ^cache!
----- Method: RequiredSelectorsChangesCalculator>>shouldProcess:forSinsIn: (in category 'calculating') ----- shouldProcess: rc forSinsIn: sinners rc withAllSuperclassesDo: [:rootSuperClass | (sinners includes: rootSuperClass) ifTrue: [^true]. "theres a rootClass closer to the sin, we don't need to do it again." (rc ~= rootSuperClass and: [(rootClasses includes: rootSuperClass)]) ifTrue: [^false]]. ^false.!
----- Method: RequiredSelectorsChangesCalculator>>sinsIn: (in category 'as yet unclassified') ----- sinsIn: aClass | negativeDefined selfSent sins | negativeDefined := IdentitySet new. aClass selectorsAndMethodsDo: [:s :m | m isProvided ifFalse: [negativeDefined add: s]]. selfSent := aClass sendCaches selfSenders ifNil: [^negativeDefined] ifNotNilDo: [:dict | dict keys]. sins := negativeDefined union: (selfSent copyWithoutAll: aClass providedSelectors). ^sins!
----- Method: RequiredSelectorsChangesCalculator>>storeOldRequirementsUnder:into:ignoreSet: (in category 'calculating') ----- storeOldRequirementsUnder: rc into: oldRequiredSelectorsByClass ignoreSet: classWithOldRequirementsRecorded classesToUpdate do: [:someClass | (rc == someClass or: [(someClass inheritsFrom: rc)]) ifTrue: [(classWithOldRequirementsRecorded includes: someClass) ifFalse: [oldRequiredSelectorsByClass at: someClass put: someClass requirements]]]!
----- Method: RequiredSelectorsChangesCalculator>>storeRequirementsUnder:for:in: (in category 'calculating') ----- storeRequirementsUnder: rc for: selector in: requiredSelectorsByClass | requiringClasses selectorsForClass | requiringClasses := rc updateRequiredStatusFor: selector inSubclasses: (self possiblyAffectedForRoot: rc). ^requiringClasses do: [:requiringClass | selectorsForClass := requiredSelectorsByClass at: requiringClass ifAbsentPut: [IdentitySet new]. selectorsForClass add: selector]!
----- Method: RequiredSelectorsChangesCalculator>>targetBehaviors (in category 'accessing') ----- targetBehaviors ^targetBehaviors!
----- Method: RequiredSelectorsChangesCalculator>>targetBehaviors: (in category 'accessing') ----- targetBehaviors: anObject targetBehaviors := anObject!
----- Method: RequiredSelectorsChangesCalculator>>traitsToUpdate (in category 'accessing') ----- traitsToUpdate ^traitsToUpdate!
----- Method: RequiredSelectorsChangesCalculator>>traitsToUpdate: (in category 'accessing') ----- traitsToUpdate: anObject traitsToUpdate := anObject!
Object subclass: #RequirementsCache instanceVariableNames: 'requirements superRequirements' classVariableNames: '' poolDictionaries: '' category: 'Traits-LocalSends'!
----- Method: RequirementsCache>>addRequirement: (in category 'updates') ----- addRequirement: selector requirements ifNil: [requirements := self newRequirementsObject]. requirements add: selector.!
----- Method: RequirementsCache>>newRequirementsObject (in category 'accessing') ----- newRequirementsObject ^ IdentitySet new.!
----- Method: RequirementsCache>>removeRequirement: (in category 'updates') ----- removeRequirement: selector requirements ifNil: [^ self]. requirements remove: selector ifAbsent: [].!
----- Method: RequirementsCache>>requirements (in category 'accessing') ----- requirements ^ requirements isNil ifTrue: [self newRequirementsObject] ifFalse: [requirements].!
----- Method: RequirementsCache>>superRequirements (in category 'accessing') ----- superRequirements "Answer the value of superRequirements"
^ superRequirements isNil ifTrue: [IdentitySet new] ifFalse: [superRequirements].!
Object subclass: #SendCaches instanceVariableNames: 'selfSenders superSenders classSenders' classVariableNames: '' poolDictionaries: '' category: 'Traits-LocalSends'!
!SendCaches commentStamp: 'NS 5/27/2005 15:13' prior: 0! Instances of this class are used to keep track of selectors that are sent to self, sent to super, and sent to the class-side in any of the methods of a certain class. It also keeps track of the requirements of a class.
It's important to understand that this class just serves as storage for these sets of selectors. It does not contain any logic to actually compute them. In particular, it cannot compute the requirements.!
----- Method: SendCaches class>>initializeAllInstances (in category 'fixup') ----- initializeAllInstances self allSubInstancesDo: [ : each | each properlyInitialize ]!
----- Method: SendCaches>>addClassSender:of: (in category 'updates') ----- addClassSender: sendingSelector of: sentSelector | senders | senders _ classSenders at: sentSelector ifAbsent: [#()]. classSenders at: sentSelector put: (senders copyWith: sendingSelector).!
----- Method: SendCaches>>addSelfSender:of: (in category 'updates') ----- addSelfSender: sendingSelector of: sentSelector | senders | senders _ selfSenders at: sentSelector ifAbsent: [#()]. selfSenders at: sentSelector put: (senders copyWith: sendingSelector).!
----- Method: SendCaches>>addSuperSender:of: (in category 'updates') ----- addSuperSender: sendingSelector of: sentSelector | senders | senders _ superSenders at: sentSelector ifAbsent: [#()]. superSenders at: sentSelector put: (senders copyWith: sendingSelector).!
----- Method: SendCaches>>allSentSelectorsAndSendersDo: (in category 'accessing-specific') ----- allSentSelectorsAndSendersDo: aBlock self selfSentSelectorsAndSendersDo: aBlock. self superSentSelectorsAndSendersDo: aBlock. self classSentSelectorsAndSendersDo: aBlock.!
----- Method: SendCaches>>classSendersOf: (in category 'accessing') ----- classSendersOf: selector ^ classSenders at: selector ifAbsent: [#()].!
----- Method: SendCaches>>classSentSelectorsAndSendersDo: (in category 'accessing-specific') ----- classSentSelectorsAndSendersDo: aBlock classSenders keysAndValuesDo: aBlock!
----- Method: SendCaches>>initialize (in category 'accessing') ----- initialize selfSenders := IdentityDictionary new. superSenders := IdentityDictionary new. classSenders := IdentityDictionary new.!
----- Method: SendCaches>>printOn: (in category 'fixup') ----- printOn: aStream super printOn: aStream. aStream nextPut: $[. selfSenders printOn: aStream. aStream nextPut: $|. superSenders printOn: aStream. aStream nextPut: $|. classSenders printOn: aStream. aStream nextPut: $]!
----- Method: SendCaches>>properlyInitialize (in category 'fixup') ----- properlyInitialize selfSenders isEmptyOrNil ifTrue: [selfSenders := IdentityDictionary new]. superSenders isEmptyOrNil ifTrue: [superSenders := IdentityDictionary new]. classSenders isEmptyOrNil ifTrue: [classSenders := IdentityDictionary new]. !
----- Method: SendCaches>>selfSenders (in category 'accessing') ----- selfSenders ^selfSenders!
----- Method: SendCaches>>selfSenders: (in category 'accessing') ----- selfSenders: anObject ^selfSenders := anObject!
----- Method: SendCaches>>selfSendersOf: (in category 'accessing-specific') ----- selfSendersOf: selector ^ selfSenders at: selector ifAbsent: [#()].!
----- Method: SendCaches>>selfSentSelectorsAndSendersDo: (in category 'accessing-specific') ----- selfSentSelectorsAndSendersDo: aBlock selfSenders keysAndValuesDo: aBlock!
----- Method: SendCaches>>superSenders (in category 'accessing') ----- superSenders ^superSenders!
----- Method: SendCaches>>superSenders: (in category 'accessing') ----- superSenders: anObject ^superSenders := anObject!
----- Method: SendCaches>>superSendersOf: (in category 'accessing-specific') ----- superSendersOf: selector ^ superSenders at: selector ifAbsent: [#()].!
----- Method: SendCaches>>superSentSelectorsAndSendersDo: (in category 'accessing-specific') ----- superSentSelectorsAndSendersDo: aBlock superSenders keysAndValuesDo: aBlock!
Object subclass: #TraitComposition instanceVariableNames: 'transformations' classVariableNames: '' poolDictionaries: '' category: 'Traits-Composition'!
!TraitComposition commentStamp: '<historical>' prior: 0! I hold a collection of trait transformations and provide important facilities to query the trait composition. For each trait in the composition clause there exists exactly one transformation in the collection.
Note, that directly manipulating the composition of a class or trait does not effect changes automatically. Use PureBehavior>>setTraitComposition: to do this. You have to make a copy of the old trait composition before changing it because only the difference between the new and the old composition is updated!!!
----- Method: TraitComposition class>>with: (in category 'instance creation') ----- with: aTraitTransformation ^self new add: aTraitTransformation; yourself!
----- Method: TraitComposition class>>with:with: (in category 'instance creation') ----- with: aTraitTransformation with: anotherTraitTransformation ^self new add: aTraitTransformation; add: anotherTraitTransformation; yourself!
----- Method: TraitComposition>>+ (in category 'composition') ----- + aTraitExpression ^ aTraitExpression addCompositionOnLeft: self. !
----- Method: TraitComposition>>- (in category 'composition') ----- - anArray "the modifier operators #@ and #- bind stronger than +. Thus, #@ or #- sent to a sum will only affect the most right summand" self transformations addLast: (self transformations removeLast - anArray)!
----- Method: TraitComposition>>@ (in category 'composition') ----- @ anArrayOfAssociations "the modifier operators #@ and #- bind stronger than +. Thus, #@ or #- sent to a sum will only affect the most right summand"
self transformations addLast: (self transformations removeLast @ anArrayOfAssociations)!
----- Method: TraitComposition>>add: (in category 'accessing') ----- add: aTraitTransformation self errorIfNotAddable: aTraitTransformation. self transformations addLast: aTraitTransformation!
----- Method: TraitComposition>>addCompositionOnLeft: (in category 'private') ----- addCompositionOnLeft: aTraitComposition self transformations do: [ : each | aTraitComposition add: each ]. ^ aTraitComposition!
----- Method: TraitComposition>>addOnTheLeft: (in category 'composition') ----- addOnTheLeft: aTrait self errorIfNotAddable: aTrait. self transformations addFirst: aTrait!
----- Method: TraitComposition>>allTraits (in category 'accessing') ----- allTraits ^self traits gather: [:trait | trait hasTraitComposition ifTrue: [trait traitComposition allTraits copyWith: trait] ifFalse: [Array with: trait]]!
----- Method: TraitComposition>>asTraitComposition (in category 'converting') ----- asTraitComposition ^self!
----- Method: TraitComposition>>assertValidUser: (in category 'error-handling') ----- assertValidUser: aBehavior "Assert that this trait composition set for aBehavior does not introduce a cycle." (self allTraits includes: aBehavior) ifTrue: [ TraitCompositionException signal: 'Cycle in compositions: The composition (in)directly includes this trait!!']!
----- Method: TraitComposition>>changedSelectorsComparedTo: (in category 'enquiries') ----- changedSelectorsComparedTo: oldComposition | changedSelectors oldTransformation traits newTransformation | changedSelectors := IdentitySet new. traits := self traits asIdentitySet addAll: oldComposition traits asIdentitySet; yourself. 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!
----- Method: TraitComposition>>copy (in category 'copying') ----- copy self error: 'should not be called'. ^super copy transformations: (self transformations collect: [:each | each copy]); yourself!
----- Method: TraitComposition>>copyTraitExpression (in category 'copying') ----- copyTraitExpression | newCopy | newCopy _ self shallowCopy. newCopy transformations: (self transformations collect: [ : each | each copyTraitExpression ]). ^ newCopy !
----- Method: TraitComposition>>copyWithExclusionOf:to: (in category 'copying') ----- copyWithExclusionOf: aSymbol to: aTrait | composition transformation | composition _ self copyTraitExpression. transformation _ (composition transformationOfTrait: aTrait). ^composition remove: transformation; add: (transformation addExclusionOf: aSymbol); yourself!
----- Method: TraitComposition>>copyWithoutAlias:of: (in category 'copying') ----- copyWithoutAlias: aSymbol of: aTrait | composition transformation | composition _ self copyTraitExpression. transformation _ (composition transformationOfTrait: aTrait). ^composition remove: transformation; add: (transformation removeAlias: aSymbol); normalizeTransformations; yourself!
----- Method: TraitComposition>>errorIfNotAddable: (in category 'error-handling') ----- errorIfNotAddable: aTraitTransformation (self includesTrait: aTraitTransformation trait) ifTrue: [ ^TraitCompositionException signal: 'Trait ' , aTraitTransformation trait asString, ' already in composition']!
----- Method: TraitComposition>>includesMethod: (in category 'testing') ----- includesMethod: aSelector ^(self methodDescriptionForSelector: aSelector) isEmpty not!
----- Method: TraitComposition>>includesTrait: (in category 'testing') ----- includesTrait: aTrait ^self traits includes: aTrait!
----- Method: TraitComposition>>initialize (in category 'initialize-release') ----- initialize super initialize. transformations _ OrderedCollection new!
----- Method: TraitComposition>>isAliasSelector: (in category 'testing') ----- isAliasSelector: aSymbol "Return true if the selector aSymbol is an alias defined in this or in another composition somewhere deeper in the tree of traits compositions."
| methodDescription | methodDescription _ (self methodDescriptionsForSelector: aSymbol) detect: [:each | each selector = aSymbol]. ^methodDescription isAliasSelector!
----- Method: TraitComposition>>isEmpty (in category 'testing') ----- isEmpty ^self transformations isEmpty!
----- Method: TraitComposition>>isLocalAliasSelector: (in category 'testing') ----- isLocalAliasSelector: aSymbol "Return true if the selector aSymbol is an alias defined in this composition."
| methodDescription | methodDescription _ (self methodDescriptionsForSelector: aSymbol) detect: [:each | each selector = aSymbol]. ^methodDescription isLocalAliasSelector!
----- Method: TraitComposition>>methodDescriptionForSelector: (in category 'enquiries') ----- methodDescriptionForSelector: aSymbol "Return a TraitMethodDescription for the selector aSymbol."
| description | description _ TraitMethodDescription selector: aSymbol. self transformations do: [:each | each collectMethodsFor: aSymbol into: description]. ^description!
----- Method: TraitComposition>>methodDescriptionsForSelector: (in category 'enquiries') ----- methodDescriptionsForSelector: aSymbol "Return a collection of TraitMethodDescriptions for aSymbol and all the aliases of aSymbol."
| selectors collection | selectors _ IdentitySet with: aSymbol. self transformations do: [:each | selectors addAll: (each aliasesForSelector: aSymbol)]. collection _ OrderedCollection new: selectors size. selectors do: [:each | collection add: (self methodDescriptionForSelector: each)]. ^collection!
----- Method: TraitComposition>>normalizeTransformations (in category 'composition') ----- normalizeTransformations self transformations: ( self transformations collect: [:each | each normalized])!
----- Method: TraitComposition>>notEmpty (in category 'testing') ----- notEmpty ^self isEmpty not!
----- Method: TraitComposition>>printOn: (in category 'printing') ----- printOn: aStream self transformations isEmptyOrNil ifFalse: [ self transformations do: [:each | aStream print: each] separatedBy: [aStream nextPutAll: ' + '] ] ifTrue: [aStream nextPutAll: '{}'] !
----- Method: TraitComposition>>printString (in category 'printing') ----- printString ^String streamContents: [:stream | self printOn: stream]!
----- Method: TraitComposition>>remove: (in category 'accessing') ----- remove: aTransformation self transformations remove: aTransformation!
----- Method: TraitComposition>>removeFromComposition: (in category 'accessing') ----- removeFromComposition: aTrait self remove: (self transformationOfTrait: aTrait)!
----- Method: TraitComposition>>size (in category 'accessing') ----- size ^transformations size!
----- Method: TraitComposition>>traitProvidingSelector: (in category 'enquiries') ----- traitProvidingSelector: aSymbol "Return the trait which originally provides the method aSymbol or return nil if trait composition does not provide this selector or there is a conflict. Take aliases into account. Return the trait which the aliased method is defined in."
| methodDescription locatedMethod | methodDescription _ self methodDescriptionForSelector: aSymbol. (methodDescription isProvided not or: [methodDescription isConflict]) ifTrue: [^nil]. locatedMethod _ methodDescription providedLocatedMethod. ^locatedMethod location traitOrClassOfSelector: locatedMethod selector!
----- Method: TraitComposition>>traits (in category 'accessing') ----- traits ^self transformations collect: [:each | each trait]!
----- Method: TraitComposition>>transformationOfTrait: (in category 'accessing') ----- transformationOfTrait: aTrait "Return the transformation which holds aTrait or nil if this composition doesn't include aTrait." ^self transformations detect: [:each | each trait = aTrait] ifNone: [nil]!
----- Method: TraitComposition>>transformations (in category 'accessing') ----- transformations ^transformations!
----- Method: TraitComposition>>transformations: (in category 'private') ----- transformations: aCollection transformations _ aCollection!
Object subclass: #TraitMethodDescription instanceVariableNames: 'selector locatedMethods' classVariableNames: 'RequiredMethods ConflictMethods' poolDictionaries: '' category: 'Traits-Composition'!
!TraitMethodDescription commentStamp: '<historical>' prior: 0! Used by TraitComposition to encapsulates a collection of methods for one particular selector when querying for changes. According to the number and kind of those methods a provided method exists, there is a conflict or there are no provided nor conflicting methods at all. I provide the interface to query for those situations, e.g., effectiveMethod returns the provided method or the conflict marker method. !
----- Method: TraitMethodDescription class>>initialize (in category 'class initialization') ----- initialize " self initialize " ConflictMethods _ Array new: self maxArguments + 2. RequiredMethods _ Array new: self maxArguments + 2.!
----- Method: TraitMethodDescription class>>maxArguments (in category 'private') ----- maxArguments ^30!
----- Method: TraitMethodDescription class>>new (in category 'instance creation') ----- new ^super new initialize; yourself!
----- Method: TraitMethodDescription class>>selector: (in category 'instance creation') ----- selector: aSymbol ^self new selector: aSymbol yourself!
----- Method: TraitMethodDescription>>addLocatedMethod: (in category 'accessing') ----- addLocatedMethod: aLocatedMethod locatedMethods add: aLocatedMethod!
----- Method: TraitMethodDescription>>conflictMethod (in category 'accessing') ----- conflictMethod | templateMethod argumentNames binary numberOfArguments | self isConflict ifFalse: [^nil]. argumentNames _ self getArgumentNames. binary _ self isBinarySelector. numberOfArguments _ binary ifTrue: [1] ifFalse: [argumentNames size + 2]. templateMethod _ self conflictMethodForArguments: numberOfArguments ifAbsentPut: [ self generateTemplateMethodWithMarker: CompiledMethod conflictMarker forArgs: argumentNames size binary: binary]. ^templateMethod copyWithTempNames: argumentNames !
----- Method: TraitMethodDescription>>conflictMethodForArguments:ifAbsentPut: (in category 'private') ----- conflictMethodForArguments: aNumber ifAbsentPut: aBlock "ConflictMethods is an array that caches the generated conflict methods. At position 1: binary method; 2: unary method; n+2: keywordmethod with n arguments."
^(ConflictMethods at: aNumber) ifNil: [ConflictMethods at: aNumber put: aBlock value]!
----- Method: TraitMethodDescription>>effectiveMethod (in category 'accessing') ----- effectiveMethod "Return the effective compiled method of this method description."
| locatedMethod method | method _ self providedMethod. method isNil ifFalse: [^ method]. method _ self conflictMethod. method isNil ifFalse: [^ method]. ^ self requiredMethod.!
----- Method: TraitMethodDescription>>effectiveMethodCategory (in category 'accessing') ----- effectiveMethodCategory ^ self effectiveMethodCategoryCurrent: nil new: nil!
----- Method: TraitMethodDescription>>effectiveMethodCategoryCurrent:new: (in category 'accessing') ----- effectiveMethodCategoryCurrent: currentCategoryOrNil new: newCategoryOrNil | 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 _ each category. isCurrent _ isCurrent or: [cat == currentCategoryOrNil]. isConflict _ isConflict or: [cat ~~ result]]. isConflict ifFalse: [^ result]. (isCurrent not and: [newCategoryOrNil notNil]) ifTrue: [^ newCategoryOrNil]. ^ ClassOrganizer ambiguous.!
----- Method: TraitMethodDescription>>generateTemplateMethodWithMarker:forArgs:binary: (in category 'private') ----- generateTemplateMethodWithMarker: aSymbol forArgs: aNumber binary: aBoolean | source node | source _ String streamContents: [:stream | aNumber < 1 ifTrue: [stream nextPutAll: 'selector'] ifFalse: [aBoolean ifTrue: [ stream nextPutAll: '* anObject'] ifFalse: [ 1 to: aNumber do: [:argumentNumber | stream nextPutAll: 'with:'; space; nextPutAll: 'arg'; nextPutAll: argumentNumber asString; space]]]. stream cr; tab; nextPutAll: 'self '; nextPutAll: aSymbol]. node _ self class compilerClass new compile: source in: self class notifying: nil ifFail: []. ^node generate.!
----- Method: TraitMethodDescription>>getArgumentNames (in category 'private') ----- getArgumentNames | argumentNamesCollection names defaultName | defaultName _ 'arg'. argumentNamesCollection _ self locatedMethods collect: [:each | each argumentNames ]. names _ Array new: argumentNamesCollection anyOne size. argumentNamesCollection do: [:collection | 1 to: names size do: [:index | (names at: index) isNil ifTrue: [names at: index put: (collection at: index)] ifFalse: [(names at: index) ~= (collection at: index) ifTrue: [names at: index put: defaultName, index asString]]]]. ^names !
----- Method: TraitMethodDescription>>initialize (in category 'initialize-release') ----- initialize super initialize. locatedMethods _ Set new!
----- Method: TraitMethodDescription>>isAliasSelector (in category 'testing') ----- isAliasSelector "Return true if the selector is an alias (if it is different from the original selector) or already an aliased method in the original location (recursively search the compositions). Return false, if not or if we have a conflict." | locatedMethod | ^self size = 1 and: [ locatedMethod _ self locatedMethods anyOne. (locatedMethod selector ~= self selector) or: [ locatedMethod location isAliasSelector: self selector]]!
----- Method: TraitMethodDescription>>isBinarySelector (in category 'testing') ----- isBinarySelector ^self locatedMethods anyOne isBinarySelector!
----- Method: TraitMethodDescription>>isConflict (in category 'testing') ----- isConflict | count | count _ 0. self methodsDo: [:each | each isProvided ifTrue: [ count _ count + 1. count > 1 ifTrue: [^true]]]. ^false!
----- Method: TraitMethodDescription>>isEmpty (in category 'testing') ----- isEmpty ^self size = 0!
----- Method: TraitMethodDescription>>isLocalAliasSelector (in category 'testing') ----- isLocalAliasSelector "Return true if the selector is an alias (if it is different from the original selector). Return false, if not or if we have a conflict." ^self size = 1 and: [ (self locatedMethods anyOne selector ~= self selector)]!
----- Method: TraitMethodDescription>>isProvided (in category 'testing') ----- isProvided ^ self providedMethod notNil!
----- Method: TraitMethodDescription>>isRequired (in category 'testing') ----- isRequired self isEmpty ifTrue: [^ false]. ^ self locatedMethods allSatisfy: [:each | each method isRequired]!
----- Method: TraitMethodDescription>>locatedMethods (in category 'accessing') ----- locatedMethods ^locatedMethods!
----- Method: TraitMethodDescription>>methodsDo: (in category 'enumeration') ----- methodsDo: aBlock self locatedMethods do: [:each | aBlock value: each method]!
----- Method: TraitMethodDescription>>providedLocatedMethod (in category 'accessing') ----- providedLocatedMethod | locatedMethod | locatedMethod _ nil. self locatedMethods do: [:each | each method isProvided ifTrue: [ locatedMethod isNil ifFalse: [^nil]. locatedMethod _ each]]. ^locatedMethod!
----- Method: TraitMethodDescription>>providedMethod (in category 'accessing') ----- providedMethod ^self providedLocatedMethod ifNotNilDo: [:locatedMethod | locatedMethod method]!
----- Method: TraitMethodDescription>>requiredMethod (in category 'accessing') ----- requiredMethod | templateMethod argumentNames numberOfArguments binary | self isRequired ifFalse: [^nil]. self size = 1 ifTrue: [^self locatedMethods anyOne method]. argumentNames _ self getArgumentNames. binary _ self isBinarySelector. numberOfArguments _ binary ifTrue: [1] ifFalse: [argumentNames size + 2]. templateMethod _ self requiredMethodForArguments: numberOfArguments ifAbsentPut: [ self generateTemplateMethodWithMarker: CompiledMethod implicitRequirementMarker forArgs: argumentNames size binary: binary]. ^templateMethod copyWithTempNames: argumentNames !
----- Method: TraitMethodDescription>>requiredMethodForArguments:ifAbsentPut: (in category 'private') ----- requiredMethodForArguments: aNumber ifAbsentPut: aBlock "ConflictMethods is an array that caches the generated conflict methods. At position 1: binary method; 2: unary method; n+2: keywordmethod with n arguments."
^(RequiredMethods at: aNumber) ifNil: [ConflictMethods at: aNumber put: aBlock value]!
----- Method: TraitMethodDescription>>selector (in category 'accessing') ----- selector ^selector!
----- Method: TraitMethodDescription>>selector: (in category 'accessing') ----- selector: aSymbol selector _ aSymbol!
----- Method: TraitMethodDescription>>size (in category 'accessing') ----- size ^self locatedMethods size!
----- Method: Trait class>>defaultEnvironment (in category 'instance creation') ----- defaultEnvironment ^Smalltalk!
----- Method: Trait class>>named:uses:category: (in category 'instance creation') ----- named: aSymbol uses: aTraitCompositionOrCollection category: aString | env | env _ self environment. ^self named: aSymbol uses: aTraitCompositionOrCollection category: aString env: env!
----- Method: Trait class>>named:uses:category:env: (in category 'instance creation') ----- named: aSymbol uses: aTraitCompositionOrCollection category: aString env: anEnvironment | trait oldTrait systemCategory | systemCategory _ aString asSymbol. trait _ anEnvironment at: aSymbol ifAbsent: [nil]. oldTrait _ trait copy. trait _ trait ifNil: [super new]. (trait isKindOf: Trait) ifFalse: [ ^self error: trait name , ' is not a Trait']. trait setName: aSymbol andRegisterInCategory: systemCategory environment: anEnvironment. trait setTraitComposition: aTraitCompositionOrCollection asTraitComposition. "... notify interested clients ..." oldTrait isNil ifTrue: [ SystemChangeNotifier uniqueInstance classAdded: trait inCategory: systemCategory. ^ trait]. SystemChangeNotifier uniqueInstance traitDefinitionChangedFrom: oldTrait to: trait. systemCategory ~= oldTrait category ifTrue: [SystemChangeNotifier uniqueInstance class: trait recategorizedFrom: oldTrait category to: systemCategory]. ^ trait!
----- Method: Trait class>>new (in category 'instance creation') ----- new self shouldNotImplement!
----- Method: Trait class>>newTemplateIn: (in category 'printing') ----- newTemplateIn: categoryString ^String streamContents: [:stream | stream nextPutAll: self name; nextPutAll: ' named: #NameOfTrait'; cr; tab; nextPutAll: 'uses: {}'; cr; tab; nextPutAll: 'category: '; nextPut: $'; nextPutAll: categoryString; nextPut: $' ]!
----- Method: Trait>>applyChangesOfNewTraitCompositionReplacing: (in category 'private') ----- applyChangesOfNewTraitCompositionReplacing: oldComposition "Duplicated on Class" | changedSelectors | changedSelectors _ super applyChangesOfNewTraitCompositionReplacing: oldComposition. self classSide noteNewBaseTraitCompositionApplied: self traitComposition. ^ changedSelectors!
----- Method: Trait>>baseTrait (in category 'accessing parallel hierarchy') ----- baseTrait ^self!
----- Method: Trait>>basicCategory (in category 'accessing') ----- basicCategory ^category!
----- Method: Trait>>basicCategory: (in category 'accessing') ----- basicCategory: aSymbol category := aSymbol!
----- Method: Trait>>binding (in category 'compiling') ----- binding
^ Smalltalk associationAt: name ifAbsent: [nil -> self] !
----- Method: Trait>>classTrait (in category 'accessing parallel hierarchy') ----- classTrait ^classTrait!
----- Method: Trait>>classTrait: (in category 'accessing parallel hierarchy') ----- classTrait: aTrait "Assigns the class trait associated with the receiver." self assert: aTrait isClassTrait. classTrait _ aTrait!
----- Method: Trait>>copy (in category 'copying') ----- copy | newTrait | newTrait := self class basicNew initialize name: self name traitComposition: self traitComposition copyTraitExpression methodDict: self methodDict copy localSelectors: self localSelectors copy organization: self organization copy. newTrait classTrait initializeFrom: self classTrait. ^newTrait!
----- Method: Trait>>environment (in category 'accessing') ----- environment ^environment!
----- Method: Trait>>environment: (in category 'accessing') ----- environment: anObject environment _ anObject!
----- Method: Trait>>fileOutAsHtml: (in category 'fileIn/Out') ----- fileOutAsHtml: useHtml "File a description of the receiver onto a new file whose base name is the name of the receiver."
| internalStream | internalStream _ WriteStream on: (String new: 100). internalStream header; timeStamp.
self fileOutOn: internalStream moveSource: false toFile: 0. internalStream trailer.
FileStream writeSourceCodeFrom: internalStream baseName: self name isSt: true useHtml: useHtml. !
----- Method: Trait>>fileOutOn:moveSource:toFile: (in category 'fileIn/Out') ----- fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex "This is just copied from Class.. the whole fileout is a mess." ^self fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: true!
----- Method: Trait>>fileOutOn:moveSource:toFile:initializing: (in category 'fileIn/Out') ----- fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool "File a description of the receiver on aFileStream. If the boolean argument, moveSource, is true, then set the trailing bytes to the position of aFileStream and to fileIndex in order to indicate where to find the source code."
Transcript cr; show: name. super fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex. self hasClassTrait ifTrue: [ aFileStream cr; nextPutAll: '"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!!'; cr; cr. self classTrait fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex]!
----- Method: Trait>>hasClassTrait (in category 'accessing parallel hierarchy') ----- hasClassTrait ^classTrait notNil!
----- Method: Trait>>initialize (in category 'initialize-release') ----- initialize super initialize. classTrait _ ClassTrait for: self!
----- Method: Trait>>isBaseTrait (in category 'accessing parallel hierarchy') ----- isBaseTrait ^true!
----- Method: Trait>>isClassTrait (in category 'accessing parallel hierarchy') ----- isClassTrait ^false!
----- Method: Trait>>isObsolete (in category 'testing') ----- isObsolete "Return true if the receiver is obsolete." ^(self environment at: name ifAbsent: [nil]) ~~ self!
----- Method: Trait>>isValidTraitName: (in category 'private') ----- isValidTraitName: aSymbol ^(aSymbol isEmptyOrNil or: [aSymbol first isLetter not] or: [aSymbol anySatisfy: [:character | character isAlphaNumeric not]]) not!
----- Method: Trait>>name (in category 'accessing') ----- name ^name!
----- Method: Trait>>name: (in category 'accessing') ----- name: aSymbol name _ aSymbol!
----- Method: Trait>>name:traitComposition:methodDict:localSelectors:organization: (in category 'initialize-release') ----- name: aString traitComposition: aComposition methodDict: aMethodDict localSelectors: aSet organization: aClassOrganization
"Used by copy" self name: aString. localSelectors _ aSet. methodDict _ aMethodDict. traitComposition _ aComposition. self organization: aClassOrganization !
----- Method: Trait>>obsolete (in category 'initialize-release') ----- obsolete self name: ('AnObsolete' , self name) asSymbol. self hasClassTrait ifTrue: [ self classTrait obsolete]. super obsolete!
----- Method: Trait>>removeFromSystem (in category 'initialize-release') ----- removeFromSystem self removeFromSystem: true!
----- Method: Trait>>removeFromSystem: (in category 'initialize-release') ----- removeFromSystem: logged self environment forgetClass: self logged: logged. self obsolete!
----- Method: Trait>>rename: (in category 'private') ----- rename: aString "The new name of the receiver is the argument, aString."
| newName | (newName _ aString asSymbol) ~= self name ifFalse: [^ self]. (self environment includesKey: newName) ifTrue: [^ self error: newName , ' already exists']. (Undeclared includesKey: newName) ifTrue: [self inform: 'There are references to, ' , aString printString , ' from Undeclared. Check them after this change.']. self environment renameClass: self as: newName. name _ newName!
----- Method: Trait>>requirements (in category 'accessing') ----- requirements ^self requiredSelectors!
----- Method: Trait>>setName:andRegisterInCategory:environment: (in category 'private') ----- setName: aSymbol andRegisterInCategory: categorySymbol environment: aSystemDictionary (self isValidTraitName: aSymbol) ifFalse: [TraitException signal: 'Invalid trait name']. (self environment == aSystemDictionary and: [self name = aSymbol and: [self category = categorySymbol]]) ifTrue: [^self]. ((aSystemDictionary includes: aSymbol) and: [(aSystemDictionary at: aSymbol) ~~ self]) ifTrue: [TraitException signal: 'The name ''' , aSymbol , ''' is already used'].
(self environment notNil and: [self name notNil and: [self name ~= aSymbol]]) ifTrue: [ self environment renameClass: self as: aSymbol]. self name: aSymbol. self environment: aSystemDictionary. self environment at: self name put: self. self environment organization classify: self name under: categorySymbol. ^ true!
----- Method: SequenceableCollection>>asTraitComposition (in category '*Traits') ----- asTraitComposition "For convenience the composition {T1. T2 ...} is the same as T1 + T2 + ..." ^self isEmpty ifFalse: [ self size = 1 ifTrue: [self first asTraitComposition] ifFalse: [ self copyWithoutFirst inject: self first into: [:left :right | left + right]]] ifTrue: [ TraitComposition new]!
----- Method: TBasicCategorisingDescription>>errorCategoryName (in category 'private') ----- errorCategoryName self error: 'Category name must be a String'!
----- Method: TBasicCategorisingDescription>>methodReferencesInCategory: (in category 'organization') ----- methodReferencesInCategory: aCategoryName ^(self organization listAtCategoryNamed: aCategoryName) collect: [:ea | MethodReference new setClassSymbol: self theNonMetaClass name classIsMeta: self isMeta methodSymbol: ea stringVersion: ''] !
----- Method: TBasicCategorisingDescription>>removeCategory: (in category 'accessing method dictionary') ----- removeCategory: aString "Remove each of the messages categorized under aString in the method dictionary of the receiver. Then remove the category aString." | categoryName | categoryName _ aString asSymbol. (self organization listAtCategoryNamed: categoryName) do: [:sel | self removeSelector: sel]. self organization removeCategory: categoryName!
----- Method: TBasicCategorisingDescription>>reorganize (in category 'organization') ----- reorganize "During fileIn, !!Rectangle reorganize!! allows Rectangle to seize control and treat the next chunk as its organization. See the transfer of control where ReadWriteStream fileIn calls scanFrom:"
^self organization!
----- Method: TBasicCategorisingDescription>>whichCategoryIncludesSelector: (in category 'organization') ----- whichCategoryIncludesSelector: aSelector "Answer the category of the argument, aSelector, in the organization of the receiver, or answer nil if the receiver does not inlcude this selector."
(self includesSelector: aSelector) ifTrue: [^ self organization categoryOfElement: aSelector] ifFalse: [^nil]!
----- Method: TBasicCategorisingDescription>>zapOrganization (in category 'organization') ----- zapOrganization "Remove the organization of this class by message categories. This is typically done to save space in small systems. Classes and methods created or filed in subsequently will, nonetheless, be organized"
self organization: nil. self isClassSide ifFalse: [self classSide zapOrganization]!
----- Method: TFileInOutDescription>>definition (in category 'fileIn/Out') ----- definition "Answer a String that defines the receiver in good old ST-80."
^ self definitionST80!
----- Method: TFileInOutDescription>>fileOutCategory: (in category 'fileIn/Out') ----- fileOutCategory: catName ^ self fileOutCategory: catName asHtml: false!
----- Method: TFileInOutDescription>>fileOutCategory:asHtml: (in category 'fileIn/Out') ----- fileOutCategory: catName asHtml: useHtml "FileOut the named category, possibly in Html format." | internalStream | internalStream _ WriteStream on: (String new: 1000). internalStream header; timeStamp. self fileOutCategory: catName on: internalStream moveSource: false toFile: 0. internalStream trailer.
FileStream writeSourceCodeFrom: internalStream baseName: (self name , '-' , catName) isSt: true useHtml: useHtml.!
----- Method: TFileInOutDescription>>fileOutCategory:on:moveSource:toFile: (in category 'fileIn/Out') ----- fileOutCategory: aSymbol on: aFileStream moveSource: moveSource toFile: fileIndex "File a description of the receiver's category, aString, 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 .sources file, and should only write one preamble per method category."
| selectors |
aFileStream cr. selectors := (aSymbol asString = ClassOrganizer allCategory) ifTrue: [ self organization allMethodSelectors ] ifFalse: [ self organization listAtCategoryNamed: aSymbol ].
selectors _ selectors select: [:each | self includesLocalSelector: each]. "Overridden to preserve author stamps in sources file regardless" selectors do: [:sel | self printMethodChunk: sel withPreamble: true on: aFileStream moveSource: moveSource toFile: fileIndex]. ^ self!
----- Method: TFileInOutDescription>>fileOutChangedMessages:on: (in category 'fileIn/Out') ----- fileOutChangedMessages: aSet on: aFileStream "File a description of the messages of the receiver that have been changed (i.e., are entered into the argument, aSet) onto aFileStream."
self fileOutChangedMessages: aSet on: aFileStream moveSource: false toFile: 0!
----- 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 sels | (org _ self organization) categories do: [:cat | sels _ (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel]. sels do: [:sel | self printMethodChunk: sel withPreamble: true on: aFileStream moveSource: moveSource toFile: fileIndex]]!
----- Method: TFileInOutDescription>>fileOutMethod: (in category 'fileIn/Out') ----- fileOutMethod: selector "Write source code of a single method on a file. Make up a name for the file." self fileOutMethod: selector asHtml: false!
----- Method: TFileInOutDescription>>fileOutMethod:asHtml: (in category 'fileIn/Out') ----- fileOutMethod: selector asHtml: useHtml "Write source code of a single method on a file in .st or .html format"
| internalStream | (selector == #Comment) ifTrue: [^ self inform: 'Sorry, cannot file out class comment in isolation.']. (self includesSelector: selector) ifFalse: [^ self error: 'Selector ', selector asString, ' not found']. internalStream _ WriteStream on: (String new: 1000). internalStream header; timeStamp. self printMethodChunk: selector withPreamble: true on: internalStream moveSource: false toFile: 0.
FileStream writeSourceCodeFrom: internalStream baseName: (self name , '-' , (selector copyReplaceAll: ':' with: '')) isSt: true useHtml: useHtml. !
----- Method: TFileInOutDescription>>fileOutOn: (in category 'fileIn/Out') ----- fileOutOn: aFileStream "File a description of the receiver on aFileStream."
self fileOutOn: aFileStream moveSource: false toFile: 0!
----- Method: TFileInOutDescription>>fileOutOn:moveSource:toFile: (in category 'fileIn/Out') ----- fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex "File a description of the receiver on aFileStream. If the boolean argument, moveSource, is true, then set the trailing bytes to the position of aFileStream and to fileIndex in order to indicate where to find the source code."
aFileStream command: 'H3'. aFileStream nextChunkPut: self definition. aFileStream command: '/H3'.
self organization putCommentOnFile: aFileStream numbered: fileIndex moveSource: moveSource forClass: self. self organization categories do: [:heading | self fileOutCategory: heading on: aFileStream moveSource: moveSource toFile: fileIndex]!
----- Method: TFileInOutDescription>>fileOutOrganizationOn: (in category 'fileIn/Out') ----- fileOutOrganizationOn: aFileStream "File a description of the receiver's organization on aFileStream."
aFileStream cr; nextPut: $!!. aFileStream nextChunkPut: self name, ' reorganize'; cr. aFileStream nextChunkPut: self organization printString; cr!
----- Method: TFileInOutDescription>>methods (in category 'fileIn/Out') ----- methods "Answer a ClassCategoryReader for compiling messages that are not classified, as in fileouts made with Smalltalk/V"
^ ClassCategoryReader new setClass: self category: ClassOrganizer default!
----- Method: TFileInOutDescription>>methodsFor: (in category 'fileIn/Out') ----- methodsFor: categoryName "Answer a ClassCategoryReader for compiling the messages in the category, categoryName, of the receiver."
^ ClassCategoryReader new setClass: self category: categoryName asSymbol
"(False methodsFor: 'logical operations') inspect"!
----- Method: TFileInOutDescription>>methodsFor:priorSource:inFile: (in category 'fileIn/Out') ----- methodsFor: aString priorSource: sourcePosition inFile: fileIndex "Prior source pointer ignored when filing in." ^ self methodsFor: aString!
----- Method: TFileInOutDescription>>methodsFor:stamp: (in category 'fileIn/Out') ----- methodsFor: categoryName stamp: changeStamp ^ self methodsFor: categoryName stamp: (Utilities fixStamp: changeStamp) prior: 0!
----- Method: TFileInOutDescription>>methodsFor:stamp:prior: (in category 'fileIn/Out') ----- methodsFor: categoryName stamp: changeStamp prior: indexAndOffset "Prior source link ignored when filing in." ^ ClassCategoryReader new setClass: self category: categoryName asSymbol changeStamp: changeStamp
"Most importantly, return the new ClassCategoryReader, so a fileIn will let it seize control. So method will be placed in the proper category. See the transfer of control where ReadWriteStream fileIn calls scanFrom:"!
----- Method: TFileInOutDescription>>moveChangesTo: (in category 'fileIn/Out') ----- moveChangesTo: newFile "Used in the process of condensing changes, this message requests that the source code of all methods of the receiver that have been changed should be moved to newFile."
| changes | changes := self methodDict keys select: [:sel | (self compiledMethodAt: sel) fileIndex > 1 and: [ (self includesLocalSelector: sel) or: [ (self compiledMethodAt: sel) sendsToSuper]]]. self fileOutChangedMessages: changes on: newFile moveSource: true toFile: 2!
----- Method: TFileInOutDescription>>printCategoryChunk:on: (in category 'fileIn/Out') ----- printCategoryChunk: categoryName on: aFileStream ^ self printCategoryChunk: categoryName withStamp: '' on: aFileStream!
----- Method: TFileInOutDescription>>printCategoryChunk:on:priorMethod: (in category 'fileIn/Out') ----- printCategoryChunk: category on: aFileStream priorMethod: priorMethod ^ self printCategoryChunk: category on: aFileStream withStamp: Utilities changeStamp priorMethod: priorMethod!
----- Method: TFileInOutDescription>>printCategoryChunk:on:withStamp:priorMethod: (in category 'fileIn/Out') ----- printCategoryChunk: category on: aFileStream withStamp: changeStamp priorMethod: priorMethod "Print a method category preamble. This must have a category name. It may have an author/date stamp, and it may have a prior source link. If it has a prior source link, it MUST have a stamp, even if it is empty."
"The current design is that changeStamps and prior source links are preserved in the changes file. All fileOuts include changeStamps. Condensing sources, however, eliminates all stamps (and links, natch)."
aFileStream cr; command: 'H3'; nextPut: $!!. aFileStream nextChunkPut: (String streamContents: [:strm | strm nextPutAll: self name; nextPutAll: ' methodsFor: '; print: category asString. (changeStamp ~~ nil and: [changeStamp size > 0 or: [priorMethod ~~ nil]]) ifTrue: [strm nextPutAll: ' stamp: '; print: changeStamp]. priorMethod ~~ nil ifTrue: [strm nextPutAll: ' prior: '; print: priorMethod sourcePointer]]). aFileStream command: '/H3'.!
----- Method: TFileInOutDescription>>printCategoryChunk:withStamp:on: (in category 'fileIn/Out') ----- printCategoryChunk: categoryName withStamp: changeStamp on: aFileStream ^ self printCategoryChunk: categoryName on: aFileStream withStamp: changeStamp priorMethod: nil!
----- Method: TFileInOutDescription>>printMethodChunk:withPreamble:on:moveSource:toFile: (in category 'fileIn/Out') ----- printMethodChunk: selector withPreamble: doPreamble on: outStream moveSource: moveSource toFile: fileIndex "Copy the source code for the method associated with selector onto the fileStream. If moveSource true, then also set the source code pointer of the method." | preamble method oldPos newPos sourceFile endPos | doPreamble ifTrue: [preamble _ self name , ' methodsFor: ' , (self organization categoryOfElement: selector) asString printString] ifFalse: [preamble _ '']. method _ self methodDict at: selector ifAbsent: [outStream nextPutAll: selector; cr. outStream tab; nextPutAll: '** ERROR!! THIS SCRIPT IS MISSING ** ' translated; cr; cr. outStream nextPutAll: ' '. ^ outStream].
((method fileIndex = 0 or: [(SourceFiles at: method fileIndex) == nil]) or: [(oldPos _ method filePosition) = 0]) ifTrue: ["The source code is not accessible. We must decompile..." preamble size > 0 ifTrue: [outStream cr; nextPut: $!!; nextChunkPut: preamble; cr]. outStream nextChunkPut: method decompileString] ifFalse: [sourceFile _ SourceFiles at: method fileIndex. preamble size > 0 ifTrue: "Copy the preamble" [outStream copyPreamble: preamble from: sourceFile at: oldPos] ifFalse: [sourceFile position: oldPos]. "Copy the method chunk" newPos _ outStream position. outStream copyMethodChunkFrom: sourceFile. sourceFile skipSeparators. "The following chunk may have ]style[" sourceFile peek == $] ifTrue: [ outStream cr; copyMethodChunkFrom: sourceFile]. moveSource ifTrue: "Set the new method source pointer" [endPos _ outStream position. method checkOKToAdd: endPos - newPos at: newPos. method setSourcePosition: newPos inFile: fileIndex]]. preamble size > 0 ifTrue: [outStream nextChunkPut: ' ']. ^ outStream cr!
----- Method: TFileInOutDescription>>putClassCommentToCondensedChangesFile: (in category 'fileIn/Out') ----- putClassCommentToCondensedChangesFile: aFileStream "Called when condensing changes. If the receiver has a class comment, and if that class comment does not reside in the .sources file, then write it to the given filestream, with the resulting RemoteString being reachable from the source file #2. Note that any existing backpointer into the .sources file is lost by this process -- a situation that maybe should be fixed someday."
| header aStamp aCommentRemoteStr | self isMeta ifTrue: [^ self]. "bulletproofing only" ((aCommentRemoteStr _ self organization commentRemoteStr) isNil or: [aCommentRemoteStr sourceFileNumber == 1]) ifTrue: [^ self].
aFileStream cr; nextPut: $!!. header _ String streamContents: [:strm | strm nextPutAll: self name; nextPutAll: ' commentStamp: '. (aStamp _ self organization commentStamp ifNil: ['<historical>']) storeOn: strm. strm nextPutAll: ' prior: 0']. aFileStream nextChunkPut: header. aFileStream cr. self organization classComment: (RemoteString newString: self organization classComment onFileNumber: 2 toFile: aFileStream) stamp: aStamp!
TestResource subclass: #TraitsResource instanceVariableNames: 'createdClassesAndTraits t1 t2 t3 t4 t5 t6 c1 c2 c3 c4 c5 c6 c7 c8 dirty' classVariableNames: 'SetUpCount' poolDictionaries: '' category: 'Traits-Tests'!
----- Method: TraitsResource class>>resetIfDirty (in category 'as yet unclassified') ----- resetIfDirty self current isDirty ifTrue: [self reset]!
----- Method: TraitsResource>>c1 (in category 'accessing') ----- c1 ^c1!
----- Method: TraitsResource>>c1: (in category 'accessing') ----- c1: anObject ^c1 := anObject!
----- Method: TraitsResource>>c2 (in category 'accessing') ----- c2 ^c2!
----- Method: TraitsResource>>c2: (in category 'accessing') ----- c2: anObject ^c2 := anObject!
----- Method: TraitsResource>>c3 (in category 'accessing') ----- c3 ^c3!
----- Method: TraitsResource>>c3: (in category 'accessing') ----- c3: anObject ^c3 := anObject!
----- Method: TraitsResource>>c4 (in category 'accessing') ----- c4 ^c4!
----- Method: TraitsResource>>c4: (in category 'accessing') ----- c4: anObject ^c4 := anObject!
----- Method: TraitsResource>>c5 (in category 'accessing') ----- c5 ^c5!
----- Method: TraitsResource>>c5: (in category 'accessing') ----- c5: anObject ^c5 := anObject!
----- Method: TraitsResource>>c6 (in category 'accessing') ----- c6 ^c6!
----- Method: TraitsResource>>c6: (in category 'accessing') ----- c6: anObject ^c6 := anObject!
----- Method: TraitsResource>>c7 (in category 'accessing') ----- c7 ^c7!
----- Method: TraitsResource>>c7: (in category 'accessing') ----- c7: anObject ^c7 := anObject!
----- Method: TraitsResource>>c8 (in category 'accessing') ----- c8 ^c8!
----- Method: TraitsResource>>c8: (in category 'accessing') ----- c8: anObject ^c8 := anObject!
----- Method: TraitsResource>>categoryName (in category 'as yet unclassified') ----- categoryName ^self class category!
----- Method: TraitsResource>>codeChangedEvent: (in category 'as yet unclassified') ----- codeChangedEvent: anEvent
(anEvent isDoIt not and: [anEvent itemClass notNil] and: [self createdClassesAndTraits includes: anEvent itemClass instanceSide]) ifTrue: [self setDirty] !
----- Method: TraitsResource>>createClassNamed:superclass:uses: (in category 'as yet unclassified') ----- createClassNamed: aSymbol superclass: aClass uses: aTraitComposition | class | class := aClass subclass: aSymbol uses: aTraitComposition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryName. self createdClassesAndTraits add: class. ^class!
----- Method: TraitsResource>>createTraitNamed:uses: (in category 'as yet unclassified') ----- createTraitNamed: aSymbol uses: aTraitComposition | trait | trait := Trait named: aSymbol uses: aTraitComposition category: self categoryName. self createdClassesAndTraits add: trait. ^trait!
----- Method: TraitsResource>>createdClassesAndTraits (in category 'as yet unclassified') ----- createdClassesAndTraits createdClassesAndTraits ifNil: [ createdClassesAndTraits := OrderedCollection new]. ^createdClassesAndTraits!
----- Method: TraitsResource>>isDirty (in category 'accessing') ----- isDirty ^dirty!
----- Method: TraitsResource>>setDirty (in category 'accessing') ----- setDirty dirty := true!
----- Method: TraitsResource>>setUp (in category 'as yet unclassified') ----- setUp "Please note, that most tests rely on this setup of traits and classes - and that especially the order of the definitions matters." "SetUpCount := SetUpCount + 1."
dirty := false. SystemChangeNotifier uniqueInstance doSilently: [self t1: (self createTraitNamed: #T1 uses: { }). self t1 comment: 'I am the trait T1'. self t2: (self createTraitNamed: #T2 uses: { }). self t2 compile: 'm21 ^21' classified: #cat1. self t2 compile: 'm22 ^22' classified: #cat2. self t2 classSide compile: 'm2ClassSide: a ^a'. self t3: (self createTraitNamed: #T3 uses: { }). self t3 compile: 'm31 ^31' classified: #cat1. self t3 compile: 'm32 ^32' classified: #cat2. self t3 compile: 'm33 ^33' classified: #cat3. self t4: (self createTraitNamed: #T4 uses: { (self t1). (self t2) }). self t4 compile: 'm11 ^41' classified: #catX. "overrides T1>>m11" self t4 compile: 'm42 ^42' classified: #cat2. self t5: (self createTraitNamed: #T5 uses: self t1 + self t2). self t5 compile: 'm51 ^super foo' classified: #cat1. self t5 compile: 'm52 ^ self class bar' classified: #cat1. self t5 compile: 'm53 ^ self class bar' classified: #cat1. self t6: (self createTraitNamed: #T6 uses: (self t1 + self t2) @ { (#m22Alias -> #m22) }). self c1: (self createClassNamed: #C1 superclass: Object uses: { }). self c1 compile: 'foo ^true' classified: #accessing. self t1 compile: 'm11 ^11' classified: #cat1. self t1 compile: 'm12 ^12' classified: #cat2. self t1 compile: 'm13 ^self m12' classified: #cat3. self c2: (self createClassNamed: #C2 superclass: self c1 uses: self t5 - { #m11 }). self c2 compile: 'foo ^false' classified: #private. self c2 compile: 'bar ^self foo' classified: #private. self setUpTrivialRequiresFixture. self setUpTwoLevelRequiresFixture. self setUpTranslatingRequiresFixture]. SystemChangeNotifier uniqueInstance notify: self ofAllSystemChangesUsing: #codeChangedEvent:!
----- Method: TraitsResource>>setUpTranslatingRequiresFixture (in category 'as yet unclassified') ----- setUpTranslatingRequiresFixture self c6: (self createClassNamed: #C6 superclass: ProtoObject uses: { }). self c6 superclass: nil. self c7: (self createClassNamed: #C7 superclass: self c6 uses: { }). self c8: (self createClassNamed: #C8 superclass: self c7 uses: { }). self c6 compile: 'foo ^self x' classified: #accessing. self c7 compile: 'foo ^3' classified: #accessing. self c7 compile: 'bar ^super foo' classified: #accessing. self c8 compile: 'bar ^self blah' classified: #accessing!
----- Method: TraitsResource>>setUpTrivialRequiresFixture (in category 'as yet unclassified') ----- setUpTrivialRequiresFixture self c3: (self createClassNamed: #C3 superclass: ProtoObject uses: { }). self c3 superclass: nil. self c3 compile: 'foo ^self bla' classified: #accessing!
----- Method: TraitsResource>>setUpTwoLevelRequiresFixture (in category 'as yet unclassified') ----- setUpTwoLevelRequiresFixture self c4: (self createClassNamed: #C4 superclass: ProtoObject uses: { }). self c4 superclass: nil. self c5: (self createClassNamed: #C5 superclass: self c4 uses: { }). self c4 compile: 'foo ^self blew' classified: #accessing. self c5 compile: 'foo ^self blah' classified: #accessing!
----- Method: TraitsResource>>t1 (in category 'accessing') ----- t1 ^t1!
----- Method: TraitsResource>>t1: (in category 'accessing') ----- t1: anObject ^t1 := anObject!
----- Method: TraitsResource>>t2 (in category 'accessing') ----- t2 ^t2!
----- Method: TraitsResource>>t2: (in category 'accessing') ----- t2: anObject ^t2 := anObject!
----- Method: TraitsResource>>t3 (in category 'accessing') ----- t3 ^t3!
----- Method: TraitsResource>>t3: (in category 'accessing') ----- t3: anObject ^t3 := anObject!
----- Method: TraitsResource>>t4 (in category 'accessing') ----- t4 ^t4!
----- Method: TraitsResource>>t4: (in category 'accessing') ----- t4: anObject ^t4 := anObject!
----- Method: TraitsResource>>t5 (in category 'accessing') ----- t5 ^t5!
----- Method: TraitsResource>>t5: (in category 'accessing') ----- t5: anObject ^t5 := anObject!
----- Method: TraitsResource>>t6 (in category 'accessing') ----- t6 ^t6!
----- Method: TraitsResource>>t6: (in category 'accessing') ----- t6: anObject ^t6 := anObject!
----- Method: TraitsResource>>tearDown (in category 'as yet unclassified') ----- tearDown | behaviorName | SystemChangeNotifier uniqueInstance noMoreNotificationsFor: self. self createdClassesAndTraits do: [: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)))))))))))))!
TestCase subclass: #ATestCase instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Traits-Tests'!
----- Method: ATestCase>>testRequirement (in category 'as yet unclassified') ----- testRequirement " self debug: #testRequirement " | class | class := Object subclass: #AClassForTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self class category. [ class compile: 'call ^ self isCalled'. self assert: (class requiredSelectors includes: #isCalled).
class compile: 'isCalled ^ 1'. "Fail here:" self deny: (class requiredSelectors includes: #isCalled)]
ensure: [class removeFromSystem] !
TestCase subclass: #SendsInfoTest instanceVariableNames: 'state' classVariableNames: '' poolDictionaries: '' category: 'Traits-Tests'!
----- Method: SendsInfoTest>>assert:sends:supersends:classSends: (in category 'test subjects') ----- assert: aSelector sends: sendsCollection supersends: superCollection classSends: classCollection | theMethod info | theMethod := self class >> aSelector. info := (SendInfo on: theMethod) collectSends. self assert: #self sendsIn: info for: aSelector are: sendsCollection. self assert: #super sendsIn: info for: aSelector are: superCollection. self assert: #class sendsIn: info for: aSelector are: classCollection. !
----- Method: SendsInfoTest>>assert:sendsIn:are: (in category 'test subjects') ----- assert: levelSymbol sendsIn: aSelector are: anArrayOfSelectors
!
----- Method: SendsInfoTest>>assert:sendsIn:for:are: (in category 'test subjects') ----- assert: alevel sendsIn: aSendInfo for: aSelector are: aCollectionOfSelectors | detectedSends message | detectedSends := aSendInfo perform: (alevel, 'SentSelectors') asSymbol. message := alevel, ' sends wrong for ', aSelector. self assert: ((detectedSends isEmpty and: [aCollectionOfSelectors isEmpty]) or: [detectedSends = (aCollectionOfSelectors asIdentitySet)]) description: message!
----- Method: SendsInfoTest>>branch (in category 'test subjects') ----- branch "This method is never run. It is here just so that the sends in it can be tallied by the SendInfo interpreter." (state ifNil: [self] ifNotNil: [state]) clip. (state isNil ifTrue: [self] ifFalse: [state]) truncate. !
----- Method: SendsInfoTest>>classBranch (in category 'test subjects') ----- classBranch self shouldnt: [state isNil ifTrue: [self tell] ifFalse: [self class tell]] raise: MessageNotUnderstood!
----- Method: SendsInfoTest>>clip (in category 'test subjects') ----- clip "This method is never run. It is here just so that the sends in it can be tallied by the SendInfo interpreter." | temp | self printString. temp _ self. temp error: 4 + 5!
----- Method: SendsInfoTest>>clipRect: (in category 'test subjects') ----- clipRect: aRectangle "This method is never run. It is here just so that the sends in it can be tallied by the SendInfo interpreter." super clipRect: aRectangle. (state notNil and: [self bitBlt notNil]) ifTrue: [state bitBlt clipRect: aRectangle]!
----- Method: SendsInfoTest>>pseudoCopy (in category 'test subjects') ----- pseudoCopy "This method is never run. It is here just so that the sends in it can be tallied by the SendInfo interpreter." | array | array := self class new: self basicSize. self instVarsWithIndexDo: [:each :i | array at: i put: each]. ^ array!
----- Method: SendsInfoTest>>superBranch (in category 'test subjects') ----- superBranch self should: [state isNil ifTrue: [super tell] ifFalse: [self tell]] raise: MessageNotUnderstood!
----- Method: SendsInfoTest>>tell (in category 'test subjects') ----- tell "this method should not be defined in super"!
----- Method: SendsInfoTest>>testBranch (in category 'tests') ----- testBranch self assert: #branch sends: #(clip truncate) supersends: #() classSends: #()!
----- Method: SendsInfoTest>>testClassBranch (in category 'tests') ----- testClassBranch self assert: #classBranch sends: #(tell shouldnt:raise:) supersends: #() classSends: #(tell). self classBranch.!
----- Method: SendsInfoTest>>testClip (in category 'tests') ----- testClip self assert: #clip sends: #(printString) supersends: #() classSends: #()!
----- Method: SendsInfoTest>>testClipRect (in category 'tests') ----- testClipRect self assert: #clipRect: sends: #(bitBlt) supersends: #(clipRect:) classSends: #() !
----- Method: SendsInfoTest>>testPseudoCopy (in category 'tests') ----- testPseudoCopy self assert: #pseudoCopy sends: #(instVarsWithIndexDo: basicSize) supersends: #() classSends: #(#new:)!
----- Method: SendsInfoTest>>testSuperBranch (in category 'tests') ----- testSuperBranch self assert: #superBranch sends: #(tell should:raise:) supersends: #(tell) classSends: #(). self superBranch.!
TestCase subclass: #TimeMeasuringTest instanceVariableNames: 'realTime shouldProfile' classVariableNames: '' poolDictionaries: '' category: 'Traits-Requires'!
TimeMeasuringTest subclass: #RequiresSpeedTestCase instanceVariableNames: 'displayedClasses focusedClasses interestingCategories' classVariableNames: '' poolDictionaries: '' category: 'Traits-Requires'!
!RequiresSpeedTestCase commentStamp: 'al 2/17/2006 08:50' prior: 0! This class sets some performance requirements for the requirements algorithm. Subclasses set up and test different caching strategies.
Test methods are prefixed with "performance" to exclude them from normal test runs.!
RequiresSpeedTestCase subclass: #FullMERequiresSpeedTestCase instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Traits-Requires'!
----- Method: FullMERequiresSpeedTestCase>>getInformationFor: (in category 'as yet unclassified') ----- getInformationFor: classes classes do: [:interestingCl | interestingCl withAllSuperclassesDo: [:cl | LocalSends current for: cl. ProvidedSelectors current for: cl. RequiredSelectors current for: cl]]!
----- Method: FullMERequiresSpeedTestCase>>loseInterestInClasses: (in category 'as yet unclassified') ----- loseInterestInClasses: classes classes do: [:interestingCl | RequiredSelectors current lostInterest: self in: interestingCl. interestingCl withAllSuperclassesDo: [:cl | ProvidedSelectors current lostInterest: self in: cl. LocalSends current lostInterest: self in: cl]]!
----- Method: FullMERequiresSpeedTestCase>>noteInterestInClasses: (in category 'as yet unclassified') ----- noteInterestInClasses: classes classes do: [:interestingCl | interestingCl withAllSuperclassesDo: [:cl | LocalSends current noteInterestOf: self in: cl. ProvidedSelectors current noteInterestOf: self in: cl]. RequiredSelectors current noteInterestOf: self in: interestingCl]!
----- Method: FullMERequiresSpeedTestCase>>prepareAllCaches (in category 'as yet unclassified') ----- prepareAllCaches | classes | classes := displayedClasses , focusedClasses. self noteInterestInClasses: classes. self getInformationFor: classes!
----- Method: RequiresSpeedTestCase class>>isAbstract (in category 'as yet unclassified') ----- isAbstract ^self == RequiresSpeedTestCase !
----- Method: RequiresSpeedTestCase>>classesInCategories: (in category 'as yet unclassified') ----- classesInCategories: currentCats ^currentCats gather: [:c | (SystemOrganization listAtCategoryNamed: c) collect: [:name | Smalltalk at: name]]!
----- Method: RequiresSpeedTestCase>>decideInterestingClasses (in category 'as yet unclassified') ----- decideInterestingClasses interestingCategories := { 'Morphic-Basic'. 'Morphic-Books'. 'Morphic-Demo'. 'System-Compression'. 'System-Compiler' }. displayedClasses := self classesInCategories: interestingCategories. focusedClasses := { AtomMorph. AlignmentMorph. BookMorph. GZipReadStream. CommentNode }!
----- Method: RequiresSpeedTestCase>>performanceTestFileInScenario (in category 'as yet unclassified') ----- performanceTestFileInScenario self prepareAllCaches. "decide the interesting sets" "set them up as such" "decide the classes and methods to be touched" self measure: ["touch the code as decided" "ask isAbsract of many classes" "ask requiredSelectors of a few"]. self assert: realTime < 1000 !
----- Method: RequiresSpeedTestCase>>performanceTestFullRequires (in category 'as yet unclassified') ----- performanceTestFullRequires self prepareAllCaches. "note that we do not invalidate any caches" self measure: [AlignmentMorph requiredSelectors]. "assuming we want 5 browsers to update their requiredSelectors list in 0.1 second" self assert: realTime < 20!
----- Method: RequiresSpeedTestCase>>performanceTestMethodChangeScenario (in category 'as yet unclassified') ----- performanceTestMethodChangeScenario RequiredSelectors doWithTemporaryInstance: [ LocalSends doWithTemporaryInstance: [ ProvidedSelectors doWithTemporaryInstance: [ self prepareAllCaches. self measure: [self touchObjectHalt. displayedClasses do: [:cl | cl hasRequiredSelectors]. focusedClasses do: [:cl | cl requiredSelectors]]. self assert: realTime < 200]]]!
----- Method: RequiresSpeedTestCase>>performanceTestMorphMethodChangeScenario (in category 'as yet unclassified') ----- performanceTestMorphMethodChangeScenario RequiredSelectors doWithTemporaryInstance: [LocalSends doWithTemporaryInstance: [ProvidedSelectors doWithTemporaryInstance: [self prepareAllCaches. self measure: [self touchMorphStep. displayedClasses do: [:cl | cl hasRequiredSelectors]. focusedClasses do: [:cl | cl requiredSelectors]]. self assert: realTime < 200]]]!
----- Method: RequiresSpeedTestCase>>performanceTestParseNodeMethodChangeScenario (in category 'as yet unclassified') ----- performanceTestParseNodeMethodChangeScenario RequiredSelectors doWithTemporaryInstance: [LocalSends doWithTemporaryInstance: [ProvidedSelectors doWithTemporaryInstance: [self prepareAllCaches. self measure: [self touchParseNodeComment. displayedClasses do: [:cl | cl hasRequiredSelectors]. focusedClasses do: [:cl | cl requiredSelectors]]. self assert: realTime < 100]]]!
----- 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: [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]]]!
----- Method: RequiresSpeedTestCase>>prepareAllCaches (in category 'as yet unclassified') ----- prepareAllCaches self subclassResponsibility.!
----- Method: RequiresSpeedTestCase>>setUp (in category 'as yet unclassified') ----- setUp self decideInterestingClasses. !
----- Method: RequiresSpeedTestCase>>touchMorphStep (in category 'as yet unclassified') ----- touchMorphStep Morph compile: (Morph sourceCodeAt: #step ifAbsent: []) asString!
----- Method: RequiresSpeedTestCase>>touchObjectHalt (in category 'as yet unclassified') ----- touchObjectHalt ^Object compile: (Object sourceCodeAt: #halt ifAbsent: []) asString!
----- Method: RequiresSpeedTestCase>>touchParseNodeComment (in category 'as yet unclassified') ----- touchParseNodeComment ParseNode compile: (ParseNode sourceCodeAt: #comment ifAbsent: []) asString!
----- Method: RequiresSpeedTestCase>>workingCopyPredicate (in category 'as yet unclassified') ----- workingCopyPredicate ^[:e | {'TraitsOmniBrowser'. 'Traits'} includes: e package name]!
TimeMeasuringTest subclass: #SendCachePerformanceTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Traits-LocalSends'!
----- Method: SendCachePerformanceTest>>performanceTestBaseline (in category 'as yet unclassified') ----- performanceTestBaseline LocalSends current for: Morph. self assert: [LocalSends current for: Morph] timeToRun < 1. Morph clearSendCaches. self measure: [LocalSends current for: Morph]. self assert: realTime < 100. self assert: [LocalSends current for: Morph] timeToRun < 1!
----- Method: TimeMeasuringTest>>debug (in category 'as yet unclassified') ----- debug self resources do: [:res | res isAvailable ifFalse: [^res signalInitializationError]]. [(self class selector: testSelector) setToDebug; runCase] ensure: [self resources do: [:each | each reset]] !
----- Method: TimeMeasuringTest>>initialize (in category 'as yet unclassified') ----- initialize shouldProfile _ false.!
----- Method: TimeMeasuringTest>>measure: (in category 'as yet unclassified') ----- measure: measuredBlock shouldProfile ifTrue: [TimeProfileBrowser onBlock: [10 timesRepeat: measuredBlock]]. realTime := measuredBlock timeToRun!
----- Method: TimeMeasuringTest>>openDebuggerOnFailingTestMethod (in category 'as yet unclassified') ----- openDebuggerOnFailingTestMethod shouldProfile _ true!
----- Method: TimeMeasuringTest>>reportPerformance (in category 'as yet unclassified') ----- reportPerformance | str | str := CrLfFileStream fileNamed: 'performanceReports.txt'. str setToEnd; nextPutAll: ' test: ', testSelector; nextPutAll: ' time: ', realTime asString; nextPutAll: ' version: ', self versionInformation; cr; close!
----- Method: TimeMeasuringTest>>runCase (in category 'as yet unclassified') ----- runCase [super runCase] ensure: [self reportPerformance]!
----- Method: TimeMeasuringTest>>setToDebug (in category 'as yet unclassified') ----- setToDebug shouldProfile _ true !
----- Method: TimeMeasuringTest>>versionInfoForWorkingCopiesThat: (in category 'as yet unclassified') ----- versionInfoForWorkingCopiesThat: wcPredicate ^(MCWorkingCopy allManagers select: wcPredicate) inject: '' into: [:s :e | s , e description]!
----- Method: TimeMeasuringTest>>versionInformation (in category 'as yet unclassified') ----- versionInformation | wcPredicate | wcPredicate := self workingCopyPredicate. ^self versionInfoForWorkingCopiesThat: wcPredicate!
----- Method: TimeMeasuringTest>>workingCopyPredicate (in category 'as yet unclassified') ----- workingCopyPredicate ^[:e | '*Traits*' match: e package name]!
TestCase subclass: #TraitsTestCase instanceVariableNames: 'createdClassesAndTraits' classVariableNames: '' poolDictionaries: '' category: 'Traits-Tests'!
TraitsTestCase subclass: #ClassTraitTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Traits-Tests'!
----- Method: ClassTraitTest>>testChanges (in category 'testing') ----- testChanges "Test the most important features to ensure that general functionality of class traits are working."
"self run: #testChanges"
| classTrait | classTrait := self t1 classTrait. classTrait compile: 'm1ClassSide ^17' classified: 'mycategory'.
"local selectors" self assert: (classTrait includesLocalSelector: #m1ClassSide). self deny: (classTrait includesLocalSelector: #otherSelector).
"propagation" self assert: (self t5 classSide methodDict includesKey: #m1ClassSide). self assert: (self c2 class methodDict includesKey: #m1ClassSide). self shouldnt: [self c2 m1ClassSide] raise: Error. self assert: self c2 m1ClassSide = 17.
"category" self assert: (self c2 class organization categoryOfElement: #m1ClassSide) = 'mycategory'.
"conflicts" self t2 classSide compile: 'm1ClassSide' classified: 'mycategory'. self assert: (self c2 class methodDict includesKey: #m1ClassSide). self deny: (self c2 class includesLocalSelector: #m1ClassSide). self should: [self c2 m1ClassSide] raise: Error.
"conflict category" self assert: (self c2 class organization categoryOfElement: #m1ClassSide) = #mycategory!
----- Method: ClassTraitTest>>testConflictsAliasesAndExclusions (in category 'testing') ----- testConflictsAliasesAndExclusions "conflict"
self t1 classTrait compile: 'm2ClassSide: x ^99' classified: 'mycategory'. self assert: (self t1 classTrait includesLocalSelector: #m2ClassSide:). self assert: (self t5 classTrait >> #m2ClassSide:) isConflict. self assert: (self c2 class >> #m2ClassSide:) isConflict.
"exclusion and alias" self assert: self t5 classSide traitComposition asString = 'T1 classTrait + T2 classTrait'. self t5 classSide setTraitCompositionFrom: (self t1 classTrait @ { (#m2ClassSideAlias1: -> #m2ClassSide:) } + self t2 classTrait) @ { (#m2ClassSideAlias2: -> #m2ClassSide:) } - { #m2ClassSide: }. self deny: (self t5 classTrait >> #m2ClassSide:) isConflict. self deny: (self c2 class >> #m2ClassSide:) isConflict. self assert: (self c2 m2ClassSideAlias1: 13) = 99. self assert: (self c2 m2ClassSideAlias2: 13) = 13!
----- Method: ClassTraitTest>>testInitialization (in category 'testing') ----- testInitialization "self run: #testInitialization"
| classTrait | classTrait := self t1 classTrait. self assert: self t1 hasClassTrait. self assert: self t1 classTrait == classTrait. self assert: classTrait isClassTrait. self assert: classTrait classSide == classTrait. self deny: classTrait isBaseTrait. self assert: classTrait baseTrait == self t1.
"assert classtrait methods are propagated to users when setting traitComposition" self assert: self t4 hasClassTrait. self assert: self t5 hasClassTrait. self assert: (self t2 classSide includesLocalSelector: #m2ClassSide:). self assert: (self t4 classSide methodDict includesKey: #m2ClassSide:). self assert: (self t5 classSide methodDict includesKey: #m2ClassSide:). self assert: (self c2 m2ClassSide: 17) = 17!
----- Method: ClassTraitTest>>testUsers (in category 'testing') ----- testUsers self assert: self t2 classSide users size = 3. self assert: (self t2 classSide users includesAllOf: { (self t4 classTrait). (self t5 classTrait). (self t6 classTrait) }). self assert: self t5 classSide users size = 1. self assert: self t5 classSide users anyOne = self c2 class. self c2 setTraitCompositionFrom: self t1 + self t5. self assert: self t5 classSide users size = 1. self assert: self t5 classSide users anyOne = self c2 class. self c2 setTraitComposition: self t2 asTraitComposition. self assert: self t5 classSide users isEmpty!
TraitsTestCase subclass: #LocatedMethodTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Traits-Tests'!
----- Method: LocatedMethodTest>>setUp (in category 'setUp') ----- setUp super setUp. self t1 compile: '+ aNumber ^aNumber + 17'. self t1 compile: '!!aNumber | temp | ^aNumber + 17'. self t1 compile: '&& anObject'. self t1 compile: '@%+anObject'. self t1 compile: 'mySelector "a comment"'. self t1 compile: 'mySelector: something ^17'. self t1 compile: 'mySelector: something and:somethingElse ^true'!
----- Method: LocatedMethodTest>>testArgumentNames (in category 'running') ----- testArgumentNames
self assert: (LocatedMethod location: self t1 selector: #+) argumentNames = #(aNumber). self assert: (LocatedMethod location: self t1 selector: #!!) argumentNames = #(aNumber). self assert: (LocatedMethod location: self t1 selector: #&&) argumentNames = #(anObject). self assert: (LocatedMethod location: self t1 selector: #@%+) argumentNames = #(anObject). self assert: (LocatedMethod location: self t1 selector: #mySelector) argumentNames = #(). self assert: (LocatedMethod location: self t1 selector: #mySelector:) argumentNames = #(something). self assert: (LocatedMethod location: self t1 selector: #mySelector:and:) argumentNames = #(something somethingElse). !
----- Method: LocatedMethodTest>>testBinarySelectors (in category 'running') ----- testBinarySelectors self assert: (LocatedMethod location: self t1 selector: #+) isBinarySelector. self assert: (LocatedMethod location: self t1 selector: #!!) isBinarySelector. self assert: (LocatedMethod location: self t1 selector: #&&) isBinarySelector. self assert: (LocatedMethod location: self t1 selector: #@%+) isBinarySelector. self deny: (LocatedMethod location: self t1 selector: #mySelector) isBinarySelector. self deny: (LocatedMethod location: self t1 selector: #mySelector:) isBinarySelector. self deny: (LocatedMethod location: self t1 selector: #mySelector:and:) isBinarySelector. !
----- Method: LocatedMethodTest>>testEquality (in category 'running') ----- testEquality | locatedMethod1 locatedMethod2 | locatedMethod1 _ LocatedMethod location: self class selector: #testEquality. locatedMethod2 _ LocatedMethod location: self class selector: #testEquality. self assert: locatedMethod1 = locatedMethod2. self assert: locatedMethod1 hash = locatedMethod2 hash!
TraitsTestCase subclass: #PureBehaviorTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Traits-Tests'!
----- Method: PureBehaviorTest>>testChangeSuperclass (in category 'testing-applying trait composition') ----- testChangeSuperclass "self run: #testChangeSuperclass"
"Test that when the superclass of a class is changed the non-local methods of the class sending super are recompiled to correctly store the new superclass."
| aC2 newSuperclass | aC2 := self c2 new.
"C1 is current superclass of C2" self assert: aC2 m51. self assert: self c2 superclass == self c1. self deny: (self c2 localSelectors includes: #m51).
"change superclass of C2 from C1 to X" newSuperclass := self createClassNamed: #X superclass: Object uses: {}. newSuperclass subclass: self c2 name uses: self c2 traitComposition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self c2 category.
self assert: self c2 superclass == newSuperclass.
newSuperclass compile: 'foo ^17'. self assert: aC2 m51 = 17. self deny: (self c2 localSelectors includes: #m51).
self c2 compile: 'm51 ^19'. self assert: aC2 m51 = 19.
"Other methods than those sending super should not have been recompiled" self assert: self c2 >> #m52 == (self t5 >> #m52).
!
----- Method: PureBehaviorTest>>testClassesWithTraits (in category 'testing-applying trait composition') ----- testClassesWithTraits "self debug: #testClassesWithTraits"
self assert: (self c1 methodDict includesKey: #foo). self assert: (self c2 methodDict includesKey: #bar). self assert: (self c2 methodDict includesKey: #m51). self assert: (self c2 methodDict includesKey: #m12). self assert: (self c2 methodDict includesKey: #m13). self assert: (self c2 methodDict includesKey: #m21). self assert: (self c2 methodDict includesKey: #m22). self deny: self c1 class hasTraitComposition. self assert: self c2 class hasTraitComposition.
self assert: (self c2 class traitComposition size = 1). self assert: (self c2 class traitComposition includesTrait: self t5 classTrait)!
----- Method: PureBehaviorTest>>testIsAliasSelector (in category 'testing') ----- testIsAliasSelector self deny: (self t1 isAliasSelector: #m11). self deny: (self t1 isAliasSelector: #foo).
"directly" self assert: (self t6 isAliasSelector: #m22Alias). self deny: (self t6 isAliasSelector: #m22).
"indirectly" self c1 setTraitCompositionFrom: self t6. self assert: (self c1 isAliasSelector: #m22Alias). self deny: (self c1 isAliasSelector: #m22)!
----- Method: PureBehaviorTest>>testIsLocalAliasSelector (in category 'testing') ----- testIsLocalAliasSelector self deny: (self t1 isLocalAliasSelector: #m11). self deny: (self t1 isLocalAliasSelector: #foo).
"directly" self assert: (self t6 isLocalAliasSelector: #m22Alias). self deny: (self t6 isLocalAliasSelector: #m22).
"indirectly" self c1 setTraitComposition: self t6 asTraitComposition. self deny: (self c1 isLocalAliasSelector: #m22Alias). self deny: (self c1 isLocalAliasSelector: #m22)!
----- Method: PureBehaviorTest>>testLocalSelectors (in category 'testing') ----- testLocalSelectors "self run: #testLocalSelectors"
self assert: self t3 localSelectors size = 3. self assert: (self t3 localSelectors includesAllOf: #(#m31 #m32 #m33 )). self assert: (self t3 includesLocalSelector: #m32). self deny: (self t3 includesLocalSelector: #inexistantSelector). self assert: self t5 localSelectors size = 3. self assert: (self t5 localSelectors includes: #m51). self assert: (self t5 includesLocalSelector: #m51). self deny: (self t5 includesLocalSelector: #m11). self t5 removeSelector: #m51. self deny: (self t3 includesLocalSelector: #m51). self deny: (self t5 includesLocalSelector: #m11). self assert: self t5 localSelectors size = 2. self t5 compile: 'm52 ^self'. self assert: self t5 localSelectors size = 2. self assert: (self t5 localSelectors includes: #m52).
"test that propagated methods do not get in as local methods" self t2 compile: 'local2 ^self'. self deny: (self t5 includesLocalSelector: #local2). self assert: self t5 localSelectors size = 2. self assert: (self t5 localSelectors includes: #m52). self assert: self c2 localSelectors size = 2. self assert: (self c2 localSelectors includesAllOf: #(#foo #bar ))!
----- Method: PureBehaviorTest>>testMethodCategoryReorganization (in category 'testing') ----- testMethodCategoryReorganization "self run: #testMethodCategory"
self t1 compile: 'm1' classified: 'category1'. self assert: (self t5 organization categoryOfElement: #m1) = #category1. self assert: (self c2 organization categoryOfElement: #m1) = #category1. self t1 organization classify: #m1 under: #category2 suppressIfDefault: true. self assert: (self t5 organization categoryOfElement: #m1) = #category2. self assert: (self c2 organization categoryOfElement: #m1) = #category2!
----- Method: PureBehaviorTest>>testOwnMethodsTakePrecedenceOverTraitsMethods (in category 'testing-applying trait composition') ----- testOwnMethodsTakePrecedenceOverTraitsMethods "First create a trait with no subtraits and then add subtrait t1 which implements m11 as well."
| trait | trait := self createTraitNamed: #T uses: { }. trait compile: 'm11 ^999'. self assert: trait methodDict size = 1. self assert: (trait methodDict at: #m11) decompileString = 'm11 ^ 999'. Trait named: #T uses: self t1 category: self class category. self assert: trait methodDict size = 3. self assert: (trait methodDict keys includesAllOf: #(#m11 #m12 #m13 )). self assert: (trait methodDict at: #m11) decompileString = 'm11 ^ 999'. self assert: (trait methodDict at: #m12) decompileString = 'm12 ^ 12'!
----- Method: PureBehaviorTest>>testPropagationOfChangesInTraits (in category 'testing-applying trait composition') ----- testPropagationOfChangesInTraits | aC2 | aC2 := self c2 new. self assert: self c2 methodDict size = 9. self t1 compile: 'zork ^false'. self assert: self c2 methodDict size = 10. self deny: aC2 zork. self t1 removeSelector: #m12. self assert: self c2 methodDict size = 9. self should: [aC2 m12] raise: MessageNotUnderstood. self assert: aC2 m21 = 21. self t2 compile: 'm21 ^99'. self assert: aC2 m21 = 99!
----- Method: PureBehaviorTest>>testPropagationOfChangesInTraitsToAliasMethods (in category 'testing-applying trait composition') ----- testPropagationOfChangesInTraitsToAliasMethods | anObject | anObject := (self createClassNamed: #AliasTestClass superclass: Object uses: self t6) new. self assert: anObject m22Alias = 22.
"test update alias method" self t2 compile: 'm22 ^17'. self assert: anObject m22Alias = 17.
"removing original method should also remove alias method" self t2 removeSelector: #m22. self should: [anObject m22Alias] raise: MessageNotUnderstood!
----- Method: PureBehaviorTest>>testPropagationOfChangesInTraitsToAliasMethodsWhenOriginalMethodIsExcluded (in category 'testing-applying trait composition') ----- testPropagationOfChangesInTraitsToAliasMethodsWhenOriginalMethodIsExcluded "Assert that alias method is updated although the original method is excluded from this user."
| anObject | anObject := (self createClassNamed: #AliasTestClass superclass: Object uses: self t1 @ { (#aliasM11 -> #m11) } - { #m11 }) new. self assert: anObject aliasM11 = 11. self deny: (anObject class methodDict includesKey: #m11). self t1 compile: 'm11 ^17'. self assert: anObject aliasM11 = 17!
----- Method: PureBehaviorTest>>testPropagationWhenTraitCompositionModifications (in category 'testing-applying trait composition') ----- testPropagationWhenTraitCompositionModifications "Test that the propagation mechanism works when setting new traitCompositions."
self assert: self c2 methodDict size = 9. "2 + (3+(3+2))-1"
"removing methods" Trait named: #T5 uses: self t1 + self t2 - { #m21. #m22 } category: self class category. self assert: self c2 methodDict size = 7.
"adding methods" Trait named: #T2 uses: self t3 category: self class category. self assert: self c2 methodDict size = 10. self assert: (self c2 methodDict keys includesAllOf: #(#m31 #m32 #m33 ))!
----- Method: PureBehaviorTest>>testRemovingMethods (in category 'testing') ----- testRemovingMethods "When removing a local method, assure that the method from the trait is installed instead and that the users are updated."
"self run: #testRemovingMethods"
"Classes"
self c2 compile: 'm12 ^0' classified: #xxx. self assert: (self c2 includesLocalSelector: #m12). self c2 removeSelector: #m12. self deny: (self c2 includesLocalSelector: #m12). self assert: (self c2 selectors includes: #m12).
"Traits" self t5 compile: 'm12 ^0' classified: #xxx. self assert: self c2 new m12 = 0. self t5 removeSelector: #m12. self deny: (self t5 includesLocalSelector: #m12). self assert: (self t5 selectors includes: #m12). self assert: self c2 new m12 = 12!
----- Method: PureBehaviorTest>>testSuperSends (in category 'testing-applying trait composition') ----- testSuperSends | aC2 | aC2 := self c2 new. self assert: aC2 m51. self deny: aC2 foo. self deny: aC2 bar!
----- Method: PureBehaviorTest>>testTraitCompositionModifications (in category 'testing-applying trait composition') ----- testTraitCompositionModifications self assert: self t6 methodDict size = 6. self assert: (self t6 sourceCodeAt: #m22Alias) asString = 'm22Alias ^22'. self t6 setTraitComposition: self t2 asTraitComposition. self assert: self t6 methodDict size = 2. self deny: (self t6 methodDict includesKey: #m22Alias). self t6 setTraitCompositionFrom: self t1 @ { (#m13Alias -> #m13) } - { #m11. #m12 } + self t2. self assert: self t6 methodDict size = 4. self assert: (self t6 methodDict keys includesAllOf: #(#m13 #m13Alias #m21 #m22 )). self assert: (self t6 sourceCodeAt: #m13Alias) asString = 'm13Alias ^self m12'!
----- Method: PureBehaviorTest>>testTraitCompositionWithCycles (in category 'testing-applying trait composition') ----- testTraitCompositionWithCycles self should: [self t1 setTraitComposition: self t1 asTraitComposition] raise: Error. self t2 setTraitComposition: self t3 asTraitComposition. self should: [self t3 setTraitComposition: self t5 asTraitComposition] raise: Error!
----- Method: PureBehaviorTest>>testUpdateWhenLocalMethodRemoved (in category 'testing-applying trait composition') ----- testUpdateWhenLocalMethodRemoved | aC2 | aC2 := self c2 new. self t5 compile: 'foo ^123'. self deny: aC2 foo. self c2 removeSelector: #foo. self assert: aC2 foo = 123!
----- Method: PureBehaviorTest>>traitOrClassOfSelector (in category 'testing') ----- traitOrClassOfSelector "self run: #traitOrClassOfSelector"
"locally defined in trait or class"
self assert: (self t1 traitOrClassOfSelector: #m12) = self t1. self assert: (self c1 traitOrClassOfSelector: #foo) = self c1.
"not locally defined - simple" self assert: (self t4 traitOrClassOfSelector: #m21) = self t2. self assert: (self c2 traitOrClassOfSelector: #m51) = self t5.
"not locally defined - into nested traits" self assert: (self c2 traitOrClassOfSelector: #m22) = self t2.
"not locally defined - aliases" self assert: (self t6 traitOrClassOfSelector: #m22Alias) = self t2.
"class side" self assert: (self t2 classSide traitOrClassOfSelector: #m2ClassSide:) = self t2 classSide. self assert: (self t6 classSide traitOrClassOfSelector: #m2ClassSide:) = self t2 classSide!
TraitsTestCase subclass: #RequiresTestCase instanceVariableNames: 't7 t8 t9 t10 t11 c9 c10 c11 c12 t13 c13 ta tb tc ca cb cc cd ce cf ch ci cg' classVariableNames: '' poolDictionaries: '' category: 'Traits-Tests'!
RequiresTestCase subclass: #RequiresOriginalTestCase instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Traits-Tests'!
----- Method: RequiresOriginalTestCase class>>updateRequiredStatusFor:in: (in category 'as yet unclassified') ----- updateRequiredStatusFor: selector in: aClass aClass updateRequiredStatusFor: selector inSubclasses: self systemNavigation allClassesAndTraits !
----- Method: RequiresTestCase class>>isAbstract (in category 'as yet unclassified') ----- isAbstract ^self == RequiresTestCase!
----- Method: RequiresTestCase>>for:classesComposedWith: (in category 'as yet unclassified') ----- for: ba classesComposedWith: aBehavior ^(ba includes: aBehavior) or: [(ba gather: [:c | c traitComposition allTraits]) includes: aBehavior]!
----- Method: RequiresTestCase>>loseInterestsFor: (in category 'as yet unclassified') ----- loseInterestsFor: behavior RequiredSelectors current lostInterest: self in: behavior. LocalSends current lostInterest: self in: behavior. ^ProvidedSelectors current lostInterest: self inAll: behavior withAllSuperclasses!
----- Method: RequiresTestCase>>loseInterestsInAll (in category 'as yet unclassified') ----- loseInterestsInAll ^self createdClassesAndTraits , TraitsResource current createdClassesAndTraits do: [:e | self loseInterestsFor: e]!
----- Method: RequiresTestCase>>noteInterestsFor: (in category 'as yet unclassified') ----- noteInterestsFor: behavior RequiredSelectors current noteInterestOf: self in: behavior. LocalSends current noteInterestOf: self in: behavior. ProvidedSelectors current noteInterestOf: self inAll: behavior withAllSuperclasses!
----- Method: RequiresTestCase>>noteInterestsForAll (in category 'as yet unclassified') ----- noteInterestsForAll self createdClassesAndTraits , TraitsResource current createdClassesAndTraits do: [:e | self noteInterestsFor: e]!
----- Method: RequiresTestCase>>requiredMethodsForTrait: (in category 'as yet unclassified') ----- requiredMethodsForTrait: aTrait ^aTrait requiredSelectors!
----- Method: RequiresTestCase>>requiredMethodsOfTrait:inContextOf: (in category 'as yet unclassified') ----- requiredMethodsOfTrait: basicTrait inContextOf: composedTrait | interestingSelectors sss | interestingSelectors := (composedTrait traitComposition transformationOfTrait: basicTrait) allSelectors. sss := composedTrait selfSentSelectorsFromSelectors: interestingSelectors. ^sss copyWithoutAll: composedTrait allSelectors!
----- Method: RequiresTestCase>>selfSentSelectorsInTrait: (in category 'as yet unclassified') ----- selfSentSelectorsInTrait: aTrait ^self selfSentSelectorsInTrait: aTrait fromSelectors: aTrait allSelectors !
----- Method: RequiresTestCase>>selfSentSelectorsInTrait:fromSelectors: (in category 'as yet unclassified') ----- selfSentSelectorsInTrait: composedTrait fromSelectors: interestingSelectors ^composedTrait selfSentSelectorsFromSelectors: interestingSelectors !
----- Method: RequiresTestCase>>setUp (in category 'as yet unclassified') ----- setUp super setUp. t7 := self createTraitNamed: #T7 uses: { }. t7 compile: 'm13 ^self m12' classified: #cat3. t8 := self createTraitNamed: #T8 uses: { (t7 - { #m13 }) }. t9 := self createTraitNamed: #T9 uses: { }. t9 compile: 'm13 ^self m12' classified: #cat3. t9 compile: 'm12 ^3' classified: #cat3. t10 := self createTraitNamed: #T10 uses: { (t9 - { #m12 }) }.
t11 := self createTraitNamed: #T11 uses: { (t9 @ { (#m11 -> #m12) } - { #m12 }) }.
c9 := self createClassNamed: #C9 superclass: ProtoObject uses: t7.
c10 := self createClassNamed: #C10 superclass: ProtoObject uses: t7. c10 compile: 'm12 ^3'.
c11 := self createClassNamed: #C11 superclass: ProtoObject uses: {}. c11 compile: 'm12 ^3'. c12 := self createClassNamed: #C12 superclass: c11 uses: {t7}. !
----- Method: RequiresTestCase>>setUpHierarchy (in category 'as yet unclassified') ----- setUpHierarchy ta := self createTraitNamed: #TA uses: { }. tb := self createTraitNamed: #TB uses: { }. tc := self createTraitNamed: #TC uses: tb. ca := self createClassNamed: #CA superclass: ProtoObject uses: { }. cb := self createClassNamed: #CB superclass: ca uses: ta + tb. cc := self createClassNamed: #CC superclass: cb uses: tb. cd := self createClassNamed: #CD superclass: cc uses: { }. ce := self createClassNamed: #CE superclass: cc uses: { }. cf := self createClassNamed: #CF superclass: cb uses: { }. cg := self createClassNamed: #CG superclass: cf uses: { }. ch := self createClassNamed: #CH superclass: ca uses: { ta }. ci := self createClassNamed: #CI superclass: ch uses: { }.
ca compile: 'mca ^self ssca'. cb compile: 'mca ^3'. cb compile: 'mcb super mca'. cc compile: 'mcb ^3'. cc compile: 'mcb ^self sscc'. !
----- Method: RequiresTestCase>>testAffectedClassesAndTraits (in category 'as yet unclassified') ----- testAffectedClassesAndTraits | rscc | self setUpHierarchy. rscc := RequiredSelectorsChangesCalculator onModificationOf: {tb} withTargets: {ta. cg. ci. cd. tc}. self assert: rscc rootClasses asSet = (Set withAll: {cc. cb}). self assert: rscc classesToUpdate asSet = (Set withAll: {cg. cd. cf. cc. cb}). self assert: rscc traitsToUpdate asSet = (Set withAll: {tc}). self assert: (#(sscc) copyWithoutAll: (rscc selectorsToUpdateIn: cc)) isEmpty. self assert: (#(ssca) copyWithoutAll: (rscc selectorsToUpdateIn: cb)) isEmpty.!
----- Method: RequiresTestCase>>testExclusionWithAliasing (in category 'as yet unclassified') ----- testExclusionWithAliasing self assert: ((self requiredMethodsForTrait: t11) = (Set with: #m12)). !
----- Method: RequiresTestCase>>testExlcusionInTraits (in category 'as yet unclassified') ----- testExlcusionInTraits self assert: ((self requiredMethodsForTrait: t8) = (Set new)). self assert: ((self requiredMethodsForTrait: t9) = (Set new)). self assert: ((self requiredMethodsForTrait: t10) = (Set with:#m12)). !
----- Method: RequiresTestCase>>testOneLevelRequires (in category 'as yet unclassified') ----- testOneLevelRequires [self noteInterestsForAll. self assert: self c3 localSelectors size = 1. self assert: (self c3 sendCaches selfSendersOf: #bla) = #(#foo ). self c3 requiredSelectors. self assert: self c3 requirements = (Set withAll: #(#bla ))] ensure: [self loseInterestsInAll]!
----- Method: RequiresTestCase>>testRequiresOfTraitInContextOfClass (in category 'as yet unclassified') ----- testRequiresOfTraitInContextOfClass "a class providing nothing, leaves the requirements of the trait intact" self assert: (self requiredMethodsOfTrait: t7 inContextOf: c9) = (Set with: #m12). "a class can provide the Trait requirement" self assert: (self requiredMethodsOfTrait: t7 inContextOf: c10) = (Set new). "a class' superclass can provide the Trait requirement" self assert: (self requiredMethodsOfTrait: t7 inContextOf: c12) = (Set new). !
----- Method: RequiresTestCase>>testSimpleCompositionContexts (in category 'as yet unclassified') ----- testSimpleCompositionContexts self assert: (self requiredMethodsOfTrait: t7 inContextOf: t8) = (Set new). self assert: (self requiredMethodsOfTrait: t9 inContextOf: t10) = (Set with: #m12). self assert: (self requiredMethodsOfTrait: t9 inContextOf: t11) = (Set with: #m12).!
----- Method: RequiresTestCase>>testSins (in category 'as yet unclassified') ----- testSins | caa cab cac cad | caa := self createClassNamed: #CAA superclass: ProtoObject uses: { }. caa superclass: nil. cab := self createClassNamed: #CAB superclass: caa uses: {}. cac := self createClassNamed: #CAC superclass: cab uses: {}. cad := self createClassNamed: #CAD superclass: cac uses: { }.
caa compile: 'ma self foo'. caa compile: 'md self explicitRequirement'. cac compile: 'mb self bar'. self noteInterestsFor: cad. self assert: (cad requiredSelectors = (Set withAll: #(foo bar md))). cab compile: 'mc ^3'. self assert: (cad requiredSelectors = (Set withAll: #(foo bar md))). self loseInterestsFor: cad.!
----- Method: RequiresTestCase>>testStandAloneTrait (in category 'as yet unclassified') ----- testStandAloneTrait self assert: ((self requiredMethodsForTrait: t7) = (Set with: #m12)).!
----- Method: RequiresTestCase>>testTwoLevelRequires (in category 'as yet unclassified') ----- testTwoLevelRequires [self noteInterestsForAll. self assert: self c4 localSelectors size = 1. self assert: self c5 localSelectors size = 1. self assert: (self c4 sendCaches selfSendersOf: #blew) = #(#foo ). self assert: (self c5 sendCaches selfSendersOf: #blah) = #(#foo ). self c4 requiredSelectors. self assert: self c4 requirements = (Set withAll: #(#blew )). self assert: self c5 requirements = (Set withAll: #(#blah ))] ensure: [self loseInterestsInAll ]!
----- Method: RequiresTestCase>>testTwoLevelRequiresWithUnalignedSuperSends (in category 'as yet unclassified') ----- testTwoLevelRequiresWithUnalignedSuperSends [self noteInterestsForAll. self updateRequiredStatusFor: #x in: self c6. self updateRequiredStatusFor: #blah in: self c8. self assert: self c6 requirements = (Set with: #x). self assert: self c7 requirements = (Set with: #x). self assert: self c8 requirements = (Set with: #blah).] ensure: [self loseInterestsInAll] !
----- Method: RequiresTestCase>>testTwoLevelRequiresWithUnalignedSuperSendsStartLate (in category 'as yet unclassified') ----- testTwoLevelRequiresWithUnalignedSuperSendsStartLate [self noteInterestsForAll. self updateRequiredStatusFor: #x in: self c8. self updateRequiredStatusFor: #blah in: self c8. self assert: self c8 requirements = (Set with: #blah). self updateRequiredStatusFor: #x in: self c7. self updateRequiredStatusFor: #blah in: self c7. self assert: self c7 requirements = (Set with: #x)] ensure: [self loseInterestsInAll] !
----- Method: RequiresTestCase>>updateRequiredStatusFor:in: (in category 'as yet unclassified') ----- updateRequiredStatusFor: selector in: aClass self class updateRequiredStatusFor: selector in: aClass !
TraitsTestCase subclass: #SystemTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Traits-Tests'!
----- Method: SystemTest>>testAllClassesAndTraits (in category 'testing') ----- testAllClassesAndTraits "self debug: #testAllClassesAndTraits" | trait | trait := self t1. self assert: (Smalltalk allClassesAndTraits includes: trait). self deny: (Smalltalk allClasses includes: trait). !
----- Method: SystemTest>>testAllImplementedMessagesWithout (in category 'testing') ----- testAllImplementedMessagesWithout "self debug: #testAllImplementedMessagesWithout"
self t6 compile: 'das2qwdqwd'. self assert: (SystemNavigation default allImplementedMessages includes: #das2qwdqwd). self deny: (SystemNavigation default allImplementedMessages includes: #qwdqwdqwdc).!
----- Method: SystemTest>>testAllMethodsWithSourceString (in category 'testing') ----- testAllMethodsWithSourceString "self debug: #testAllMethodsWithSourceString"
| result classes | self t6 compile: 'foo self das2d3oia'. result := SystemNavigation default allMethodsWithSourceString: '2d3oi' matchCase: false. self assert: result size = 2. classes := result collect: [:each | each actualClass]. self assert: (classes includesAllOf: {self t6. self class}). self assert: (SystemNavigation default allMethodsWithSourceString: '2d3asdas' , 'ascascoi' matchCase: false) isEmpty.!
----- Method: SystemTest>>testAllSentMessages (in category 'testing') ----- testAllSentMessages "self debug: #testAllSentMessages"
self t1 compile: 'foo 1 dasoia'. self assert: (SystemNavigation default allSentMessages includes: 'dasoia' asSymbol). self deny: (SystemNavigation default allSentMessages includes: 'nioaosi' asSymbol).!
----- Method: SystemTest>>testClassFromPattern (in category 'testing') ----- testClassFromPattern "self debug: #testClassFromPattern"
self assert: (Utilities classFromPattern: 'TCompilingB' withCaption: '') = TCompilingBehavior!
TraitsTestCase subclass: #TraitCompositionTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Traits-Tests'!
----- Method: TraitCompositionTest>>testAliasCompositions (in category 'testing-basic') ----- testAliasCompositions "unary"
self shouldnt: [self t2 setTraitCompositionFrom: self t1 @ { (#aliasM11 -> #m11) }] raise: TraitCompositionException. self should: [self t2 setTraitCompositionFrom: self t1 @ { (#alias: -> #m11) }] raise: TraitCompositionException. self should: [self t2 setTraitCompositionFrom: self t1 @ { (#alias:x:y: -> #m11) }] raise: TraitCompositionException.
"binary" self t1 compile: '= anObject'. self shouldnt: [self t2 setTraitCompositionFrom: self t1 @ { (#equals: -> #=) }] raise: TraitCompositionException. self shouldnt: [self t2 setTraitCompositionFrom: self t1 @ { (#% -> #=) }] raise: TraitCompositionException. self should: [self t2 setTraitCompositionFrom: self t1 @ { (#equals -> #=) }] raise: TraitCompositionException. self should: [self t2 setTraitCompositionFrom: self t1 @ { (#equals:x: -> #=) }] raise: TraitCompositionException.
"keyword" self t1 compile: 'x: a y: b z: c'. self should: [self t2 setTraitCompositionFrom: self t1 @ { (#'==' -> #x:y:z:) }] raise: TraitCompositionException. self should: [self t2 setTraitCompositionFrom: self t1 @ { (#x -> #x:y:z:) }] raise: TraitCompositionException. self should: [self t2 setTraitCompositionFrom: self t1 @ { (#x: -> #x:y:z:) }] raise: TraitCompositionException. self should: [self t2 setTraitCompositionFrom: self t1 @ { (#x:y: -> #x:y:z:) }] raise: TraitCompositionException. self shouldnt: [self t2 setTraitCompositionFrom: self t1 @ { (#myX:y:z: -> #x:y:z:) }] raise: TraitCompositionException.
"alias same as selector" self should: [self t2 setTraitCompositionFrom: self t1 @ { (#m11 -> #m11) }] raise: TraitCompositionException.
"same alias name used twice" self should: [self t2 setTraitCompositionFrom: self t1 @ { (#alias -> #m11). (#alias -> #m12) }] raise: TraitCompositionException.
"aliasing an alias" self should: [self t2 setTraitCompositionFrom: self t1 @ { (#alias -> #m11). (#alias2 -> #alias) }] raise: TraitCompositionException!
----- Method: TraitCompositionTest>>testClassMethodsTakePrecedenceOverTraitsMethods (in category 'testing-enquiries') ----- testClassMethodsTakePrecedenceOverTraitsMethods | keys | keys := Set new. self t4 methodDict bindingsDo: [:each | keys add: each key]. self assert: keys size = 6. self assert: (keys includesAllOf: #( #m12 #m13 #m13 #m21 #m22 #m11 #m42 )). self assert: (self t4 methodDict at: #m11) decompileString = 'm11 ^ 41'!
----- Method: TraitCompositionTest>>testCompositionFromArray (in category 'testing-basic') ----- testCompositionFromArray | composition | composition := { (self t1) } asTraitComposition. self assert: (composition isKindOf: TraitComposition). self assert: (composition traits includes: self t1). self assert: composition traits size = 1. composition := { (self t1). self t2 } asTraitComposition. self assert: (composition isKindOf: TraitComposition). self assert: (composition traits includes: self t1). self assert: (composition traits includes: self t2). self assert: composition traits size = 2!
----- Method: TraitCompositionTest>>testEmptyTrait (in category 'testing-basic') ----- testEmptyTrait | composition | composition _ {} asTraitComposition. self assert: (composition isKindOf: TraitComposition). self assert: composition transformations isEmpty. self assert: composition traits isEmpty!
----- Method: TraitCompositionTest>>testInvalidComposition (in category 'testing-basic') ----- testInvalidComposition self should: [self t1 @ { (#a -> #b) } @ { (#x -> #y) }] raise: TraitCompositionException. self should: [(self t1 + self t2) @ { (#a -> #b) } @ { (#x -> #y) }] raise: TraitCompositionException. self should: [self t1 - { #a } - { #b }] raise: TraitCompositionException. self should: [self t1 + self t2 - { #a } - { #b }] raise: TraitCompositionException. self should: [(self t1 - { #x }) @ { (#a -> #b) }] raise: TraitCompositionException. self should: [(self t1 + self t2 - { #x }) @ { (#a -> #b) }] raise: TraitCompositionException. self should: [self t1 + self t1] raise: TraitCompositionException. self should: [(self t1 + self t2) @ { (#a -> #b) } + self t1] raise: TraitCompositionException. self should: [self t1 @ { (#a -> #m11). (#a -> #m12) }] raise: TraitCompositionException. self should: [self t1 @ { (#a -> #m11). (#b -> #a) }] raise: TraitCompositionException!
----- Method: TraitCompositionTest>>testPrinting (in category 'testing-basic') ----- testPrinting | composition1 composition2 | composition1 := ((self t1 - { #a } + self t2) @ { (#z -> #c) } - { #b. #c } + self t3 - { #d. #e } + self t4) @ { (#x -> #a). (#y -> #b) }. composition2 := self t4 @ { (#x -> #a). (#y -> #b) } + self t1 - { #a } + self t3 - { #d. #e } + self t2 - { #b. #c }. self assertPrints: composition1 printString like: 'T1 - {#a} + T2 @ {#z->#c} - {#b. #c} + T3 - {#d. #e} + T4 @ {#x->#a. #y->#b}'. self assertPrints: composition2 printString like: 'T4 @ {#x->#a. #y->#b} + T1 - {#a} + T3 - {#d. #e} + T2 - {#b. #c}'!
----- Method: TraitCompositionTest>>testProvidedMethodBindingsWithConflicts (in category 'testing-enquiries') ----- testProvidedMethodBindingsWithConflicts | traitWithConflict methodDict | traitWithConflict := self createTraitNamed: #TraitWithConflict uses: self t1 + self t4. methodDict := traitWithConflict methodDict. self assert: methodDict size = 6. self assert: (methodDict keys includesAllOf: #( #m11 #m12 #m13 #m21 #m22 #m42 )). self assert: (methodDict at: #m11) decompileString = 'm11 self traitConflict'!
----- Method: TraitCompositionTest>>testSum (in category 'testing-basic') ----- testSum | composition | composition := self t1 + self t2 + self t3. self assert: (composition isKindOf: TraitComposition). self assert: (composition traits includes: self t1). self assert: (composition traits includes: self t2). self assert: (composition traits includes: self t3). self assert: composition traits size = 3!
----- Method: TraitCompositionTest>>testSumWithParenthesis (in category 'testing-basic') ----- testSumWithParenthesis | composition | composition := self t1 + (self t2 + self t3). self assert: (composition isKindOf: TraitComposition). self assert: (composition traits includes: self t1). self assert: (composition traits includes: self t2). self assert: (composition traits includes: self t3). self assert: composition traits size = 3. self assert: composition size = 3!
TraitsTestCase subclass: #TraitFileOutTest instanceVariableNames: 'ca cb ta tb tc td' classVariableNames: '' poolDictionaries: '' category: 'Traits-Tests'!
----- Method: TraitFileOutTest>>categoryName (in category 'running') ----- categoryName ^'Traits-Tests-FileOut'!
----- Method: TraitFileOutTest>>setUp (in category 'running') ----- setUp super setUp. SystemOrganization addCategory: self categoryName. td _ self createTraitNamed: #TD uses: {}. td compile: 'd' classified: #cat1. tc _ self createTraitNamed: #TC uses: td. tc compile: 'c' classified: #cat1. tb _ self createTraitNamed: #TB uses: td. tb compile: 'b' classified: #cat1. ta _ self createTraitNamed: #TA uses: tb + tc @ {#cc->#c} - {#c}. ta compile: 'a' classified: #cat1. ca _ self createClassNamed: #CA superclass: Object uses: {}. ca compile: 'ca' classified: #cat1. cb _ self createClassNamed: #CB superclass: ca uses: ta. cb compile: 'cb' classified: #cat1. "make the class of cb also use tc:" cb class uses: ta classTrait + tc instanceVariableNames: ''.!
----- Method: TraitFileOutTest>>tearDown (in category 'running') ----- tearDown | dir | dir := FileDirectory default. self createdClassesAndTraits, self resourceClassesAndTraits do: [:each | dir deleteFileNamed: each asString , '.st' ifAbsent: []]. dir deleteFileNamed: self categoryName , '.st' ifAbsent: []. SystemOrganization removeSystemCategory: self categoryName. super tearDown!
----- Method: TraitFileOutTest>>testFileOutCategory (in category 'testing') ----- testFileOutCategory "File out whole system category, delete all classes and traits and then file them in again."
"self run: #testFileOutCategory"
| file | SystemOrganization fileOutCategory: self categoryName. SystemOrganization removeSystemCategory: self categoryName. self deny: (Smalltalk keys includesAnyOf: #(CA CB TA TB TC TD)). [ file _ FileStream readOnlyFileNamed: self categoryName , '.st'. file fileIn] ensure: [file close].
self assert: (Smalltalk keys includesAllOf: #(CA CB TA TB TC TD)).
ta _ Smalltalk at: #TA. self assert: ta traitComposition asString = 'TB + TC @ {#cc->#c} - {#c}'. self assert: (ta methodDict keys includesAllOf: #(a b cc)).
cb _ Smalltalk at: #CB. self assert: cb traitComposition asString = 'TA'. self assert: (cb methodDict keys includesAllOf: #(cb a b cc)).
"test classSide traitComposition of CB"
self assert: cb classSide traitComposition asString = 'TA classTrait + TC'. self assert: (cb classSide methodDict keys includesAllOf: #(d c)) !
----- Method: TraitFileOutTest>>testFileOutTrait (in category 'testing') ----- testFileOutTrait "fileOut trait T6, remove it from system and then file it in again"
"self run: #testFileOutTrait"
| fileName file | self t6 compile: 'localMethod: argument ^argument'. self t6 classSide compile: 'localClassSideMethod: argument ^argument'. self t6 fileOut. fileName := self t6 asString , '.st'. self resourceClassesAndTraits remove: self t6. self t6 removeFromSystem. [file := FileStream readOnlyFileNamed: fileName. file fileIn] ensure: [file close]. self assert: (Smalltalk includesKey: #T6). TraitsResource current t6: (Smalltalk at: #T6). self resourceClassesAndTraits add: self t6. self assert: self t6 traitComposition asString = 'T1 + T2 @ {#m22Alias->#m22}'. self assert: (self t6 methodDict keys includesAllOf: #( #localMethod: #m11 #m12 #m13 #m21 #m22 #m22Alias )). self assert: self t6 classSide methodDict size = 2. self assert: (self t6 classSide methodDict keys includesAllOf: #(#localClassSideMethod: #m2ClassSide: ))!
----- Method: TraitFileOutTest>>testRemovingMethods (in category 'testing') ----- testRemovingMethods "When removing a local method, assure that the method from the trait is installed instead and that the users are updated."
"self run: #testRemovingMethods"
"Classes"
self c2 compile: 'm12 ^0' classified: #xxx. self assert: (self c2 includesLocalSelector: #m12). self c2 removeSelector: #m12. self deny: (self c2 includesLocalSelector: #m12). self assert: (self c2 selectors includes: #m12).
"Traits" self t5 compile: 'm12 ^0' classified: #xxx. self assert: self c2 new m12 = 0. self t5 removeSelector: #m12. self deny: (self t5 includesLocalSelector: #m12). self assert: (self t5 selectors includes: #m12). self assert: self c2 new m12 = 12!
TraitsTestCase subclass: #TraitMethodDescriptionTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Traits-Tests'!
----- Method: TraitMethodDescriptionTest>>testArgumentNames (in category 'running') ----- testArgumentNames self t1 compile: 'zork1: myArgument zork2: mySecondArgument ^true'. self t2 compile: 'zork1: myArgument zork2: somethingElse ^false'. self assert: ((self t5 sourceCodeAt: #zork1:zork2:) asString beginsWith: 'zork1: myArgument zork2: arg2'). self t1 compile: 'zork1: myArgument zork2: mySecondArgument ^true'. self t2 compile: 'zork1: somethingElse zork2: myArgument ^false'. self assert: ((self t5 sourceCodeAt: #zork1:zork2:) asString beginsWith: 'zork1: arg1 zork2: arg2')!
----- Method: TraitMethodDescriptionTest>>testCategories (in category 'running') ----- testCategories self assert: (self t4 organization categoryOfElement: #m21) = #cat1. self assert: (self t4 organization categoryOfElement: #m22) = #cat2. self assert: (self t4 organization categoryOfElement: #m11) = #catX. self assert: (self t4 organization categoryOfElement: #m12) = #cat2. self assert: (self t4 organization categoryOfElement: #m13) = #cat3. self assert: (self t6 organization categoryOfElement: #m22Alias) = #cat2. self t2 organization classify: #m22 under: #catX. self assert: (self t4 organization categoryOfElement: #m22) = #catX. self assert: (self t6 organization categoryOfElement: #m22Alias) = #catX. self t6 organization classify: #m22 under: #catY. self t6 organization classify: #m22Alias under: #catY. self t2 organization classify: #m22 under: #catZ. self assert: (self t6 organization categoryOfElement: #m22) = #catY. self assert: (self t6 organization categoryOfElement: #m22Alias) = #catY. self t1 compile: 'mA' classified: #catA. self assert: (self t4 organization categoryOfElement: #mA) = #catA. self t1 organization classify: #mA under: #cat1. self assert: (self t4 organization categories includes: #catA) not!
----- Method: TraitMethodDescriptionTest>>testConflictMethodCreation (in category 'running') ----- testConflictMethodCreation "Generate conflicting methods between t1 and t2 and check the resulting method in Trait t5 (or c2). Also test selectors like foo:x (without space) or selectors with CRs."
"unary"
self t2 compile: 'm12 ^false'. self assert: ((self t5 sourceCodeAt: #m12) asString beginsWith: 'm12'). self should: [self c2 new m12] raise: Error.
"binary" self t1 compile: '@ myArgument ^true'. self t2 compile: '@myArgument ^false'. self assert: ((self t5 sourceCodeAt: #@) asString beginsWith: '@ myArgument'). self should: [self c2 new @ 17] raise: Error.
"keyword" self t1 compile: 'zork: myArgument ^true'. self t2 compile: 'zork: myArgument ^false'. self assert: ((self t5 sourceCodeAt: #zork:) asString beginsWith: 'zork: myArgument'). self should: [self c2 new zork: 17] raise: Error. self t1 compile: 'zork:myArgument ^true'. self t2 compile: 'zork:myArgument ^false'. self assert: ((self t5 sourceCodeAt: #zork:) asString beginsWith: 'zork: myArgument'). self should: [self c2 new zork: 17] raise: Error. self t1 compile: 'zork1: myArgument zork2: mySecondArgument ^true'. self t2 compile: 'zork1: anObject zork2: anotherObject ^false'. self assert: ((self t5 sourceCodeAt: #zork1:zork2:) asString beginsWith: 'zork1: arg1 zork2: arg2'). self should: [self c2 new zork1: 1 zork2: 2] raise: Error!
----- Method: TraitMethodDescriptionTest>>testConflictingCategories (in category 'running') ----- testConflictingCategories | t7 t8 | self t2 compile: 'm11' classified: #catY. self assert: (self t4 organization categoryOfElement: #m11) = #catX. self assert: (self t5 organization categoryOfElement: #m11) = #cat1. t7 := self createTraitNamed: #T7 uses: self t1 + self t2. self assert: (t7 organization categoryOfElement: #m11) = ClassOrganizer ambiguous. self t1 removeSelector: #m11. self assert: (self t4 organization categoryOfElement: #m11) = #catX. self assert: (self t5 organization categoryOfElement: #m11) = #catY. self assert: (t7 organization categoryOfElement: #m11) = #catY. self assert: (t7 organization categories includes: ClassOrganizer ambiguous) not. self t1 compile: 'm11' classified: #cat1. t8 := self createTraitNamed: #T8 uses: self t1 + self t2. t8 organization classify: #m11 under: #cat1. self t1 organization classify: #m11 under: #catZ. self assert: (self t4 organization categoryOfElement: #m11) = #catX. self assert: (self t5 organization categoryOfElement: #m11) = #catY. self assert: (t8 organization categoryOfElement: #m11) = #catZ!
----- Method: TraitMethodDescriptionTest>>testInitialize (in category 'running') ----- testInitialize | empty | empty _ TraitMethodDescription new. self assert: empty isEmpty. self deny: empty isConflict. self deny: empty isProvided. self deny: empty isRequired!
TraitsTestCase subclass: #TraitTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Traits-Tests'!
----- Method: TraitTest>>testAddAndRemoveMethodsFromSubtraits (in category 'testing') ----- testAddAndRemoveMethodsFromSubtraits | aC2 | aC2 := self c2 new. self assert: aC2 m51. self t5 removeSelector: #m51. self should: [aC2 m51] raise: MessageNotUnderstood. self t1 compile: 'foo ^true'. self deny: aC2 foo. self t1 compile: 'm51 ^self'. self shouldnt: [aC2 m51] raise: MessageNotUnderstood. self assert: aC2 m51 == aC2!
----- Method: TraitTest>>testAddAndRemoveMethodsInClassOrTrait (in category 'testing') ----- testAddAndRemoveMethodsInClassOrTrait | aC2 | aC2 := self c2 new. self assert: aC2 m51. self c2 compile: 'm51 ^123'. self assert: aC2 m51 = 123. self c2 removeSelector: #m51. self shouldnt: [aC2 m51] raise: MessageNotUnderstood. self assert: aC2 m51. self t4 removeSelector: #m11. self assert: (self t4 methodDict includesKey: #m11)!
----- Method: TraitTest>>testAllClassVarNames (in category 'testing') ----- testAllClassVarNames self assert: self t1 allClassVarNames isEmpty!
----- Method: TraitTest>>testCompositionCopy (in category 'testing') ----- testCompositionCopy | t6compositionCopyFirst c2compositionCopy | self assert: (self t1 + self t2) allTraits = (self t1 + self t2) copyTraitExpression allTraits. self assert: (self t1 classTrait + self t2 classTrait) allTraits = (self t1 classTrait + self t2 classTrait) copyTraitExpression allTraits. self assert: self t6 traitComposition allTraits = self t6 traitComposition copyTraitExpression allTraits. self assert: self t6 asTraitComposition copyTraitExpression allTraits = { (self t1). (self t2). (self t6) }. "make no undue sharing happens of exclusions and aliases after an expression copy" t6compositionCopyFirst := self t6 traitComposition copyTraitExpression. t6compositionCopyFirst transformations at: 1 put: #m22Alias -> #m33. self assert: self t6 traitComposition transformations second aliases first value = #m22. c2compositionCopy := self c2 traitComposition copyTraitExpression. c2compositionCopy transformations first exclusions at: 1 put: #m4. self c2 traitComposition transformations first exclusions = #(#m11 )!
----- Method: TraitTest>>testExplicitRequirement (in category 'testing') ----- testExplicitRequirement "self run: #testExplicitRequirement"
self t1 compile: 'm self explicitRequirement'. self t2 compile: 'm ^true'. self assert: self t4 >> #m == (self t2 >> #m). self assert: self c2 new m. self t2 removeSelector: #m. self assert: self t5 >> #m == (self t1 >> #m). self should: [self c2 new m] raise: Error!
----- Method: TraitTest>>testLocalMethodWithSameCodeInTrait (in category 'testing') ----- testLocalMethodWithSameCodeInTrait "Note, takes all behaviors (classes and traits) into account"
SystemNavigation default allBehaviorsDo: [ :each | each hasTraitComposition ifTrue: [ each methodDict keys do: [ :selector | (each includesLocalSelector: selector) ifTrue: [ (each traitComposition traitProvidingSelector: selector) ifNotNilDo: [ :trait | self deny: (trait >> selector = (each >> selector)) ] ] ] ] ].!
----- Method: TraitTest>>testMarkerMethods (in category 'testing') ----- testMarkerMethods "self debug: #testMarkerMethods"
self t1 compile: 'm1 self foo bar'. self assert: (self t1 >> #m1) markerOrNil isNil.
self t1 compile: 'm2 self requirement'. self assert: (self t1 >> #m2) markerOrNil == #requirement. self t1 compile: 'm3 ^self requirement'. self assert: (self t1 >> #m3) markerOrNil == #requirement.!
----- Method: TraitTest>>testPrinting (in category 'testing') ----- testPrinting self assertPrints: self t6 definitionST80 like: 'Trait named: #T6 uses: T1 + T2 @ {#m22Alias->#m22} category: ''Traits-Tests'''!
----- Method: TraitTest>>testPrintingClassSide (in category 'testing') ----- testPrintingClassSide "self run: #testPrintingClassSide" self assertPrints: self t6 classSide definitionST80 like: 'T6 classTrait uses: T1 classTrait + T2 classTrait'!
----- Method: TraitTest>>testRemoveFromSystem (in category 'testing') ----- testRemoveFromSystem self t4 removeFromSystem. self deny: (Smalltalk includesKey: #T4). self assert: self t4 name = 'AnObsoleteT4'. self assert: self t4 methodDict isEmpty. self deny: (self t1 users includes: self t4)!
----- Method: TraitTest>>testRequirement (in category 'testing') ----- testRequirement "self run: #testRequirement"
self t1 compile: 'm self requirement'. self t2 compile: 'm ^true'. self assert: self t4 >> #m == (self t2 >> #m). self assert: self c2 new m. self t2 removeSelector: #m. self assert: self t5 >> #m == (self t1 >> #m). self should: [self c2 new m] raise: Error!
----- Method: TraitTest>>testUsers (in category 'testing') ----- testUsers self assert: self t1 users size = 3. self assert: (self t1 users includesAllOf: {self t4. self t5. self t6 }). self assert: self t3 users isEmpty. self assert: self t5 users size = 1. self assert: self t5 users anyOne = self c2. self c2 setTraitCompositionFrom: self t1 + self t5. self assert: self t5 users size = 1. self assert: self t5 users anyOne = self c2. self c2 setTraitComposition: self t2 asTraitComposition. self assert: self t5 users isEmpty!
----- Method: TraitsTestCase class>>resources (in category 'as yet unclassified') ----- resources ^{TraitsResource}!
----- Method: TraitsTestCase>>assertPrints:like: (in category 'utility') ----- assertPrints: aString like: anotherString self assert: (aString copyWithout: $ ) = (anotherString copyWithout: $ )!
----- Method: TraitsTestCase>>c1 (in category 'accessing') ----- c1 ^TraitsResource current c1!
----- Method: TraitsTestCase>>c2 (in category 'accessing') ----- c2 ^TraitsResource current c2!
----- Method: TraitsTestCase>>c3 (in category 'accessing') ----- c3 ^TraitsResource current c3!
----- Method: TraitsTestCase>>c4 (in category 'accessing') ----- c4 ^TraitsResource current c4!
----- Method: TraitsTestCase>>c5 (in category 'accessing') ----- c5 ^TraitsResource current c5!
----- Method: TraitsTestCase>>c6 (in category 'accessing') ----- c6 ^TraitsResource current c6!
----- Method: TraitsTestCase>>c7 (in category 'accessing') ----- c7 ^TraitsResource current c7!
----- Method: TraitsTestCase>>c8 (in category 'accessing') ----- c8 ^TraitsResource current c8!
----- Method: TraitsTestCase>>categoryName (in category 'running') ----- categoryName ^self class category!
----- Method: TraitsTestCase>>createClassNamed:superclass:uses: (in category 'utility') ----- createClassNamed: aSymbol superclass: aClass uses: aTraitComposition | class | class := aClass subclass: aSymbol uses: aTraitComposition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryName. self createdClassesAndTraits add: class. ^class!
----- Method: TraitsTestCase>>createTraitNamed:uses: (in category 'utility') ----- createTraitNamed: aSymbol uses: aTraitComposition | trait | trait := Trait named: aSymbol uses: aTraitComposition category: self categoryName. self createdClassesAndTraits add: trait. ^trait!
----- Method: TraitsTestCase>>createdClassesAndTraits (in category 'utility') ----- createdClassesAndTraits createdClassesAndTraits ifNil: [ createdClassesAndTraits := OrderedCollection new]. ^createdClassesAndTraits!
----- Method: TraitsTestCase>>resourceClassesAndTraits (in category 'utility') ----- resourceClassesAndTraits ^TraitsResource current createdClassesAndTraits!
----- Method: TraitsTestCase>>t1 (in category 'accessing') ----- t1 ^TraitsResource current t1!
----- Method: TraitsTestCase>>t2 (in category 'accessing') ----- t2 ^TraitsResource current t2!
----- Method: TraitsTestCase>>t3 (in category 'accessing') ----- t3 ^TraitsResource current t3!
----- Method: TraitsTestCase>>t4 (in category 'accessing') ----- t4 ^TraitsResource current t4!
----- Method: TraitsTestCase>>t5 (in category 'accessing') ----- t5 ^TraitsResource current t5!
----- Method: TraitsTestCase>>t6 (in category 'accessing') ----- t6 ^TraitsResource current t6!
----- Method: TraitsTestCase>>tearDown (in category 'running') ----- tearDown | behaviorName | TraitsResource resetIfDirty. self createdClassesAndTraits do: [:aClassOrTrait | behaviorName := aClassOrTrait name. Smalltalk at: behaviorName ifPresent: [:classOrTrait | classOrTrait removeFromSystem]. ChangeSet current removeClassChanges: behaviorName]. createdClassesAndTraits := nil!
----- Method: TraitsTestCase>>testChangeSuperclass (in category 'testing-applying trait composition') ----- testChangeSuperclass "self run: #testChangeSuperclass"
"Test that when the superclass of a class is changed the non-local methods of the class sending super are recompiled to correctly store the new superclass."
| aC2 newSuperclass | aC2 := self c2 new.
"C1 is current superclass of C2" self assert: aC2 m51. self assert: self c2 superclass == self c1. self deny: (self c2 localSelectors includes: #m51).
"change superclass of C2 from C1 to X" newSuperclass := self createClassNamed: #X superclass: Object uses: {}. newSuperclass subclass: self c2 name uses: self c2 traitComposition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self c2 category.
self assert: self c2 superclass == newSuperclass.
newSuperclass compile: 'foo ^17'. self assert: aC2 m51 = 17. self deny: (self c2 localSelectors includes: #m51).
self c2 compile: 'm51 ^19'. self assert: aC2 m51 = 19.
self assert: self c2 >> #m52 == (self t5 >> #m52).
!
----- Method: TPrintingDescription>>printOn: (in category 'printing') ----- printOn: aStream aStream nextPutAll: self name!
----- Method: TPrintingDescription>>printOnStream: (in category 'printing') ----- printOnStream: aStream aStream print: self name!
----- Method: TPrintingDescription>>storeOn: (in category 'printing') ----- storeOn: aStream "Classes and Metaclasses have global names."
aStream nextPutAll: self name!
----- Method: TComposingDescription>>+ (in category 'composition') ----- + aTraitOrTraitComposition "Use double dispatch to avoid having nested composition in cases where parenthesis are used, such as T1 + (T2 + T3)" ^aTraitOrTraitComposition addOnTheLeft: self!
----- Method: TComposingDescription>>- (in category 'composition') ----- - anArrayOfSelectors ^TraitExclusion with: self exclusions: anArrayOfSelectors!
----- Method: TComposingDescription>>@ (in category 'composition') ----- @ anArrayOfAssociations ^ TraitAlias with: self aliases: anArrayOfAssociations!
----- Method: TComposingDescription>>addCompositionOnLeft: (in category 'private') ----- addCompositionOnLeft: aTraitComposition ^ aTraitComposition add: self!
----- Method: TComposingDescription>>addOnTheLeft: (in category 'private') ----- addOnTheLeft: aTraitExpression ^TraitComposition with: aTraitExpression with: self!
----- Method: TComposingDescription>>asTraitComposition (in category 'converting') ----- asTraitComposition ^TraitComposition with: self!
----- Method: TraitDescription>>addExclusionOf: (in category 'composition') ----- addExclusionOf: aSymbol ^self - {aSymbol}!
----- Method: TraitDescription>>allMethodsInCategory: (in category 'accessing method dictionary') ----- allMethodsInCategory: aName "Answer a list of all the method categories of the receiver" | aColl | aColl _ aName = ClassOrganizer allCategory ifTrue: [self organization allMethodSelectors] ifFalse: [self organization listAtCategoryNamed: aName]. ^aColl asSet asSortedArray
"TileMorph allMethodsInCategory: #initialization"!
----- Method: TraitDescription>>baseTrait (in category 'accessing parallel hierarchy') ----- baseTrait self subclassResponsibility!
----- Method: TraitDescription>>category (in category 'organization') ----- category self subclassResponsibility!
----- Method: TraitDescription>>category: (in category 'organization') ----- category: aString self subclassResponsibility!
----- Method: TraitDescription>>classCommentBlank (in category 'accessing comment') ----- classCommentBlank
| existingComment stream | existingComment := self instanceSide organization classComment. existingComment isEmpty ifFalse: [^existingComment].
stream := WriteStream on: (String new: 100). stream nextPutAll: 'A'; nextPutAll: (self name first isVowel ifTrue: ['n '] ifFalse: [' ']); nextPutAll: self name; nextPutAll: ' is xxxxxxxxx.'. stream cr. ^stream contents!
----- Method: TraitDescription>>classSide (in category 'accessing parallel hierarchy') ----- classSide ^self classTrait!
----- Method: TraitDescription>>classTrait (in category 'accessing parallel hierarchy') ----- classTrait self subclassResponsibility!
----- Method: TraitDescription>>copyTraitExpression (in category 'copying') ----- copyTraitExpression "When recursively copying a trait expression, the primitive traits should NOT be copied because they are globally named 'well-known' objects" ^ self !
----- Method: TraitDescription>>definitionST80 (in category 'fileIn/Out') ----- definitionST80 ^String streamContents: [:stream | stream nextPutAll: self class name. stream nextPutAll: ' named: '; store: self name. stream cr; tab; nextPutAll: 'uses: '; nextPutAll: self traitCompositionString. stream cr; tab; nextPutAll: 'category: '; store: self category asString].!
----- Method: TraitDescription>>fileOut (in category 'fileIn/Out') ----- fileOut "Create a file whose name is the name of the receiver with '.st' as the extension, and file a description of the receiver onto it." ^ self fileOutAsHtml: false!
----- Method: TraitDescription>>forgetDoIts (in category 'initialize-release') ----- forgetDoIts "get rid of old DoIt methods and bogus entries in the ClassOrganizer." SystemChangeNotifier uniqueInstance doSilently: [ self organization removeElement: #DoIt; removeElement: #DoItIn:. ]. super forgetDoIts.!
----- Method: TraitDescription>>hasClassTrait (in category 'accessing parallel hierarchy') ----- hasClassTrait self subclassResponsibility!
----- Method: TraitDescription>>instanceSide (in category 'accessing parallel hierarchy') ----- instanceSide ^self baseTrait!
----- Method: TraitDescription>>isBaseTrait (in category 'accessing parallel hierarchy') ----- isBaseTrait self subclassResponsibility!
----- Method: TraitDescription>>isClassTrait (in category 'accessing parallel hierarchy') ----- isClassTrait self subclassResponsibility!
----- Method: TraitDescription>>isTestCase (in category 'testing') ----- isTestCase ^false!
----- Method: TraitDescription>>isUniClass (in category 'testing') ----- isUniClass ^false!
----- Method: TraitDescription>>linesOfCode (in category 'private') ----- linesOfCode "An approximate measure of lines of code. Includes comments, but excludes blank lines." | lines | lines _ self methodDict values inject: 0 into: [:sum :each | sum + each linesOfCode]. self isMeta ifTrue: [^ lines] ifFalse: [^ lines + self class linesOfCode]!
----- Method: TraitDescription>>logMethodSource:forMethodWithNode:inCategory:withStamp:notifying: (in category 'private') ----- logMethodSource: aText forMethodWithNode: aCompiledMethodWithNode inCategory: category withStamp: changeStamp notifying: requestor | priorMethodOrNil newText | priorMethodOrNil := self compiledMethodAt: aCompiledMethodWithNode selector ifAbsent: []. newText _ ((requestor == nil or: [requestor isKindOf: SyntaxError]) not and: [Preferences confirmFirstUseOfStyle]) ifTrue: [aText askIfAddStyle: priorMethodOrNil req: requestor] ifFalse: [aText]. aCompiledMethodWithNode method putSource: newText fromParseNode: aCompiledMethodWithNode node class: self category: category withStamp: changeStamp inFile: 2 priorMethod: priorMethodOrNil.!
----- Method: TraitDescription>>notifyOfRecategorizedSelector:from:to: (in category 'organization updating') ----- notifyOfRecategorizedSelector: element from: oldCategory to: newCategory SystemChangeNotifier uniqueInstance selector: element recategorizedFrom: oldCategory to: newCategory inClass: self. SystemChangeNotifier uniqueInstance doSilently: [self notifyUsersOfRecategorizedSelector: element from: oldCategory to: newCategory].!
----- Method: TraitDescription>>notifyUsersOfChangedSelectors: (in category 'users notification') ----- notifyUsersOfChangedSelectors: aCollection self users do: [:each | each noteChangedSelectors: aCollection]!
----- Method: TraitDescription>>notifyUsersOfRecategorizedSelector:from:to: (in category 'users notification') ----- notifyUsersOfRecategorizedSelector: element from: oldCategory to: newCategory self users do: [:each | each noteRecategorizedSelector: element from: oldCategory to: newCategory]!
----- Method: TraitDescription>>obsolete (in category 'initialize-release') ----- obsolete "Make the receiver obsolete." self organization: nil. super obsolete!
----- Method: TraitDescription>>organization (in category 'organization') ----- organization "Answer the instance of ClassOrganizer that represents the organization of the messages of the receiver."
organization ifNil: [self organization: (ClassOrganizer defaultList: self methodDict keys asSortedCollection asArray)]. (organization isMemberOf: Array) ifTrue: [self recoverFromMDFaultWithTrace]. "Making sure that subject is set correctly. It should not be necessary." organization ifNotNil: [organization setSubject: self]. ^ organization!
----- Method: TraitDescription>>organization: (in category 'organization') ----- organization: aClassOrg "Install an instance of ClassOrganizer that represents the organization of the messages of the receiver."
aClassOrg ifNotNil: [aClassOrg setSubject: self]. organization _ aClassOrg!
----- Method: TraitDescription>>spaceUsed (in category 'private') ----- spaceUsed ^super spaceUsed + (self hasClassTrait ifTrue: [self classTrait spaceUsed] ifFalse: [0])!
----- Method: TraitDescription>>theMetaClass (in category 'class compatibility') ----- theMetaClass ^ self classTrait!
----- Method: TraitDescription>>theNonMetaClass (in category 'class compatibility') ----- theNonMetaClass ^ self baseTrait!
----- Method: TraitDescription>>traitVersion (in category 'accessing') ----- traitVersion "Default. Any class may return a later version to inform readers that use ReferenceStream. 8/17/96 tk" "This method allows you to distinguish between class versions when the shape of the class hasn't changed (when there's no change in the instVar names). In the conversion methods you usually can tell by the inst var names what old version you have. In a few cases, though, the same inst var names were kept but their interpretation changed (like in the layoutFrame). By changing the class version when you keep the same instVars you can warn older and newer images that they have to convert." ^ 0!
----- Method: TraitDescription>>version (in category 'accessing') ----- version "Allows polymoprhism with ClassDescription>>version" ^ self traitVersion!
----- Method: TCopyingDescription>>copy:from: (in category 'copying') ----- copy: sel from: class "Install the method associated with the first argument, sel, a message selector, found in the method dictionary of the second argument, class, as one of the receiver's methods. Classify the message under -As yet not classified-."
self copy: sel from: class classified: nil!
----- Method: TCopyingDescription>>copy:from:classified: (in category 'copying') ----- copy: sel from: class classified: cat "Install the method associated with the first arugment, sel, a message selector, found in the method dictionary of the second argument, class, as one of the receiver's methods. Classify the message under the third argument, cat."
| code category | "Useful when modifying an existing class" code _ class sourceMethodAt: sel. code == nil ifFalse: [cat == nil ifTrue: [category _ class organization categoryOfElement: sel] ifFalse: [category _ cat]. (self methodDict includesKey: sel) ifTrue: [code asString = (self sourceMethodAt: sel) asString ifFalse: [self error: self name , ' ' , sel , ' will be redefined if you proceed.']]. self compile: code classified: category]!
----- Method: TCopyingDescription>>copyAll:from: (in category 'copying') ----- copyAll: selArray from: class "Install all the methods found in the method dictionary of the second argument, class, as the receiver's methods. Classify the messages under -As yet not classified-."
self copyAll: selArray from: class classified: nil!
----- Method: TCopyingDescription>>copyAll:from:classified: (in category 'copying') ----- copyAll: selArray from: class classified: cat "Install all the methods found in the method dictionary of the second argument, class, as the receiver's methods. Classify the messages under the third argument, cat."
selArray do: [:s | self copy: s from: class classified: cat]!
----- Method: TCopyingDescription>>copyAllCategoriesFrom: (in category 'copying') ----- copyAllCategoriesFrom: aClass "Specify that the categories of messages for the receiver include all of those found in the class, aClass. Install each of the messages found in these categories into the method dictionary of the receiver, classified under the appropriate categories."
aClass organization categories do: [:cat | self copyCategory: cat from: aClass]!
----- Method: TCopyingDescription>>copyCategory:from: (in category 'copying') ----- copyCategory: cat from: class "Specify that one of the categories of messages for the receiver is cat, as found in the class, class. Copy each message found in this category."
self copyCategory: cat from: class classified: cat!
----- Method: TCopyingDescription>>copyCategory:from:classified: (in category 'copying') ----- copyCategory: cat from: aClass classified: newCat "Specify that one of the categories of messages for the receiver is the third argument, newCat. Copy each message found in the category cat in class aClass into this new category."
self copyAll: (aClass organization listAtCategoryNamed: cat) from: aClass classified: newCat!
----- Method: TCopyingDescription>>copyMethodDictionaryFrom: (in category 'copying') ----- copyMethodDictionaryFrom: donorClass "Copy the method dictionary of the donor class over to the receiver"
self methodDict: donorClass copyOfMethodDictionary. self organization: donorClass organization deepCopy.!
----- Method: TApplyingOnClassSide>>assertConsistantCompositionsForNew: (in category 'composition') ----- assertConsistantCompositionsForNew: aTraitComposition "Applying or modifying a trait composition on the class side of a behavior has some restrictions."
| baseTraits notAddable message | baseTraits _ aTraitComposition traits select: [:each | each isBaseTrait]. baseTraits isEmpty ifFalse: [ notAddable _ (baseTraits reject: [:each | each classSide methodDict isEmpty]). notAddable isEmpty ifFalse: [ message _ String streamContents: [:stream | stream nextPutAll: 'You can not add the base trait(s)'; cr. notAddable do: [:each | stream nextPutAll: each name] separatedBy: [ stream nextPutAll: ', ']. stream cr; nextPutAll: 'to this composition because it/they define(s) methods on the class side.']. ^TraitCompositionException signal: message]]. (self instanceSide traitComposition traits asSet = (aTraitComposition traits select: [:each | each isClassTrait] thenCollect: [:each | each baseTrait]) asSet) ifFalse: [ ^TraitCompositionException signal: 'You can not add or remove class side traits on the class side of a composition. (But you can specify aliases or exclusions for existing traits or add a trait which does not have any methods on the class side.)']!
----- Method: TApplyingOnClassSide>>noteNewBaseTraitCompositionApplied: (in category 'composition') ----- noteNewBaseTraitCompositionApplied: aTraitComposition "The argument is the new trait composition of my base trait - add the new traits or remove non existing traits on my class side composition. (Each class trait in my composition has its base trait on the instance side of the composition - manually added traits to the class side are always base traits.)" | newComposition traitsFromInstanceSide | traitsFromInstanceSide := self traitComposition traits select: [:each | each isClassTrait] thenCollect: [:each | each baseTrait]. newComposition := self traitComposition copyTraitExpression. (traitsFromInstanceSide copyWithoutAll: aTraitComposition traits) do: [:each | newComposition removeFromComposition: each classTrait]. (aTraitComposition traits copyWithoutAll: traitsFromInstanceSide) do: [:each | newComposition add: (each classTrait)].
self setTraitComposition: newComposition!
----- Method: ClassTrait class>>for: (in category 'instance creation') ----- for: aTrait ^self new initializeWithBaseTrait: aTrait; yourself!
----- Method: ClassTrait>>baseClass:traitComposition:methodDict:localSelectors:organization: (in category 'initialize') ----- baseClass: aTrait traitComposition: aComposition methodDict: aMethodDict localSelectors: aSet organization: aClassOrganization
self baseTrait: aTrait. self traitComposition: aComposition methodDict: aMethodDict localSelectors: aSet organization: aClassOrganization !
----- Method: ClassTrait>>baseTrait (in category 'accessing parallel hierarchy') ----- baseTrait ^baseTrait!
----- Method: ClassTrait>>baseTrait: (in category 'accessing parallel hierarchy') ----- baseTrait: aTrait self assert: aTrait isBaseTrait. baseTrait _ aTrait !
----- Method: ClassTrait>>classTrait (in category 'accessing parallel hierarchy') ----- classTrait ^self!
----- Method: ClassTrait>>classTrait: (in category 'accessing parallel hierarchy') ----- classTrait: aClassTrait self error: 'Trait is already a class trait!!' !
----- Method: ClassTrait>>compile:classified:withStamp:notifying:logSource: (in category 'compiling') ----- compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource | classSideUsersOfBaseTrait message | classSideUsersOfBaseTrait _ self baseTrait users select: [:each | each isClassSide]. classSideUsersOfBaseTrait isEmpty ifFalse: [ message _ String streamContents: [:stream | stream nextPutAll: 'The instance side of this trait is used on '; cr. classSideUsersOfBaseTrait do: [:each | stream nextPutAll: each name] separatedBy: [ stream nextPutAll: ', ']. stream cr; nextPutAll: ' You can not add methods to the class side of this trait!!']. ^TraitException signal: message]. ^super compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource!
----- Method: ClassTrait>>copy (in category 'copying') ----- copy "Make a copy of the receiver. Share the reference to the base trait."
^(self class new) baseTrait: self baseTrait; initializeFrom: self; yourself!
----- Method: ClassTrait>>definitionST80 (in category 'fileIn/Out') ----- definitionST80 ^String streamContents: [:stream | stream nextPutAll: self name; crtab; nextPutAll: 'uses: '; nextPutAll: self traitCompositionString]!
----- Method: ClassTrait>>hasClassTrait (in category 'accessing parallel hierarchy') ----- hasClassTrait ^false!
----- Method: ClassTrait>>initializeFrom: (in category 'initialize') ----- initializeFrom: anotherClassTrait traitComposition _ self traitComposition copyTraitExpression. methodDict _ self methodDict copy. localSelectors _ self localSelectors copy. organization _ self organization copy.!
----- Method: ClassTrait>>initializeWithBaseTrait: (in category 'initialize') ----- initializeWithBaseTrait: aTrait self baseTrait: aTrait. self noteNewBaseTraitCompositionApplied: aTrait traitComposition. aTrait users do: [:each | self addUser: each classSide]. !
----- Method: ClassTrait>>isBaseTrait (in category 'accessing parallel hierarchy') ----- isBaseTrait ^false!
----- Method: ClassTrait>>isClassTrait (in category 'accessing parallel hierarchy') ----- isClassTrait ^true!
----- Method: ClassTrait>>name (in category 'accessing') ----- name ^self baseTrait name , ' classTrait'!
----- Method: ClassTrait>>traitComposition:methodDict:localSelectors:organization: (in category 'initialize') ----- traitComposition: aComposition methodDict: aMethodDict localSelectors: aSet organization: aClassOrganization
"Used by copy of Trait"
localSelectors _ aSet. methodDict _ aMethodDict. traitComposition _ aComposition. self organization: aClassOrganization!
----- Method: ClassTrait>>uses: (in category 'composition') ----- uses: aTraitCompositionOrArray | copyOfOldTrait newComposition | copyOfOldTrait _ self copy. newComposition _ aTraitCompositionOrArray asTraitComposition. self assertConsistantCompositionsForNew: newComposition. self setTraitComposition: newComposition. SystemChangeNotifier uniqueInstance traitDefinitionChangedFrom: copyOfOldTrait to: self.!
TraitTransformation subclass: #TraitAlias instanceVariableNames: 'aliases' classVariableNames: 'AliasMethodCache' poolDictionaries: '' category: 'Traits-Composition'!
!TraitAlias commentStamp: '<historical>' prior: 0! See comment of my superclass TraitTransformation.!
----- Method: TraitAlias class>>assertValidAliasDefinition: (in category 'instance creation') ----- assertValidAliasDefinition: anArrayOfAssociations "Throw an exceptions if the alias definition is not valid. It is expected to be a collection of associations and the number of arguments of the alias selector has to be the same as the original selector."
((anArrayOfAssociations isKindOf: Collection) and: [ anArrayOfAssociations allSatisfy: [:each | each isKindOf: Association]]) ifFalse: [ TraitCompositionException signal: 'Invalid alias definition: Not a collection of associations.']. (anArrayOfAssociations allSatisfy: [:association | (association key numArgs = association value numArgs and: [ (association key numArgs = -1) not])]) ifFalse: [ TraitCompositionException signal: 'Invalid alias definition: Alias and original selector have to have the same number of arguments.']!
----- Method: TraitAlias class>>with:aliases: (in category 'instance creation') ----- with: aTraitComposition aliases: anArrayOfAssociations self assertValidAliasDefinition: anArrayOfAssociations. ^self new subject: aTraitComposition; aliases: anArrayOfAssociations; yourself!
----- Method: TraitAlias>>- (in category 'composition') ----- - anArrayOfSelectors ^TraitExclusion with: self exclusions: anArrayOfSelectors!
----- Method: TraitAlias>>aliasNamed:ifAbsent: (in category 'enumeration') ----- aliasNamed: aSymbol ifAbsent: aBlock ^self aliases detect: [:association | association key = aSymbol] ifNone: aBlock!
----- Method: TraitAlias>>aliases (in category 'accessing') ----- aliases "Collection of associations where key is the alias and value the original selector." ^aliases!
----- Method: TraitAlias>>aliases: (in category 'accessing') ----- aliases: anArrayOfAssociations | newNames | newNames _ (anArrayOfAssociations collect: [:each | each key]) asIdentitySet. newNames size < anArrayOfAssociations size ifTrue: [ TraitCompositionException signal: 'Cannot use the same alias name twice']. anArrayOfAssociations do: [:each | (newNames includes: each value) ifTrue: [ TraitCompositionException signal: 'Cannot define an alias for an alias']]. aliases _ anArrayOfAssociations!
----- Method: TraitAlias>>aliasesForSelector: (in category 'enquiries') ----- aliasesForSelector: aSymbol | selectors | selectors _ self aliases select: [:association | association value = aSymbol] thenCollect: [:association | association key]. ^(super aliasesForSelector: aSymbol) addAll: selectors; yourself !
----- Method: TraitAlias>>allAliasesDict (in category 'enquiries') ----- allAliasesDict | dict | dict _ super allAliasesDict. self aliases do: [:assoc | dict at: assoc key put: assoc value]. ^dict!
----- Method: TraitAlias>>allSelectors (in category 'enquiries') ----- allSelectors ^self subject allSelectors addAll: (self aliases collect: [:each | each key]) asSet; yourself!
----- Method: TraitAlias>>collectMethodsFor:into: (in category 'enquiries') ----- collectMethodsFor: aSelector into: methodDescription | originalSelector association | self subject collectMethodsFor: aSelector into: methodDescription. association _ self aliasNamed: aSelector ifAbsent: [nil]. association notNil ifTrue: [ originalSelector _ association value. self subject collectMethodsFor: originalSelector into: methodDescription]!
----- Method: TraitAlias>>copy (in category 'copying') ----- copy ^super copy aliases: self aliases copy; yourself!
----- Method: TraitAlias>>copyTraitExpression (in category 'copying') ----- copyTraitExpression ^super copyTraitExpression aliases: self aliases deepCopy; yourself!
----- Method: TraitAlias>>isEmpty (in category 'testing') ----- isEmpty ^self aliases isEmpty!
----- Method: TraitAlias>>printOn: (in category 'printing') ----- printOn: aStream super printOn: aStream. aStream space; nextPut: $@; space; nextPut: ${. self aliases do: [:each | aStream print: each] separatedBy: [aStream nextPutAll: '. ']. aStream nextPut: $}!
----- Method: TraitAlias>>removeAlias: (in category 'composition') ----- removeAlias: aSymbol self aliases: (self aliases reject: [:each | each key = aSymbol])!
TraitTransformation subclass: #TraitExclusion instanceVariableNames: 'exclusions' classVariableNames: '' poolDictionaries: '' category: 'Traits-Composition'!
!TraitExclusion commentStamp: '<historical>' prior: 0! See comment of my superclass TraitTransformation.!
----- Method: TraitExclusion class>>with:exclusions: (in category 'instance creation') ----- with: aTraitComposition exclusions: anArrayOfSelectors ^self new subject: aTraitComposition; exclusions: anArrayOfSelectors; yourself !
----- Method: TraitExclusion>>addExclusionOf: (in category 'composition') ----- addExclusionOf: aSymbol self exclusions: (self exclusions copyWith: aSymbol)!
----- Method: TraitExclusion>>allSelectors (in category 'enquiries') ----- allSelectors | selectors | selectors _ self subject allSelectors. self exclusions do: [:each | selectors remove: each ifAbsent: []]. ^selectors!
----- Method: TraitExclusion>>collectMethodsFor:into: (in category 'enquiries') ----- collectMethodsFor: aSelector into: methodDescription (self exclusions includes: aSelector) ifFalse: [ self subject collectMethodsFor: aSelector into: methodDescription]!
----- Method: TraitExclusion>>copy (in category 'copying') ----- copy ^super copy exclusions: self exclusions copy; yourself!
----- Method: TraitExclusion>>copyTraitExpression (in category 'copying') ----- copyTraitExpression ^super copyTraitExpression exclusions: self exclusions deepCopy; yourself!
----- Method: TraitExclusion>>exclusions (in category 'accessing') ----- exclusions ^exclusions!
----- Method: TraitExclusion>>exclusions: (in category 'accessing') ----- exclusions: aCollection exclusions _ aCollection!
----- Method: TraitExclusion>>isEmpty (in category 'testing') ----- isEmpty ^self exclusions isEmpty!
----- Method: TraitExclusion>>methodReferencesInCategory: (in category 'accessing') ----- methodReferencesInCategory: aCategoryName ^(self organization listAtCategoryNamed: aCategoryName) collect: [:ea | MethodReference new setClassSymbol: self theNonMetaClass name classIsMeta: self isMeta methodSymbol: ea stringVersion: ''] !
----- Method: TraitExclusion>>printOn: (in category 'printing') ----- printOn: aStream super printOn: aStream. aStream space; nextPut: $-; space; nextPut: ${. self exclusions do: [:each | aStream print: each] separatedBy: [aStream nextPutAll: '. ']. aStream nextPut: $}!
----- Method: TraitTransformation>>- (in category 'composition') ----- - anArray TraitCompositionException signal: 'Invalid trait exclusion. Exclusions have to be specified after aliases.'!
----- Method: TraitTransformation>>@ (in category 'composition') ----- @ anArrayOfAssociations TraitCompositionException signal: 'Invalid trait exclusion. Aliases have to be specified before exclusions.'!
----- Method: TraitTransformation>>addExclusionOf: (in category 'composition') ----- addExclusionOf: aSymbol ^self - {aSymbol}!
----- Method: TraitTransformation>>aliasesForSelector: (in category 'enquiries') ----- aliasesForSelector: aSymbol "Return a collection of alias selectors that are defined in this transformation." ^self subject aliasesForSelector: aSymbol!
----- Method: TraitTransformation>>allAliasesDict (in category 'enquiries') ----- allAliasesDict "Return a dictionary with all alias associations that are defined in this transformation." ^self subject allAliasesDict!
----- Method: TraitTransformation>>allSelectors (in category 'enquiries') ----- allSelectors ^self subclassResponsibility!
----- Method: TraitTransformation>>changedSelectorsComparedTo: (in category 'enquiries') ----- changedSelectorsComparedTo: aTraitTransformation | selectors otherSelectors changedSelectors aliases otherAliases | selectors _ self allSelectors asIdentitySet. otherSelectors _ aTraitTransformation allSelectors asIdentitySet. changedSelectors _ IdentitySet withAll: ( (selectors difference: otherSelectors) union: (otherSelectors difference: selectors)). aliases _ self allAliasesDict. otherAliases _ aTraitTransformation allAliasesDict. aliases keysAndValuesDo: [:key :value | (value ~~ (otherAliases at: key ifAbsent: [nil])) ifTrue: [changedSelectors add: key]]. otherAliases keysAndValuesDo: [:key :value | (value ~~ (aliases at: key ifAbsent: [nil])) ifTrue: [changedSelectors add: key]]. ^ changedSelectors.!
----- Method: TraitTransformation>>collectMethodsFor:into: (in category 'enquiries') ----- collectMethodsFor: aSelector into: methodDescription "Collect instances of LocatedMethod into methodDescription for each method that has the selector aSelector and is not excluded or for which aSelector is an alias."
self subclassResponsibility!
----- Method: TraitTransformation>>copy (in category 'copying') ----- copy self error: 'should not be called'. ^super copy subject: self subject copy; yourself!
----- Method: TraitTransformation>>copyTraitExpression (in category 'copying') ----- copyTraitExpression ^self shallowCopy subject: self subject copyTraitExpression; yourself!
----- Method: TraitTransformation>>isEmpty (in category 'testing') ----- isEmpty self subclassResponsibility!
----- Method: TraitTransformation>>isMeta (in category 'accessing parallel hierarchy') ----- isMeta ^self subject isMeta!
----- Method: TraitTransformation>>normalized (in category 'accessing') ----- normalized ^self isEmpty ifFalse: [ self subject: self subject normalized. self] ifTrue: [self subject normalized] !
----- Method: TraitTransformation>>printOn: (in category 'printing') ----- printOn: aStream aStream print: self subject!
----- Method: TraitTransformation>>removeAlias: (in category 'composition') ----- removeAlias: aSymbol self subject removeAlias: aSymbol!
----- Method: TraitTransformation>>selectors (in category 'enquiries') ----- selectors ^self allSelectors!
----- Method: TraitTransformation>>sourceCodeTemplate (in category 'browser support') ----- sourceCodeTemplate ^ self subject sourceCodeTemplate!
----- Method: TraitTransformation>>subject (in category 'accessing') ----- subject ^subject!
----- Method: TraitTransformation>>subject: (in category 'accessing') ----- subject: aTraitTransformation subject _ aTraitTransformation!
----- Method: TraitTransformation>>theNonMetaClass (in category 'accessing parallel hierarchy') ----- theNonMetaClass ^ self subject theNonMetaClass !
----- Method: TraitTransformation>>trait (in category 'enquiries') ----- trait ^self subject trait!
----- Method: TraitTransformation>>traitTransformations (in category 'enquiries') ----- traitTransformations ^ { subject }!
----- Method: TUpdateTraitsBehavior>>addTraitSelector:withMethod: (in category 'traits') ----- addTraitSelector: aSymbol withMethod: aCompiledMethod "Add aMethod with selector aSymbol to my methodDict. aMethod must not be defined locally. Note that I am overridden by ClassDescription to do a recompilation of the method if it has supersends."
self assert: [(self includesLocalSelector: aSymbol) not]. self ensureLocalSelectors. self basicAddSelector: aSymbol withMethod: aCompiledMethod.!
----- Method: TUpdateTraitsBehavior>>applyChangesOfNewTraitCompositionReplacing: (in category 'traits') ----- applyChangesOfNewTraitCompositionReplacing: oldComposition | changedSelectors | changedSelectors _ self traitComposition changedSelectorsComparedTo: oldComposition. changedSelectors isEmpty ifFalse: [ self noteChangedSelectors: changedSelectors]. self traitComposition isEmpty ifTrue: [ self purgeLocalSelectors]. ^changedSelectors!
----- Method: TUpdateTraitsBehavior>>noteChangedSelectors: (in category 'traits') ----- noteChangedSelectors: aCollection "Start update of my methodDict (after changes to traits in traitComposition or after a local method was removed from my methodDict). The argument is a collection of method selectors that may have been changed. Most of the time aCollection only holds one selector. But when there are aliases involved there may be several method changes that have to be propagated to users."
| affectedSelectors | affectedSelectors _ IdentitySet new. aCollection do: [:selector | affectedSelectors addAll: (self updateMethodDictionarySelector: selector)]. self notifyUsersOfChangedSelectors: affectedSelectors. ^ affectedSelectors!
----- Method: TUpdateTraitsBehavior>>notifyUsersOfChangedSelector: (in category 'traits') ----- notifyUsersOfChangedSelector: aSelector self notifyUsersOfChangedSelectors: (Array with: aSelector)!
----- Method: TUpdateTraitsBehavior>>notifyUsersOfChangedSelectors: (in category 'traits') ----- notifyUsersOfChangedSelectors: aCollection!
----- Method: TUpdateTraitsBehavior>>removeTraitSelector: (in category 'traits') ----- removeTraitSelector: aSymbol self assert: [(self includesLocalSelector: aSymbol) not]. self basicRemoveSelector: aSymbol!
----- Method: TUpdateTraitsBehavior>>setTraitComposition: (in category 'traits') ----- setTraitComposition: aTraitComposition | oldComposition | (self hasTraitComposition not and: [aTraitComposition isEmpty]) ifTrue: [^self]. aTraitComposition assertValidUser: self.
oldComposition _ self traitComposition. self traitComposition: aTraitComposition. self applyChangesOfNewTraitCompositionReplacing: oldComposition. oldComposition traits do: [:each | each removeUser: self]. aTraitComposition traits do: [:each | each addUser: self]!
----- Method: TUpdateTraitsBehavior>>setTraitCompositionFrom: (in category 'traits') ----- setTraitCompositionFrom: aTraitExpression ^ self setTraitComposition: aTraitExpression asTraitComposition!
----- 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."
| effectiveMethod modifiedSelectors descriptions selector | modifiedSelectors _ IdentitySet new. descriptions _ self hasTraitComposition ifTrue: [ self traitComposition methodDescriptionsForSelector: aSymbol ] ifFalse: [ #() ]. 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!
----- Method: TTraitsCategorisingDescription>>applyChangesOfNewTraitCompositionReplacing: (in category 'organization updating') ----- applyChangesOfNewTraitCompositionReplacing: oldComposition | changedSelectors | changedSelectors _ super applyChangesOfNewTraitCompositionReplacing: oldComposition. self noteRecategorizedSelectors: changedSelectors oldComposition: oldComposition. ^ changedSelectors.!
----- Method: TTraitsCategorisingDescription>>noteRecategorizedSelector:from:to: (in category 'organization updating') ----- noteRecategorizedSelector: aSymbol from: oldCategoryOrNil to: newCategoryOrNil | changedCategories | changedCategories _ self updateOrganizationSelector: aSymbol oldCategory: oldCategoryOrNil newCategory: newCategoryOrNil. changedCategories do: [:each | (self organization isEmptyCategoryNamed: each) ifTrue: [self organization removeCategory: each]]!
----- Method: TTraitsCategorisingDescription>>noteRecategorizedSelectors:oldComposition: (in category 'organization updating') ----- noteRecategorizedSelectors: aCollection oldComposition: aTraitComposition | oldCategory newCategory | aCollection do: [:each | oldCategory _ self organization categoryOfElement: each. newCategory _ (self traitComposition methodDescriptionForSelector: each) effectiveMethodCategory. self noteRecategorizedSelector: each from: oldCategory to: newCategory]!
----- Method: TTraitsCategorisingDescription>>notifyOfRecategorizedSelector:from:to: (in category 'organization updating') ----- notifyOfRecategorizedSelector: element from: oldCategory to: newCategory SystemChangeNotifier uniqueInstance selector: element recategorizedFrom: oldCategory to: newCategory inClass: self!
----- Method: TTraitsCategorisingDescription>>updateOrganizationSelector:oldCategory:newCategory: (in category 'organization updating') ----- updateOrganizationSelector: aSymbol oldCategory: oldCategoryOrNil newCategory: newCategoryOrNil | currentCategory effectiveCategory sel changedCategories composition | changedCategories _ IdentitySet new. composition := self hasTraitComposition ifTrue: [self traitComposition] ifFalse: [TraitComposition new]. (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!
----- Method: TraitBehavior>>addSelectorSilently:withMethod: (in category 'accessing method dictionary') ----- addSelectorSilently: selector withMethod: compiledMethod self pureAddSelectorSilently: selector withMethod: compiledMethod. self notifyUsersOfChangedSelector: selector.!
----- Method: TraitBehavior>>addUser: (in category 'traits') ----- addUser: aClassOrTrait users add: aClassOrTrait!
----- Method: TraitBehavior>>allClassVarNames (in category 'class compatibility') ----- allClassVarNames ^#()!
----- Method: TraitBehavior>>allInstVarNames (in category 'class compatibility') ----- allInstVarNames ^ #()!
----- Method: TraitBehavior>>allSelectors (in category 'accessing method dictionary') ----- allSelectors ^ self selectors!
----- Method: TraitBehavior>>allSubclasses (in category 'class compatibility') ----- allSubclasses ^ Array new!
----- Method: TraitBehavior>>allSubclassesDo: (in category 'class compatibility') ----- allSubclassesDo: aBlock!
----- Method: TraitBehavior>>allSuperclasses (in category 'class compatibility') ----- allSuperclasses ^ OrderedCollection new!
----- Method: TraitBehavior>>allSuperclassesDo: (in category 'class compatibility') ----- allSuperclassesDo: aBlock!
----- Method: TraitBehavior>>basicLocalSelectors (in category 'accessing method dictionary') ----- basicLocalSelectors "Direct accessor for the instance variable localSelectors. Since localSelectors is lazily initialized, this may return nil, which means that all selectors are local."
^ localSelectors!
----- Method: TraitBehavior>>basicLocalSelectors: (in category 'accessing method dictionary') ----- basicLocalSelectors: aSetOrNil localSelectors _ aSetOrNil!
----- Method: TraitBehavior>>classPool (in category 'remove me later') ----- classPool ^ Dictionary new!
----- Method: TraitBehavior>>classVarNames (in category 'class compatibility') ----- classVarNames ^#()!
----- Method: TraitBehavior>>classesComposedWithMe (in category 'traits') ----- classesComposedWithMe ^users gather: [:u | u classesComposedWithMe] !
----- Method: TraitBehavior>>forgetDoIts (in category 'initialize-release') ----- forgetDoIts "get rid of old DoIt methods" self basicRemoveSelector: #DoIt; basicRemoveSelector: #DoItIn:!
----- Method: TraitBehavior>>hasTraitComposition (in category 'traits') ----- hasTraitComposition ^traitComposition notNil!
----- Method: TraitBehavior>>inheritsFrom: (in category 'class compatibility') ----- inheritsFrom: aClass "Used by RB" ^false!
----- Method: TraitBehavior>>initialize (in category 'initialize-release') ----- initialize self methodDict: MethodDictionary new. self traitComposition: nil. users _ IdentitySet new.!
----- Method: TraitBehavior>>instSize (in category 'class compatibility') ----- instSize ^0!
----- Method: TraitBehavior>>instVarNames (in category 'class compatibility') ----- instVarNames ^#()!
----- Method: TraitBehavior>>isTrait (in category 'testing') ----- isTrait ^true!
----- Method: TraitBehavior>>lookupSelector: (in category 'accessing method dictionary') ----- lookupSelector: selector ^(self includesSelector: selector) ifTrue: [self compiledMethodAt: selector] ifFalse: [nil]!
----- Method: TraitBehavior>>methodDict (in category 'accessing method dictionary') ----- methodDict ^ methodDict!
----- Method: TraitBehavior>>methodDict: (in category 'accessing method dictionary') ----- methodDict: aDictionary methodDict _ aDictionary!
----- Method: TraitBehavior>>precodeCommentOrInheritedCommentFor: (in category 'accessing method dictionary') ----- precodeCommentOrInheritedCommentFor: aSelector ^self firstPrecodeCommentFor: aSelector !
----- Method: TraitBehavior>>removeFromTraitCompositionOfUsers (in category 'traits') ----- removeFromTraitCompositionOfUsers self users do: [:each | each removeFromComposition: self ]!
----- Method: TraitBehavior>>removeSelector: (in category 'accessing method dictionary') ----- removeSelector: selector self pureRemoveSelector: selector. self notifyUsersOfChangedSelector: selector.!
----- Method: TraitBehavior>>removeUser: (in category 'traits') ----- removeUser: aClassOrTrait users remove: aClassOrTrait ifAbsent: []!
----- Method: TraitBehavior>>requiredSelectors (in category 'send caches') ----- requiredSelectors | sss selfSentNotProvided otherRequired | sss := self selfSentSelectorsFromSelectors: self allSelectors. selfSentNotProvided _ sss copyWithoutAll: (self allSelectors select: [:e | (self >> e) isProvided]). otherRequired _ self allSelectors select: [:e | (self >> e) isRequired]. ^(selfSentNotProvided, otherRequired) asSet !
----- Method: TraitBehavior>>sendCaches (in category 'send caches') ----- sendCaches ^LocalSends current for: self!
----- Method: TraitBehavior>>sharedPools (in category 'remove me later') ----- sharedPools ^ Dictionary new!
----- Method: TraitBehavior>>subclassDefinerClass (in category 'class compatibility') ----- subclassDefinerClass ^nil subclassDefinerClass !
----- Method: TraitBehavior>>subclasses (in category 'class compatibility') ----- subclasses ^ Array new!
----- Method: TraitBehavior>>traitComposition (in category 'traits') ----- traitComposition traitComposition ifNil: [traitComposition _ TraitComposition new]. ^traitComposition!
----- Method: TraitBehavior>>traitComposition: (in category 'traits') ----- traitComposition: aTraitComposition traitComposition _ aTraitComposition!
----- Method: TraitBehavior>>updateRequires (in category 'send caches') ----- updateRequires | sss aTrait | sss := self selfSentSelectorsInTrait: aTrait. ^sss copyWithoutAll: aTrait allSelectors.!
----- Method: TraitBehavior>>users (in category 'traits') ----- users ^users!
----- Method: TraitBehavior>>whichClassIncludesSelector: (in category 'class compatibility') ----- whichClassIncludesSelector: aSymbol "Traits compatibile implementation for: Answer the class on the receiver's superclass chain where the argument, aSymbol (a message selector), will be found. Answer nil if none found." ^(self includesSelector: aSymbol) ifTrue: [self] ifFalse: [nil]!
----- Method: TraitBehavior>>zapAllMethods (in category 'accessing method dictionary') ----- zapAllMethods "Remove all methods in this trait which is assumed to be obsolete"
methodDict _ MethodDictionary new. self hasClassTrait ifTrue: [self classTrait zapAllMethods]!
----- Method: TTestingDescription>>isClassSide (in category 'accessing parallel hierarchy') ----- isClassSide ^self == self classSide!
----- Method: TTestingDescription>>isInstanceSide (in category 'accessing parallel hierarchy') ----- isInstanceSide ^self isClassSide not!
----- Method: TTestingDescription>>isMeta (in category 'accessing parallel hierarchy') ----- isMeta ^self isClassSide!
----- Method: TBehaviorCategorization>>category (in category 'organization') ----- category "Answer the system organization category for the receiver. First check whether the category name stored in the ivar is still correct and only if this fails look it up (latter is much more expensive)"
| result | self basicCategory ifNotNilDo: [ :symbol | ((SystemOrganization listAtCategoryNamed: symbol) includes: self name) ifTrue: [ ^symbol ] ]. self basicCategory: (result := SystemOrganization categoryOfElement: self name). ^result!
----- Method: TBehaviorCategorization>>category: (in category 'organization') ----- category: aString "Categorize the receiver under the system category, aString, removing it from any previous categorization."
| oldCategory | oldCategory := self basicCategory. aString isString ifTrue: [ self basicCategory: aString asSymbol. SystemOrganization classify: self name under: self basicCategory ] ifFalse: [self errorCategoryName]. SystemChangeNotifier uniqueInstance class: self recategorizedFrom: oldCategory to: self basicCategory!
InstructionStream subclass: #SendInfo instanceVariableNames: 'stack savedStacks selfSentSelectors superSentSelectors classSentSelectors isStartOfBlock numBlockArgs nr1 nr2 nr3 nr4 nr5' classVariableNames: '' poolDictionaries: '' category: 'Traits-LocalSends'!
!SendInfo commentStamp: '<historical>' prior: 0! SendInfo objects perform an abstract interpretation of a compiled method to ascertain the messages that are self-sent, super-sent and class-sent.
The idea is to simulate the execution of the instruction stream in the compiled method, keeping track of whether the values on the stack are self or some other value. IN one place we have to keep track of the small integers that are on the stack, becuase they determine how many elements are to be popped off of the stack.
Everything is fairly straighforward except for jumps.
Conditional forward jumps, as generated by ifTrue: and ifFalse:, are fairly easy. At the site of the conditional jump, we copy the stack, and use one copy on each path. When the paths eventually merge, the stacks should be the same size (if they aren't it's a compiler error!!). We build a new stack that has #self on it every place where either of the old stacks had #self. Thus, expressions like
(aBoolean ifTrue: self ifFalse: other) foo: 3
that might send foo: 3 to self are recognized.
For unconditional jumps, we save the stack for use at the join point, and continue execution at the instruciton after the jump with an empty stack, which will be immediately overwritten by the stack that comes with the arriving execution.
The bottlenecks in this algorithm turned out to be detecting join points and simulating the stack. Using an OrderedCollection for a stack caused a lot of redundant work, especially when emptying the stack. Using a dictionary to detect join points turned out to be very slow, because of the possibility of having to scan through the hash table.
QuickIntegerDictionary and QuickStack provide the same core functionality, but in much more efficient forms.
Use SendInfo as follows:
(SendInfo on: aCompiledMethod) collectSends
aSendInfo is both an InstructionStream and an InstructionStream client.
Structure: stack -- the simulated execution stack savedStacks -- The dictionary on which the extra stacks waiting to be merged in are saved.
sentSelectors -- an Identity Set accumulating the set of sent selectors. superSentSelectors -- an Identity Set accumulating the set of super sent selectors.
classSentSelectors -- an Identity Set accumulating the set of selectors sent to self class. isStartOfBlock -- a flag indicating that we have found the start of a block, and that the next jump will skip over it. numBlockArgs -- nr1' 'nr2' 'nr3' 'nr4') !
----- Method: SendInfo class>>neverRequiredSelectors (in category 'accessing') ----- neverRequiredSelectors | nrs | nrs _ Array new: 5. nrs at: 1 put: CompiledMethod conflictMarker. nrs at: 2 put: CompiledMethod disabledMarker. nrs at: 3 put: CompiledMethod explicitRequirementMarker. nrs at: 4 put: CompiledMethod implicitRequirementMarker. nrs at: 5 put: CompiledMethod subclassResponsibilityMarker. ^ nrs. !
----- Method: SendInfo>>addClassSentSelector: (in category 'private') ----- addClassSentSelector: aSymbol classSentSelectors ifNil: [classSentSelectors _ IdentitySet new]. classSentSelectors add: aSymbol.!
----- Method: SendInfo>>addSelfSentSelector: (in category 'private') ----- addSelfSentSelector: aSymbol selfSentSelectors ifNil: [selfSentSelectors _ IdentitySet new]. selfSentSelectors add: aSymbol.!
----- Method: SendInfo>>addSuperSentSelector: (in category 'private') ----- addSuperSentSelector: aSymbol superSentSelectors ifNil: [superSentSelectors _ IdentitySet new]. superSentSelectors add: aSymbol.!
----- Method: SendInfo>>assert:because: (in category 'private') ----- assert: aBlock because: aMessage "Throw an assertion error if aBlock does not evaluates to true."
aBlock value ifFalse: [AssertionFailure signal: aMessage]!
----- Method: SendInfo>>atMergePoint (in category 'stack manipulation') ----- atMergePoint ^ savedStacks includesKey: pc!
----- Method: SendInfo>>blockReturn (in category 'stack manipulation') ----- blockReturn "we could empty the stack, but what's the point?"!
----- Method: SendInfo>>blockReturnTop (in category 'instruction decoding') ----- blockReturnTop "Return from a block with Top Of Stack as result. The following instruction will be branched to from somewhere, and will therefore trigger a stackMerge, so it is important that the stack be emptied."
self pop. self emptyStack.!
----- Method: SendInfo>>classSentSelectors (in category 'accessing') ----- classSentSelectors ^ classSentSelectors ifNil: [#()] ifNotNil: [classSentSelectors].!
----- Method: SendInfo>>collectSends (in category 'initialization') ----- collectSends | end | end _ self method endPC. [pc <= end] whileTrue: [self interpretNextInstructionFor: self]!
----- Method: SendInfo>>doDup (in category 'instruction decoding') ----- doDup "Simulate the action of a 'duplicate top of stack' bytecode."
self push: self top!
----- Method: SendInfo>>doPop (in category 'instruction decoding') ----- doPop
stack isEmpty ifFalse: [self pop]!
----- Method: SendInfo>>emptyStack (in category 'stack manipulation') ----- emptyStack stack becomeEmpty!
----- Method: SendInfo>>home (in category 'accessing') ----- home "Answer the context in which the receiver was defined."
^ sender!
----- Method: SendInfo>>interpretNextInstructionFor: (in category 'instruction decoding') ----- interpretNextInstructionFor: client self atMergePoint ifTrue: [self mergeStacks]. super interpretNextInstructionFor: client!
----- Method: SendInfo>>jump: (in category 'instruction decoding') ----- jump: distance "Simulate the action of a 'unconditional jump' bytecode whose offset is the argument, distance." distance < 0 ifTrue: [^ self]. distance = 0 ifTrue: [self error: 'bad compiler!!']. savedStacks at: (self pc + distance) put: stack. "We empty the stack to signify that execution cannot 'fall through' to the next statement. Note that since we just stored the current stack, not a copy, in the savedStacks dictionary, here we need to allocate a new stack." self newEmptyStack. isStartOfBlock ifTrue: [isStartOfBlock _ false. numBlockArgs timesRepeat: [self push: #stuff]]!
----- Method: SendInfo>>jump:if: (in category 'instruction decoding') ----- jump: distance if: aBooleanConstant "Simulate the action of a 'conditional jump' bytecode whose offset is distance, and whose condition is aBooleanConstant."
| destination | distance < 0 ifTrue:[^ self]. distance = 0 ifTrue:[self error: 'bad compiler!!']. destination _ self pc + distance. "remove the condition from the stack." self pop. savedStacks at: destination put: stack copy. !
----- Method: SendInfo>>mergeStacks (in category 'stack manipulation') ----- mergeStacks | otherStack | otherStack _ savedStacks at: pc. savedStacks removeKey: pc. stack isEmpty ifTrue: [ "This happens at the end of a block, or a short circuit conditional. In these cases, it is not possible for execution to 'fall through' to the merge point. In other words, this is not a real merge point at all, and we just continue execution with the saved stack." ^ stack _ otherStack ]. "self assert: [stack size = otherStack size]. This assertion was true for every method in every subclass of Object, so I think that we can safely omit it!!" 1 to: stack size do: [:i | ((stack at: i) ~~ #self and: [(otherStack at: i) == #self]) ifTrue: [stack at: i put: #self]]!
----- Method: SendInfo>>method (in category 'accessing') ----- method "Answer the method of this context."
^ sender!
----- Method: SendInfo>>method:pc: (in category 'initialization') ----- method: method pc: initialPC super method: method pc: initialPC. self prepareState.!
----- Method: SendInfo>>methodReturnConstant: (in category 'instruction decoding') ----- methodReturnConstant: aConstant "Simulate the action of a 'return receiver' bytecode. This corresponds to the source expression '^aConstant'."
self push: aConstant. self emptyStack!
----- Method: SendInfo>>methodReturnReceiver (in category 'instruction decoding') ----- methodReturnReceiver "Simulate the action of a 'return receiver' bytecode. This corresponds to the source expression '^self'."
self push: #self. self emptyStack !
----- Method: SendInfo>>methodReturnTop (in category 'instruction decoding') ----- methodReturnTop "Simulate the action of a 'return receiver' bytecode. This corresponds to the source expression '^ <result of the last evaluation>'."
self emptyStack !
----- Method: SendInfo>>newEmptyStack (in category 'stack manipulation') ----- newEmptyStack stack _ QuickStack new!
----- Method: SendInfo>>pop (in category 'stack manipulation') ----- pop ^ stack removeLast!
----- Method: SendInfo>>pop: (in category 'stack manipulation') ----- pop: n stack removeLast: n!
----- Method: SendInfo>>popIntoLiteralVariable: (in category 'instruction decoding') ----- popIntoLiteralVariable: value "Simulate the action of bytecode that removes the top of the stack and stores it into a literal variable of my method."
self pop!
----- Method: SendInfo>>popIntoReceiverVariable: (in category 'instruction decoding') ----- popIntoReceiverVariable: offset "Simulate the action of bytecode that removes the top of the stack and stores it into an instance variable of my receiver."
self pop!
----- Method: SendInfo>>popIntoTemporaryVariable: (in category 'instruction decoding') ----- popIntoTemporaryVariable: offset "Simulate the action of bytecode that removes the top of the stack and stores it into an instance variable of my receiver."
self pop!
----- Method: SendInfo>>prepareState (in category 'initialization') ----- prepareState | nrsArray | self newEmptyStack. savedStacks _ QuickIntegerDictionary new: (sender endPC). isStartOfBlock _ false. nrsArray _ self class neverRequiredSelectors. self assert:[nrsArray size = 5] because: 'Size of neverRequiredSelectors has been changed; re-optimize (by hand) #tallySelfSendsFor:'. nr1 _ nrsArray at: 1. nr2 _ nrsArray at: 2. nr3 _ nrsArray at: 3. nr4 _ nrsArray at: 4. nr5 _ nrsArray at: 5.!
----- Method: SendInfo>>printOn: (in category 'printing') ----- printOn: aStream aStream nextPut: $[. aStream print: self selfSentSelectors asArray. aStream space. aStream print: self superSentSelectors asArray. aStream space. aStream print: self classSentSelectors asArray. aStream nextPut: $].!
----- Method: SendInfo>>push: (in category 'stack manipulation') ----- push: aValue stack addLast: aValue.!
----- Method: SendInfo>>pushActiveContext (in category 'instruction decoding') ----- pushActiveContext "Simulate the action of bytecode that pushes the active context on the top of its own stack."
self push: #block.!
----- Method: SendInfo>>pushConstant: (in category 'instruction decoding') ----- pushConstant: value
self push: value!
----- Method: SendInfo>>pushLiteralVariable: (in category 'instruction decoding') ----- pushLiteralVariable: value
self push: #stuff!
----- Method: SendInfo>>pushReceiver (in category 'instruction decoding') ----- pushReceiver self push: #self.!
----- Method: SendInfo>>pushReceiverVariable: (in category 'instruction decoding') ----- pushReceiverVariable: anOffset "Push the value of one of the receiver's instance variables."
self push: #stuff.!
----- Method: SendInfo>>pushTemporaryVariable: (in category 'instruction decoding') ----- pushTemporaryVariable: offset "Simulate the action of bytecode that pushes the contents of the temporary variable whose index is the argument, index, on the top of the stack."
self push: #stuff!
----- Method: SendInfo>>selfSentSelectors (in category 'accessing') ----- selfSentSelectors ^ selfSentSelectors ifNil: [#()] ifNotNil: [selfSentSelectors].!
----- Method: SendInfo>>send:super:numArgs: (in category 'instruction decoding') ----- send: selector super: superFlag numArgs: numArgs "Simulate the action of bytecodes that send a message with selector. superFlag, tells whether the receiver of the message was 'super' in the source. The arguments of the message are found in the top numArgs locations on the stack and the receiver just below them." | stackTop | selector == #blockCopy: ifTrue: ["self assert: [numArgs = 1]." isStartOfBlock _ true. numBlockArgs _ self pop. ^ self]. self pop: numArgs. stackTop _ self pop. superFlag ifTrue: [self addSuperSentSelector: selector] ifFalse: [stackTop == #self ifTrue: [self tallySelfSendsFor: selector]. stackTop == #class ifTrue: [self addClassSentSelector: selector]]. self push: ((selector == #class and: [stackTop == #self]) ifTrue: [#class] ifFalse: [#stuff])!
----- Method: SendInfo>>storeIntoLiteralVariable: (in category 'instruction decoding') ----- storeIntoLiteralVariable: value "Simulate the action of bytecode that stores the top of the stack into a literal variable of my method." !
----- Method: SendInfo>>storeIntoReceiverVariable: (in category 'instruction decoding') ----- storeIntoReceiverVariable: offset "Simulate the action of bytecode that stores the top of the stack into an instance variable of my receiver." !
----- Method: SendInfo>>storeIntoTemporaryVariable: (in category 'instruction decoding') ----- storeIntoTemporaryVariable: offset "Simulate the action of bytecode that stores the top of the stack into one of my temporary variables." !
----- Method: SendInfo>>superSentSelectors (in category 'accessing') ----- superSentSelectors ^ superSentSelectors ifNil: [#()] ifNotNil: [superSentSelectors].!
----- Method: SendInfo>>tallySelfSendsFor: (in category 'private') ----- tallySelfSendsFor: selector "Logically, we do the following test: (self neverRequiredSelectors includes: selector) ifTrue: [^ self]. However, since this test alone was reponsible for 2.8% of the execution time, we replace it with the following:" selector == nr1 ifTrue:[^ self]. selector == nr2 ifTrue:[^ self]. selector == nr3 ifTrue:[^ self]. selector == nr4 ifTrue:[^ self]. selector == nr5 ifTrue:[^ self]. selector == #class ifTrue:[^ self]. self addSelfSentSelector: selector.!
----- Method: SendInfo>>top (in category 'stack manipulation') ----- top ^ stack last!
----- Method: TCompilingDescription>>acceptsLoggingOfCompilation (in category 'compiling') ----- acceptsLoggingOfCompilation "weird name is so that it will come lexically before #compile, so that a clean build can make it through. 7/7/96 sw"
^ true!
----- Method: TCompilingDescription>>compile:classified: (in category 'compiling') ----- compile: code classified: heading "Compile the argument, code, as source code in the context of the receiver and install the result in the receiver's method dictionary under the classification indicated by the second argument, heading. nil is to be notified if an error occurs. The argument code is either a string or an object that converts to a string or a PositionableStream on an object that converts to a string."
^self compile: code classified: heading notifying: nil!
----- Method: TCompilingDescription>>compile:classified:notifying: (in category 'compiling') ----- compile: text classified: category notifying: requestor | stamp | stamp _ self acceptsLoggingOfCompilation ifTrue: [Utilities changeStamp] ifFalse: [nil]. ^ self compile: text classified: category withStamp: stamp notifying: requestor!
----- Method: TCompilingDescription>>compile:classified:withStamp:notifying: (in category 'compiling') ----- compile: text classified: category withStamp: changeStamp notifying: requestor ^ self compile: text classified: category withStamp: changeStamp notifying: requestor logSource: self acceptsLoggingOfCompilation!
----- Method: TCompilingDescription>>compile:classified:withStamp:notifying:logSource: (in category 'compiling') ----- compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource | methodAndNode | methodAndNode := self compile: text asString classified: category notifying: requestor trailer: self defaultMethodTrailer ifFail: [^nil]. logSource ifTrue: [ self logMethodSource: text forMethodWithNode: methodAndNode inCategory: category withStamp: changeStamp notifying: requestor. ]. self addAndClassifySelector: methodAndNode selector withMethod: methodAndNode method inProtocol: category notifying: requestor. self instanceSide noteCompilationOf: methodAndNode selector meta: self isClassSide. ^ methodAndNode selector!
----- Method: TCompilingDescription>>compile:notifying: (in category 'compiling') ----- compile: code notifying: requestor "Refer to the comment in Behavior|compile:notifying:."
^self compile: code classified: ClassOrganizer default notifying: requestor!
----- Method: TCompilingDescription>>compileSilently:classified: (in category 'compiling') ----- compileSilently: code classified: category "Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed."
^ self compileSilently: code classified: category notifying: nil.!
----- Method: TCompilingDescription>>compileSilently:classified:notifying: (in category 'compiling') ----- compileSilently: code classified: category notifying: requestor "Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed."
^ SystemChangeNotifier uniqueInstance doSilently: [self compile: code classified: category withStamp: nil notifying: requestor logSource: false].!
----- Method: TCompilingDescription>>doneCompiling (in category 'compiling') ----- doneCompiling "A ClassBuilder has finished the compilation of the receiver. This message is a notification for a class that needs to do some cleanup / reinitialization after it has been recompiled."!
----- Method: TCompilingDescription>>noteCompilationOf:meta: (in category 'compiling') ----- noteCompilationOf: aSelector meta: isMeta "A hook allowing some classes to react to recompilation of certain selectors"!
----- Method: TCompilingDescription>>reformatAll (in category 'compiling') ----- reformatAll "Reformat all methods in this class. Leaves old code accessible to version browsing" self selectorsDo: [:sel | self reformatMethodAt: sel]!
----- Method: TCompilingDescription>>reformatMethodAt: (in category 'compiling') ----- reformatMethodAt: selector | newCodeString method | newCodeString := self prettyPrinterClass format: (self sourceCodeAt: selector) in: self notifying: nil decorated: false. method := self compiledMethodAt: selector. method putSource: newCodeString fromParseNode: nil class: self category: (self organization categoryOfElement: selector) inFile: 2 priorMethod: method !
----- Method: TCompilingDescription>>wantsChangeSetLogging (in category 'compiling') ----- wantsChangeSetLogging "Answer whether code submitted for the receiver should be remembered by the changeSet mechanism. 7/12/96 sw"
^ true!
----- Method: TCompilingDescription>>wantsRecompilationProgressReported (in category 'compiling') ----- wantsRecompilationProgressReported "Answer whether the receiver would like progress of its recompilation reported interactively to the user."
^ true!
----- Method: TTransformationCompatibility>>aliasesForSelector: (in category 'enquiries') ----- aliasesForSelector: aSelector ^ OrderedCollection new !
----- Method: TTransformationCompatibility>>allAliasesDict (in category 'enquiries') ----- allAliasesDict ^IdentityDictionary new !
----- Method: TTransformationCompatibility>>changedSelectorsComparedTo: (in category 'enquiries') ----- changedSelectorsComparedTo: aTraitTransformation | selectors otherSelectors changedSelectors aliases otherAliases | selectors := self allSelectors asIdentitySet. otherSelectors := aTraitTransformation allSelectors asIdentitySet. changedSelectors := IdentitySet withAll: ( (selectors difference: otherSelectors) union: (otherSelectors difference: selectors)). aliases := self allAliasesDict. otherAliases := aTraitTransformation allAliasesDict. aliases keysAndValuesDo: [:key :value | (value ~~ (otherAliases at: key ifAbsent: [nil])) ifTrue: [changedSelectors add: key]]. otherAliases keysAndValuesDo: [:key :value | (value ~~ (aliases at: key ifAbsent: [nil])) ifTrue: [changedSelectors add: key]]. ^ changedSelectors. !
----- Method: TTransformationCompatibility>>collectMethodsFor:into: (in category 'enquiries') ----- collectMethodsFor: aSelector into: methodDescription (self includesSelector: aSelector) ifTrue: [ methodDescription addLocatedMethod: ( LocatedMethod location: self selector: aSelector)] !
----- Method: TTransformationCompatibility>>subject (in category 'enquiries') ----- subject "for compatibility with TraitTransformations" ^ self !
----- Method: TTransformationCompatibility>>trait (in category 'enquiries') ----- trait "for compatibility with TraitTransformations" ^ self !
----- Method: TCompilingBehavior>>>> (in category 'accessing method dictionary') -----
selector
"Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, create an error notification."
^self compiledMethodAt: selector !
----- Method: TCompilingBehavior>>addSelector:withMethod: (in category 'adding/removing methods') ----- addSelector: selector withMethod: compiledMethod ^ self addSelector: selector withMethod: compiledMethod notifying: nil!
----- Method: TCompilingBehavior>>addSelector:withMethod:notifying: (in category 'adding/removing methods') ----- addSelector: selector withMethod: compiledMethod notifying: requestor ^ self addSelectorSilently: selector withMethod: compiledMethod!
----- Method: TCompilingBehavior>>addSelectorSilently:withMethod: (in category 'adding/removing methods') ----- addSelectorSilently: selector withMethod: compiledMethod self basicAddSelector: selector withMethod: compiledMethod!
----- Method: TCompilingBehavior>>basicAddSelector:withMethod: (in category 'adding/removing methods') ----- basicAddSelector: selector withMethod: compiledMethod "Add the message selector with the corresponding compiled method to the receiver's method dictionary. Do this without sending system change notifications"
| oldMethodOrNil | oldMethodOrNil _ self lookupSelector: selector. self methodDict at: selector put: compiledMethod. compiledMethod methodClass: self. compiledMethod selector: selector.
"Now flush Squeak's method cache, either by selector or by method" oldMethodOrNil == nil ifFalse: [oldMethodOrNil flushCache]. selector flushCache.!
----- Method: TCompilingBehavior>>basicRemoveSelector: (in category 'adding/removing methods') ----- basicRemoveSelector: selector "Assuming that the argument, selector (a Symbol), is a message selector in my method dictionary, remove it and its method."
| oldMethod | oldMethod _ self methodDict at: selector ifAbsent: [^ self]. self methodDict removeKey: selector.
"Now flush Squeak's method cache, either by selector or by method" oldMethod flushCache. selector flushCache!
----- Method: TCompilingBehavior>>binding (in category 'compiling') ----- binding ^ nil -> self!
----- Method: TCompilingBehavior>>bindingOf: (in category 'compiling') ----- bindingOf: varName "Answer the binding of some variable resolved in the scope of the receiver" | aSymbol binding | aSymbol _ varName asSymbol.
"Look in declared environment." binding _ self environment bindingOf: aSymbol. ^binding!
----- Method: TCompilingBehavior>>compile: (in category 'compiling') ----- compile: code "Compile the argument, code, as source code in the context of the receiver. Create an error notification if the code can not be compiled. The argument is either a string or an object that converts to a string or a PositionableStream on an object that converts to a string."
^self compile: code notifying: nil!
----- Method: TCompilingBehavior>>compile:classified:notifying:trailer:ifFail: (in category 'compiling') ----- compile: code classified: category notifying: requestor trailer: bytes ifFail: failBlock "Compile code without logging the source in the changes file"
| methodNode | methodNode := self compilerClass new compile: code in: self classified: category notifying: requestor ifFail: failBlock. ^ CompiledMethodWithNode generateMethodFromNode: methodNode trailer: bytes.!
----- Method: TCompilingBehavior>>compile:notifying: (in category 'compiling') ----- compile: code notifying: requestor "Compile the argument, code, as source code in the context of the receiver and insEtall the result in the receiver's method dictionary. The second argument, requestor, is to be notified if an error occurs. The argument code is either a string or an object that converts to a string or a PositionableStream. This method also saves the source code." | methodAndNode | methodAndNode := self compile: code "a Text" classified: nil notifying: requestor trailer: self defaultMethodTrailer ifFail: [^nil]. methodAndNode method putSource: code fromParseNode: methodAndNode node inFile: 2 withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Behavior method'; cr]. self addSelector: methodAndNode selector withMethod: methodAndNode method notifying: requestor. ^ methodAndNode selector!
----- Method: TCompilingBehavior>>compileAll (in category 'compiling') ----- compileAll ^ self compileAllFrom: self!
----- Method: TCompilingBehavior>>compileAllFrom: (in category 'compiling') ----- compileAllFrom: oldClass "Compile all the methods in the receiver's method dictionary. This validates sourceCode and variable references and forces all methods to use the current bytecode set" "ar 7/10/1999: Use oldClass selectors not self selectors" oldClass selectorsDo: [:sel | self recompile: sel from: oldClass]. self environment currentProjectDo: [:proj | proj compileAllIsolated: self from: oldClass].!
----- Method: TCompilingBehavior>>compiledMethodAt: (in category 'accessing method dictionary') ----- compiledMethodAt: selector "Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, create an error notification."
^ self methodDict at: selector!
----- Method: TCompilingBehavior>>compiledMethodAt:ifAbsent: (in category 'accessing method dictionary') ----- compiledMethodAt: selector ifAbsent: aBlock "Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, return the value of aBlock"
^ self methodDict at: selector ifAbsent: [aBlock value]!
----- Method: TCompilingBehavior>>compilerClass (in category 'compiling') ----- compilerClass "Answer a compiler class appropriate for source methods of this class."
^Compiler!
----- Method: TCompilingBehavior>>compress (in category 'accessing method dictionary') ----- compress "Compact the method dictionary of the receiver."
self methodDict rehash!
----- Method: TCompilingBehavior>>compressedSourceCodeAt: (in category 'accessing method dictionary') ----- compressedSourceCodeAt: selector "(Paragraph compressedSourceCodeAt: #displayLines:affectedRectangle:) size 721 1921 Paragraph selectors inject: 0 into: [:tot :sel | tot + (Paragraph compressedSourceCodeAt: sel) size] 13606 31450" | rawText parse | rawText _ (self sourceCodeAt: selector) asString. parse _ self compilerClass new parse: rawText in: self notifying: nil. ^ rawText compressWithTable: ((selector keywords , parse tempNames , self instVarNames , #(self super ifTrue: ifFalse:) , ((0 to: 7) collect: [:i | String streamContents: [:s | s cr. i timesRepeat: [s tab]]]) , (self compiledMethodAt: selector) literalStrings) asSortedCollection: [:a :b | a size > b size])!
----- Method: TCompilingBehavior>>copyOfMethodDictionary (in category 'copying') ----- copyOfMethodDictionary "Return a copy of the receiver's method dictionary"
^ self methodDict copy!
----- Method: TCompilingBehavior>>crossReference (in category 'user interface') ----- crossReference "Answer an Array of arrays of size 2 whose first element is a message selector in the receiver's method dictionary and whose second element is a set of all message selectors in the method dictionary whose methods send a message with that selector. Subclasses are not included."
^self selectors asSortedCollection asArray collect: [:x | Array with: (String with: Character cr), x with: (self whichSelectorsReferTo: x)]
"Point crossReference."!
----- Method: TCompilingBehavior>>decompile: (in category 'compiling') ----- decompile: selector "Find the compiled code associated with the argument, selector, as a message selector in the receiver's method dictionary and decompile it. Answer the resulting source code as a string. Create an error notification if the selector is not in the receiver's method dictionary."
^self decompilerClass new decompile: selector in: self!
----- Method: TCompilingBehavior>>decompilerClass (in category 'compiling') ----- decompilerClass "Answer a decompiler class appropriate for compiled methods of this class."
^ self compilerClass decompilerClass!
----- Method: TCompilingBehavior>>defaultMethodTrailer (in category 'compiling') ----- defaultMethodTrailer ^ #(0 0 0 0)!
----- Method: TCompilingBehavior>>evaluatorClass (in category 'compiling') ----- evaluatorClass "Answer an evaluator class appropriate for evaluating expressions in the context of this class."
^Compiler!
----- Method: TCompilingBehavior>>firstCommentAt: (in category 'accessing method dictionary') ----- firstCommentAt: selector "Answer a string representing the first comment in the method associated with selector. Return an empty string if the relevant source file is not available, or if the method's source code does not contain a comment. Not smart enough to bypass quotes in string constants, but does map doubled quote into a single quote."
|someComments| someComments := self commentsAt: selector. ^someComments isEmpty ifTrue: [''] ifFalse: [someComments first]
"Behavior firstCommentAt: #firstCommentAt:"!
----- Method: TCompilingBehavior>>firstPrecodeCommentFor: (in category 'accessing method dictionary') ----- firstPrecodeCommentFor: selector "If there is a comment in the source code at the given selector that preceeds the body of the method, return it here, else return nil"
| parser source tree | "Behavior firstPrecodeCommentFor: #firstPrecodeCommentFor:" (#(Comment Definition Hierarchy) includes: selector) ifTrue: ["Not really a selector" ^ nil]. source _ self sourceCodeAt: selector asSymbol ifAbsent: [^ nil]. parser _ self parserClass new. tree _ parser parse: (ReadStream on: source) class: self noPattern: false context: nil notifying: nil ifFail: [^ nil]. ^ (tree comment ifNil: [^ nil]) first!
----- Method: TCompilingBehavior>>fullyImplementsVocabulary: (in category 'testing method dictionary') ----- fullyImplementsVocabulary: aVocabulary "Answer whether instances of the receiver respond to all the messages in aVocabulary"
(aVocabulary encompassesAPriori: self) ifTrue: [^ true]. aVocabulary allSelectorsInVocabulary do: [:aSelector | (self canUnderstand: aSelector) ifFalse: [^ false]]. ^ true!
----- Method: TCompilingBehavior>>hasMethods (in category 'testing method dictionary') ----- hasMethods "Answer whether the receiver has any methods in its method dictionary."
^ self methodDict size > 0!
----- Method: TCompilingBehavior>>implementsVocabulary: (in category 'testing method dictionary') ----- implementsVocabulary: aVocabulary "Answer whether instances of the receiver respond to the messages in aVocabulary."
(aVocabulary isKindOf: FullVocabulary orOf: ScreenedVocabulary) ifTrue: [^ true]. ^ self fullyImplementsVocabulary: aVocabulary!
----- Method: TCompilingBehavior>>includesSelector: (in category 'testing method dictionary') ----- includesSelector: aSymbol "Answer whether the message whose selector is the argument is in the method dictionary of the receiver's class."
^ self methodDict includesKey: aSymbol!
----- Method: TCompilingBehavior>>methodDictionary (in category 'accessing method dictionary') ----- methodDictionary "Convenience" ^self methodDict!
----- Method: TCompilingBehavior>>methodDictionary: (in category 'accessing method dictionary') ----- methodDictionary: aDictionary self methodDict: aDictionary!
----- Method: TCompilingBehavior>>methodsDo: (in category 'accessing method dictionary') ----- methodsDo: aBlock "Evaluate aBlock for all the compiled methods in my method dictionary."
^ self methodDict valuesDo: aBlock!
----- Method: TCompilingBehavior>>parseScope (in category 'newcompiler') ----- parseScope
^ Smalltalk at: #ClassScope ifPresent: [:class | class new class: self]!
----- Method: TCompilingBehavior>>parserClass (in category 'compiling') ----- parserClass "Answer a parser class to use for parsing method headers."
^self compilerClass parserClass!
----- Method: TCompilingBehavior>>recompile: (in category 'compiling') ----- recompile: selector "Compile the method associated with selector in the receiver's method dictionary." ^self recompile: selector from: self!
----- Method: TCompilingBehavior>>recompile:from: (in category 'compiling') ----- recompile: selector from: oldClass "Compile the method associated with selector in the receiver's method dictionary." "ar 7/10/1999: Use oldClass compiledMethodAt: not self compiledMethodAt:" | method trailer methodNode | method _ oldClass compiledMethodAt: selector. trailer _ method trailer. methodNode _ self compilerClass new compile: (oldClass sourceCodeAt: selector) in: self notifying: nil ifFail: [^ self]. "Assume OK after proceed from SyntaxError" selector == methodNode selector ifFalse: [self error: 'selector changed!!']. self basicAddSelector: selector withMethod: (methodNode generate: trailer). !
----- Method: TCompilingBehavior>>recompileChanges (in category 'compiling') ----- recompileChanges "Compile all the methods that are in the changes file. This validates sourceCode and variable references and forces methods to use the current bytecode set"
self selectorsDo: [:sel | (self compiledMethodAt: sel) fileIndex > 1 ifTrue: [self recompile: sel from: self]]!
----- Method: TCompilingBehavior>>recompileNonResidentMethod:atSelector:from: (in category 'compiling') ----- recompileNonResidentMethod: method atSelector: selector from: oldClass "Recompile the method supplied in the context of this class."
| trailer methodNode | trailer _ method trailer. methodNode _ self compilerClass new compile: (method getSourceFor: selector in: oldClass) in: self notifying: nil ifFail: ["We're in deep doo-doo if this fails (syntax error). Presumably the user will correct something and proceed, thus installing the result in this methodDict. We must retrieve that new method, and restore the original (or remove) and then return the method we retrieved." ^ self error: 'see comment']. selector == methodNode selector ifFalse: [self error: 'selector changed!!']. ^ methodNode generate: trailer !
----- Method: TCompilingBehavior>>removeSelector: (in category 'adding/removing methods') ----- removeSelector: selector "Assuming that the argument, selector (a Symbol), is a message selector in my method dictionary, remove it and its method."
^ self basicRemoveSelector: selector !
----- Method: TCompilingBehavior>>removeSelectorSilently: (in category 'adding/removing methods') ----- removeSelectorSilently: selector "Remove selector without sending system change notifications"
^ SystemChangeNotifier uniqueInstance doSilently: [self removeSelector: selector].!
----- Method: TCompilingBehavior>>selectors (in category 'accessing method dictionary') ----- selectors "Answer a Set of all the message selectors specified in the receiver's method dictionary."
^ self methodDict keys!
----- Method: TCompilingBehavior>>selectorsAndMethodsDo: (in category 'accessing method dictionary') ----- selectorsAndMethodsDo: aBlock "Evaluate selectorBlock for all the message selectors in my method dictionary."
^ self methodDict keysAndValuesDo: aBlock!
----- Method: TCompilingBehavior>>selectorsDo: (in category 'accessing method dictionary') ----- selectorsDo: selectorBlock "Evaluate selectorBlock for all the message selectors in my method dictionary."
^ self methodDict keysDo: selectorBlock!
----- 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 num | list _ OrderedCollection new. self selectorsDo: [:aSel | num _ aSel count: [:char | char == $:]. num = 0 ifTrue: [aSel last isLetter ifFalse: [num _ 1]]. num = numberOfArgs ifTrue: [list add: aSel]]. ^ list!
----- Method: TCompilingBehavior>>sourceCodeAt: (in category 'accessing method dictionary') ----- sourceCodeAt: selector
^ (self methodDict at: selector) getSourceFor: selector in: self!
----- Method: TCompilingBehavior>>sourceCodeAt:ifAbsent: (in category 'accessing method dictionary') ----- sourceCodeAt: selector ifAbsent: aBlock
^ (self methodDict at: selector ifAbsent: [^ aBlock value]) getSourceFor: selector in: self!
----- Method: TCompilingBehavior>>sourceMethodAt: (in category 'accessing method dictionary') ----- sourceMethodAt: selector "Answer the paragraph corresponding to the source code for the argument."
^(self sourceCodeAt: selector) asText makeSelectorBoldIn: self!
----- Method: TCompilingBehavior>>sourceMethodAt:ifAbsent: (in category 'accessing method dictionary') ----- sourceMethodAt: selector ifAbsent: aBlock "Answer the paragraph corresponding to the source code for the argument."
^ (self sourceCodeAt: selector ifAbsent: [^ aBlock value]) asText makeSelectorBoldIn: self!
----- 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 method | space _ 0. 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!
----- Method: TCompilingBehavior>>thoroughWhichSelectorsReferTo:special:byte: (in category 'testing method dictionary') ----- thoroughWhichSelectorsReferTo: literal special: specialFlag byte: specialByte "Answer a set of selectors whose methods access the argument as a literal. Dives into the compact literal notation, making it slow but thorough "
| who | who _ IdentitySet new. self selectorsAndMethodsDo: [:sel :method | ((method hasLiteralThorough: literal) or: [specialFlag and: [method scanFor: specialByte]]) ifTrue: [((literal isVariableBinding) not or: [method literals allButLast includes: literal]) ifTrue: [who add: sel]]]. ^ who!
----- Method: TCompilingBehavior>>whichSelectorsReferTo: (in category 'testing method dictionary') ----- whichSelectorsReferTo: literal "Answer a Set of selectors whose methods access the argument as a literal."
| special byte | special _ self environment hasSpecialSelector: literal ifTrueSetByte: [:b | byte _ b]. ^self whichSelectorsReferTo: literal special: special byte: byte
"Rectangle whichSelectorsReferTo: #+."!
----- Method: TCompilingBehavior>>whichSelectorsReferTo:special:byte: (in category 'testing method dictionary') ----- whichSelectorsReferTo: literal special: specialFlag byte: specialByte "Answer a set of selectors whose methods access the argument as a literal."
| who | who _ IdentitySet new. self selectorsAndMethodsDo: [:sel :method | ((method hasLiteral: literal) or: [specialFlag and: [method scanFor: specialByte]]) ifTrue: [((literal isVariableBinding) not or: [method literals allButLast includes: literal]) ifTrue: [who add: sel]]]. ^ who!
----- Method: TCommentDescription>>classComment: (in category 'fileIn/Out') ----- classComment: aString "Store the comment, aString or Text or RemoteString, associated with the class we are orgainzing. Empty string gets stored only if had a non-empty one before." ^ self classComment: aString stamp: '<historical>'!
----- Method: TCommentDescription>>classComment:stamp: (in category 'fileIn/Out') ----- classComment: aString stamp: aStamp "Store the comment, aString or Text or RemoteString, associated with the class we are organizing. Empty string gets stored only if had a non-empty one before."
| ptr header file oldCommentRemoteStr oldComment oldStamp | oldComment := self organization classComment. oldStamp := self organization commentStamp. (aString isKindOf: RemoteString) ifTrue: [SystemChangeNotifier uniqueInstance class: self oldComment: oldComment newComment: aString string oldStamp: oldStamp newStamp: aStamp. ^ self organization classComment: aString stamp: aStamp].
oldCommentRemoteStr := self organization commentRemoteStr. (aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: [^ self organization classComment: nil]. "never had a class comment, no need to write empty string out"
ptr := oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer]. SourceFiles ifNotNil: [(file := SourceFiles at: 2) ifNotNil: [file setToEnd; cr; nextPut: $!!. "directly" "Should be saying (file command: 'H3') for HTML, but ignoring it here" header := String streamContents: [:strm | strm nextPutAll: self name; nextPutAll: ' commentStamp: '. aStamp storeOn: strm. strm nextPutAll: ' prior: '; nextPutAll: ptr printString]. file nextChunkPut: header]]. self organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp. SystemChangeNotifier uniqueInstance class: self oldComment: oldComment newComment: aString oldStamp: oldStamp newStamp: aStamp!
----- Method: TCommentDescription>>comment (in category 'accessing comment') ----- comment "Answer the receiver's comment. (If missing, supply a template) " | aString | aString := self instanceSide organization classComment. aString isEmpty ifFalse: [^ aString]. ^self classCommentBlank!
----- Method: TCommentDescription>>comment: (in category 'accessing comment') ----- comment: aStringOrText "Set the receiver's comment to be the argument, aStringOrText."
self instanceSide classComment: aStringOrText.!
----- Method: TCommentDescription>>comment:stamp: (in category 'accessing comment') ----- comment: aStringOrText stamp: aStamp "Set the receiver's comment to be the argument, aStringOrText."
self instanceSide classComment: aStringOrText stamp: aStamp.!
----- Method: TCommentDescription>>commentFollows (in category 'fileIn/Out') ----- commentFollows "Answer a ClassCommentReader who will scan in the comment."
^ ClassCommentReader new setClass: self category: #Comment
"False commentFollows inspect"!
----- Method: TCommentDescription>>commentStamp: (in category 'fileIn/Out') ----- commentStamp: changeStamp self organization commentStamp: changeStamp. ^ self commentStamp: changeStamp prior: 0!
----- Method: TCommentDescription>>commentStamp:prior: (in category 'fileIn/Out') ----- commentStamp: changeStamp prior: indexAndOffset "Prior source link ignored when filing in."
^ ClassCommentReader new setClass: self category: #Comment changeStamp: changeStamp!
----- Method: TCommentDescription>>hasComment (in category 'accessing comment') ----- hasComment "return whether this class truly has a comment other than the default" | org | org _ self instanceSide organization. ^org classComment isEmptyOrNil not!
----- Method: TPureBehavior>>addSelectorSilently:withMethod: (in category 'adding/removing methods') ----- addSelectorSilently: selector withMethod: compiledMethod self methodDictAddSelectorSilently: selector withMethod: compiledMethod. self registerLocalSelector: selector!
----- Method: TPureBehavior>>allSelectors (in category 'accessing method dictionary') ----- allSelectors self explicitRequirement!
----- Method: TPureBehavior>>basicLocalSelectors (in category 'accessing method dictionary') ----- basicLocalSelectors self explicitRequirement!
----- Method: TPureBehavior>>basicLocalSelectors: (in category 'accessing method dictionary') ----- basicLocalSelectors: aSetOrNil self explicitRequirement!
----- Method: TPureBehavior>>canUnderstand: (in category 'testing method dictionary') ----- canUnderstand: selector "Answer whether the receiver can respond to the message whose selector is the argument."
^ self classAndMethodFor: selector do: [:c :m | m isProvided] ifAbsent: [false].!
----- Method: TPureBehavior>>canZapMethodDictionary (in category 'testing') ----- canZapMethodDictionary "Return true if it is safe to zap the method dictionary on #obsolete" ^true!
----- Method: TPureBehavior>>changeRecordsAt: (in category 'accessing method dictionary') ----- changeRecordsAt: selector "Return a list of ChangeRecords for all versions of the method at selector. Source code can be retrieved by sending string to any one. Return nil if the method is absent."
"(Pen changeRecordsAt: #go:) collect: [:cRec | cRec string]" ^ChangeSet scanVersionsOf: (self compiledMethodAt: selector ifAbsent: [^ nil]) class: self meta: self isMeta category: (self whichCategoryIncludesSelector: selector) selector: selector.!
----- Method: TPureBehavior>>classAndMethodFor:do:ifAbsent: (in category 'accessing method dictionary') ----- classAndMethodFor: aSymbol do: binaryBlock ifAbsent: absentBlock "Looks up the selector aSymbol in this class/trait. If it is found, binaryBlock is evaluated with this class/trait and the associated method. Otherwise absentBlock is evaluated. Note that this implementation is very simple because PureBehavior does not know about inheritance (cf. implementation in Behavior)" ^ binaryBlock value: self value: (self compiledMethodAt: aSymbol ifAbsent: [^ absentBlock value]).!
----- Method: TPureBehavior>>clearSendCaches (in category 'send caches') ----- clearSendCaches LocalSends current clearOut: self!
----- Method: TPureBehavior>>copy (in category 'copying') ----- copy "Answer a copy of the receiver without a list of subclasses."
| myCopy | myCopy _ self shallowCopy. ^myCopy methodDictionary: self copyOfMethodDictionary!
----- Method: TPureBehavior>>deepCopy (in category 'copying') ----- deepCopy "Classes should only be shallowCopied or made anew."
^ self shallowCopy!
----- Method: TPureBehavior>>defaultNameStemForInstances (in category 'printing') ----- defaultNameStemForInstances "Answer a basis for external names for default instances of the receiver. For classees, the class-name itself is a good one."
^ self name!
----- Method: TPureBehavior>>deregisterLocalSelector: (in category 'accessing method dictionary') ----- deregisterLocalSelector: aSymbol self basicLocalSelectors notNil ifTrue: [ self basicLocalSelectors remove: aSymbol ifAbsent: []]!
----- Method: TPureBehavior>>emptyMethodDictionary (in category 'initialization') ----- emptyMethodDictionary
^ MethodDictionary new!
----- Method: TPureBehavior>>ensureLocalSelectors (in category 'traits') ----- ensureLocalSelectors "Ensures that the instance variable localSelectors is effectively used to maintain the set of local selectors. This method must be called before any non-local selectors are added to the method dictionary!!"
self basicLocalSelectors isNil ifTrue: [self basicLocalSelectors: self selectors]!
----- Method: TPureBehavior>>environment (in category 'naming') ----- environment "Return the environment in which the receiver is visible" ^Smalltalk!
----- Method: TPureBehavior>>formalHeaderPartsFor: (in category 'accessing method dictionary') ----- "popeye" formalHeaderPartsFor: "olive oil" aSelector "RELAX!! The warning you may have just seen about possibly having a bad source file does not apply here, because this method *intends* to have its source code start with a comment. This method returns a collection giving the parts in the formal declaration for aSelector. This parse is in support of schemes in which adjutant properties of a method can be declared via special comments secreted in the formal header The result will have 3 elements for a simple, argumentless selector. 5 elements for a single-argument selector 9 elements for a two-argument selector 13 elements for a three-argument, selector etc...
The syntactic elements are:
1 comment preceding initial selector fragment
2 first selector fragment 3 comment following first selector fragment (nil if selector has no arguments)
---------------------- (ends here for, e.g., #copy)
4 first formal argument 5 comment following first formal argument (nil if selector has only one argument)
---------------------- (ends here for, e.g., #copyFrom:)
6 second keyword 7 comment following second keyword 8 second formal argument 9 comment following second formal argument (nil if selector has only two arguments)
---------------------- (ends here for, e.g., #copyFrom:to:)
Any nil element signifies an absent comment. NOTE: The comment following the final formal argument is *not* successfully retrieved by this method in its current form, though it can be obtained, if needed, by other means (e.g. calling #firstPrecodeCommentFor:). Thus, the *final* element in the structure returned by this method is always going to be nil."
^ Scanner new scanMessageParts: (self methodHeaderFor: aSelector)
" Behavior class formalHeaderPartsFor: #formalHeaderPartsFor: "
!
----- Method: TPureBehavior>>formalParametersAt: (in category 'accessing method dictionary') ----- formalParametersAt: aSelector "Return the names of the arguments used in this method."
| source parser message list params | source _ self sourceCodeAt: aSelector ifAbsent: [^ #()]. "for now" (parser _ self parserClass new) parseSelector: source. message _ source copyFrom: 1 to: (parser endOfLastToken min: source size). list _ message string findTokens: Character separators. params _ OrderedCollection new. list withIndexDo: [:token :ind | ind even ifTrue: [params addLast: token]]. ^ params!
----- Method: TPureBehavior>>hasRequiredSelectors (in category 'send caches') ----- hasRequiredSelectors ^ self requiredSelectors notEmpty!
----- Method: TPureBehavior>>hasTraitComposition (in category 'traits') ----- hasTraitComposition self explicitRequirement!
----- Method: TPureBehavior>>includesBehavior: (in category 'testing') ----- includesBehavior: aBehavior ^self == aBehavior!
----- Method: TPureBehavior>>includesLocalSelector: (in category 'testing method dictionary') ----- includesLocalSelector: aSymbol ^self basicLocalSelectors isNil ifTrue: [self includesSelector: aSymbol] ifFalse: [self localSelectors includes: aSymbol]!
----- Method: TPureBehavior>>isDisabledSelector: (in category 'testing method dictionary') ----- isDisabledSelector: selector ^ self classAndMethodFor: selector do: [:c :m | m isDisabled] ifAbsent: [false]!
----- Method: TPureBehavior>>isProvidedSelector: (in category 'testing method dictionary') ----- isProvidedSelector: selector ^ ProvidedSelectors current isSelector: selector providedIn: self !
----- Method: TPureBehavior>>literalScannedAs:notifying: (in category 'printing') ----- literalScannedAs: scannedLiteral notifying: requestor "Postprocesses a literal scanned by Scanner scanToken (esp. xLitQuote). If scannedLiteral is not an association, answer it. Else, if it is of the form: nil->#NameOfMetaclass answer nil->theMetaclass, if any has that name, else report an error. Else, if it is of the form: #NameOfGlobalVariable->anythiEng answer the global, class, or pool association with that nameE, if any, else add it to Undeclared a answer the new Association."
| key value | (scannedLiteral isVariableBinding) ifFalse: [^ scannedLiteral]. key _ scannedLiteral key. value _ scannedLiteral value. key isNil ifTrue: "###<metaclass soleInstance name>" [(self bindingOf: value) ifNotNilDo:[:assoc| (assoc value isKindOf: Behavior) ifTrue: [^ nil->assoc value class]]. requestor notify: 'No such metaclass'. ^false]. (key isSymbol) ifTrue: "##<global var name>" [(self bindingOf: key) ifNotNilDo:[:assoc | ^assoc]. Undeclared at: key put: nil. ^Undeclared bindingOf: key]. requestor notify: '## must be followed by a non-local variable name'. ^false
" Form literalScannedAs: 14 notifying: nil 14 Form literalScannedAs: #OneBitForm notiEfying: nil OneBitForm Form literalScannedAs: ##OneBitForm notifying: nil OneBitForm->a Form Form literalScannedAs: ##Form notifying: nil Form->Form Form literalScannedAs: ###Form notifying: nil nilE->Form class "!
----- Method: TPureBehavior>>localSelectors (in category 'adding/removing methods') ----- localSelectors "Return a set of selectors defined locally. The instance variable is lazily initialized. If it is nil then there are no non-local selectors"
^ self basicLocalSelectors isNil ifTrue: [self selectors] ifFalse: [self basicLocalSelectors].!
----- Method: TPureBehavior>>longPrintOn: (in category 'printing') ----- longPrintOn: aStream "Append to the argument, aStream, the names and values of all of the receiver's instance variables. But, not useful for a class with a method dictionary."
aStream nextPutAll: '<<too complex to show>>'; cr.!
----- Method: TPureBehavior>>lookupSelector: (in category 'accessing method dictionary') ----- lookupSelector: selector ^ self explicitRequirement!
----- Method: TPureBehavior>>methodDict (in category 'accessing method dictionary') ----- methodDict ^ self explicitRequirement!
----- Method: TPureBehavior>>methodDict: (in category 'accessing method dictionary') ----- methodDict: aDictionary ^ self explicitRequirement!
----- Method: TPureBehavior>>methodHeaderFor: (in category 'accessing method dictionary') ----- methodHeaderFor: selector "Answer the string corresponding to the method header for the given selector"
| sourceString parser | sourceString _ self ultimateSourceCodeAt: selector ifAbsent: [self standardMethodHeaderFor: selector]. (parser _ self parserClass new) parseSelector: sourceString. ^ sourceString asString copyFrom: 1 to: (parser endOfLastToken min: sourceString size)
"Behavior methodHeaderFor: #methodHeaderFor: " !
----- Method: TPureBehavior>>name (in category 'naming') ----- name ^ self explicitRequirement!
----- Method: TPureBehavior>>obsolete (in category 'initialization') ----- obsolete "Invalidate and recycle local methods, e.g., zap the method dictionary if can be done safely." self canZapMethodDictionary ifTrue: [self methodDict: self emptyMethodDictionary]. self hasTraitComposition ifTrue: [ self traitComposition traits do: [:each | each removeUser: self]]!
----- Method: TPureBehavior>>prettyPrinterClass (in category 'printing') ----- prettyPrinterClass ^self compilerClass!
----- Method: TPureBehavior>>providedSelectors (in category '*Traits') ----- providedSelectors ^ProvidedSelectors current for: self!
----- Method: TPureBehavior>>purgeLocalSelectors (in category 'traits') ----- purgeLocalSelectors self basicLocalSelectors: nil!
----- Method: TPureBehavior>>registerLocalSelector: (in category 'accessing method dictionary') ----- registerLocalSelector: aSymbol self basicLocalSelectors notNil ifTrue: [ self basicLocalSelectors add: aSymbol]!
----- Method: TPureBehavior>>removeSelector: (in category 'adding/removing methods') ----- removeSelector: aSelector "Assuming that the argument, selector (a Symbol), is a message selector in my method dictionary, remove it and its method. If the method to remove will be replaced by a method from my trait composition, the current method does not have to be removed because we mark it as non-local. If it is not identical to the actual method from the trait it will be replaced automatically by #noteChangedSelectors:. This is useful to avoid bootstrapping problems when moving methods to a trait (e.g., from TPureBehavior to TMethodDictionaryBehavior). Manual moving (implementing the method in the trait and then remove it from the class) does not work if the methods themselves are used for this process (such as compiledMethodAt:, includesLocalSelector: or addTraitSelector:withMethod:)"
| changeFromLocalToTraitMethod | changeFromLocalToTraitMethod _ (self includesLocalSelector: aSelector) and: [self hasTraitComposition] and: [self traitComposition includesMethod: aSelector].
changeFromLocalToTraitMethod ifFalse: [self basicRemoveSelector: aSelector] ifTrue: [self ensureLocalSelectors]. self deregisterLocalSelector: aSelector. self noteChangedSelectors: (Array with: aSelector) !
----- Method: TPureBehavior>>requirements (in category 'send caches') ----- requirements ^ self requiredSelectorsCache ifNil: [#()] ifNotNilDo: [:rsc | rsc requirements]!
----- Method: TPureBehavior>>selfSentSelectorsFromSelectors: (in category 'traits') ----- selfSentSelectorsFromSelectors: interestingSelectors | m result info | result := IdentitySet new. interestingSelectors collect: [:sel | m := self compiledMethodAt: sel ifAbsent: []. m ifNotNil: [info := (SendInfo on: m) collectSends. info selfSentSelectors do: [:sentSelector | result add: sentSelector]]]. ^result!
----- Method: TPureBehavior>>sendCaches (in category 'send caches') ----- sendCaches ^ self explicitRequirement!
----- Method: TPureBehavior>>sendCaches: (in category 'send caches') ----- sendCaches: aSendCaches ^ self explicitRequirement!
----- Method: TPureBehavior>>setRequiredStatusOf:to: (in category 'send caches') ----- setRequiredStatusOf: selector to: aBoolean aBoolean ifTrue: [self requiredSelectorsCache addRequirement: selector] ifFalse: [self requiredSelectorsCache removeRequirement: selector].!
----- Method: TPureBehavior>>sourceCodeTemplate (in category 'compiling') ----- sourceCodeTemplate "Answer an expression to be edited and evaluated in order to define methods in this class or trait."
^'message selector and argument names "comment stating purpose of message"
| temporary variable names | statements'!
----- Method: TPureBehavior>>standardMethodHeaderFor: (in category 'accessing method dictionary') ----- standardMethodHeaderFor: aSelector | args | args _ (1 to: aSelector numArgs) collect:[:i| 'arg', i printString]. args size = 0 ifTrue:[^aSelector asString]. args size = 1 ifTrue:[^aSelector,' arg1']. ^String streamContents:[:s| (aSelector findTokens:':') with: args do:[:tok :arg| s nextPutAll: tok; nextPutAll:': '; nextPutAll: arg; nextPutAll:' '. ]. ]. !
----- Method: TPureBehavior>>storeLiteral:on: (in category 'printing') ----- storeLiteral: aCodeLiteral on: aStream "Store aCodeLiteral on aStream, changing an Association to ##GlobalName or ###MetaclassSoleInstanceName format if appropriate" | key value | (aCodeLiteral isVariableBinding) ifFalse: [aCodeLiteral storeOn: aStream. ^self]. key _ aCodeLiteral key. (key isNil and: [(value _ aCodeLiteral value) isMemberOf: Metaclass]) ifTrue: [aStream nextPutAll: '###'; nextPutAll: value soleInstance name. ^self]. (key isSymbol and: [(self bindingOf: key) notNil]) ifTrue: [aStream nextPutAll: '##'; nextPutAll: key. ^self]. aCodeLiteral storeOn: aStream!
----- Method: TPureBehavior>>superRequirements (in category 'send caches') ----- superRequirements ^ self requiredSelectorsCache superRequirements!
----- Method: TPureBehavior>>traitComposition (in category 'traits') ----- traitComposition "Return my trait composition. Manipulating the composition does not effect changes automatically. Use #setTraitComposition: to do this but note, that you have to make a copy of the old trait composition before changing it because only the difference between the new and the old composition is updated." ^self explicitRequirement !
----- Method: TPureBehavior>>traitComposition: (in category 'traits') ----- traitComposition: aTraitComposition ^self explicitRequirement !
----- Method: TPureBehavior>>traitCompositionIncludes: (in category 'traits') ----- traitCompositionIncludes: aTrait ^self == aTrait or: [self hasTraitComposition and: [self traitComposition allTraits includes: aTrait]]!
----- Method: TPureBehavior>>traitCompositionString (in category 'traits') ----- traitCompositionString ^self hasTraitComposition ifTrue: [self traitComposition asString] ifFalse: ['{}']!
----- Method: TPureBehavior>>traitTransformations (in category 'traits') ----- traitTransformations ^ self traitComposition transformations !
----- Method: TPureBehavior>>ultimateSourceCodeAt:ifAbsent: (in category 'accessing method dictionary') ----- ultimateSourceCodeAt: selector ifAbsent: aBlock "Return the source code at selector" ^self sourceCodeAt: selector ifAbsent: aBlock!
----- Method: TPureBehavior>>withAllSuperclasses (in category 'accessing class hierarchy') ----- withAllSuperclasses "Answer an OrderedCollection of the receiver and the receiver's superclasses. The first element is the receiver, followed by its superclass; the last element is Object."
| temp | temp _ self allSuperclasses. temp addFirst: self. ^ temp!
Array variableSubclass: #FixedIdentitySet instanceVariableNames: 'tally capacity' classVariableNames: '' poolDictionaries: '' category: 'Traits-Requires'!
!FixedIdentitySet commentStamp: 'NS 5/26/2005 13:00' prior: 0! This is a fast but lazy implementation of fixed size identity sets. The two main difference to regular identity sets are:
1) These identity sets have a fixed size. If they are full, adding another element doesn't have any effect. 2) No rehashing. If two elements were to be stored on the same position in the underlying array, one of them is simply discarded.
As a consequence of (1) and (2), these identity sets are very fast!! Note that this class inherits form Array. This is not clean but reduces memory overhead when instances are created.!
----- Method: FixedIdentitySet class>>arraySizeForCapacity: (in category 'constants') ----- arraySizeForCapacity: anInteger "Because of the hash performance, the array size is always a power of 2 and at least twice as big as the capacity anInteger"
^ anInteger <= 0 ifTrue: [0] ifFalse: [1 << (anInteger << 1 - 1) highBit].!
----- Method: FixedIdentitySet class>>defaultSize (in category 'constants') ----- defaultSize ^ 4!
----- Method: FixedIdentitySet class>>new (in category 'constants') ----- new ^ self new: self defaultSize!
----- Method: FixedIdentitySet class>>new: (in category 'constants') ----- new: anInteger ^ (super new: (self arraySizeForCapacity: anInteger)) initializeCapacity: anInteger!
----- Method: FixedIdentitySet class>>readonlyWithAll:notIn: (in category 'instance creation') ----- readonlyWithAll: aCollection notIn: notCollection "For performance reasons, this method may return an array rather than a FixedIdentitySet. Therefore it should only be used if the return value does not need to be modified. Use #withAll:notIn: if the return value might need to be modified."
| size | aCollection isEmpty ifTrue: [^ #()]. size _ aCollection size = 1 ifTrue: [1] ifFalse: [self sizeFor: aCollection]. ^ (self new: size) addAll: aCollection notIn: notCollection; yourself!
----- Method: FixedIdentitySet class>>sizeFor: (in category 'private') ----- sizeFor: aCollection ^ aCollection species == self ifTrue: [aCollection capacity] ifFalse: [self defaultSize].!
----- Method: FixedIdentitySet class>>with: (in category 'instance creation') ----- with: anObject "Answer an instance of me containing anObject."
^ self new add: anObject; yourself!
----- Method: FixedIdentitySet class>>with:with: (in category 'instance creation') ----- with: firstObject with: secondObject "Answer an instance of me containing the two arguments as elements."
^ self new add: firstObject; add: secondObject; yourself!
----- Method: FixedIdentitySet class>>with:with:with: (in category 'instance creation') ----- with: firstObject with: secondObject with: thirdObject "Answer an instance of me containing the three arguments as elements."
^ self new add: firstObject; add: secondObject; add: thirdObject; yourself!
----- Method: FixedIdentitySet class>>with:with:with:with: (in category 'instance creation') ----- with: firstObject with: secondObject with: thirdObject with: fourthObject "Answer an instance of me, containing the four arguments as the elements."
^ self new add: firstObject; add: secondObject; add: thirdObject; add: fourthObject; yourself!
----- Method: FixedIdentitySet class>>with:with:with:with:with: (in category 'instance creation') ----- with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject "Answer an instance of me, containing the five arguments as the elements."
^ self new add: firstObject; add: secondObject; add: thirdObject; add: fourthObject; add: fifthObject; yourself!
----- Method: FixedIdentitySet class>>with:with:with:with:with:with: (in category 'instance creation') ----- with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject with: sixthObject "Answer an instance of me, containing the six arguments as the elements."
^ self new add: firstObject; add: secondObject; add: thirdObject; add: fourthObject; add: fifthObject; add: sixthObject; yourself!
----- Method: FixedIdentitySet class>>withAll: (in category 'instance creation') ----- withAll: aCollection "Create a new collection containing all the elements from aCollection."
^ (self new: (self sizeFor: aCollection)) addAll: aCollection; yourself!
----- Method: FixedIdentitySet class>>withAll:notIn: (in category 'instance creation') ----- withAll: aCollection notIn: notCollection ^ (self new: (self sizeFor: aCollection)) addAll: aCollection notIn: notCollection; yourself!
----- Method: FixedIdentitySet>>= (in category 'comparing') ----- = aCollection self == aCollection ifTrue: [^ true]. aCollection size = self size ifFalse: [^ false]. aCollection do: [:each | (self includes: each) ifFalse: [^ false]]. ^ true!
----- Method: FixedIdentitySet>>add: (in category 'accessing') ----- add: anObject | index old | self isFull ifTrue: [^ false]. index _ self indexOf: anObject. old _ self basicAt: index. old == anObject ifTrue: [^ true]. old ifNotNil: [^ false]. self basicAt: index put: anObject. tally _ tally + 1. ^ true!
----- Method: FixedIdentitySet>>addAll: (in category 'accessing') ----- addAll: aCollection aCollection do: [:each | self isFull ifTrue: [^ self]. self add: each. ].!
----- Method: FixedIdentitySet>>addAll:notIn: (in category 'accessing') ----- addAll: aCollection notIn: notCollection aCollection do: [:each | self isFull ifTrue: [^ self]. (notCollection includes: each) ifFalse: [self add: each]. ].!
----- Method: FixedIdentitySet>>arraySize (in category 'private') ----- arraySize ^ super size!
----- Method: FixedIdentitySet>>at: (in category 'accessing') ----- at: index self shouldNotImplement!
----- Method: FixedIdentitySet>>at:put: (in category 'accessing') ----- at: index put: anObject self shouldNotImplement!
----- Method: FixedIdentitySet>>capacity (in category 'accessing') ----- capacity ^ capacity!
----- Method: FixedIdentitySet>>destructiveAdd: (in category 'accessing') ----- destructiveAdd: anObject | index old | self isFull ifTrue: [^ false]. index _ self indexOf: anObject. old _ self basicAt: index. self basicAt: index put: anObject. old ifNil: [tally _ tally + 1]. ^ true!
----- Method: FixedIdentitySet>>do: (in category 'enumerating') ----- do: aBlock | obj count | count _ 0. 1 to: self basicSize do: [:index | count >= tally ifTrue: [^ self]. obj _ self basicAt: index. obj ifNotNil: [count _ count + 1. aBlock value: obj]. ]. !
----- Method: FixedIdentitySet>>hash (in category 'comparing') ----- hash "Answer an integer hash value for the receiver such that, -- the hash value of an unchanged object is constant over time, and -- two equal objects have equal hash values"
| hash | hash _ self species hash. self size <= 10 ifTrue: [self do: [:elem | hash _ hash bitXor: elem hash]]. ^hash bitXor: self size hash!
----- Method: FixedIdentitySet>>includes: (in category 'accessing') ----- includes: anObject ^ (self basicAt: (self indexOf: anObject)) == anObject!
----- Method: FixedIdentitySet>>indexOf: (in category 'private') ----- indexOf: anObject anObject isNil ifTrue: [self error: 'This class collection cannot handle nil as an element']. ^ (anObject identityHash bitAnd: self basicSize - 1) + 1!
----- Method: FixedIdentitySet>>initializeCapacity: (in category 'initialize-release') ----- initializeCapacity: anInteger tally _ 0. capacity _ anInteger.!
----- Method: FixedIdentitySet>>isFull (in category 'testing') ----- isFull ^ tally >= capacity!
----- Method: FixedIdentitySet>>notFull (in category 'testing') ----- notFull ^ tally < capacity!
----- Method: FixedIdentitySet>>printOn: (in category 'printing') ----- printOn: aStream | count | aStream nextPutAll: '#('. count _ 0. self do: [:each | count _ count + 1. each printOn: aStream. count < self size ifTrue: [aStream nextPut: $ ] ]. aStream nextPut: $).!
----- Method: FixedIdentitySet>>remove:ifAbsent: (in category 'accessing') ----- remove: anObject ifAbsent: aBlock | index | index _ self indexOf: anObject. ^ (self basicAt: index) == anObject ifTrue: [self basicAt: index put: nil. tally _ tally - 1. anObject] ifFalse: [aBlock value].!
----- Method: FixedIdentitySet>>select: (in category 'enumerating') ----- select: aBlock | result | result _ self species new: self capacity. self do: [:each | (aBlock value: each) ifTrue: [result add: each]]. ^ result.!
----- Method: FixedIdentitySet>>size (in category 'accessing') ----- size ^ tally!
Array variableSubclass: #QuickIntegerDictionary instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Traits-LocalSends'!
!QuickIntegerDictionary commentStamp: 'dvf 8/4/2005 11:06' prior: 0! This implementation serves as a very quick dictionary under the assumption that the keys are small natural numbers.!
----- Method: QuickIntegerDictionary>>includesKey: (in category 'accessing') ----- includesKey: anIntegerKey ^ (self at: anIntegerKey) notNil !
----- Method: QuickIntegerDictionary>>removeKey: (in category 'accessing') ----- removeKey: anIntegerKey ^ self at: anIntegerKey put: nil.!
Array variableSubclass: #QuickStack instanceVariableNames: 'top' classVariableNames: '' poolDictionaries: '' category: 'Traits-LocalSends'!
!QuickStack commentStamp: 'apb 8/30/2003 10:55' prior: 0! This class is a quick and dirty implementation of a stack, designed to be used in the SendsInfo abstract interpreter. As opposed to using an OrderedCollection, this stack is quick because it can be emptied in a single assignment, and dirty because elements above the logical top of the stack (i.e., those that have been popped off) are not nil'ed out. For our application, these are important optimizations with no ill effects.
QuickStacks will expand beyond their initial size if required, but we intend that the initial size will always be sufficient, so the efficiency of this feature is not important. !
----- Method: QuickStack class>>new (in category 'instance creation') ----- new ^ (super new: 16) initialize "Why 16? Because in performing an abstract interpretation of every method in every Class <= Object, the largest stack that was found to be necessary was 15"!
----- Method: QuickStack>>addLast: (in category 'accessing') ----- addLast: aValue top = self basicSize ifTrue: [self grow]. top _ top + 1. ^ self at: top put: aValue!
----- Method: QuickStack>>becomeEmpty (in category 'accessing') ----- becomeEmpty top _ 0!
----- Method: QuickStack>>copy (in category 'copying') ----- copy "Answer a copy of a myself" | newSize | newSize _ self basicSize. ^ (self class new: newSize) replaceFrom: 1 to: top with: self startingAt: 1; setTop: top!
----- Method: QuickStack>>grow (in category 'private') ----- grow | newStack | newStack _ self class new: (self basicSize * 2). newStack replaceFrom: 1 to: top with: self startingAt: 1. newStack setTop: top. self becomeForward: newStack. !
----- Method: QuickStack>>initialize (in category 'initialization') ----- initialize top _ 0!
----- Method: QuickStack>>isEmpty (in category 'accessing') ----- isEmpty ^ top = 0!
----- Method: QuickStack>>removeLast (in category 'accessing') ----- removeLast | answer | answer _ self at: top. top _ top - 1. ^ answer!
----- Method: QuickStack>>removeLast: (in category 'accessing') ----- removeLast: n
top _ top - n!
----- Method: QuickStack>>setTop: (in category 'private') ----- setTop: t top _ t!
----- Method: QuickStack>>size (in category 'accessing') ----- size ^ top!
----- 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 _ class compiledMethodAt: aSymbol ifAbsent: [nil]. method ifNotNil: [^ binaryBlock value: class value: method]. ]. ^ absentBlock value.!
----- Method: Behavior>>classesComposedWithMe (in category '*Traits-requires') ----- classesComposedWithMe ^{self}!
----- Method: Behavior>>computeSelfSendersFromInheritedSelfSenders:localSelfSenders: (in category '*Traits-requires') ----- computeSelfSendersFromInheritedSelfSenders: inheritedCollection localSelfSenders: localCollection "Compute the set of all self-senders from the set of inherited self-senders and the set of local self-senders."
| result mDict | mDict _ self methodDict. result _ IdentitySet new: inheritedCollection size + localCollection size. "This if-statement is just a performance optimization. Both branches are semantically equivalent." inheritedCollection size > mDict size ifTrue: [ result addAll: inheritedCollection. mDict keysDo: [:each | result remove: each ifAbsent: []]. ] ifFalse: [ inheritedCollection do: [:each | (mDict includesKey: each) ifFalse: [result add: each]]. ]. result addAll: localCollection. ^ result.!
----- 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 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 _ FixedIdentitySet readonlyWithAll: senders notIn: oldUnreachable. reachableSenders isEmpty ifFalse: [ translations at: sent put: reachableSenders. unreachableCollection remove: sent ifAbsent: []. ]. ]. ^ translations!
----- Method: Behavior>>findSelfSendersOf:unreachable:noInheritedSelfSenders: (in category '*Traits-requires') ----- findSelfSendersOf: selector unreachable: unreachableCollection noInheritedSelfSenders: noInheritedBoolean "This method answers a subset of all the reachable methods (local or inherited) that self-send selector (empty set => no self-senders). See Nathanael Schärli's PhD for more details." | selfSenders reachableSelfSenders translations | "Check whether there are local methods that self-send selector and are reachable." selfSenders := self sendCaches selfSendersOf: selector. reachableSelfSenders := FixedIdentitySet readonlyWithAll: selfSenders notIn: unreachableCollection. (self superclass isNil or: [noInheritedBoolean or: [reachableSelfSenders notEmpty]]) ifTrue: [^ reachableSelfSenders].
"Compute the set of unreachable superclass methods and super-send translations and recurse." translations := self computeTranslationsAndUpdateUnreachableSet: unreachableCollection. reachableSelfSenders := superclass findSelfSendersOf: selector unreachable: unreachableCollection noInheritedSelfSenders: false. "Use the translations to replace selectors that are super-sent with the methods that issue the super-sends." reachableSelfSenders := self translateReachableSelfSenders: reachableSelfSenders translations: translations. ^ reachableSelfSenders.!
----- Method: Behavior>>requiredSelectors (in category '*Traits-requires') ----- requiredSelectors ^RequiredSelectors current for: self!
----- Method: Behavior>>requiredSelectorsCache (in category '*Traits-requires') ----- requiredSelectorsCache ^RequiredSelectors current cacheFor: self!
----- Method: Behavior>>sendCaches (in category '*Traits-requires') ----- sendCaches ^LocalSends current for: self!
----- Method: Behavior>>translateReachableSelfSenders:translations: (in category '*Traits-requires') ----- translateReachableSelfSenders: senderCollection translations: translationDictionary | result superSenders | (translationDictionary isEmptyOrNil or: [senderCollection isEmpty]) ifTrue: [^ senderCollection]. result _ FixedIdentitySet new. senderCollection do: [:s | superSenders _ translationDictionary at: s ifAbsent: [nil]. superSenders isNil ifTrue: [result add: s] ifFalse: [result addAll: superSenders]. result isFull ifTrue: [^ result]. ]. ^ result.!
----- Method: Behavior>>updateRequiredStatusFor:inSubclasses: (in category '*Traits-requires') ----- updateRequiredStatusFor: selector inSubclasses: someClasses "Updates the requirements cache to reflect whether selector is required in this class and some of its subclasses." | inheritedMethod | inheritedMethod := self superclass ifNotNil: [self superclass lookupSelector: selector]. ^self updateRequiredStatusFor: selector inSubclasses: someClasses parentSelfSenders: FixedIdentitySet new providedInParent: inheritedMethod noInheritedSelfSenders: false accumulatingInto: IdentitySet new.!
----- Method: Behavior>>updateRequiredStatusFor:inSubclasses:parentSelfSenders:providedInParent:noInheritedSelfSenders: (in category '*Traits-requires') ----- updateRequiredStatusFor: selector inSubclasses: someClasses parentSelfSenders: inheritedSelfSenders providedInParent: providedBoolean noInheritedSelfSenders: noInheritedBoolean "Updates the requirements cache to reflect whether selector is required in this class and all of its subclasses. The parameter inheritedSelfSenders is a subset of the methods in the parent of this class that are known to self-send selector. providedBoolean indicates whether selector is provided in the parent. noInheritedBoolean is true if no self-senders could be found in the superclass. See Nathanael Schärli's PhD for more details."
| selfSenders provided m | "Remove from the inherited selfSenders methods that are potentially unreachable." selfSenders := inheritedSelfSenders reject: [:each | self includesSelector: each]. "Check whether the method is provided." m := self compiledMethodAt: selector ifAbsent: [nil]. providedBoolean ifTrue: [ provided := m isNil or: [m isDisabled not and: [m isExplicitlyRequired not and: [m isSubclassResponsibility not]]]. ] ifFalse: [ provided := m notNil and: [m isProvided]. ].
provided ifTrue: [ "If it is provided, it cannot be required." self setRequiredStatusOf: selector to: false. ] ifFalse: [ "If there are non-overridden inherited selfSenders we know that it must be required. Otherwise, we search for self-senders." selfSenders isEmpty ifTrue: [selfSenders := self findSelfSendersOf: selector unreachable: IdentitySet new noInheritedSelfSenders: noInheritedBoolean]. self setRequiredStatusOf: selector to: selfSenders notEmpty. ].
"Do the same for all subclasses." self subclassesDo: [:each | (someClasses includes: each) ifTrue: [each updateRequiredStatusFor: selector inSubclasses: someClasses parentSelfSenders: selfSenders providedInParent: provided noInheritedSelfSenders: (provided not and: [selfSenders isEmpty])]].!
----- Method: Behavior>>updateRequiredStatusFor:inSubclasses:parentSelfSenders:providedInParent:noInheritedSelfSenders:accumulatingInto: (in category '*Traits-requires') ----- updateRequiredStatusFor: selector inSubclasses: someClasses parentSelfSenders: inheritedSelfSenders providedInParent: inheritedMethod noInheritedSelfSenders: noInheritedBoolean accumulatingInto: requiringClasses "Updates the requirements cache to reflect whether selector is required in this class and all of its subclasses. The parameter inheritedSelfSenders is a subset of the methods in the parent of this class that are known to self-send selector. providedBoolean indicates whether selector is provided in the parent. noInheritedBoolean is true if no self-senders could be found in the superclass. See Nathanael Schärli's PhD for more details."
"Remove from the inherited selfSenders methods that are potentially unreachable."
| selfSenders m relevantMethod required lookedForInheritedSelfSenders | lookedForInheritedSelfSenders := false. selfSenders := inheritedSelfSenders reject: [:each | self includesSelector: each].
"Check whether the method is provided." m := self compiledMethodAt: selector ifAbsent: [nil]. relevantMethod := m ifNotNil: [m] ifNil: [inheritedMethod]. relevantMethod ifNotNil: [required := relevantMethod isSubclassResponsibility or: [ relevantMethod isDisabled or: [ relevantMethod isExplicitlyRequired]]] ifNil: ["If there are non-overridden inherited selfSenders we know that it must be required. Otherwise, we search for self-senders."
selfSenders isEmpty ifTrue: [selfSenders := self findSelfSendersOf: selector unreachable: IdentitySet new noInheritedSelfSenders: noInheritedBoolean. lookedForInheritedSelfSenders := true]. required := selfSenders notEmpty].
required ifTrue: [requiringClasses add: self].
"Do the same for all subclasses." self subclassesDo: [:each | (someClasses includes: each) ifTrue: [each updateRequiredStatusFor: selector inSubclasses: someClasses parentSelfSenders: selfSenders providedInParent: relevantMethod noInheritedSelfSenders: (lookedForInheritedSelfSenders and: [selfSenders isEmpty]) accumulatingInto: requiringClasses]]. ^requiringClasses!
----- Method: Behavior>>withInheritanceTraitCompositionIncludes: (in category '*Traits-requires') ----- withInheritanceTraitCompositionIncludes: aTrait ^self withAllSuperclasses anySatisfy: [:c | c traitCompositionIncludes: aTrait]!
----- Method: TAccessingTraitCompositionBehavior>>addExclusionOf:to: (in category 'traits') ----- addExclusionOf: aSymbol to: aTrait self setTraitComposition: ( self traitComposition copyWithExclusionOf: aSymbol to: aTrait)!
----- Method: TAccessingTraitCompositionBehavior>>addToComposition: (in category 'traits') ----- addToComposition: aTrait self setTraitComposition: (self traitComposition copyTraitExpression add: aTrait; yourself)!
----- Method: TAccessingTraitCompositionBehavior>>isAliasSelector: (in category 'testing method dictionary') ----- isAliasSelector: aSymbol "Return true if the selector aSymbol is an alias defined in my or in another composition somewhere deeper in the tree of traits compositions."
^(self includesLocalSelector: aSymbol) not and: [self hasTraitComposition] and: [self traitComposition isAliasSelector: aSymbol]!
----- Method: TAccessingTraitCompositionBehavior>>isLocalAliasSelector: (in category 'testing method dictionary') ----- isLocalAliasSelector: aSymbol "Return true if the selector aSymbol is an alias defined in my trait composition."
^(self includesLocalSelector: aSymbol) not and: [self hasTraitComposition] and: [self traitComposition isLocalAliasSelector: aSymbol]!
----- Method: TAccessingTraitCompositionBehavior>>removeAlias:of: (in category 'traits') ----- removeAlias: aSymbol of: aTrait self setTraitComposition: ( self traitComposition copyWithoutAlias: aSymbol of: aTrait)!
----- Method: TAccessingTraitCompositionBehavior>>removeFromComposition: (in category 'traits') ----- removeFromComposition: aTrait self setTraitComposition: (self traitComposition copy removeFromComposition: aTrait)!
----- Method: TAccessingTraitCompositionBehavior>>traitOrClassOfSelector: (in category 'traits') ----- traitOrClassOfSelector: aSymbol "Return the trait or the class which originally defines the method aSymbol or return self if locally defined or if it is a conflict marker method. This is primarly used by Debugger to determin the behavior in which a recompiled method should be put. If a conflict method is recompiled it should be put into the class, thus return self. Also see TraitComposition>>traitProvidingSelector:" ((self includesLocalSelector: aSymbol) or: [ self hasTraitComposition not]) ifTrue: [^self]. ^(self traitComposition traitProvidingSelector: aSymbol) ifNil: [self]!
----- Method: TAccessingTraitCompositionBehavior>>traitsProvidingSelector: (in category 'traits') ----- traitsProvidingSelector: aSymbol | result | result _ OrderedCollection new. self hasTraitComposition ifFalse: [^result]. (self traitComposition methodDescriptionsForSelector: aSymbol) do: [:methodDescription | methodDescription selector = aSymbol ifTrue: [ result addAll: (methodDescription locatedMethods collect: [:each | each location])]]. ^result!
packages@lists.squeakfoundation.org