[Pkg] DeltaStreams: Traits-gk.230.mcz

squeak-dev-noreply at lists.squeakfoundation.org squeak-dev-noreply at lists.squeakfoundation.org
Fri Sep 4 08:04:12 UTC 2009


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!



More information about the Packages mailing list